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,gradcattranx,&
 141           gradcattranc,gradcatangc,gradcatangx
 142 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 143 !----------------------------------------
 144         real(kind=8),dimension(:,:),allocatable  ::gradlipelec,gradlipbond,&
 145           gradlipang,gradliplj
 146
 147       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 148         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 149       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 150         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 151         g_corr6_loc      !(maxvar)
 152       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 153       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 154 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 155       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 156 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 157       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 158          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 159 !      integer :: nfl,icg
 160 !      common /deriv_loc/
 161       real(kind=8), dimension(:),allocatable :: fac_shield
 162       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 163 !      common /deriv_scloc/
 164       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 165        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 166        dZZ_XYZtab      !(3,maxres)
 167 !-----------------------------------------------------------------------------
 168 ! common.maxgrad
 169 !      common /maxgrad/
 170       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 171        gradb_max,ghpbc_max,&
 172        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 173        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 174        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 175        gsccorx_max,gsclocx_max
 176 !-----------------------------------------------------------------------------
 177 ! common.MD
 178 !      common /back_constr/
 179       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 180       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 181 !      common /qmeas/
 182       real(kind=8) :: Ucdfrag,Ucdpair
 183       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 184        dqwol,dxqwol      !(3,0:MAXRES)
 185 !-----------------------------------------------------------------------------
 186 ! common.sbridge
 187 !      common /dyn_ssbond/
 188       real(kind=8),dimension(:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 189 !-----------------------------------------------------------------------------
 190 ! common.sccor
 191 ! Parameters of the SCCOR term
 192 !      common/sccor/
 193       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 194        dcosomicron,domicron      !(3,3,3,maxres2)
 195 !-----------------------------------------------------------------------------
 196 ! common.vectors
 197 !      common /vectors/
 198       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 199       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 200 !-----------------------------------------------------------------------------
 201 ! common /przechowalnia/
 202       real(kind=8),dimension(:,:,:),allocatable :: zapas
 203       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 204 #ifdef FIVEDIAG
 205       real(kind=8),dimension(:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 206 #else
 207       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 208 #endif
 209 !-----------------------------------------------------------------------------
 210 !-----------------------------------------------------------------------------
 211 !
 212 !
 213 !-----------------------------------------------------------------------------
 214       contains
 215 !-----------------------------------------------------------------------------
 216 ! energy_p_new_barrier.F
 217 !-----------------------------------------------------------------------------
 218       subroutine etotal(energia)
 219 !      implicit real(kind=8) (a-h,o-z)
 220 !      include 'DIMENSIONS'
 221       use MD_data
 222 #ifndef ISNAN
 223       external proc_proc
 224 #ifdef WINPGI
 225 !MS$ATTRIBUTES C ::  proc_proc
 226 #endif
 227 #endif
 228 #ifdef MPI
 229       include "mpif.h"
 230 #endif
 231 !      include 'COMMON.SETUP'
 232 !      include 'COMMON.IOUNITS'
 233       real(kind=8),dimension(0:n_ene) :: energia
 234 !      include 'COMMON.LOCAL'
 235 !      include 'COMMON.FFIELD'
 236 !      include 'COMMON.DERIV'
 237 !      include 'COMMON.INTERACT'
 238 !      include 'COMMON.SBRIDGE'
 239 !      include 'COMMON.CHAIN'
 240 !      include 'COMMON.VAR'
 241 !      include 'COMMON.MD'
 242 !      include 'COMMON.CONTROL'
 243 !      include 'COMMON.TIME1'
 244       real(kind=8) :: time00
 245 !el local variables
 246       integer :: n_corr,n_corr1,ierror,imatupdate
 247       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 248       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 249       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 250                       Eafmforce,ethetacnstr
 251       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6,ehomology_constr
 252 ! now energies for nulceic alone parameters
 253       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 254                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 255                       ecorr3_nucl
 256 ! energies for ions
 257       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
 258                       ecation_nucl,ecat_prottran,ecation_protang
 259 ! energies for protein nucleic acid interaction
 260       real(kind=8) :: escbase,epepbase,escpho,epeppho
 261 ! energies for MARTINI
 262        real(kind=8) :: elipbond,elipang,elipelec,eliplj
 263
 264 #ifdef MPI
 265       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 266 ! shielding effect varibles for MPI
 267       real(kind=8) ::  fac_shieldbuf(nres_molec(1)), &
 268       grad_shield_locbuf1(3*maxcontsshi*nres_molec(1)), &
 269       grad_shield_sidebuf1(3*maxcontsshi*nres_molec(1)), &
 270       grad_shield_locbuf2(3*maxcontsshi*nres_molec(1)), &
 271       grad_shield_sidebuf2(3*maxcontsshi*nres_molec(1)), &
 272       grad_shieldbuf1(3*nres_molec(1)), &
 273       grad_shieldbuf2(3*nres_molec(1))
 274
 275        integer ishield_listbuf(-1:nres_molec(1)), &
 276        shield_listbuf(maxcontsshi,-1:nres_molec(1)),k,j,i,iii,impishi,mojint,jjj
 277        integer :: imatupdate2
 278 !       print *,"I START ENERGY"
 279        imatupdate=100
 280        imatupdate2=100
 281 !       if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 282 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 283 !      real(kind=8), dimension(:,:,:),allocatable:: &
 284 !       grad_shield_locbuf,grad_shield_sidebuf
 285 !      real(kind=8), dimension(:,:),allocatable:: &
 286 !        grad_shieldbuf
 287 !       integer, dimension(:),allocatable:: &
 288 !       ishield_listbuf
 289 !       integer, dimension(:,:),allocatable::  shield_listbuf
 290 !       integer :: k,j,i
 291 !      if (.not.allocated(fac_shieldbuf)) then
 292 !          allocate(fac_shieldbuf(nres))
 293 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 294 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 295 !          allocate(grad_shieldbuf(3,-1:nres))
 296 !          allocate(ishield_listbuf(nres))
 297 !          allocate(shield_listbuf(maxcontsshi,nres))
 298 !       endif
 299 !       print *,"wstrain check", wstrain
 300 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 301 !     & " nfgtasks",nfgtasks
 302       if (nfgtasks.gt.1) then
 303         time00=MPI_Wtime()
 304 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 305         if (fg_rank.eq.0) then
 306           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 307 !          print *,"Processor",myrank," BROADCAST iorder"
 308 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 309 ! FG slaves as WEIGHTS array.
 310           weights_(1)=wsc
 311           weights_(2)=wscp
 312           weights_(3)=welec
 313           weights_(4)=wcorr
 314           weights_(5)=wcorr5
 315           weights_(6)=wcorr6
 316           weights_(7)=wel_loc
 317           weights_(8)=wturn3
 318           weights_(9)=wturn4
 319           weights_(10)=wturn6
 320           weights_(11)=wang
 321           weights_(12)=wscloc
 322           weights_(13)=wtor
 323           weights_(14)=wtor_d
 324           weights_(15)=wstrain
 325           weights_(16)=wvdwpp
 326           weights_(17)=wbond
 327           weights_(18)=scal14
 328           weights_(21)=wsccor
 329           weights_(26)=wvdwpp_nucl
 330           weights_(27)=welpp
 331           weights_(28)=wvdwpsb
 332           weights_(29)=welpsb
 333           weights_(30)=wvdwsb
 334           weights_(31)=welsb
 335           weights_(32)=wbond_nucl
 336           weights_(33)=wang_nucl
 337           weights_(34)=wsbloc
 338           weights_(35)=wtor_nucl
 339           weights_(36)=wtor_d_nucl
 340           weights_(37)=wcorr_nucl
 341           weights_(38)=wcorr3_nucl
 342           weights_(41)=wcatcat
 343           weights_(42)=wcatprot
 344           weights_(46)=wscbase
 345           weights_(47)=wpepbase
 346           weights_(48)=wscpho
 347           weights_(49)=wpeppho
 348           weights_(50)=wcatnucl
 349           weights_(56)=wcat_tran
 350
 351 !          wcatcat= weights(41)
 352 !          wcatprot=weights(42)
 353
 354 ! FG Master broadcasts the WEIGHTS_ array
 355           call MPI_Bcast(weights_(1),n_ene,&
 356              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 357         else
 358 ! FG slaves receive the WEIGHTS array
 359           call MPI_Bcast(weights(1),n_ene,&
 360               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 361           wsc=weights(1)
 362           wscp=weights(2)
 363           welec=weights(3)
 364           wcorr=weights(4)
 365           wcorr5=weights(5)
 366           wcorr6=weights(6)
 367           wel_loc=weights(7)
 368           wturn3=weights(8)
 369           wturn4=weights(9)
 370           wturn6=weights(10)
 371           wang=weights(11)
 372           wscloc=weights(12)
 373           wtor=weights(13)
 374           wtor_d=weights(14)
 375           wstrain=weights(15)
 376           wvdwpp=weights(16)
 377           wbond=weights(17)
 378           scal14=weights(18)
 379           wsccor=weights(21)
 380           wvdwpp_nucl =weights(26)
 381           welpp  =weights(27)
 382           wvdwpsb=weights(28)
 383           welpsb =weights(29)
 384           wvdwsb =weights(30)
 385           welsb  =weights(31)
 386           wbond_nucl  =weights(32)
 387           wang_nucl   =weights(33)
 388           wsbloc =weights(34)
 389           wtor_nucl   =weights(35)
 390           wtor_d_nucl =weights(36)
 391           wcorr_nucl  =weights(37)
 392           wcorr3_nucl =weights(38)
 393           wcatcat= weights(41)
 394           wcatprot=weights(42)
 395           wscbase=weights(46)
 396           wpepbase=weights(47)
 397           wscpho=weights(48)
 398           wpeppho=weights(49)
 399           wcatnucl=weights(50)
 400           wcat_tran=weights(56)
 401
 402 !      welpsb=weights(28)*fact(1)
 403 !
 404 !      wcorr_nucl= weights(37)*fact(1)
 405 !     wcorr3_nucl=weights(38)*fact(2)
 406 !     wtor_nucl=  weights(35)*fact(1)
 407 !     wtor_d_nucl=weights(36)*fact(2)
 408
 409         endif
 410         time_Bcast=time_Bcast+MPI_Wtime()-time00
 411         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 412 !        call chainbuild_cart
 413       endif
 414 !       print *,"itime_mat",itime_mat,imatupdate
 415         if (nfgtasks.gt.1) then
 416         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 417         endif
 418        if (nres_molec(1).gt.0) then
 419        if (mod(itime_mat,imatupdate).eq.0) call make_SCp_inter_list
 420 !       write (iout,*) "after make_SCp_inter_list"
 421        if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 422 !       write (iout,*) "after make_SCSC_inter_list"
 423
 424        if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list
 425        if (nres_molec(5).gt.0) then
 426        if (mod(itime_mat,imatupdate).eq.0) then
 427 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 428         call  make_cat_pep_list
 429 !        call  make_cat_cat_list
 430        endif
 431        endif
 432        endif
 433        if (nres_molec(5).gt.0) then
 434        if (mod(itime_mat,imatupdate2).eq.0) then
 435 !       print *, "before cat cat"
 436 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 437 !        call  make_cat_pep_list
 438         call  make_cat_cat_list
 439        endif
 440        endif
 441 !       write (iout,*) "after make_pp_inter_list"
 442
 443 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 444 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 445 #else
 446 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 447 !        call int_from_cart1(.false.)
 448 !      endif
 449 #endif
 450 #ifdef TIMING
 451       time00=MPI_Wtime()
 452 #endif
 453 !
 454 ! Compute the side-chain and electrostatic interaction energy
 455 !        print *, "Before EVDW"
 456 !      goto (101,102,103,104,105,106) ipot
 457       if (nres_molec(1).gt.0) then
 458       select case(ipot)
 459 ! Lennard-Jones potential.
 460 !  101 call elj(evdw)
 461        case (1)
 462          call elj(evdw)
 463 !d    print '(a)','Exit ELJcall el'
 464 !      goto 107
 465 ! Lennard-Jones-Kihara potential (shifted).
 466 !  102 call eljk(evdw)
 467        case (2)
 468          call eljk(evdw)
 469 !      goto 107
 470 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 471 !  103 call ebp(evdw)
 472        case (3)
 473          call ebp(evdw)
 474 !      goto 107
 475 ! Gay-Berne potential (shifted LJ, angular dependence).
 476 !  104 call egb(evdw)
 477        case (4)
 478 !       print *,"MOMO",scelemode
 479         if (scelemode.eq.0) then
 480          call egb(evdw)
 481         else
 482          call emomo(evdw)
 483         endif
 484 !      goto 107
 485 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 486 !  105 call egbv(evdw)
 487        case (5)
 488          call egbv(evdw)
 489 !      goto 107
 490 ! Soft-sphere potential
 491 !  106 call e_softsphere(evdw)
 492        case (6)
 493          call e_softsphere(evdw)
 494 !
 495 ! Calculate electrostatic (H-bonding) energy of the main chain.
 496 !
 497 !  107 continue
 498        case default
 499          write(iout,*)"Wrong ipot"
 500 !         return
 501 !   50 continue
 502       end select
 503 !      continue
 504 !        print *,"after EGB"
 505 ! shielding effect
 506        if (shield_mode.eq.2) then
 507                  call set_shield_fac2
 508
 509       if (nfgtasks.gt.1) then
 510       grad_shield_sidebuf1(:)=0.0d0
 511       grad_shield_locbuf1(:)=0.0d0
 512       grad_shield_sidebuf2(:)=0.0d0
 513       grad_shield_locbuf2(:)=0.0d0
 514       grad_shieldbuf1(:)=0.0d0
 515       grad_shieldbuf2(:)=0.0d0
 516 !#define DEBUG
 517 #ifdef DEBUG
 518        write(iout,*) "befor reduce fac_shield reduce"
 519        do i=1,nres
 520         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 521         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 522        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 523        enddo
 524 #endif
 525         iii=0
 526         jjj=0
 527         do i=1,nres
 528         ishield_listbuf(i)=0
 529         do k=1,3
 530         iii=iii+1
 531         grad_shieldbuf1(iii)=grad_shield(k,i)
 532         enddo
 533         enddo
 534         do i=1,nres
 535          do j=1,maxcontsshi
 536           do k=1,3
 537               jjj=jjj+1
 538               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 539               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 540            enddo
 541           enddo
 542          enddo
 543         call MPI_Allgatherv(fac_shield(ivec_start), &
 544         ivec_count(fg_rank1), &
 545         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 546         ivec_displ(0), &
 547         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 548         call MPI_Allgatherv(shield_list(1,ivec_start), &
 549         ivec_count(fg_rank1), &
 550         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 551         ivec_displ(0), &
 552         MPI_I50,FG_COMM,IERROR)
 553 !        write(2,*) "After I50"
 554 !        call flush(iout)
 555         call MPI_Allgatherv(ishield_list(ivec_start), &
 556         ivec_count(fg_rank1), &
 557         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 558         ivec_displ(0), &
 559         MPI_INTEGER,FG_COMM,IERROR)
 560 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 561
 562 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 563 !        write (2,*) "before"
 564 !        write(2,*) grad_shieldbuf1
 565 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 566 !        ivec_count(fg_rank1)*3, &
 567 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 568 !        ivec_count(0), &
 569 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 570         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 571         nres*3, &
 572         MPI_DOUBLE_PRECISION, &
 573         MPI_SUM, &
 574         FG_COMM,IERROR)
 575         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 576         nres*3*maxcontsshi, &
 577         MPI_DOUBLE_PRECISION, &
 578         MPI_SUM, &
 579         FG_COMM,IERROR)
 580
 581         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 582         nres*3*maxcontsshi, &
 583         MPI_DOUBLE_PRECISION, &
 584         MPI_SUM, &
 585         FG_COMM,IERROR)
 586
 587 !        write(2,*) "after"
 588 !        write(2,*) grad_shieldbuf2
 589
 590 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 591 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 592 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 593 !        ivec_displ(0)*3*maxcontsshi, &
 594 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 595 !        write(2,*) "After grad_shield_side"
 596 !        call flush(iout)
 597 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 598 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 599 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 600 !        ivec_displ(0)*3*maxcontsshi, &
 601 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 602 !        write(2,*) "After MPI_SHI"
 603 !        call flush(iout)
 604         iii=0
 605         jjj=0
 606         do i=1,nres
 607          fac_shield(i)=fac_shieldbuf(i)
 608          ishield_list(i)=ishield_listbuf(i)
 609 !         write(iout,*) i,fac_shield(i)
 610          do j=1,3
 611          iii=iii+1
 612          grad_shield(j,i)=grad_shieldbuf2(iii)
 613          enddo !j
 614          do j=1,ishield_list(i)
 615 !          write (iout,*) "ishild", ishield_list(i),i
 616            shield_list(j,i)=shield_listbuf(j,i)
 617           enddo
 618           do j=1,maxcontsshi
 619           do k=1,3
 620            jjj=jjj+1
 621           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 622           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 623           enddo !k
 624         enddo !j
 625        enddo !i
 626        endif
 627 #ifdef DEBUG
 628        write(iout,*) "after reduce fac_shield reduce"
 629        do i=1,nres
 630         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 631         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 632         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 633        enddo
 634 #endif
 635 #undef DEBUG
 636        endif
 637
 638
 639
 640 !       print *,"AFTER EGB",ipot,evdw
 641 !mc
 642 !mc Sep-06: egb takes care of dynamic ss bonds too
 643 !mc
 644 !      if (dyn_ss) call dyn_set_nss
 645 !      print *,"Processor",myrank," computed USCSC"
 646 #ifdef TIMING
 647       time01=MPI_Wtime()
 648 #endif
 649       call vec_and_deriv
 650 #ifdef TIMING
 651       time_vec=time_vec+MPI_Wtime()-time01
 652 #endif
 653
 654
 655
 656
 657 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 658       if (ipot.lt.6) then
 659 #ifdef SPLITELE
 660 !         print *,"after ipot if", ipot
 661          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 662              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 663              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 664              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 665 #else
 666          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 667              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 668              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 669              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 670 #endif
 671 !            print *,"just befor eelec call"
 672             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 673 !            print *, "ELEC calc"
 674          else
 675             ees=0.0d0
 676             evdw1=0.0d0
 677             eel_loc=0.0d0
 678             eello_turn3=0.0d0
 679             eello_turn4=0.0d0
 680          endif
 681       else
 682 !        write (iout,*) "Soft-spheer ELEC potential"
 683         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 684          eello_turn4)
 685       endif
 686 !      print *,"Processor",myrank," computed UELEC"
 687 !
 688 ! Calculate excluded-volume interaction energy between peptide groups
 689 ! and side chains.
 690 !
 691 !       write(iout,*) "in etotal calc exc;luded",ipot
 692
 693       if (ipot.lt.6) then
 694        if(wscp.gt.0d0) then
 695         call escp(evdw2,evdw2_14)
 696        else
 697         evdw2=0
 698         evdw2_14=0
 699        endif
 700       else
 701 !        write (iout,*) "Soft-sphere SCP potential"
 702         call escp_soft_sphere(evdw2,evdw2_14)
 703       endif
 704 !        write(iout,*) "in etotal before ebond",ipot
 705 !      print *,"after escp"
 706 !
 707 ! Calculate the bond-stretching energy
 708 !
 709       call ebond(estr)
 710 !       print *,"EBOND",estr
 711 !       write(iout,*) "in etotal afer ebond",ipot
 712
 713 !
 714 ! Calculate the disulfide-bridge and other energy and the contributions
 715 ! from other distance constraints.
 716 !      print *,'Calling EHPB'
 717 !      call edis(ehpb)
 718 !elwrite(iout,*) "in etotal afer edis",ipot
 719 !      print *,'EHPB exitted succesfully.'
 720 !
 721 ! Calculate the virtual-bond-angle energy.
 722 !       write(iout,*) "in etotal afer edis",ipot
 723
 724 !      if (wang.gt.0.0d0) then
 725 !        call ebend(ebe,ethetacnstr)
 726 !      else
 727 !        ebe=0
 728 !        ethetacnstr=0
 729 !      endif
 730       if (wang.gt.0d0) then
 731        if (tor_mode.eq.0) then
 732          call ebend(ebe)
 733        else
 734 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 735 !C energy function
 736          call ebend_kcc(ebe)
 737        endif
 738       else
 739         ebe=0.0d0
 740       endif
 741       ethetacnstr=0.0d0
 742 !      write(iout,*) with_theta_constr,"with_theta_constr"
 743       if (with_theta_constr) call etheta_constr(ethetacnstr)
 744
 745 !       write(iout,*) "in etotal afer ebe",ipot
 746
 747 !      print *,"Processor",myrank," computed UB"
 748 !
 749 ! Calculate the SC local energy.
 750 !
 751       call esc(escloc)
 752 !      print *, "in etotal afer esc",wtor
 753 !      print *,"Processor",myrank," computed USC"
 754 !
 755 ! Calculate the virtual-bond torsional energy.
 756 !
 757 !d    print *,'nterm=',nterm
 758 !      if (wtor.gt.0) then
 759 !       call etor(etors,edihcnstr)
 760 !      else
 761 !       etors=0
 762 !       edihcnstr=0
 763 !      endif
 764       if (wtor.gt.0.0d0) then
 765 !         print *,"WTOR",wtor,tor_mode
 766          if (tor_mode.eq.0) then
 767            call etor(etors)
 768          else
 769 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 770 !C energy function
 771            call etor_kcc(etors)
 772          endif
 773       else
 774         etors=0.0d0
 775       endif
 776       edihcnstr=0.0d0
 777       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 778 !c      print *,"Processor",myrank," computed Utor"
 779
 780 !       print *, "constr_homol",constr_homology
 781 !      print *,"Processor",myrank," computed Utor"
 782       if (constr_homology.ge.1) then
 783         call e_modeller(ehomology_constr)
 784 !        print *,'iset=',iset,'me=',me,ehomology_constr,
 785 !     &  'Processor',fg_rank,' CG group',kolor,
 786 !     &  ' absolute rank',MyRank
 787 !       print *,"tu"
 788       else
 789         ehomology_constr=0.0d0
 790       endif
 791
 792 !
 793 ! 6/23/01 Calculate double-torsional energy
 794 !
 795 !      print *, "before etor_d",wtor_d
 796       if (wtor_d.gt.0) then
 797        call etor_d(etors_d)
 798       else
 799        etors_d=0
 800       endif
 801 !      print *,"Processor",myrank," computed Utord"
 802 !
 803 ! 21/5/07 Calculate local sicdechain correlation energy
 804 !
 805       if (wsccor.gt.0.0d0) then
 806         call eback_sc_corr(esccor)
 807       else
 808         esccor=0.0d0
 809       endif
 810
 811 !      write(iout,*) "before multibody"
 812       call flush(iout)
 813 !      print *,"Processor",myrank," computed Usccorr"
 814 !
 815 ! 12/1/95 Multi-body terms
 816 !
 817       n_corr=0
 818       n_corr1=0
 819       call flush(iout)
 820       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 821           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 822          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 823 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 824 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 825       else
 826          ecorr=0.0d0
 827          ecorr5=0.0d0
 828          ecorr6=0.0d0
 829          eturn6=0.0d0
 830       endif
 831 !elwrite(iout,*) "in etotal",ipot
 832       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 833          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 834 !d         write (iout,*) "multibody_hb ecorr",ecorr
 835       endif
 836 !      write(iout,*) "afeter  multibody hb"
 837
 838 !      print *,"Processor",myrank," computed Ucorr"
 839 !
 840 ! If performing constraint dynamics, call the constraint energy
 841 !  after the equilibration time
 842       if((usampl).and.(totT.gt.eq_time)) then
 843         write(iout,*) "usampl",usampl
 844          call EconstrQ
 845 !elwrite(iout,*) "afeter  multibody hb"
 846          call Econstr_back
 847 !elwrite(iout,*) "afeter  multibody hb"
 848       else
 849          Uconst=0.0d0
 850          Uconst_back=0.0d0
 851       endif
 852       call flush(iout)
 853 !         write(iout,*) "after Econstr"
 854
 855       if (wliptran.gt.0) then
 856 !        print *,"PRZED WYWOLANIEM"
 857         call Eliptransfer(eliptran)
 858       else
 859        eliptran=0.0d0
 860       endif
 861       else
 862       eliptran=0.0d0
 863       evdw=0.0d0
 864 #ifdef SCP14
 865       evdw2=0.0d0
 866       evdw2_14=0.0d0
 867 #else
 868       evdw2=0.0d0
 869 #endif
 870 #ifdef SPLITELE
 871       ees=0.0d0
 872       evdw1=0.0d0
 873 #else
 874       ees=0.0d0
 875       evdw1=0.0d0
 876 #endif
 877       ecorr=0.0d0
 878       ecorr5=0.0d0
 879       ecorr6=0.0d0
 880       eel_loc=0.0d0
 881       eello_turn3=0.0d0
 882       eello_turn4=0.0d0
 883       eturn6=0.0d0
 884       ebe=0.0d0
 885       escloc=0.0d0
 886       etors=0.0d0
 887       etors_d=0.0d0
 888       ehpb=0.0d0
 889       edihcnstr=0.0d0
 890       estr=0.0d0
 891       Uconst=0.0d0
 892       esccor=0.0d0
 893       ehomology_constr=0.0d0
 894       ethetacnstr=0.0d0
 895       endif !nres_molec(1)
 896 !      write(iout,*) "TU JEST PRZED EHPB"
 897 !      call edis(ehpb)
 898       if (fg_rank.eq.0) then
 899       if (AFMlog.gt.0) then
 900         call AFMforce(Eafmforce)
 901       else if (selfguide.gt.0) then
 902         call AFMvel(Eafmforce)
 903       else
 904         Eafmforce=0.0d0
 905       endif
 906       endif
 907 !      print *,"before tubemode",tubemode
 908       if (tubemode.eq.1) then
 909        call calctube(etube)
 910       else if (tubemode.eq.2) then
 911        call calctube2(etube)
 912       elseif (tubemode.eq.3) then
 913        call calcnano(etube)
 914       else
 915        etube=0.0d0
 916       endif
 917 !      print *, "TU JEST PRZED EHPB"
 918       call edis(ehpb)
 919
 920 !--------------------------------------------------------
 921 !       print *, "NRES_MOLEC(2),",nres_molec(2)
 922 !      print *,"before",ees,evdw1,ecorr
 923 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 924       if (nres_molec(2).gt.0) then
 925       call ebond_nucl(estr_nucl)
 926       call ebend_nucl(ebe_nucl)
 927       call etor_nucl(etors_nucl)
 928       call esb_gb(evdwsb,eelsb)
 929       call epp_nucl_sub(evdwpp,eespp)
 930       call epsb(evdwpsb,eelpsb)
 931       call esb(esbloc)
 932       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 933             call ecat_nucl(ecation_nucl)
 934       else
 935        etors_nucl=0.0d0
 936        estr_nucl=0.0d0
 937        ecorr3_nucl=0.0d0
 938        ecorr_nucl=0.0d0
 939        ebe_nucl=0.0d0
 940        evdwsb=0.0d0
 941        eelsb=0.0d0
 942        esbloc=0.0d0
 943        evdwpsb=0.0d0
 944        eelpsb=0.0d0
 945        evdwpp=0.0d0
 946        eespp=0.0d0
 947        etors_d_nucl=0.0d0
 948        ecation_nucl=0.0d0
 949       endif
 950 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 951 !      print *,"before ecatcat",wcatcat
 952       if (nres_molec(5).gt.0) then
 953        if (g_ilist_catsctran.gt.0) then
 954         call ecat_prot_transition(ecat_prottran)
 955        else
 956         ecat_prottran=0.0d0
 957        endif
 958        if (g_ilist_catscang.gt.0) then
 959          call ecat_prot_ang(ecation_protang)
 960        else
 961          ecation_protang=0.0d0
 962        endif
 963 !       if (nfgtasks.gt.1) then
 964 !       if (fg_rank.eq.0) then
 965         if (nres_molec(5).gt.1)  call ecatcat(ecationcation)
 966 !       endif
 967 !       else
 968 !        if (nres_molec(5).gt.1) call ecatcat(ecationcation)
 969 !       endif
 970        if (oldion.gt.0) then
 971        if (g_ilist_catpnorm.gt.0) call ecat_prot(ecation_prot)
 972         else
 973        if (g_ilist_catpnorm.gt.0) call ecats_prot_amber(ecation_prot)
 974         endif
 975       else
 976       ecationcation=0.0d0
 977       ecation_prot=0.0d0
 978       ecation_protang=0.0d0
 979       ecat_prottran=0.0d0
 980       endif
 981       if (g_ilist_catscnorm.eq.0) ecation_prot=0.0d0
 982       if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then
 983       call eprot_sc_base(escbase)
 984       call epep_sc_base(epepbase)
 985       call eprot_sc_phosphate(escpho)
 986       call eprot_pep_phosphate(epeppho)
 987       else
 988       epepbase=0.0
 989       escbase=0.0
 990       escpho=0.0
 991       epeppho=0.0
 992       endif
 993 ! MARTINI FORCE FIELD ENERGY TERMS
 994       if (nres_molec(4).gt.0) then
 995       if (nfgtasks.gt.1) then
 996       if (fg_rank.eq.0) then
 997         call lipid_bond(elipbond)
 998         call lipid_angle(elipang)
 999       endif
1000       else
1001         call lipid_bond(elipbond)
1002         call lipid_angle(elipang)
1003       endif
1004         call lipid_LJ(eliplj)
1005         call lipid_elec(elipelec)
1006       else
1007         elipbond=0.0d0
1008         elipang=0.0d0
1009         eliplj=0.0d0
1010         elipelec=0.0d0
1011        endif
1012 !      call ecatcat(ecationcation)
1013 !      print *,"after ebend", wtor_nucl
1014 #ifdef TIMING
1015       time_enecalc=time_enecalc+MPI_Wtime()-time00
1016 #endif
1017 !      print *,"Processor",myrank," computed Uconstr"
1018 #ifdef TIMING
1019       time00=MPI_Wtime()
1020 #endif
1021 !
1022 ! Sum the energies
1023 !
1024       energia(1)=evdw
1025 #ifdef SCP14
1026       energia(2)=evdw2-evdw2_14
1027       energia(18)=evdw2_14
1028 #else
1029       energia(2)=evdw2
1030       energia(18)=0.0d0
1031 #endif
1032 #ifdef SPLITELE
1033       energia(3)=ees
1034       energia(16)=evdw1
1035 #else
1036       energia(3)=ees+evdw1
1037       energia(16)=0.0d0
1038 #endif
1039       energia(4)=ecorr
1040       energia(5)=ecorr5
1041       energia(6)=ecorr6
1042       energia(7)=eel_loc
1043       energia(8)=eello_turn3
1044       energia(9)=eello_turn4
1045       energia(10)=eturn6
1046       energia(11)=ebe
1047       energia(12)=escloc
1048       energia(13)=etors
1049       energia(14)=etors_d
1050       energia(15)=ehpb
1051       energia(19)=edihcnstr
1052       energia(17)=estr
1053       energia(20)=Uconst+Uconst_back
1054       energia(21)=esccor
1055       energia(22)=eliptran
1056       energia(23)=Eafmforce
1057       energia(24)=ethetacnstr
1058       energia(25)=etube
1059 !---------------------------------------------------------------
1060       energia(26)=evdwpp
1061       energia(27)=eespp
1062       energia(28)=evdwpsb
1063       energia(29)=eelpsb
1064       energia(30)=evdwsb
1065       energia(31)=eelsb
1066       energia(32)=estr_nucl
1067       energia(33)=ebe_nucl
1068       energia(34)=esbloc
1069       energia(35)=etors_nucl
1070       energia(36)=etors_d_nucl
1071       energia(37)=ecorr_nucl
1072       energia(38)=ecorr3_nucl
1073 !----------------------------------------------------------------------
1074 !    Here are the energies showed per procesor if the are more processors
1075 !    per molecule then we sum it up in sum_energy subroutine
1076 !      print *," Processor",myrank," calls SUM_ENERGY"
1077       energia(42)=ecation_prot
1078       energia(41)=ecationcation
1079       energia(46)=escbase
1080       energia(47)=epepbase
1081       energia(48)=escpho
1082       energia(49)=epeppho
1083 !      energia(50)=ecations_prot_amber
1084       energia(50)=ecation_nucl
1085       energia(51)=ehomology_constr
1086 !     energia(51)=homology
1087       energia(52)=elipbond
1088       energia(53)=elipang
1089       energia(54)=eliplj
1090       energia(55)=elipelec
1091       energia(56)=ecat_prottran
1092       energia(57)=ecation_protang
1093 !      write(iout,*) elipelec,"elipelec"
1094 !      write(iout,*) elipang,"elipang"
1095 !      write(iout,*) eliplj,"eliplj"
1096       call sum_energy(energia,.true.)
1097       if (dyn_ss) call dyn_set_nss
1098 !      print *," Processor",myrank," left SUM_ENERGY"
1099 #ifdef TIMING
1100       time_sumene=time_sumene+MPI_Wtime()-time00
1101 #endif
1102 !        call enerprint(energia)
1103 !elwrite(iout,*)"finish etotal"
1104       return
1105       end subroutine etotal
1106 !-----------------------------------------------------------------------------
1107       subroutine sum_energy(energia,reduce)
1108 !      implicit real(kind=8) (a-h,o-z)
1109 !      include 'DIMENSIONS'
1110 #ifndef ISNAN
1111       external proc_proc
1112 #ifdef WINPGI
1113 !MS$ATTRIBUTES C ::  proc_proc
1114 #endif
1115 #endif
1116 #ifdef MPI
1117       include "mpif.h"
1118 #endif
1119 !      include 'COMMON.SETUP'
1120 !      include 'COMMON.IOUNITS'
1121       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
1122 !      include 'COMMON.FFIELD'
1123 !      include 'COMMON.DERIV'
1124 !      include 'COMMON.INTERACT'
1125 !      include 'COMMON.SBRIDGE'
1126 !      include 'COMMON.CHAIN'
1127 !      include 'COMMON.VAR'
1128 !      include 'COMMON.CONTROL'
1129 !      include 'COMMON.TIME1'
1130       logical :: reduce
1131       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
1132       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
1133       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
1134         eliptran,etube, Eafmforce,ethetacnstr
1135       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1136                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1137                       ecorr3_nucl,ehomology_constr
1138       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1139                       ecation_nucl,ecat_prottran,ecation_protang
1140       real(kind=8) :: escbase,epepbase,escpho,epeppho
1141       integer :: i
1142       real(kind=8) :: elipbond,elipang,eliplj,elipelec
1143 #ifdef MPI
1144       integer :: ierr
1145       real(kind=8) :: time00
1146       if (nfgtasks.gt.1 .and. reduce) then
1147
1148 #ifdef DEBUG
1149         write (iout,*) "energies before REDUCE"
1150         call enerprint(energia)
1151         call flush(iout)
1152 #endif
1153         do i=0,n_ene
1154           enebuff(i)=energia(i)
1155         enddo
1156         time00=MPI_Wtime()
1157         call MPI_Barrier(FG_COMM,IERR)
1158         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1159         time00=MPI_Wtime()
1160         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1161           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1162 #ifdef DEBUG
1163         write (iout,*) "energies after REDUCE"
1164         call enerprint(energia)
1165         call flush(iout)
1166 #endif
1167         time_Reduce=time_Reduce+MPI_Wtime()-time00
1168       endif
1169       if (fg_rank.eq.0) then
1170 #endif
1171       evdw=energia(1)
1172 #ifdef SCP14
1173       evdw2=energia(2)+energia(18)
1174       evdw2_14=energia(18)
1175 #else
1176       evdw2=energia(2)
1177 #endif
1178 #ifdef SPLITELE
1179       ees=energia(3)
1180       evdw1=energia(16)
1181 #else
1182       ees=energia(3)
1183       evdw1=0.0d0
1184 #endif
1185       ecorr=energia(4)
1186       ecorr5=energia(5)
1187       ecorr6=energia(6)
1188       eel_loc=energia(7)
1189       eello_turn3=energia(8)
1190       eello_turn4=energia(9)
1191       eturn6=energia(10)
1192       ebe=energia(11)
1193       escloc=energia(12)
1194       etors=energia(13)
1195       etors_d=energia(14)
1196       ehpb=energia(15)
1197       edihcnstr=energia(19)
1198       estr=energia(17)
1199       Uconst=energia(20)
1200       esccor=energia(21)
1201       eliptran=energia(22)
1202       Eafmforce=energia(23)
1203       ethetacnstr=energia(24)
1204       etube=energia(25)
1205       evdwpp=energia(26)
1206       eespp=energia(27)
1207       evdwpsb=energia(28)
1208       eelpsb=energia(29)
1209       evdwsb=energia(30)
1210       eelsb=energia(31)
1211       estr_nucl=energia(32)
1212       ebe_nucl=energia(33)
1213       esbloc=energia(34)
1214       etors_nucl=energia(35)
1215       etors_d_nucl=energia(36)
1216       ecorr_nucl=energia(37)
1217       ecorr3_nucl=energia(38)
1218       ecation_prot=energia(42)
1219       ecationcation=energia(41)
1220       escbase=energia(46)
1221       epepbase=energia(47)
1222       escpho=energia(48)
1223       epeppho=energia(49)
1224       ecation_nucl=energia(50)
1225       ehomology_constr=energia(51)
1226       elipbond=energia(52)
1227       elipang=energia(53)
1228       eliplj=energia(54)
1229       elipelec=energia(55)
1230       ecat_prottran=energia(56)
1231       ecation_protang=energia(57)
1232 !      ecations_prot_amber=energia(50)
1233
1234 !      energia(41)=ecation_prot
1235 !      energia(42)=ecationcation
1236
1237
1238 #ifdef SPLITELE
1239       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1240        +wang*ebe+wtor*etors+wscloc*escloc &
1241        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1242        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1243        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1244        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1245        +Eafmforce+ethetacnstr  &
1246        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1247        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1248        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1249        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1250        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1251        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl&
1252        +elipbond+elipang+eliplj+elipelec+wcat_tran*ecat_prottran+ecation_protang&
1253 #ifdef WHAM_RUN
1254        +0.0d0
1255 #else
1256        +ehomology_constr
1257 #endif
1258 #else
1259       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1260        +wang*ebe+wtor*etors+wscloc*escloc &
1261        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1262        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1263        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1264        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1265        +Eafmforce+ethetacnstr &
1266        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1267        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1268        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1269        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1270        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1271        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl&
1272        +elipbond+elipang+eliplj+elipelec+wcat_tran*ecat_prottran+ecation_protang&
1273 #ifdef WHAM_RUN
1274        +0.0d0
1275 #else
1276        +ehomology_constr
1277 #endif
1278 #endif
1279       energia(0)=etot
1280 ! detecting NaNQ
1281 #ifdef ISNAN
1282 #ifdef AIX
1283       if (isnan(etot).ne.0) energia(0)=1.0d+99
1284 #else
1285       if (isnan(etot)) energia(0)=1.0d+99
1286 #endif
1287 #else
1288       i=0
1289 #ifdef WINPGI
1290       idumm=proc_proc(etot,i)
1291 #else
1292       call proc_proc(etot,i)
1293 #endif
1294       if(i.eq.1)energia(0)=1.0d+99
1295 #endif
1296 #ifdef MPI
1297       endif
1298 #endif
1299 !      call enerprint(energia)
1300       call flush(iout)
1301       return
1302       end subroutine sum_energy
1303 !-----------------------------------------------------------------------------
1304       subroutine rescale_weights(t_bath)
1305 !      implicit real(kind=8) (a-h,o-z)
1306 #ifdef MPI
1307       include 'mpif.h'
1308 #endif
1309 !      include 'DIMENSIONS'
1310 !      include 'COMMON.IOUNITS'
1311 !      include 'COMMON.FFIELD'
1312 !      include 'COMMON.SBRIDGE'
1313       real(kind=8) :: kfac=2.4d0
1314       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1315 !el local variables
1316       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1317       real(kind=8) :: T0=3.0d2
1318       integer :: ierror
1319 !      facT=temp0/t_bath
1320 !      facT=2*temp0/(t_bath+temp0)
1321       if (rescale_mode.eq.0) then
1322         facT(1)=1.0d0
1323         facT(2)=1.0d0
1324         facT(3)=1.0d0
1325         facT(4)=1.0d0
1326         facT(5)=1.0d0
1327         facT(6)=1.0d0
1328       else if (rescale_mode.eq.1) then
1329         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1330         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1331         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1332         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1333         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1334 #ifdef WHAM_RUN
1335 !#if defined(WHAM_RUN) || defined(CLUSTER)
1336 #if defined(FUNCTH)
1337 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1338         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1339 #elif defined(FUNCT)
1340         facT(6)=t_bath/T0
1341 #else
1342         facT(6)=1.0d0
1343 #endif
1344 #endif
1345       else if (rescale_mode.eq.2) then
1346         x=t_bath/temp0
1347         x2=x*x
1348         x3=x2*x
1349         x4=x3*x
1350         x5=x4*x
1351         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1352         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1353         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1354         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1355         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1356 #ifdef WHAM_RUN
1357 !#if defined(WHAM_RUN) || defined(CLUSTER)
1358 #if defined(FUNCTH)
1359         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1360 #elif defined(FUNCT)
1361         facT(6)=t_bath/T0
1362 #else
1363         facT(6)=1.0d0
1364 #endif
1365 #endif
1366       else
1367         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1368         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1369 #ifdef MPI
1370        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1371 #endif
1372        stop 555
1373       endif
1374       welec=weights(3)*fact(1)
1375       wcorr=weights(4)*fact(3)
1376       wcorr5=weights(5)*fact(4)
1377       wcorr6=weights(6)*fact(5)
1378       wel_loc=weights(7)*fact(2)
1379       wturn3=weights(8)*fact(2)
1380       wturn4=weights(9)*fact(3)
1381       wturn6=weights(10)*fact(5)
1382       wtor=weights(13)*fact(1)
1383       wtor_d=weights(14)*fact(2)
1384       wsccor=weights(21)*fact(1)
1385       welpsb=weights(28)*fact(1)
1386       wcorr_nucl= weights(37)*fact(1)
1387       wcorr3_nucl=weights(38)*fact(2)
1388       wtor_nucl=  weights(35)*fact(1)
1389       wtor_d_nucl=weights(36)*fact(2)
1390       wpepbase=weights(47)*fact(1)
1391       return
1392       end subroutine rescale_weights
1393 !-----------------------------------------------------------------------------
1394       subroutine enerprint(energia)
1395 !      implicit real(kind=8) (a-h,o-z)
1396 !      include 'DIMENSIONS'
1397 !      include 'COMMON.IOUNITS'
1398 !      include 'COMMON.FFIELD'
1399 !      include 'COMMON.SBRIDGE'
1400 !      include 'COMMON.MD'
1401       real(kind=8) :: energia(0:n_ene)
1402 !el local variables
1403       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1404       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1405       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1406        etube,ethetacnstr,Eafmforce
1407       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1408                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1409                       ecorr3_nucl,ehomology_constr
1410       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1411                       ecation_nucl,ecat_prottran,ecation_protang
1412       real(kind=8) :: escbase,epepbase,escpho,epeppho
1413       real(kind=8) :: elipbond,elipang,eliplj,elipelec
1414       etot=energia(0)
1415       evdw=energia(1)
1416       evdw2=energia(2)
1417 #ifdef SCP14
1418       evdw2=energia(2)+energia(18)
1419 #else
1420       evdw2=energia(2)
1421 #endif
1422       ees=energia(3)
1423 #ifdef SPLITELE
1424       evdw1=energia(16)
1425 #endif
1426       ecorr=energia(4)
1427       ecorr5=energia(5)
1428       ecorr6=energia(6)
1429       eel_loc=energia(7)
1430       eello_turn3=energia(8)
1431       eello_turn4=energia(9)
1432       eello_turn6=energia(10)
1433       ebe=energia(11)
1434       escloc=energia(12)
1435       etors=energia(13)
1436       etors_d=energia(14)
1437       ehpb=energia(15)
1438       edihcnstr=energia(19)
1439       estr=energia(17)
1440       Uconst=energia(20)
1441       esccor=energia(21)
1442       eliptran=energia(22)
1443       Eafmforce=energia(23)
1444       ethetacnstr=energia(24)
1445       etube=energia(25)
1446       evdwpp=energia(26)
1447       eespp=energia(27)
1448       evdwpsb=energia(28)
1449       eelpsb=energia(29)
1450       evdwsb=energia(30)
1451       eelsb=energia(31)
1452       estr_nucl=energia(32)
1453       ebe_nucl=energia(33)
1454       esbloc=energia(34)
1455       etors_nucl=energia(35)
1456       etors_d_nucl=energia(36)
1457       ecorr_nucl=energia(37)
1458       ecorr3_nucl=energia(38)
1459       ecation_prot=energia(42)
1460       ecationcation=energia(41)
1461       escbase=energia(46)
1462       epepbase=energia(47)
1463       escpho=energia(48)
1464       epeppho=energia(49)
1465       ecation_nucl=energia(50)
1466       elipbond=energia(52)
1467       elipang=energia(53)
1468       eliplj=energia(54)
1469       elipelec=energia(55)
1470       ecat_prottran=energia(56)
1471       ecation_protang=energia(57)
1472       ehomology_constr=energia(51)
1473
1474 !      ecations_prot_amber=energia(50)
1475 #ifdef SPLITELE
1476       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1477         estr,wbond,ebe,wang,&
1478         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1479         ecorr,wcorr,&
1480         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1481         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1482         edihcnstr,ethetacnstr,ebr*nss,&
1483         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1484         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1485         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1486         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1487         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1488         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,&
1489         ecat_prottran,wcat_tran,ecation_protang,wcat_ang,&
1490         ecationcation,wcatcat, &
1491         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1492         ecation_nucl,wcatnucl,ehomology_constr,&
1493         elipbond,elipang,eliplj,elipelec,etot
1494    10 format (/'Virtual-chain energies:'// &
1495        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1496        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1497        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1498        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1499        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1500        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1501        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1502        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1503        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1504        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1505        ' (SS bridges & dist. cnstr.)'/ &
1506        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1507        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1508        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1509        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1510        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1511        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1512        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1513        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1514        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1515        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1516        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1517        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1518        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1519        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1520        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1521        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1522        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1523        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1524        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1525        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1526        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1527        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1528        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1529        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1530        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1531        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1532        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1533        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1534        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1535        'ECATPTRAN=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot tran)'/ &
1536        'ECATPANG=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot angle)'/ &
1537        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1538        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1539        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1540        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1541        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1542        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1543        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1544        'ELIPBOND=',1pE16.6,'(matrini bond energy)'/&
1545        'ELIPANG=',1pE16.6,'(matrini angle energy)'/&
1546        'ELIPLJ=',1pE16.6,'(matrini Lennard-Jones energy)'/&
1547        'ELIPELEC=',1pE16.6,'(matrini electrostatic energy)'/&
1548        'ETOT=  ',1pE16.6,' (total)')
1549 #else
1550       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1551         estr,wbond,ebe,wang,&
1552         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1553         ecorr,wcorr,&
1554         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1555         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1556         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1557         etube,wtube, ehomology_constr,&
1558         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1559         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1560         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1561         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1562         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1563         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1564         ecation_nucl,wcatnucl,ehomology_constr,etot
1565    10 format (/'Virtual-chain energies:'// &
1566        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1567        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1568        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1569        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1570        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1571        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1572        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1573        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1574        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1575        ' (SS bridges & dist. cnstr.)'/ &
1576        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1577        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1578        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1579        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1580        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1581        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1582        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1583        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1584        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1585        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1586        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1587        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1588        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1589        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1590        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1591        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1592        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1593        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1594        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1595        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1596        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1597        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1598        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1599        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1600        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1601        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1602        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1603        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1604        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1605        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1606        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1607        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1608        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1609        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1610        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1611        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1612        'ELIPBOND=',1pE16.6,'(matrini bond energy)'/&
1613        'ELIPANG=',1pE16.6,'(matrini angle energy)'/&
1614        'ELIPLJ=',1pE16.6,'(matrini Lennard-Jones energy)'/&
1615        'ELIPELEC=',1pE16.6,'(matrini electrostatic energy)'/&
1616        'ETOT=  ',1pE16.6,' (total)')
1617 #endif
1618       return
1619       end subroutine enerprint
1620 !-----------------------------------------------------------------------------
1621       subroutine elj(evdw)
1622 !
1623 ! This subroutine calculates the interaction energy of nonbonded side chains
1624 ! assuming the LJ potential of interaction.
1625 !
1626 !      implicit real(kind=8) (a-h,o-z)
1627 !      include 'DIMENSIONS'
1628       real(kind=8),parameter :: accur=1.0d-10
1629 !      include 'COMMON.GEO'
1630 !      include 'COMMON.VAR'
1631 !      include 'COMMON.LOCAL'
1632 !      include 'COMMON.CHAIN'
1633 !      include 'COMMON.DERIV'
1634 !      include 'COMMON.INTERACT'
1635 !      include 'COMMON.TORSION'
1636 !      include 'COMMON.SBRIDGE'
1637 !      include 'COMMON.NAMES'
1638 !      include 'COMMON.IOUNITS'
1639 !      include 'COMMON.CONTACTS'
1640       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1641       integer :: num_conti
1642 !el local variables
1643       integer :: i,itypi,iint,j,itypi1,itypj,k
1644       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1645        aa,bb,sslipj,ssgradlipj
1646       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1647       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1648
1649 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1650       evdw=0.0D0
1651 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1652 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1653 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1654 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1655
1656       do i=iatsc_s,iatsc_e
1657         itypi=iabs(itype(i,1))
1658         if (itypi.eq.ntyp1) cycle
1659         itypi1=iabs(itype(i+1,1))
1660         xi=c(1,nres+i)
1661         yi=c(2,nres+i)
1662         zi=c(3,nres+i)
1663         call to_box(xi,yi,zi)
1664         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1665
1666 ! Change 12/1/95
1667         num_conti=0
1668 !
1669 ! Calculate SC interaction energy.
1670 !
1671         do iint=1,nint_gr(i)
1672 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1673 !d   &                  'iend=',iend(i,iint)
1674           do j=istart(i,iint),iend(i,iint)
1675             itypj=iabs(itype(j,1))
1676             if (itypj.eq.ntyp1) cycle
1677             xj=c(1,nres+j)-xi
1678             yj=c(2,nres+j)-yi
1679             zj=c(3,nres+j)-zi
1680             call to_box(xj,yj,zj)
1681             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1682             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1683              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1684             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1685              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1686             xj=boxshift(xj-xi,boxxsize)
1687             yj=boxshift(yj-yi,boxysize)
1688             zj=boxshift(zj-zi,boxzsize)
1689 ! Change 12/1/95 to calculate four-body interactions
1690             rij=xj*xj+yj*yj+zj*zj
1691             rrij=1.0D0/rij
1692 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1693             eps0ij=eps(itypi,itypj)
1694             fac=rrij**expon2
1695             e1=fac*fac*aa_aq(itypi,itypj)
1696             e2=fac*bb_aq(itypi,itypj)
1697             evdwij=e1+e2
1698 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1699 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1700 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1701 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1702 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1703 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1704             evdw=evdw+evdwij
1705 !
1706 ! Calculate the components of the gradient in DC and X
1707 !
1708             fac=-rrij*(e1+evdwij)
1709             gg(1)=xj*fac
1710             gg(2)=yj*fac
1711             gg(3)=zj*fac
1712             do k=1,3
1713               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1714               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1715               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1716               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1717             enddo
1718 !grad            do k=i,j-1
1719 !grad              do l=1,3
1720 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1721 !grad              enddo
1722 !grad            enddo
1723 !
1724 ! 12/1/95, revised on 5/20/97
1725 !
1726 ! Calculate the contact function. The ith column of the array JCONT will
1727 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1728 ! greater than I). The arrays FACONT and GACONT will contain the values of
1729 ! the contact function and its derivative.
1730 !
1731 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1732 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1733 ! Uncomment next line, if the correlation interactions are contact function only
1734             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1735               rij=dsqrt(rij)
1736               sigij=sigma(itypi,itypj)
1737               r0ij=rs0(itypi,itypj)
1738 !
1739 ! Check whether the SC's are not too far to make a contact.
1740 !
1741               rcut=1.5d0*r0ij
1742               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1743 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1744 !
1745               if (fcont.gt.0.0D0) then
1746 ! If the SC-SC distance if close to sigma, apply spline.
1747 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1748 !Adam &             fcont1,fprimcont1)
1749 !Adam           fcont1=1.0d0-fcont1
1750 !Adam           if (fcont1.gt.0.0d0) then
1751 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1752 !Adam             fcont=fcont*fcont1
1753 !Adam           endif
1754 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1755 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1756 !ga             do k=1,3
1757 !ga               gg(k)=gg(k)*eps0ij
1758 !ga             enddo
1759 !ga             eps0ij=-evdwij*eps0ij
1760 ! Uncomment for AL's type of SC correlation interactions.
1761 !adam           eps0ij=-evdwij
1762                 num_conti=num_conti+1
1763                 jcont(num_conti,i)=j
1764                 facont(num_conti,i)=fcont*eps0ij
1765                 fprimcont=eps0ij*fprimcont/rij
1766                 fcont=expon*fcont
1767 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1768 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1769 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1770 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1771                 gacont(1,num_conti,i)=-fprimcont*xj
1772                 gacont(2,num_conti,i)=-fprimcont*yj
1773                 gacont(3,num_conti,i)=-fprimcont*zj
1774 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1775 !d              write (iout,'(2i3,3f10.5)')
1776 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1777               endif
1778             endif
1779           enddo      ! j
1780         enddo        ! iint
1781 ! Change 12/1/95
1782         num_cont(i)=num_conti
1783       enddo          ! i
1784       do i=1,nct
1785         do j=1,3
1786           gvdwc(j,i)=expon*gvdwc(j,i)
1787           gvdwx(j,i)=expon*gvdwx(j,i)
1788         enddo
1789       enddo
1790 !******************************************************************************
1791 !
1792 !                              N O T E !!!
1793 !
1794 ! To save time, the factor of EXPON has been extracted from ALL components
1795 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1796 ! use!
1797 !
1798 !******************************************************************************
1799       return
1800       end subroutine elj
1801 !-----------------------------------------------------------------------------
1802       subroutine eljk(evdw)
1803 !
1804 ! This subroutine calculates the interaction energy of nonbonded side chains
1805 ! assuming the LJK potential of interaction.
1806 !
1807 !      implicit real(kind=8) (a-h,o-z)
1808 !      include 'DIMENSIONS'
1809 !      include 'COMMON.GEO'
1810 !      include 'COMMON.VAR'
1811 !      include 'COMMON.LOCAL'
1812 !      include 'COMMON.CHAIN'
1813 !      include 'COMMON.DERIV'
1814 !      include 'COMMON.INTERACT'
1815 !      include 'COMMON.IOUNITS'
1816 !      include 'COMMON.NAMES'
1817       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1818       logical :: scheck
1819 !el local variables
1820       integer :: i,iint,j,itypi,itypi1,k,itypj
1821       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1822          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1823       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1824
1825 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1826       evdw=0.0D0
1827       do i=iatsc_s,iatsc_e
1828         itypi=iabs(itype(i,1))
1829         if (itypi.eq.ntyp1) cycle
1830         itypi1=iabs(itype(i+1,1))
1831         xi=c(1,nres+i)
1832         yi=c(2,nres+i)
1833         zi=c(3,nres+i)
1834         call to_box(xi,yi,zi)
1835         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1836
1837 !
1838 ! Calculate SC interaction energy.
1839 !
1840         do iint=1,nint_gr(i)
1841           do j=istart(i,iint),iend(i,iint)
1842             itypj=iabs(itype(j,1))
1843             if (itypj.eq.ntyp1) cycle
1844             xj=c(1,nres+j)-xi
1845             yj=c(2,nres+j)-yi
1846             zj=c(3,nres+j)-zi
1847             call to_box(xj,yj,zj)
1848             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1849             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1850              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1851             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1852              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1853             xj=boxshift(xj-xi,boxxsize)
1854             yj=boxshift(yj-yi,boxysize)
1855             zj=boxshift(zj-zi,boxzsize)
1856             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1857             fac_augm=rrij**expon
1858             e_augm=augm(itypi,itypj)*fac_augm
1859             r_inv_ij=dsqrt(rrij)
1860             rij=1.0D0/r_inv_ij
1861             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1862             fac=r_shift_inv**expon
1863             e1=fac*fac*aa_aq(itypi,itypj)
1864             e2=fac*bb_aq(itypi,itypj)
1865             evdwij=e_augm+e1+e2
1866 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1867 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1868 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1869 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1870 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1871 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1872 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1873             evdw=evdw+evdwij
1874 !
1875 ! Calculate the components of the gradient in DC and X
1876 !
1877             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1878             gg(1)=xj*fac
1879             gg(2)=yj*fac
1880             gg(3)=zj*fac
1881             do k=1,3
1882               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1883               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1884               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1885               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1886             enddo
1887 !grad            do k=i,j-1
1888 !grad              do l=1,3
1889 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1890 !grad              enddo
1891 !grad            enddo
1892           enddo      ! j
1893         enddo        ! iint
1894       enddo          ! i
1895       do i=1,nct
1896         do j=1,3
1897           gvdwc(j,i)=expon*gvdwc(j,i)
1898           gvdwx(j,i)=expon*gvdwx(j,i)
1899         enddo
1900       enddo
1901       return
1902       end subroutine eljk
1903 !-----------------------------------------------------------------------------
1904       subroutine ebp(evdw)
1905 !
1906 ! This subroutine calculates the interaction energy of nonbonded side chains
1907 ! assuming the Berne-Pechukas potential of interaction.
1908 !
1909       use comm_srutu
1910       use calc_data
1911 !      implicit real(kind=8) (a-h,o-z)
1912 !      include 'DIMENSIONS'
1913 !      include 'COMMON.GEO'
1914 !      include 'COMMON.VAR'
1915 !      include 'COMMON.LOCAL'
1916 !      include 'COMMON.CHAIN'
1917 !      include 'COMMON.DERIV'
1918 !      include 'COMMON.NAMES'
1919 !      include 'COMMON.INTERACT'
1920 !      include 'COMMON.IOUNITS'
1921 !      include 'COMMON.CALC'
1922       use comm_srutu
1923 !el      integer :: icall
1924 !el      common /srutu/ icall
1925 !     double precision rrsave(maxdim)
1926       logical :: lprn
1927 !el local variables
1928       integer :: iint,itypi,itypi1,itypj
1929       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1930         ssgradlipj, aa, bb
1931       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1932
1933 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1934       evdw=0.0D0
1935 !     if (icall.eq.0) then
1936 !       lprn=.true.
1937 !     else
1938         lprn=.false.
1939 !     endif
1940 !el      ind=0
1941       do i=iatsc_s,iatsc_e
1942         itypi=iabs(itype(i,1))
1943         if (itypi.eq.ntyp1) cycle
1944         itypi1=iabs(itype(i+1,1))
1945         xi=c(1,nres+i)
1946         yi=c(2,nres+i)
1947         zi=c(3,nres+i)
1948         call to_box(xi,yi,zi)
1949         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1950         dxi=dc_norm(1,nres+i)
1951         dyi=dc_norm(2,nres+i)
1952         dzi=dc_norm(3,nres+i)
1953 !        dsci_inv=dsc_inv(itypi)
1954         dsci_inv=vbld_inv(i+nres)
1955 !
1956 ! Calculate SC interaction energy.
1957 !
1958         do iint=1,nint_gr(i)
1959           do j=istart(i,iint),iend(i,iint)
1960 !el            ind=ind+1
1961             itypj=iabs(itype(j,1))
1962             if (itypj.eq.ntyp1) cycle
1963 !            dscj_inv=dsc_inv(itypj)
1964             dscj_inv=vbld_inv(j+nres)
1965             chi1=chi(itypi,itypj)
1966             chi2=chi(itypj,itypi)
1967             chi12=chi1*chi2
1968             chip1=chip(itypi)
1969             chip2=chip(itypj)
1970             chip12=chip1*chip2
1971             alf1=alp(itypi)
1972             alf2=alp(itypj)
1973             alf12=0.5D0*(alf1+alf2)
1974 ! For diagnostics only!!!
1975 !           chi1=0.0D0
1976 !           chi2=0.0D0
1977 !           chi12=0.0D0
1978 !           chip1=0.0D0
1979 !           chip2=0.0D0
1980 !           chip12=0.0D0
1981 !           alf1=0.0D0
1982 !           alf2=0.0D0
1983 !           alf12=0.0D0
1984             xj=c(1,nres+j)-xi
1985             yj=c(2,nres+j)-yi
1986             zj=c(3,nres+j)-zi
1987             call to_box(xj,yj,zj)
1988             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1989             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1990              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1991             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1992              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1993             xj=boxshift(xj-xi,boxxsize)
1994             yj=boxshift(yj-yi,boxysize)
1995             zj=boxshift(zj-zi,boxzsize)
1996             dxj=dc_norm(1,nres+j)
1997             dyj=dc_norm(2,nres+j)
1998             dzj=dc_norm(3,nres+j)
1999             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2000 !d          if (icall.eq.0) then
2001 !d            rrsave(ind)=rrij
2002 !d          else
2003 !d            rrij=rrsave(ind)
2004 !d          endif
2005             rij=dsqrt(rrij)
2006 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
2007             call sc_angular
2008 ! Calculate whole angle-dependent part of epsilon and contributions
2009 ! to its derivatives
2010             fac=(rrij*sigsq)**expon2
2011             e1=fac*fac*aa_aq(itypi,itypj)
2012             e2=fac*bb_aq(itypi,itypj)
2013             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2014             eps2der=evdwij*eps3rt
2015             eps3der=evdwij*eps2rt
2016             evdwij=evdwij*eps2rt*eps3rt
2017             evdw=evdw+evdwij
2018             if (lprn) then
2019             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2020             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2021 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
2022 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2023 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
2024 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
2025 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
2026 !d     &        evdwij
2027             endif
2028 ! Calculate gradient components.
2029             e1=e1*eps1*eps2rt**2*eps3rt**2
2030             fac=-expon*(e1+evdwij)
2031             sigder=fac/sigsq
2032             fac=rrij*fac
2033 ! Calculate radial part of the gradient
2034             gg(1)=xj*fac
2035             gg(2)=yj*fac
2036             gg(3)=zj*fac
2037 ! Calculate the angular part of the gradient and sum add the contributions
2038 ! to the appropriate components of the Cartesian gradient.
2039             call sc_grad
2040           enddo      ! j
2041         enddo        ! iint
2042       enddo          ! i
2043 !     stop
2044       return
2045       end subroutine ebp
2046 !-----------------------------------------------------------------------------
2047       subroutine egb(evdw)
2048 !
2049 ! This subroutine calculates the interaction energy of nonbonded side chains
2050 ! assuming the Gay-Berne potential of interaction.
2051 !
2052       use calc_data
2053 !      implicit real(kind=8) (a-h,o-z)
2054 !      include 'DIMENSIONS'
2055 !      include 'COMMON.GEO'
2056 !      include 'COMMON.VAR'
2057 !      include 'COMMON.LOCAL'
2058 !      include 'COMMON.CHAIN'
2059 !      include 'COMMON.DERIV'
2060 !      include 'COMMON.NAMES'
2061 !      include 'COMMON.INTERACT'
2062 !      include 'COMMON.IOUNITS'
2063 !      include 'COMMON.CALC'
2064 !      include 'COMMON.CONTROL'
2065 !      include 'COMMON.SBRIDGE'
2066       logical :: lprn
2067 !el local variables
2068       integer :: iint,itypi,itypi1,itypj,subchap,icont,countss
2069       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
2070       real(kind=8) :: evdw,sig0ij
2071       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
2072                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
2073                     sslipi,sslipj,faclip
2074       integer :: ii
2075       real(kind=8) :: fracinbuf
2076
2077 !cccc      energy_dec=.false.
2078 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2079       evdw=0.0D0
2080       lprn=.false.
2081       countss=0
2082 !     if (icall.eq.0) lprn=.false.
2083 !el      ind=0
2084       dCAVdOM2=0.0d0
2085       dGCLdOM2=0.0d0
2086       dPOLdOM2=0.0d0
2087       dCAVdOM1=0.0d0
2088       dGCLdOM1=0.0d0
2089       dPOLdOM1=0.0d0
2090 !             write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
2091       if (nres_molec(1).eq.0) return
2092       do icont=g_listscsc_start,g_listscsc_end
2093       i=newcontlisti(icont)
2094       j=newcontlistj(icont)
2095 !      write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
2096 !      do i=iatsc_s,iatsc_e
2097 !C        print *,"I am in EVDW",i
2098         itypi=iabs(itype(i,1))
2099 !        if (i.ne.47) cycle
2100         if (itypi.eq.ntyp1) cycle
2101         itypi1=iabs(itype(i+1,1))
2102         xi=c(1,nres+i)
2103         yi=c(2,nres+i)
2104         zi=c(3,nres+i)
2105         call to_box(xi,yi,zi)
2106         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2107
2108         dxi=dc_norm(1,nres+i)
2109         dyi=dc_norm(2,nres+i)
2110         dzi=dc_norm(3,nres+i)
2111 !        dsci_inv=dsc_inv(itypi)
2112         dsci_inv=vbld_inv(i+nres)
2113 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
2114 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
2115 !
2116 ! Calculate SC interaction energy.
2117 !
2118 !        do iint=1,nint_gr(i)
2119 !          do j=istart(i,iint),iend(i,iint)
2120             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
2121               countss=countss+1
2122               call dyn_ssbond_ene(i,j,evdwij,countss)
2123               evdw=evdw+evdwij
2124               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
2125                               'evdw',i,j,evdwij,' ss'
2126 !              if (energy_dec) write (iout,*) &
2127 !                              'evdw',i,j,evdwij,' ss'
2128              do k=j+1,nres
2129 !C search over all next residues
2130               if (dyn_ss_mask(k)) then
2131 !C check if they are cysteins
2132 !C              write(iout,*) 'k=',k
2133
2134 !c              write(iout,*) "PRZED TRI", evdwij
2135 !               evdwij_przed_tri=evdwij
2136               call triple_ssbond_ene(i,j,k,evdwij)
2137 !c               if(evdwij_przed_tri.ne.evdwij) then
2138 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2139 !c               endif
2140
2141 !c              write(iout,*) "PO TRI", evdwij
2142 !C call the energy function that removes the artifical triple disulfide
2143 !C bond the soubroutine is located in ssMD.F
2144               evdw=evdw+evdwij
2145               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
2146                             'evdw',i,j,evdwij,'tss'
2147               endif!dyn_ss_mask(k)
2148              enddo! k
2149             ELSE
2150 !el            ind=ind+1
2151             itypj=iabs(itype(j,1))
2152             if (itypj.eq.ntyp1) cycle
2153 !             if (j.ne.78) cycle
2154 !            dscj_inv=dsc_inv(itypj)
2155             dscj_inv=vbld_inv(j+nres)
2156 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
2157 !              1.0d0/vbld(j+nres) !d
2158 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
2159             sig0ij=sigma(itypi,itypj)
2160             chi1=chi(itypi,itypj)
2161             chi2=chi(itypj,itypi)
2162             chi12=chi1*chi2
2163             chip1=chip(itypi)
2164             chip2=chip(itypj)
2165             chip12=chip1*chip2
2166             alf1=alp(itypi)
2167             alf2=alp(itypj)
2168             alf12=0.5D0*(alf1+alf2)
2169 ! For diagnostics only!!!
2170 !           chi1=0.0D0
2171 !           chi2=0.0D0
2172 !           chi12=0.0D0
2173 !           chip1=0.0D0
2174 !           chip2=0.0D0
2175 !           chip12=0.0D0
2176 !           alf1=0.0D0
2177 !           alf2=0.0D0
2178 !           alf12=0.0D0
2179            xj=c(1,nres+j)
2180            yj=c(2,nres+j)
2181            zj=c(3,nres+j)
2182               call to_box(xj,yj,zj)
2183               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2184 !              write (iout,*) "KWA2", itypi,itypj
2185               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2186                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2187               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2188                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2189               xj=boxshift(xj-xi,boxxsize)
2190               yj=boxshift(yj-yi,boxysize)
2191               zj=boxshift(zj-zi,boxzsize)
2192             dxj=dc_norm(1,nres+j)
2193             dyj=dc_norm(2,nres+j)
2194             dzj=dc_norm(3,nres+j)
2195 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2196 !            write (iout,*) "j",j," dc_norm",& !d
2197 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2198 !          write(iout,*)"rrij ",rrij
2199 !          write(iout,*)"xj yj zj ", xj, yj, zj
2200 !          write(iout,*)"xi yi zi ", xi, yi, zi
2201 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2202             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2203             rij=dsqrt(rrij)
2204             sss_ele_cut=sscale_ele(1.0d0/(rij))
2205             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2206 !            print *,sss_ele_cut,sss_ele_grad,&
2207 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2208             if (sss_ele_cut.le.0.0) cycle
2209 ! Calculate angle-dependent terms of energy and contributions to their
2210 ! derivatives.
2211             call sc_angular
2212             sigsq=1.0D0/sigsq
2213             sig=sig0ij*dsqrt(sigsq)
2214             rij_shift=1.0D0/rij-sig+sig0ij
2215 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2216 !            "sig0ij",sig0ij
2217 ! for diagnostics; uncomment
2218 !            rij_shift=1.2*sig0ij
2219 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2220             if (rij_shift.le.0.0D0) then
2221               evdw=1.0D20
2222 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2223 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2224 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2225               return
2226             endif
2227             sigder=-sig*sigsq
2228 !---------------------------------------------------------------
2229             rij_shift=1.0D0/rij_shift
2230             fac=rij_shift**expon
2231             faclip=fac
2232             e1=fac*fac*aa!(itypi,itypj)
2233             e2=fac*bb!(itypi,itypj)
2234             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2235             eps2der=evdwij*eps3rt
2236             eps3der=evdwij*eps2rt
2237 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2238 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2239 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2240             evdwij=evdwij*eps2rt*eps3rt
2241             evdw=evdw+evdwij*sss_ele_cut
2242             if (lprn) then
2243             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2244             epsi=bb**2/aa!(itypi,itypj)
2245             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2246               restyp(itypi,1),i,restyp(itypj,1),j, &
2247               epsi,sigm,chi1,chi2,chip1,chip2, &
2248               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2249               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2250               evdwij
2251             endif
2252
2253             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2254                              'evdw',i,j,evdwij,1.0D0/rij,1.0D0/rij_shift,dabs(aa/bb)**(1.0D0/6.0D0)!,"egb"
2255 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2256 !            if (energy_dec) write (iout,*) &
2257 !                             'evdw',i,j,evdwij
2258 !                       print *,"ZALAMKA", evdw
2259
2260 ! Calculate gradient components.
2261             e1=e1*eps1*eps2rt**2*eps3rt**2
2262             fac=-expon*(e1+evdwij)*rij_shift
2263             sigder=fac*sigder
2264             fac=rij*fac
2265 !            print *,'before fac',fac,rij,evdwij
2266             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2267             *rij
2268 !            print *,'grad part scale',fac,   &
2269 !             evdwij*sss_ele_grad/sss_ele_cut &
2270 !            /sigma(itypi,itypj)*rij
2271 !            fac=0.0d0
2272 ! Calculate the radial part of the gradient
2273             gg(1)=xj*fac
2274             gg(2)=yj*fac
2275             gg(3)=zj*fac
2276 !C Calculate the radial part of the gradient
2277             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2278        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2279         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2280        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2281             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2282             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2283
2284 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2285 ! Calculate angular part of the gradient.
2286             call sc_grad
2287             ENDIF    ! dyn_ss
2288 !          enddo      ! j
2289 !        enddo        ! iint
2290       enddo          ! i
2291 !       print *,"ZALAMKA", evdw
2292 !      write (iout,*) "Number of loop steps in EGB:",ind
2293 !ccc      energy_dec=.false.
2294       return
2295       end subroutine egb
2296 !-----------------------------------------------------------------------------
2297       subroutine egbv(evdw)
2298 !
2299 ! This subroutine calculates the interaction energy of nonbonded side chains
2300 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2301 !
2302       use comm_srutu
2303       use calc_data
2304 !      implicit real(kind=8) (a-h,o-z)
2305 !      include 'DIMENSIONS'
2306 !      include 'COMMON.GEO'
2307 !      include 'COMMON.VAR'
2308 !      include 'COMMON.LOCAL'
2309 !      include 'COMMON.CHAIN'
2310 !      include 'COMMON.DERIV'
2311 !      include 'COMMON.NAMES'
2312 !      include 'COMMON.INTERACT'
2313 !      include 'COMMON.IOUNITS'
2314 !      include 'COMMON.CALC'
2315       use comm_srutu
2316 !el      integer :: icall
2317 !el      common /srutu/ icall
2318       logical :: lprn
2319 !el local variables
2320       integer :: iint,itypi,itypi1,itypj
2321       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2322          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2323       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2324
2325 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2326       evdw=0.0D0
2327       lprn=.false.
2328 !     if (icall.eq.0) lprn=.true.
2329 !el      ind=0
2330       do i=iatsc_s,iatsc_e
2331         itypi=iabs(itype(i,1))
2332         if (itypi.eq.ntyp1) cycle
2333         itypi1=iabs(itype(i+1,1))
2334         xi=c(1,nres+i)
2335         yi=c(2,nres+i)
2336         zi=c(3,nres+i)
2337         call to_box(xi,yi,zi)
2338         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2339         dxi=dc_norm(1,nres+i)
2340         dyi=dc_norm(2,nres+i)
2341         dzi=dc_norm(3,nres+i)
2342 !        dsci_inv=dsc_inv(itypi)
2343         dsci_inv=vbld_inv(i+nres)
2344 !
2345 ! Calculate SC interaction energy.
2346 !
2347         do iint=1,nint_gr(i)
2348           do j=istart(i,iint),iend(i,iint)
2349 !el            ind=ind+1
2350             itypj=iabs(itype(j,1))
2351             if (itypj.eq.ntyp1) cycle
2352 !            dscj_inv=dsc_inv(itypj)
2353             dscj_inv=vbld_inv(j+nres)
2354             sig0ij=sigma(itypi,itypj)
2355             r0ij=r0(itypi,itypj)
2356             chi1=chi(itypi,itypj)
2357             chi2=chi(itypj,itypi)
2358             chi12=chi1*chi2
2359             chip1=chip(itypi)
2360             chip2=chip(itypj)
2361             chip12=chip1*chip2
2362             alf1=alp(itypi)
2363             alf2=alp(itypj)
2364             alf12=0.5D0*(alf1+alf2)
2365 ! For diagnostics only!!!
2366 !           chi1=0.0D0
2367 !           chi2=0.0D0
2368 !           chi12=0.0D0
2369 !           chip1=0.0D0
2370 !           chip2=0.0D0
2371 !           chip12=0.0D0
2372 !           alf1=0.0D0
2373 !           alf2=0.0D0
2374 !           alf12=0.0D0
2375             xj=c(1,nres+j)-xi
2376             yj=c(2,nres+j)-yi
2377             zj=c(3,nres+j)-zi
2378            call to_box(xj,yj,zj)
2379            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2380            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2381             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2382            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2383             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2384            xj=boxshift(xj-xi,boxxsize)
2385            yj=boxshift(yj-yi,boxysize)
2386            zj=boxshift(zj-zi,boxzsize)
2387             dxj=dc_norm(1,nres+j)
2388             dyj=dc_norm(2,nres+j)
2389             dzj=dc_norm(3,nres+j)
2390             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2391             rij=dsqrt(rrij)
2392 ! Calculate angle-dependent terms of energy and contributions to their
2393 ! derivatives.
2394             call sc_angular
2395             sigsq=1.0D0/sigsq
2396             sig=sig0ij*dsqrt(sigsq)
2397             rij_shift=1.0D0/rij-sig+r0ij
2398 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2399             if (rij_shift.le.0.0D0) then
2400               evdw=1.0D20
2401               return
2402             endif
2403             sigder=-sig*sigsq
2404 !---------------------------------------------------------------
2405             rij_shift=1.0D0/rij_shift
2406             fac=rij_shift**expon
2407             e1=fac*fac*aa_aq(itypi,itypj)
2408             e2=fac*bb_aq(itypi,itypj)
2409             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2410             eps2der=evdwij*eps3rt
2411             eps3der=evdwij*eps2rt
2412             fac_augm=rrij**expon
2413             e_augm=augm(itypi,itypj)*fac_augm
2414             evdwij=evdwij*eps2rt*eps3rt
2415             evdw=evdw+evdwij+e_augm
2416             if (lprn) then
2417             sigm=dabs(aa_aq(itypi,itypj)/&
2418             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2419             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2420             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2421               restyp(itypi,1),i,restyp(itypj,1),j,&
2422               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2423               chi1,chi2,chip1,chip2,&
2424               eps1,eps2rt**2,eps3rt**2,&
2425               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2426               evdwij+e_augm
2427             endif
2428 ! Calculate gradient components.
2429             e1=e1*eps1*eps2rt**2*eps3rt**2
2430             fac=-expon*(e1+evdwij)*rij_shift
2431             sigder=fac*sigder
2432             fac=rij*fac-2*expon*rrij*e_augm
2433 ! Calculate the radial part of the gradient
2434             gg(1)=xj*fac
2435             gg(2)=yj*fac
2436             gg(3)=zj*fac
2437 ! Calculate angular part of the gradient.
2438             call sc_grad
2439           enddo      ! j
2440         enddo        ! iint
2441       enddo          ! i
2442       end subroutine egbv
2443 !-----------------------------------------------------------------------------
2444 !el      subroutine sc_angular in module geometry
2445 !-----------------------------------------------------------------------------
2446       subroutine e_softsphere(evdw)
2447 !
2448 ! This subroutine calculates the interaction energy of nonbonded side chains
2449 ! assuming the LJ potential of interaction.
2450 !
2451 !      implicit real(kind=8) (a-h,o-z)
2452 !      include 'DIMENSIONS'
2453       real(kind=8),parameter :: accur=1.0d-10
2454 !      include 'COMMON.GEO'
2455 !      include 'COMMON.VAR'
2456 !      include 'COMMON.LOCAL'
2457 !      include 'COMMON.CHAIN'
2458 !      include 'COMMON.DERIV'
2459 !      include 'COMMON.INTERACT'
2460 !      include 'COMMON.TORSION'
2461 !      include 'COMMON.SBRIDGE'
2462 !      include 'COMMON.NAMES'
2463 !      include 'COMMON.IOUNITS'
2464 !      include 'COMMON.CONTACTS'
2465       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2466 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2467 !el local variables
2468       integer :: i,iint,j,itypi,itypi1,itypj,k
2469       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2470       real(kind=8) :: fac
2471
2472       evdw=0.0D0
2473       do i=iatsc_s,iatsc_e
2474         itypi=iabs(itype(i,1))
2475         if (itypi.eq.ntyp1) cycle
2476         itypi1=iabs(itype(i+1,1))
2477         xi=c(1,nres+i)
2478         yi=c(2,nres+i)
2479         zi=c(3,nres+i)
2480         call to_box(xi,yi,zi)
2481
2482 !
2483 ! Calculate SC interaction energy.
2484 !
2485         do iint=1,nint_gr(i)
2486 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2487 !d   &                  'iend=',iend(i,iint)
2488           do j=istart(i,iint),iend(i,iint)
2489             itypj=iabs(itype(j,1))
2490             if (itypj.eq.ntyp1) cycle
2491             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2492             yj=boxshift(c(2,nres+j)-yi,boxysize)
2493             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2494             rij=xj*xj+yj*yj+zj*zj
2495 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2496             r0ij=r0(itypi,itypj)
2497             r0ijsq=r0ij*r0ij
2498 !            print *,i,j,r0ij,dsqrt(rij)
2499             if (rij.lt.r0ijsq) then
2500               evdwij=0.25d0*(rij-r0ijsq)**2
2501               fac=rij-r0ijsq
2502             else
2503               evdwij=0.0d0
2504               fac=0.0d0
2505             endif
2506             evdw=evdw+evdwij
2507 !
2508 ! Calculate the components of the gradient in DC and X
2509 !
2510             gg(1)=xj*fac
2511             gg(2)=yj*fac
2512             gg(3)=zj*fac
2513             do k=1,3
2514               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2515               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2516               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2517               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2518             enddo
2519 !grad            do k=i,j-1
2520 !grad              do l=1,3
2521 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2522 !grad              enddo
2523 !grad            enddo
2524           enddo ! j
2525         enddo ! iint
2526       enddo ! i
2527       return
2528       end subroutine e_softsphere
2529 !-----------------------------------------------------------------------------
2530       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2531 !
2532 ! Soft-sphere potential of p-p interaction
2533 !
2534 !      implicit real(kind=8) (a-h,o-z)
2535 !      include 'DIMENSIONS'
2536 !      include 'COMMON.CONTROL'
2537 !      include 'COMMON.IOUNITS'
2538 !      include 'COMMON.GEO'
2539 !      include 'COMMON.VAR'
2540 !      include 'COMMON.LOCAL'
2541 !      include 'COMMON.CHAIN'
2542 !      include 'COMMON.DERIV'
2543 !      include 'COMMON.INTERACT'
2544 !      include 'COMMON.CONTACTS'
2545 !      include 'COMMON.TORSION'
2546 !      include 'COMMON.VECTORS'
2547 !      include 'COMMON.FFIELD'
2548       real(kind=8),dimension(3) :: ggg
2549 !d      write(iout,*) 'In EELEC_soft_sphere'
2550 !el local variables
2551       integer :: i,j,k,num_conti,iteli,itelj
2552       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2553       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2554       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2555
2556       ees=0.0D0
2557       evdw1=0.0D0
2558       eel_loc=0.0d0
2559       eello_turn3=0.0d0
2560       eello_turn4=0.0d0
2561 !el      ind=0
2562       do i=iatel_s,iatel_e
2563         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2564         dxi=dc(1,i)
2565         dyi=dc(2,i)
2566         dzi=dc(3,i)
2567         xmedi=c(1,i)+0.5d0*dxi
2568         ymedi=c(2,i)+0.5d0*dyi
2569         zmedi=c(3,i)+0.5d0*dzi
2570         call to_box(xmedi,ymedi,zmedi)
2571         num_conti=0
2572 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2573         do j=ielstart(i),ielend(i)
2574           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2575 !el          ind=ind+1
2576           iteli=itel(i)
2577           itelj=itel(j)
2578           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2579           r0ij=rpp(iteli,itelj)
2580           r0ijsq=r0ij*r0ij
2581           dxj=dc(1,j)
2582           dyj=dc(2,j)
2583           dzj=dc(3,j)
2584           xj=c(1,j)+0.5D0*dxj-xmedi
2585           yj=c(2,j)+0.5D0*dyj-ymedi
2586           zj=c(3,j)+0.5D0*dzj-zmedi
2587           call to_box(xj,yj,zj)
2588           xj=boxshift(xj-xmedi,boxxsize)
2589           yj=boxshift(yj-ymedi,boxysize)
2590           zj=boxshift(zj-zmedi,boxzsize)
2591           rij=xj*xj+yj*yj+zj*zj
2592           if (rij.lt.r0ijsq) then
2593             evdw1ij=0.25d0*(rij-r0ijsq)**2
2594             fac=rij-r0ijsq
2595           else
2596             evdw1ij=0.0d0
2597             fac=0.0d0
2598           endif
2599           evdw1=evdw1+evdw1ij
2600 !
2601 ! Calculate contributions to the Cartesian gradient.
2602 !
2603           ggg(1)=fac*xj
2604           ggg(2)=fac*yj
2605           ggg(3)=fac*zj
2606           do k=1,3
2607             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2608             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2609           enddo
2610 !
2611 ! Loop over residues i+1 thru j-1.
2612 !
2613 !grad          do k=i+1,j-1
2614 !grad            do l=1,3
2615 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2616 !grad            enddo
2617 !grad          enddo
2618         enddo ! j
2619       enddo   ! i
2620 !grad      do i=nnt,nct-1
2621 !grad        do k=1,3
2622 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2623 !grad        enddo
2624 !grad        do j=i+1,nct-1
2625 !grad          do k=1,3
2626 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2627 !grad          enddo
2628 !grad        enddo
2629 !grad      enddo
2630       return
2631       end subroutine eelec_soft_sphere
2632 !-----------------------------------------------------------------------------
2633       subroutine vec_and_deriv
2634 !      implicit real(kind=8) (a-h,o-z)
2635 !      include 'DIMENSIONS'
2636 #ifdef MPI
2637       include 'mpif.h'
2638 #endif
2639 !      include 'COMMON.IOUNITS'
2640 !      include 'COMMON.GEO'
2641 !      include 'COMMON.VAR'
2642 !      include 'COMMON.LOCAL'
2643 !      include 'COMMON.CHAIN'
2644 !      include 'COMMON.VECTORS'
2645 !      include 'COMMON.SETUP'
2646 !      include 'COMMON.TIME1'
2647       real(kind=8),dimension(3,3,2) :: uyder,uzder
2648       real(kind=8),dimension(2) :: vbld_inv_temp
2649 ! Compute the local reference systems. For reference system (i), the
2650 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2651 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2652 !el local variables
2653       integer :: i,j,k,l
2654       real(kind=8) :: facy,fac,costh
2655
2656 #ifdef PARVEC
2657       do i=ivec_start,ivec_end
2658 #else
2659       do i=1,nres-1
2660 #endif
2661           if (i.eq.nres-1) then
2662 ! Case of the last full residue
2663 ! Compute the Z-axis
2664             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2665             costh=dcos(pi-theta(nres))
2666             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2667             do k=1,3
2668               uz(k,i)=fac*uz(k,i)
2669             enddo
2670 ! Compute the derivatives of uz
2671             uzder(1,1,1)= 0.0d0
2672             uzder(2,1,1)=-dc_norm(3,i-1)
2673             uzder(3,1,1)= dc_norm(2,i-1)
2674             uzder(1,2,1)= dc_norm(3,i-1)
2675             uzder(2,2,1)= 0.0d0
2676             uzder(3,2,1)=-dc_norm(1,i-1)
2677             uzder(1,3,1)=-dc_norm(2,i-1)
2678             uzder(2,3,1)= dc_norm(1,i-1)
2679             uzder(3,3,1)= 0.0d0
2680             uzder(1,1,2)= 0.0d0
2681             uzder(2,1,2)= dc_norm(3,i)
2682             uzder(3,1,2)=-dc_norm(2,i)
2683             uzder(1,2,2)=-dc_norm(3,i)
2684             uzder(2,2,2)= 0.0d0
2685             uzder(3,2,2)= dc_norm(1,i)
2686             uzder(1,3,2)= dc_norm(2,i)
2687             uzder(2,3,2)=-dc_norm(1,i)
2688             uzder(3,3,2)= 0.0d0
2689 ! Compute the Y-axis
2690             facy=fac
2691             do k=1,3
2692               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2693             enddo
2694 ! Compute the derivatives of uy
2695             do j=1,3
2696               do k=1,3
2697                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2698                               -dc_norm(k,i)*dc_norm(j,i-1)
2699                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2700               enddo
2701               uyder(j,j,1)=uyder(j,j,1)-costh
2702               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2703             enddo
2704             do j=1,2
2705               do k=1,3
2706                 do l=1,3
2707                   uygrad(l,k,j,i)=uyder(l,k,j)
2708                   uzgrad(l,k,j,i)=uzder(l,k,j)
2709                 enddo
2710               enddo
2711             enddo
2712             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2713             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2714             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2715             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2716           else
2717 ! Other residues
2718 ! Compute the Z-axis
2719             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2720             costh=dcos(pi-theta(i+2))
2721             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2722             do k=1,3
2723               uz(k,i)=fac*uz(k,i)
2724             enddo
2725 ! Compute the derivatives of uz
2726             uzder(1,1,1)= 0.0d0
2727             uzder(2,1,1)=-dc_norm(3,i+1)
2728             uzder(3,1,1)= dc_norm(2,i+1)
2729             uzder(1,2,1)= dc_norm(3,i+1)
2730             uzder(2,2,1)= 0.0d0
2731             uzder(3,2,1)=-dc_norm(1,i+1)
2732             uzder(1,3,1)=-dc_norm(2,i+1)
2733             uzder(2,3,1)= dc_norm(1,i+1)
2734             uzder(3,3,1)= 0.0d0
2735             uzder(1,1,2)= 0.0d0
2736             uzder(2,1,2)= dc_norm(3,i)
2737             uzder(3,1,2)=-dc_norm(2,i)
2738             uzder(1,2,2)=-dc_norm(3,i)
2739             uzder(2,2,2)= 0.0d0
2740             uzder(3,2,2)= dc_norm(1,i)
2741             uzder(1,3,2)= dc_norm(2,i)
2742             uzder(2,3,2)=-dc_norm(1,i)
2743             uzder(3,3,2)= 0.0d0
2744 ! Compute the Y-axis
2745             facy=fac
2746             do k=1,3
2747               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2748             enddo
2749 ! Compute the derivatives of uy
2750             do j=1,3
2751               do k=1,3
2752                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2753                               -dc_norm(k,i)*dc_norm(j,i+1)
2754                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2755               enddo
2756               uyder(j,j,1)=uyder(j,j,1)-costh
2757               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2758             enddo
2759             do j=1,2
2760               do k=1,3
2761                 do l=1,3
2762                   uygrad(l,k,j,i)=uyder(l,k,j)
2763                   uzgrad(l,k,j,i)=uzder(l,k,j)
2764                 enddo
2765               enddo
2766             enddo
2767             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2768             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2769             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2770             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2771           endif
2772       enddo
2773       do i=1,nres-1
2774         vbld_inv_temp(1)=vbld_inv(i+1)
2775         if (i.lt.nres-1) then
2776           vbld_inv_temp(2)=vbld_inv(i+2)
2777           else
2778           vbld_inv_temp(2)=vbld_inv(i)
2779           endif
2780         do j=1,2
2781           do k=1,3
2782             do l=1,3
2783               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2784               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2785             enddo
2786           enddo
2787         enddo
2788       enddo
2789 #if defined(PARVEC) && defined(MPI)
2790       if (nfgtasks1.gt.1) then
2791         time00=MPI_Wtime()
2792 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2793 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2794 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2795         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2796          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2797          FG_COMM1,IERR)
2798         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2799          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2800          FG_COMM1,IERR)
2801         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2802          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2803          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2804         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2805          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2806          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2807         time_gather=time_gather+MPI_Wtime()-time00
2808       endif
2809 !      if (fg_rank.eq.0) then
2810 !        write (iout,*) "Arrays UY and UZ"
2811 !        do i=1,nres-1
2812 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2813 !     &     (uz(k,i),k=1,3)
2814 !        enddo
2815 !      endif
2816 #endif
2817       return
2818       end subroutine vec_and_deriv
2819 !-----------------------------------------------------------------------------
2820       subroutine check_vecgrad
2821 !      implicit real(kind=8) (a-h,o-z)
2822 !      include 'DIMENSIONS'
2823 !      include 'COMMON.IOUNITS'
2824 !      include 'COMMON.GEO'
2825 !      include 'COMMON.VAR'
2826 !      include 'COMMON.LOCAL'
2827 !      include 'COMMON.CHAIN'
2828 !      include 'COMMON.VECTORS'
2829       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2830       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2831       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2832       real(kind=8),dimension(3) :: erij
2833       real(kind=8) :: delta=1.0d-7
2834 !el local variables
2835       integer :: i,j,k,l
2836
2837       call vec_and_deriv
2838 !d      do i=1,nres
2839 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2840 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2841 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2842 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2843 !d     &     (dc_norm(if90,i),if90=1,3)
2844 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2845 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2846 !d          write(iout,'(a)')
2847 !d      enddo
2848       do i=1,nres
2849         do j=1,2
2850           do k=1,3
2851             do l=1,3
2852               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2853               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2854             enddo
2855           enddo
2856         enddo
2857       enddo
2858       call vec_and_deriv
2859       do i=1,nres
2860         do j=1,3
2861           uyt(j,i)=uy(j,i)
2862           uzt(j,i)=uz(j,i)
2863         enddo
2864       enddo
2865       do i=1,nres
2866 !d        write (iout,*) 'i=',i
2867         do k=1,3
2868           erij(k)=dc_norm(k,i)
2869         enddo
2870         do j=1,3
2871           do k=1,3
2872             dc_norm(k,i)=erij(k)
2873           enddo
2874           dc_norm(j,i)=dc_norm(j,i)+delta
2875 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2876 !          do k=1,3
2877 !            dc_norm(k,i)=dc_norm(k,i)/fac
2878 !          enddo
2879 !          write (iout,*) (dc_norm(k,i),k=1,3)
2880 !          write (iout,*) (erij(k),k=1,3)
2881           call vec_and_deriv
2882           do k=1,3
2883             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2884             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2885             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2886             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2887           enddo
2888 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2889 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2890 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2891         enddo
2892         do k=1,3
2893           dc_norm(k,i)=erij(k)
2894         enddo
2895 !d        do k=1,3
2896 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2897 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2898 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2899 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2900 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2901 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2902 !d          write (iout,'(a)')
2903 !d        enddo
2904       enddo
2905       return
2906       end subroutine check_vecgrad
2907 !-----------------------------------------------------------------------------
2908       subroutine set_matrices
2909 !      implicit real(kind=8) (a-h,o-z)
2910 !      include 'DIMENSIONS'
2911 #ifdef MPI
2912       include "mpif.h"
2913 !      include "COMMON.SETUP"
2914       integer :: IERR
2915       integer :: status(MPI_STATUS_SIZE)
2916 #endif
2917 !      include 'COMMON.IOUNITS'
2918 !      include 'COMMON.GEO'
2919 !      include 'COMMON.VAR'
2920 !      include 'COMMON.LOCAL'
2921 !      include 'COMMON.CHAIN'
2922 !      include 'COMMON.DERIV'
2923 !      include 'COMMON.INTERACT'
2924 !      include 'COMMON.CONTACTS'
2925 !      include 'COMMON.TORSION'
2926 !      include 'COMMON.VECTORS'
2927 !      include 'COMMON.FFIELD'
2928       real(kind=8) :: auxvec(2),auxmat(2,2)
2929       integer :: i,iti1,iti,k,l,ii,innt,inct
2930       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2931        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2932 !       print *,"in set matrices"
2933 !
2934 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2935 ! to calculate the el-loc multibody terms of various order.
2936 !
2937 !AL el      mu=0.0d0
2938
2939 #ifdef PARMAT
2940       do i=ivec_start+2,ivec_end+2
2941 #else
2942       do i=3,nres+1
2943 #endif
2944 #ifdef FIVEDIAG
2945         ii=ireschain(i-2)
2946 !c        write (iout,*) "i",i,i-2," ii",ii
2947         if (ii.eq.0) cycle
2948         innt=chain_border(1,ii)
2949         inct=chain_border(2,ii)
2950 !c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2951 !c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2952         if (i.gt. innt+2 .and. i.lt.inct+2) then
2953           if (itype(i-2,1).eq.0) then
2954           iti = nloctyp
2955           else
2956           iti = itype2loc(itype(i-2,1))
2957           endif
2958         else
2959           iti=nloctyp
2960         endif
2961 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2962         if (i.gt. innt+1 .and. i.lt.inct+1) then
2963 !          iti1 = itype2loc(itype(i-1))
2964           if (itype(i-1,1).eq.0) then
2965           iti1 = nloctyp
2966           else
2967           iti1 = itype2loc(itype(i-1,1))
2968           endif
2969         else
2970           iti1=nloctyp
2971         endif
2972 #else
2973         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2974           if (itype(i-2,1).eq.0) then
2975           iti = nloctyp
2976           else
2977           iti = itype2loc(itype(i-2,1))
2978           endif
2979         else
2980           iti=nloctyp
2981         endif
2982 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2983         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2984           iti1 = itype2loc(itype(i-1,1))
2985         else
2986           iti1=nloctyp
2987         endif
2988 #endif
2989 !        print *,i,itype(i-2,1),iti
2990 #ifdef NEWCORR
2991         cost1=dcos(theta(i-1))
2992         sint1=dsin(theta(i-1))
2993         sint1sq=sint1*sint1
2994         sint1cub=sint1sq*sint1
2995         sint1cost1=2*sint1*cost1
2996 !        print *,"cost1",cost1,theta(i-1)
2997 !c        write (iout,*) "bnew1",i,iti
2998 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2999 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
3000 !c        write (iout,*) "bnew2",i,iti
3001 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3002 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3003         k=1
3004 !        print *,bnew1(1,k,iti),"bnew1"
3005         do k=1,2
3006           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3007 !          print *,b1k
3008 !          write(*,*) shape(b1)
3009 !          if(.not.allocated(b1)) print *, "WTF?"
3010           b1(k,i-2)=sint1*b1k
3011 !
3012 !             print *,b1(k,i-2)
3013
3014           gtb1(k,i-2)=cost1*b1k-sint1sq*&
3015                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3016 !             print *,gtb1(k,i-2)
3017
3018           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3019           b2(k,i-2)=sint1*b2k
3020 !             print *,b2(k,i-2)
3021
3022           gtb2(k,i-2)=cost1*b2k-sint1sq*&
3023                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3024 !             print *,gtb2(k,i-2)
3025
3026         enddo
3027 !        print *,b1k,b2k
3028         do k=1,2
3029           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3030           cc(1,k,i-2)=sint1sq*aux
3031           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
3032                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3033           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3034           dd(1,k,i-2)=sint1sq*aux
3035           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
3036                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3037         enddo
3038 !        print *,"after cc"
3039         cc(2,1,i-2)=cc(1,2,i-2)
3040         cc(2,2,i-2)=-cc(1,1,i-2)
3041         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3042         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3043         dd(2,1,i-2)=dd(1,2,i-2)
3044         dd(2,2,i-2)=-dd(1,1,i-2)
3045         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3046         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3047 !        print *,"after dd"
3048
3049         do k=1,2
3050           do l=1,2
3051             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3052             EE(l,k,i-2)=sint1sq*aux
3053             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3054           enddo
3055         enddo
3056         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3057         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3058         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3059         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3060         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3061         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3062         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3063 !        print *,"after ee"
3064
3065 !c        b1tilde(1,i-2)=b1(1,i-2)
3066 !c        b1tilde(2,i-2)=-b1(2,i-2)
3067 !c        b2tilde(1,i-2)=b2(1,i-2)
3068 !c        b2tilde(2,i-2)=-b2(2,i-2)
3069 #ifdef DEBUG
3070         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3071         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3072         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3073         write (iout,*) 'theta=', theta(i-1)
3074 #endif
3075 #else
3076         if (i.gt. innt+2 .and. i.lt.inct+2) then
3077 !         write(iout,*) "i,",molnum(i),nloctyp
3078 !         print *, "i,",molnum(i),i,itype(i-2,1)
3079         if (molnum(i).eq.1) then
3080           if (itype(i-2,1).eq.ntyp1) then
3081            iti=nloctyp
3082           else
3083           iti = itype2loc(itype(i-2,1))
3084           endif
3085         else
3086           iti=nloctyp
3087         endif
3088         else
3089           iti=nloctyp
3090         endif
3091 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3092 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3093         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3094           iti1 = itype2loc(itype(i-1,1))
3095         else
3096           iti1=nloctyp
3097         endif
3098 !        print *,i,iti
3099         b1(1,i-2)=b(3,iti)
3100         b1(2,i-2)=b(5,iti)
3101         b2(1,i-2)=b(2,iti)
3102         b2(2,i-2)=b(4,iti)
3103         do k=1,2
3104           do l=1,2
3105            CC(k,l,i-2)=ccold(k,l,iti)
3106            DD(k,l,i-2)=ddold(k,l,iti)
3107            EE(k,l,i-2)=eeold(k,l,iti)
3108           enddo
3109         enddo
3110 #endif
3111         b1tilde(1,i-2)= b1(1,i-2)
3112         b1tilde(2,i-2)=-b1(2,i-2)
3113         b2tilde(1,i-2)= b2(1,i-2)
3114         b2tilde(2,i-2)=-b2(2,i-2)
3115 !c
3116         Ctilde(1,1,i-2)= CC(1,1,i-2)
3117         Ctilde(1,2,i-2)= CC(1,2,i-2)
3118         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3119         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3120 !c
3121         Dtilde(1,1,i-2)= DD(1,1,i-2)
3122         Dtilde(1,2,i-2)= DD(1,2,i-2)
3123         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3124         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3125       enddo
3126 #ifdef PARMAT
3127       do i=ivec_start+2,ivec_end+2
3128 #else
3129       do i=3,nres+1
3130 #endif
3131
3132 !      print *,i,"i"
3133         if (i .lt. nres+1 .and. (itype(i-1,1).lt.ntyp1).and.(itype(i-1,1).ne.0)) then
3134 !        if (i .lt. nres+1) then
3135           sin1=dsin(phi(i))
3136           cos1=dcos(phi(i))
3137           sintab(i-2)=sin1
3138           costab(i-2)=cos1
3139           obrot(1,i-2)=cos1
3140           obrot(2,i-2)=sin1
3141           sin2=dsin(2*phi(i))
3142           cos2=dcos(2*phi(i))
3143           sintab2(i-2)=sin2
3144           costab2(i-2)=cos2
3145           obrot2(1,i-2)=cos2
3146           obrot2(2,i-2)=sin2
3147           Ug(1,1,i-2)=-cos1
3148           Ug(1,2,i-2)=-sin1
3149           Ug(2,1,i-2)=-sin1
3150           Ug(2,2,i-2)= cos1
3151           Ug2(1,1,i-2)=-cos2
3152           Ug2(1,2,i-2)=-sin2
3153           Ug2(2,1,i-2)=-sin2
3154           Ug2(2,2,i-2)= cos2
3155         else
3156           costab(i-2)=1.0d0
3157           sintab(i-2)=0.0d0
3158           obrot(1,i-2)=1.0d0
3159           obrot(2,i-2)=0.0d0
3160           obrot2(1,i-2)=0.0d0
3161           obrot2(2,i-2)=0.0d0
3162           Ug(1,1,i-2)=1.0d0
3163           Ug(1,2,i-2)=0.0d0
3164           Ug(2,1,i-2)=0.0d0
3165           Ug(2,2,i-2)=1.0d0
3166           Ug2(1,1,i-2)=0.0d0
3167           Ug2(1,2,i-2)=0.0d0
3168           Ug2(2,1,i-2)=0.0d0
3169           Ug2(2,2,i-2)=0.0d0
3170         endif
3171         if (i .gt. 3) then   ! .and. i .lt. nres+1) then
3172           obrot_der(1,i-2)=-sin1
3173           obrot_der(2,i-2)= cos1
3174           Ugder(1,1,i-2)= sin1
3175           Ugder(1,2,i-2)=-cos1
3176           Ugder(2,1,i-2)=-cos1
3177           Ugder(2,2,i-2)=-sin1
3178           dwacos2=cos2+cos2
3179           dwasin2=sin2+sin2
3180           obrot2_der(1,i-2)=-dwasin2
3181           obrot2_der(2,i-2)= dwacos2
3182           Ug2der(1,1,i-2)= dwasin2
3183           Ug2der(1,2,i-2)=-dwacos2
3184           Ug2der(2,1,i-2)=-dwacos2
3185           Ug2der(2,2,i-2)=-dwasin2
3186         else
3187           obrot_der(1,i-2)=0.0d0
3188           obrot_der(2,i-2)=0.0d0
3189           Ugder(1,1,i-2)=0.0d0
3190           Ugder(1,2,i-2)=0.0d0
3191           Ugder(2,1,i-2)=0.0d0
3192           Ugder(2,2,i-2)=0.0d0
3193           obrot2_der(1,i-2)=0.0d0
3194           obrot2_der(2,i-2)=0.0d0
3195           Ug2der(1,1,i-2)=0.0d0
3196           Ug2der(1,2,i-2)=0.0d0
3197           Ug2der(2,1,i-2)=0.0d0
3198           Ug2der(2,2,i-2)=0.0d0
3199         endif
3200 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3201         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3202            if (itype(i-2,1).eq.0) then
3203           iti=ntortyp+1
3204            else
3205           iti = itype2loc(itype(i-2,1))
3206            endif
3207         else
3208           iti=nloctyp
3209         endif
3210 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3211         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3212            if (itype(i-1,1).eq.0) then
3213           iti1=nloctyp
3214            else
3215           iti1 = itype2loc(itype(i-1,1))
3216            endif
3217         else
3218           iti1=nloctyp
3219         endif
3220 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3221 !d        write (iout,*) '*******i',i,' iti1',iti
3222 !        write (iout,*) 'b1',b1(:,iti)
3223 !        write (iout,*) 'b2',b2(:,i-2)
3224 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3225 !        if (i .gt. iatel_s+2) then
3226         if (i .gt. nnt+2) then
3227           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3228 #ifdef NEWCORR
3229           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3230 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3231 #endif
3232
3233           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3234           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3235           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3236           then
3237           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3238           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3239           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3240           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3241           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3242           endif
3243         else
3244           do k=1,2
3245             Ub2(k,i-2)=0.0d0
3246             Ctobr(k,i-2)=0.0d0
3247             Dtobr2(k,i-2)=0.0d0
3248             do l=1,2
3249               EUg(l,k,i-2)=0.0d0
3250               CUg(l,k,i-2)=0.0d0
3251               DUg(l,k,i-2)=0.0d0
3252               DtUg2(l,k,i-2)=0.0d0
3253             enddo
3254           enddo
3255         endif
3256         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3257         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3258         do k=1,2
3259           muder(k,i-2)=Ub2der(k,i-2)
3260         enddo
3261 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3262         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3263           if (itype(i-1,1).eq.0) then
3264            iti1=nloctyp
3265           elseif (itype(i-1,1).le.ntyp) then
3266             iti1 = itype2loc(itype(i-1,1))
3267           else
3268             iti1=nloctyp
3269           endif
3270         else
3271           iti1=nloctyp
3272         endif
3273         do k=1,2
3274           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3275         enddo
3276         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3277         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3278         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3279 !d        write (iout,*) 'mu1',mu1(:,i-2)
3280 !d        write (iout,*) 'mu2',mu2(:,i-2)
3281         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3282         then
3283         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3284         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3285         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3286         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3287         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3288 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3289         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3290         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3291         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3292         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3293         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3294         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3295         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3296         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3297         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3298         endif
3299       enddo
3300 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3301 ! The order of matrices is from left to right.
3302       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3303       then
3304 !      do i=max0(ivec_start,2),ivec_end
3305       do i=2,nres-1
3306         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3307         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3308         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3309         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3310         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3311         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3312         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3313         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3314       enddo
3315       endif
3316 #if defined(MPI) && defined(PARMAT)
3317 #ifdef DEBUG
3318 !      if (fg_rank.eq.0) then
3319         write (iout,*) "Arrays UG and UGDER before GATHER"
3320         do i=1,nres-1
3321           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3322            ((ug(l,k,i),l=1,2),k=1,2),&
3323            ((ugder(l,k,i),l=1,2),k=1,2)
3324         enddo
3325         write (iout,*) "Arrays UG2 and UG2DER"
3326         do i=1,nres-1
3327           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3328            ((ug2(l,k,i),l=1,2),k=1,2),&
3329            ((ug2der(l,k,i),l=1,2),k=1,2)
3330         enddo
3331         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3332         do i=1,nres-1
3333           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3334            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3335            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3336         enddo
3337         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3338         do i=1,nres-1
3339           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3340            costab(i),sintab(i),costab2(i),sintab2(i)
3341         enddo
3342         write (iout,*) "Array MUDER"
3343         do i=1,nres-1
3344           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3345         enddo
3346 !      endif
3347 #endif
3348       if (nfgtasks.gt.1) then
3349         time00=MPI_Wtime()
3350 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3351 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3352 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3353 #ifdef MATGATHER
3354         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3355          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3356          FG_COMM1,IERR)
3357         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3358          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3359          FG_COMM1,IERR)
3360         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3361          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3362          FG_COMM1,IERR)
3363         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3364          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3365          FG_COMM1,IERR)
3366         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3367          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3368          FG_COMM1,IERR)
3369         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3370          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3371          FG_COMM1,IERR)
3372         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3373          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3374          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3375         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3376          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3377          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3378         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3379          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3380          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3381         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3382          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3383          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3384         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3385         then
3386         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3387          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3388          FG_COMM1,IERR)
3389         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3390          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3391          FG_COMM1,IERR)
3392         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3393          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3394          FG_COMM1,IERR)
3395        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3396          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3397          FG_COMM1,IERR)
3398         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3399          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3400          FG_COMM1,IERR)
3401         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3402          ivec_count(fg_rank1),&
3403          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3404          FG_COMM1,IERR)
3405         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3406          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3407          FG_COMM1,IERR)
3408         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3409          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3410          FG_COMM1,IERR)
3411         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3412          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3413          FG_COMM1,IERR)
3414         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3415          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3416          FG_COMM1,IERR)
3417         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3418          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3419          FG_COMM1,IERR)
3420         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3421          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3422          FG_COMM1,IERR)
3423         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3424          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3425          FG_COMM1,IERR)
3426         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3427          ivec_count(fg_rank1),&
3428          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3429          FG_COMM1,IERR)
3430         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3431          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3432          FG_COMM1,IERR)
3433        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3434          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3435          FG_COMM1,IERR)
3436         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3437          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3438          FG_COMM1,IERR)
3439        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3440          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3441          FG_COMM1,IERR)
3442         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3443          ivec_count(fg_rank1),&
3444          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3445          FG_COMM1,IERR)
3446         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3447          ivec_count(fg_rank1),&
3448          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3449          FG_COMM1,IERR)
3450         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3451          ivec_count(fg_rank1),&
3452          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3453          MPI_MAT2,FG_COMM1,IERR)
3454         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3455          ivec_count(fg_rank1),&
3456          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3457          MPI_MAT2,FG_COMM1,IERR)
3458         endif
3459 #else
3460 ! Passes matrix info through the ring
3461       isend=fg_rank1
3462       irecv=fg_rank1-1
3463       if (irecv.lt.0) irecv=nfgtasks1-1
3464       iprev=irecv
3465       inext=fg_rank1+1
3466       if (inext.ge.nfgtasks1) inext=0
3467       do i=1,nfgtasks1-1
3468 !        write (iout,*) "isend",isend," irecv",irecv
3469 !        call flush(iout)
3470         lensend=lentyp(isend)
3471         lenrecv=lentyp(irecv)
3472 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3473 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3474 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3475 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3476 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3477 !        write (iout,*) "Gather ROTAT1"
3478 !        call flush(iout)
3479 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3480 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3481 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3482 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3483 !        write (iout,*) "Gather ROTAT2"
3484 !        call flush(iout)
3485         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3486          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3487          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3488          iprev,4400+irecv,FG_COMM,status,IERR)
3489 !        write (iout,*) "Gather ROTAT_OLD"
3490 !        call flush(iout)
3491         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3492          MPI_PRECOMP11(lensend),inext,5500+isend,&
3493          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3494          iprev,5500+irecv,FG_COMM,status,IERR)
3495 !        write (iout,*) "Gather PRECOMP11"
3496 !        call flush(iout)
3497         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3498          MPI_PRECOMP12(lensend),inext,6600+isend,&
3499          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3500          iprev,6600+irecv,FG_COMM,status,IERR)
3501 !        write (iout,*) "Gather PRECOMP12"
3502 !        call flush(iout)
3503         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3504         then
3505         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3506          MPI_ROTAT2(lensend),inext,7700+isend,&
3507          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3508          iprev,7700+irecv,FG_COMM,status,IERR)
3509 !        write (iout,*) "Gather PRECOMP21"
3510 !        call flush(iout)
3511         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3512          MPI_PRECOMP22(lensend),inext,8800+isend,&
3513          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3514          iprev,8800+irecv,FG_COMM,status,IERR)
3515 !        write (iout,*) "Gather PRECOMP22"
3516 !        call flush(iout)
3517         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3518          MPI_PRECOMP23(lensend),inext,9900+isend,&
3519          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3520          MPI_PRECOMP23(lenrecv),&
3521          iprev,9900+irecv,FG_COMM,status,IERR)
3522 !        write (iout,*) "Gather PRECOMP23"
3523 !        call flush(iout)
3524         endif
3525         isend=irecv
3526         irecv=irecv-1
3527         if (irecv.lt.0) irecv=nfgtasks1-1
3528       enddo
3529 #endif
3530         time_gather=time_gather+MPI_Wtime()-time00
3531       endif
3532 #ifdef DEBUG
3533 !      if (fg_rank.eq.0) then
3534         write (iout,*) "Arrays UG and UGDER"
3535         do i=1,nres-1
3536           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3537            ((ug(l,k,i),l=1,2),k=1,2),&
3538            ((ugder(l,k,i),l=1,2),k=1,2)
3539         enddo
3540         write (iout,*) "Arrays UG2 and UG2DER"
3541         do i=1,nres-1
3542           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3543            ((ug2(l,k,i),l=1,2),k=1,2),&
3544            ((ug2der(l,k,i),l=1,2),k=1,2)
3545         enddo
3546         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3547         do i=1,nres-1
3548           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3549            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3550            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3551         enddo
3552         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3553         do i=1,nres-1
3554           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3555            costab(i),sintab(i),costab2(i),sintab2(i)
3556         enddo
3557         write (iout,*) "Array MUDER"
3558         do i=1,nres-1
3559           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3560         enddo
3561 !      endif
3562 #endif
3563 #endif
3564 !d      do i=1,nres
3565 !d        iti = itortyp(itype(i,1))
3566 !d        write (iout,*) i
3567 !d        do j=1,2
3568 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3569 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3570 !d        enddo
3571 !d      enddo
3572       return
3573       end subroutine set_matrices
3574 !-----------------------------------------------------------------------------
3575       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3576 !
3577 ! This subroutine calculates the average interaction energy and its gradient
3578 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3579 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3580 ! The potential depends both on the distance of peptide-group centers and on
3581 ! the orientation of the CA-CA virtual bonds.
3582 !
3583       use comm_locel
3584 !      implicit real(kind=8) (a-h,o-z)
3585 #ifdef MPI
3586       include 'mpif.h'
3587 #endif
3588 !      include 'DIMENSIONS'
3589 !      include 'COMMON.CONTROL'
3590 !      include 'COMMON.SETUP'
3591 !      include 'COMMON.IOUNITS'
3592 !      include 'COMMON.GEO'
3593 !      include 'COMMON.VAR'
3594 !      include 'COMMON.LOCAL'
3595 !      include 'COMMON.CHAIN'
3596 !      include 'COMMON.DERIV'
3597 !      include 'COMMON.INTERACT'
3598 !      include 'COMMON.CONTACTS'
3599 !      include 'COMMON.TORSION'
3600 !      include 'COMMON.VECTORS'
3601 !      include 'COMMON.FFIELD'
3602 !      include 'COMMON.TIME1'
3603       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3604       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3605       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3606 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3607       real(kind=8),dimension(4) :: muij
3608 !el      integer :: num_conti,j1,j2
3609 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3610 !el        dz_normi,xmedi,ymedi,zmedi
3611
3612 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3613 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3614 !el          num_conti,j1,j2
3615
3616 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3617 #ifdef MOMENT
3618       real(kind=8) :: scal_el=1.0d0
3619 #else
3620       real(kind=8) :: scal_el=0.5d0
3621 #endif
3622 ! 12/13/98
3623 ! 13-go grudnia roku pamietnego...
3624       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3625                                              0.0d0,1.0d0,0.0d0,&
3626                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3627 !el local variables
3628       integer :: i,k,j,icont
3629       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3630       real(kind=8) :: fac,t_eelecij,fracinbuf
3631
3632
3633 !d      write(iout,*) 'In EELEC'
3634 !        print *,"IN EELEC"
3635 !d      do i=1,nloctyp
3636 !d        write(iout,*) 'Type',i
3637 !d        write(iout,*) 'B1',B1(:,i)
3638 !d        write(iout,*) 'B2',B2(:,i)
3639 !d        write(iout,*) 'CC',CC(:,:,i)
3640 !d        write(iout,*) 'DD',DD(:,:,i)
3641 !d        write(iout,*) 'EE',EE(:,:,i)
3642 !d      enddo
3643 !d      call check_vecgrad
3644 !d      stop
3645 !      ees=0.0d0  !AS
3646 !      evdw1=0.0d0
3647 !      eel_loc=0.0d0
3648 !      eello_turn3=0.0d0
3649 !      eello_turn4=0.0d0
3650       t_eelecij=0.0d0
3651       ees=0.0D0
3652       evdw1=0.0D0
3653       eel_loc=0.0d0
3654       eello_turn3=0.0d0
3655       eello_turn4=0.0d0
3656       if (nres_molec(1).eq.0) return
3657 !
3658
3659       if (icheckgrad.eq.1) then
3660 !el
3661 !        do i=0,2*nres+2
3662 !          dc_norm(1,i)=0.0d0
3663 !          dc_norm(2,i)=0.0d0
3664 !          dc_norm(3,i)=0.0d0
3665 !        enddo
3666         do i=1,nres-1
3667           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3668           do k=1,3
3669             dc_norm(k,i)=dc(k,i)*fac
3670           enddo
3671 !          write (iout,*) 'i',i,' fac',fac
3672         enddo
3673       endif
3674 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3675 !        wturn6
3676       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3677           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3678           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3679 !        call vec_and_deriv
3680 #ifdef TIMING
3681         time01=MPI_Wtime()
3682 #endif
3683 !        print *, "before set matrices"
3684         call set_matrices
3685 !        print *, "after set matrices"
3686
3687 #ifdef TIMING
3688         time_mat=time_mat+MPI_Wtime()-time01
3689 #endif
3690       endif
3691 !       print *, "after set matrices"
3692 !d      do i=1,nres-1
3693 !d        write (iout,*) 'i=',i
3694 !d        do k=1,3
3695 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3696 !d        enddo
3697 !d        do k=1,3
3698 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3699 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3700 !d        enddo
3701 !d      enddo
3702       t_eelecij=0.0d0
3703       ees=0.0D0
3704       evdw1=0.0D0
3705       eel_loc=0.0d0
3706       eello_turn3=0.0d0
3707       eello_turn4=0.0d0
3708 !el      ind=0
3709       do i=1,nres
3710         num_cont_hb(i)=0
3711       enddo
3712 !d      print '(a)','Enter EELEC'
3713 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3714 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3715 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3716       do i=1,nres
3717         gel_loc_loc(i)=0.0d0
3718         gcorr_loc(i)=0.0d0
3719       enddo
3720 !
3721 !
3722 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3723 !
3724 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3725 !
3726
3727
3728 !        print *,"before iturn3 loop"
3729       do i=iturn3_start,iturn3_end
3730         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3731         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3732         dxi=dc(1,i)
3733         dyi=dc(2,i)
3734         dzi=dc(3,i)
3735         dx_normi=dc_norm(1,i)
3736         dy_normi=dc_norm(2,i)
3737         dz_normi=dc_norm(3,i)
3738         xmedi=c(1,i)+0.5d0*dxi
3739         ymedi=c(2,i)+0.5d0*dyi
3740         zmedi=c(3,i)+0.5d0*dzi
3741         call to_box(xmedi,ymedi,zmedi)
3742         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3743         num_conti=0
3744        call eelecij(i,i+2,ees,evdw1,eel_loc)
3745         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3746         num_cont_hb(i)=num_conti
3747       enddo
3748       do i=iturn4_start,iturn4_end
3749         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3750           .or. itype(i+3,1).eq.ntyp1 &
3751           .or. itype(i+4,1).eq.ntyp1) cycle
3752 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3753         dxi=dc(1,i)
3754         dyi=dc(2,i)
3755         dzi=dc(3,i)
3756         dx_normi=dc_norm(1,i)
3757         dy_normi=dc_norm(2,i)
3758         dz_normi=dc_norm(3,i)
3759         xmedi=c(1,i)+0.5d0*dxi
3760         ymedi=c(2,i)+0.5d0*dyi
3761         zmedi=c(3,i)+0.5d0*dzi
3762         call to_box(xmedi,ymedi,zmedi)
3763         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3764         num_conti=num_cont_hb(i)
3765         call eelecij(i,i+3,ees,evdw1,eel_loc)
3766         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3767         call eturn4(i,eello_turn4)
3768 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3769         num_cont_hb(i)=num_conti
3770       enddo   ! i
3771 !
3772 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3773 !
3774 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3775 !      do i=iatel_s,iatel_e
3776 ! JPRDLC
3777        do icont=g_listpp_start,g_listpp_end
3778         i=newcontlistppi(icont)
3779         j=newcontlistppj(icont)
3780         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3781         dxi=dc(1,i)
3782         dyi=dc(2,i)
3783         dzi=dc(3,i)
3784         dx_normi=dc_norm(1,i)
3785         dy_normi=dc_norm(2,i)
3786         dz_normi=dc_norm(3,i)
3787         xmedi=c(1,i)+0.5d0*dxi
3788         ymedi=c(2,i)+0.5d0*dyi
3789         zmedi=c(3,i)+0.5d0*dzi
3790         call to_box(xmedi,ymedi,zmedi)
3791         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3792
3793 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3794         num_conti=num_cont_hb(i)
3795 !        do j=ielstart(i),ielend(i)
3796 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3797           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3798           call eelecij(i,j,ees,evdw1,eel_loc)
3799 !        enddo ! j
3800         num_cont_hb(i)=num_conti
3801       enddo   ! i
3802 !      write (iout,*) "Number of loop steps in EELEC:",ind
3803 !d      do i=1,nres
3804 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3805 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3806 !d      enddo
3807 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3808 !cc      eel_loc=eel_loc+eello_turn3
3809 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3810       return
3811       end subroutine eelec
3812 !-----------------------------------------------------------------------------
3813       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3814
3815       use comm_locel
3816 !      implicit real(kind=8) (a-h,o-z)
3817 !      include 'DIMENSIONS'
3818 #ifdef MPI
3819       include "mpif.h"
3820 #endif
3821 !      include 'COMMON.CONTROL'
3822 !      include 'COMMON.IOUNITS'
3823 !      include 'COMMON.GEO'
3824 !      include 'COMMON.VAR'
3825 !      include 'COMMON.LOCAL'
3826 !      include 'COMMON.CHAIN'
3827 !      include 'COMMON.DERIV'
3828 !      include 'COMMON.INTERACT'
3829 !      include 'COMMON.CONTACTS'
3830 !      include 'COMMON.TORSION'
3831 !      include 'COMMON.VECTORS'
3832 !      include 'COMMON.FFIELD'
3833 !      include 'COMMON.TIME1'
3834       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3835       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3836       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3837 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3838       real(kind=8),dimension(4) :: muij
3839       real(kind=8) :: geel_loc_ij,geel_loc_ji
3840       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3841                     dist_temp, dist_init,rlocshield,fracinbuf
3842       integer xshift,yshift,zshift,ilist,iresshield
3843 !el      integer :: num_conti,j1,j2
3844 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3845 !el        dz_normi,xmedi,ymedi,zmedi
3846
3847 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3848 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3849 !el          num_conti,j1,j2
3850
3851 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3852 #ifdef MOMENT
3853       real(kind=8) :: scal_el=1.0d0
3854 #else
3855       real(kind=8) :: scal_el=0.5d0
3856 #endif
3857 ! 12/13/98
3858 ! 13-go grudnia roku pamietnego...
3859       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3860                                              0.0d0,1.0d0,0.0d0,&
3861                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3862 !      integer :: maxconts=nres/4
3863 !el local variables
3864       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3865       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3866       real(kind=8) ::  faclipij2, faclipij
3867       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3868       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3869                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3870                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3871                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3872                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3873                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3874                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3875                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3876 !      maxconts=nres/4
3877 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3878 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3879
3880 !          time00=MPI_Wtime()
3881 !d      write (iout,*) "eelecij",i,j
3882 !          ind=ind+1
3883           iteli=itel(i)
3884           itelj=itel(j)
3885           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3886           aaa=app(iteli,itelj)
3887           bbb=bpp(iteli,itelj)
3888           ael6i=ael6(iteli,itelj)
3889           ael3i=ael3(iteli,itelj)
3890           dxj=dc(1,j)
3891           dyj=dc(2,j)
3892           dzj=dc(3,j)
3893           dx_normj=dc_norm(1,j)
3894           dy_normj=dc_norm(2,j)
3895           dz_normj=dc_norm(3,j)
3896 !          xj=c(1,j)+0.5D0*dxj-xmedi
3897 !          yj=c(2,j)+0.5D0*dyj-ymedi
3898 !          zj=c(3,j)+0.5D0*dzj-zmedi
3899           xj=c(1,j)+0.5D0*dxj
3900           yj=c(2,j)+0.5D0*dyj
3901           zj=c(3,j)+0.5D0*dzj
3902
3903           call to_box(xj,yj,zj)
3904           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3905           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3906           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3907           xj=boxshift(xj-xmedi,boxxsize)
3908           yj=boxshift(yj-ymedi,boxysize)
3909           zj=boxshift(zj-zmedi,boxzsize)
3910
3911           rij=xj*xj+yj*yj+zj*zj
3912           rrmij=1.0D0/rij
3913           rij=dsqrt(rij)
3914 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3915             sss_ele_cut=sscale_ele(rij)
3916             sss_ele_grad=sscagrad_ele(rij)
3917 !             sss_ele_cut=1.0d0
3918 !             sss_ele_grad=0.0d0
3919 !            print *,sss_ele_cut,sss_ele_grad,&
3920 !            (rij),r_cut_ele,rlamb_ele
3921             if (sss_ele_cut.le.0.0) go to 128
3922
3923           rmij=1.0D0/rij
3924           r3ij=rrmij*rmij
3925           r6ij=r3ij*r3ij
3926           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3927           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3928           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3929           fac=cosa-3.0D0*cosb*cosg
3930           ev1=aaa*r6ij*r6ij
3931 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3932           if (j.eq.i+2) ev1=scal_el*ev1
3933           ev2=bbb*r6ij
3934           fac3=ael6i*r6ij
3935           fac4=ael3i*r3ij
3936           evdwij=ev1+ev2
3937           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3938           el2=fac4*fac
3939 !          eesij=el1+el2
3940           if (shield_mode.gt.0) then
3941 !C          fac_shield(i)=0.4
3942 !C          fac_shield(j)=0.6
3943           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3944           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3945           eesij=(el1+el2)
3946           ees=ees+eesij*sss_ele_cut
3947 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3948 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3949           else
3950           fac_shield(i)=1.0
3951           fac_shield(j)=1.0
3952           eesij=(el1+el2)
3953           ees=ees+eesij   &
3954             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3955 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3956           endif
3957
3958 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3959           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3960 !          ees=ees+eesij*sss_ele_cut
3961           evdw1=evdw1+evdwij*sss_ele_cut  &
3962            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3963 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3964 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3965 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3966 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3967
3968           if (energy_dec) then
3969 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3970 !                  'evdw1',i,j,evdwij,&
3971 !                  iteli,itelj,aaa,evdw1
3972               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3973               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3974           endif
3975 !
3976 ! Calculate contributions to the Cartesian gradient.
3977 !
3978 #ifdef SPLITELE
3979           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3980               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3981           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3982              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3983           fac1=fac
3984           erij(1)=xj*rmij
3985           erij(2)=yj*rmij
3986           erij(3)=zj*rmij
3987 !
3988 ! Radial derivatives. First process both termini of the fragment (i,j)
3989 !
3990           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3991           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3992           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3993            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3994           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3995             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3996
3997           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3998           (shield_mode.gt.0)) then
3999 !C          print *,i,j
4000           do ilist=1,ishield_list(i)
4001            iresshield=shield_list(ilist,i)
4002            do k=1,3
4003            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
4004            *2.0*sss_ele_cut
4005            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
4006                    rlocshield &
4007             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
4008             *sss_ele_cut
4009             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4010            enddo
4011           enddo
4012           do ilist=1,ishield_list(j)
4013            iresshield=shield_list(ilist,j)
4014            do k=1,3
4015            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
4016           *2.0*sss_ele_cut
4017            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
4018                    rlocshield &
4019            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
4020            *sss_ele_cut
4021            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4022            enddo
4023           enddo
4024           do k=1,3
4025             gshieldc(k,i)=gshieldc(k,i)+ &
4026                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
4027            *sss_ele_cut
4028
4029             gshieldc(k,j)=gshieldc(k,j)+ &
4030                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
4031            *sss_ele_cut
4032
4033             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
4034                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
4035            *sss_ele_cut
4036
4037             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
4038                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
4039            *sss_ele_cut
4040
4041            enddo
4042            endif
4043
4044
4045 !          do k=1,3
4046 !            ghalf=0.5D0*ggg(k)
4047 !            gelc(k,i)=gelc(k,i)+ghalf
4048 !            gelc(k,j)=gelc(k,j)+ghalf
4049 !          enddo
4050 ! 9/28/08 AL Gradient compotents will be summed only at the end
4051           do k=1,3
4052             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4053             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4054           enddo
4055             gelc_long(3,j)=gelc_long(3,j)+  &
4056           ssgradlipj*eesij/2.0d0*lipscale**2&
4057            *sss_ele_cut
4058
4059             gelc_long(3,i)=gelc_long(3,i)+  &
4060           ssgradlipi*eesij/2.0d0*lipscale**2&
4061            *sss_ele_cut
4062
4063
4064 !
4065 ! Loop over residues i+1 thru j-1.
4066 !
4067 !grad          do k=i+1,j-1
4068 !grad            do l=1,3
4069 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4070 !grad            enddo
4071 !grad          enddo
4072           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
4073            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4074           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
4075            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4076           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
4077            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4078
4079 !          do k=1,3
4080 !            ghalf=0.5D0*ggg(k)
4081 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4082 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4083 !          enddo
4084 ! 9/28/08 AL Gradient compotents will be summed only at the end
4085           do k=1,3
4086             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4087             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4088           enddo
4089
4090 !C Lipidic part for scaling weight
4091            gvdwpp(3,j)=gvdwpp(3,j)+ &
4092           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4093            gvdwpp(3,i)=gvdwpp(3,i)+ &
4094           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4095 !! Loop over residues i+1 thru j-1.
4096 !
4097 !grad          do k=i+1,j-1
4098 !grad            do l=1,3
4099 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4100 !grad            enddo
4101 !grad          enddo
4102 #else
4103           facvdw=(ev1+evdwij)*sss_ele_cut &
4104            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4105
4106           facel=(el1+eesij)*sss_ele_cut
4107           fac1=fac
4108           fac=-3*rrmij*(facvdw+facvdw+facel)
4109           erij(1)=xj*rmij
4110           erij(2)=yj*rmij
4111           erij(3)=zj*rmij
4112 !
4113 ! Radial derivatives. First process both termini of the fragment (i,j)
4114 !
4115           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
4116           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
4117           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
4118 !          do k=1,3
4119 !            ghalf=0.5D0*ggg(k)
4120 !            gelc(k,i)=gelc(k,i)+ghalf
4121 !            gelc(k,j)=gelc(k,j)+ghalf
4122 !          enddo
4123 ! 9/28/08 AL Gradient compotents will be summed only at the end
4124           do k=1,3
4125             gelc_long(k,j)=gelc(k,j)+ggg(k)
4126             gelc_long(k,i)=gelc(k,i)-ggg(k)
4127           enddo
4128 !
4129 ! Loop over residues i+1 thru j-1.
4130 !
4131 !grad          do k=i+1,j-1
4132 !grad            do l=1,3
4133 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4134 !grad            enddo
4135 !grad          enddo
4136 ! 9/28/08 AL Gradient compotents will be summed only at the end
4137           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
4138            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4139           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
4140            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4141           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
4142            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4143
4144           do k=1,3
4145             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4146             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4147           enddo
4148            gvdwpp(3,j)=gvdwpp(3,j)+ &
4149           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4150            gvdwpp(3,i)=gvdwpp(3,i)+ &
4151           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4152
4153 #endif
4154 !
4155 ! Angular part
4156 !
4157           ecosa=2.0D0*fac3*fac1+fac4
4158           fac4=-3.0D0*fac4
4159           fac3=-6.0D0*fac3
4160           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4161           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4162           do k=1,3
4163             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4164             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4165           enddo
4166 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4167 !d   &          (dcosg(k),k=1,3)
4168           do k=1,3
4169             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4170              *fac_shield(i)**2*fac_shield(j)**2 &
4171              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4172
4173           enddo
4174 !          do k=1,3
4175 !            ghalf=0.5D0*ggg(k)
4176 !            gelc(k,i)=gelc(k,i)+ghalf
4177 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4178 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4179 !            gelc(k,j)=gelc(k,j)+ghalf
4180 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4181 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4182 !          enddo
4183 !grad          do k=i+1,j-1
4184 !grad            do l=1,3
4185 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4186 !grad            enddo
4187 !grad          enddo
4188           do k=1,3
4189             gelc(k,i)=gelc(k,i) &
4190                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4191                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4192                      *sss_ele_cut &
4193                      *fac_shield(i)**2*fac_shield(j)**2 &
4194                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4195
4196             gelc(k,j)=gelc(k,j) &
4197                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4198                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4199                      *sss_ele_cut  &
4200                      *fac_shield(i)**2*fac_shield(j)**2  &
4201                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4202
4203             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4204             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4205           enddo
4206
4207           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4208               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4209               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4210 !
4211 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4212 !   energy of a peptide unit is assumed in the form of a second-order
4213 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4214 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4215 !   are computed for EVERY pair of non-contiguous peptide groups.
4216 !
4217           if (j.lt.nres-1) then
4218             j1=j+1
4219             j2=j-1
4220           else
4221             j1=j-1
4222             j2=j-2
4223           endif
4224           kkk=0
4225           do k=1,2
4226             do l=1,2
4227               kkk=kkk+1
4228               muij(kkk)=mu(k,i)*mu(l,j)
4229 #ifdef NEWCORR
4230              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4231 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4232              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4233              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4234 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4235              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4236 #endif
4237
4238             enddo
4239           enddo
4240 !d         write (iout,*) 'EELEC: i',i,' j',j
4241 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4242 !d          write(iout,*) 'muij',muij
4243           ury=scalar(uy(1,i),erij)
4244           urz=scalar(uz(1,i),erij)
4245           vry=scalar(uy(1,j),erij)
4246           vrz=scalar(uz(1,j),erij)
4247           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4248           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4249           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4250           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4251           fac=dsqrt(-ael6i)*r3ij
4252           a22=a22*fac
4253           a23=a23*fac
4254           a32=a32*fac
4255           a33=a33*fac
4256 !d          write (iout,'(4i5,4f10.5)')
4257 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4258 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4259 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4260 !d     &      uy(:,j),uz(:,j)
4261 !d          write (iout,'(4f10.5)')
4262 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4263 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4264 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4265 !d           write (iout,'(9f10.5/)')
4266 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4267 ! Derivatives of the elements of A in virtual-bond vectors
4268           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4269           do k=1,3
4270             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4271             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4272             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4273             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4274             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4275             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4276             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4277             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4278             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4279             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4280             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4281             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4282           enddo
4283 ! Compute radial contributions to the gradient
4284           facr=-3.0d0*rrmij
4285           a22der=a22*facr
4286           a23der=a23*facr
4287           a32der=a32*facr
4288           a33der=a33*facr
4289           agg(1,1)=a22der*xj
4290           agg(2,1)=a22der*yj
4291           agg(3,1)=a22der*zj
4292           agg(1,2)=a23der*xj
4293           agg(2,2)=a23der*yj
4294           agg(3,2)=a23der*zj
4295           agg(1,3)=a32der*xj
4296           agg(2,3)=a32der*yj
4297           agg(3,3)=a32der*zj
4298           agg(1,4)=a33der*xj
4299           agg(2,4)=a33der*yj
4300           agg(3,4)=a33der*zj
4301 ! Add the contributions coming from er
4302           fac3=-3.0d0*fac
4303           do k=1,3
4304             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4305             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4306             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4307             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4308           enddo
4309           do k=1,3
4310 ! Derivatives in DC(i)
4311 !grad            ghalf1=0.5d0*agg(k,1)
4312 !grad            ghalf2=0.5d0*agg(k,2)
4313 !grad            ghalf3=0.5d0*agg(k,3)
4314 !grad            ghalf4=0.5d0*agg(k,4)
4315             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4316             -3.0d0*uryg(k,2)*vry)!+ghalf1
4317             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4318             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4319             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4320             -3.0d0*urzg(k,2)*vry)!+ghalf3
4321             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4322             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4323 ! Derivatives in DC(i+1)
4324             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4325             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4326             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4327             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4328             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4329             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4330             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4331             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4332 ! Derivatives in DC(j)
4333             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4334             -3.0d0*vryg(k,2)*ury)!+ghalf1
4335             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4336             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4337             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4338             -3.0d0*vryg(k,2)*urz)!+ghalf3
4339             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4340             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4341 ! Derivatives in DC(j+1) or DC(nres-1)
4342             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4343             -3.0d0*vryg(k,3)*ury)
4344             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4345             -3.0d0*vrzg(k,3)*ury)
4346             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4347             -3.0d0*vryg(k,3)*urz)
4348             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4349             -3.0d0*vrzg(k,3)*urz)
4350 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4351 !grad              do l=1,4
4352 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4353 !grad              enddo
4354 !grad            endif
4355           enddo
4356           acipa(1,1)=a22
4357           acipa(1,2)=a23
4358           acipa(2,1)=a32
4359           acipa(2,2)=a33
4360           a22=-a22
4361           a23=-a23
4362           do l=1,2
4363             do k=1,3
4364               agg(k,l)=-agg(k,l)
4365               aggi(k,l)=-aggi(k,l)
4366               aggi1(k,l)=-aggi1(k,l)
4367               aggj(k,l)=-aggj(k,l)
4368               aggj1(k,l)=-aggj1(k,l)
4369             enddo
4370           enddo
4371           if (j.lt.nres-1) then
4372             a22=-a22
4373             a32=-a32
4374             do l=1,3,2
4375               do k=1,3
4376                 agg(k,l)=-agg(k,l)
4377                 aggi(k,l)=-aggi(k,l)
4378                 aggi1(k,l)=-aggi1(k,l)
4379                 aggj(k,l)=-aggj(k,l)
4380                 aggj1(k,l)=-aggj1(k,l)
4381               enddo
4382             enddo
4383           else
4384             a22=-a22
4385             a23=-a23
4386             a32=-a32
4387             a33=-a33
4388             do l=1,4
4389               do k=1,3
4390                 agg(k,l)=-agg(k,l)
4391                 aggi(k,l)=-aggi(k,l)
4392                 aggi1(k,l)=-aggi1(k,l)
4393                 aggj(k,l)=-aggj(k,l)
4394                 aggj1(k,l)=-aggj1(k,l)
4395               enddo
4396             enddo
4397           endif
4398           ENDIF ! WCORR
4399           IF (wel_loc.gt.0.0d0) THEN
4400 ! Contribution to the local-electrostatic energy coming from the i-j pair
4401           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4402            +a33*muij(4)
4403           if (shield_mode.eq.0) then
4404            fac_shield(i)=1.0
4405            fac_shield(j)=1.0
4406           endif
4407           eel_loc_ij=eel_loc_ij &
4408          *fac_shield(i)*fac_shield(j) &
4409          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4410 !C Now derivative over eel_loc
4411           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4412          (shield_mode.gt.0)) then
4413 !C          print *,i,j
4414
4415           do ilist=1,ishield_list(i)
4416            iresshield=shield_list(ilist,i)
4417            do k=1,3
4418            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4419                                                 /fac_shield(i)&
4420            *sss_ele_cut
4421            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4422                    rlocshield  &
4423           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4424           *sss_ele_cut
4425
4426             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4427            +rlocshield
4428            enddo
4429           enddo
4430           do ilist=1,ishield_list(j)
4431            iresshield=shield_list(ilist,j)
4432            do k=1,3
4433            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4434                                             /fac_shield(j)   &
4435             *sss_ele_cut
4436            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4437                    rlocshield  &
4438       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4439        *sss_ele_cut
4440
4441            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4442                   +rlocshield
4443
4444            enddo
4445           enddo
4446
4447           do k=1,3
4448             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4449                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4450                     *sss_ele_cut
4451             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4452                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4453                     *sss_ele_cut
4454             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4455                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4456                     *sss_ele_cut
4457             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4458                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4459                     *sss_ele_cut
4460
4461            enddo
4462            endif
4463
4464 #ifdef NEWCORR
4465          geel_loc_ij=(a22*gmuij1(1)&
4466           +a23*gmuij1(2)&
4467           +a32*gmuij1(3)&
4468           +a33*gmuij1(4))&
4469          *fac_shield(i)*fac_shield(j)&
4470                     *sss_ele_cut     &
4471          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4472
4473
4474 !c         write(iout,*) "derivative over thatai"
4475 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4476 !c     &   a33*gmuij1(4)
4477          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4478            geel_loc_ij*wel_loc
4479 !c         write(iout,*) "derivative over thatai-1"
4480 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4481 !c     &   a33*gmuij2(4)
4482          geel_loc_ij=&
4483           a22*gmuij2(1)&
4484           +a23*gmuij2(2)&
4485           +a32*gmuij2(3)&
4486           +a33*gmuij2(4)
4487          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4488            geel_loc_ij*wel_loc&
4489          *fac_shield(i)*fac_shield(j)&
4490                     *sss_ele_cut &
4491          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4492
4493
4494 !c  Derivative over j residue
4495          geel_loc_ji=a22*gmuji1(1)&
4496           +a23*gmuji1(2)&
4497           +a32*gmuji1(3)&
4498           +a33*gmuji1(4)
4499 !c         write(iout,*) "derivative over thataj"
4500 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4501 !c     &   a33*gmuji1(4)
4502
4503         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4504            geel_loc_ji*wel_loc&
4505          *fac_shield(i)*fac_shield(j)&
4506                     *sss_ele_cut &
4507          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4508
4509
4510          geel_loc_ji=&
4511           +a22*gmuji2(1)&
4512           +a23*gmuji2(2)&
4513           +a32*gmuji2(3)&
4514           +a33*gmuji2(4)
4515 !c         write(iout,*) "derivative over thataj-1"
4516 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4517 !c     &   a33*gmuji2(4)
4518          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4519            geel_loc_ji*wel_loc&
4520          *fac_shield(i)*fac_shield(j)&
4521                     *sss_ele_cut &
4522          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4523
4524 #endif
4525
4526 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4527 !           eel_loc_ij=0.0
4528 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4529 !                  'eelloc',i,j,eel_loc_ij
4530           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4531                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4532 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4533
4534 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4535 !          if (energy_dec) write (iout,*) "muij",muij
4536 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4537
4538           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4539 ! Partial derivatives in virtual-bond dihedral angles gamma
4540           if (i.gt.1) &
4541           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4542                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4543                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4544                  *sss_ele_cut  &
4545           *fac_shield(i)*fac_shield(j) &
4546           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4547
4548           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4549                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4550                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4551                  *sss_ele_cut &
4552           *fac_shield(i)*fac_shield(j) &
4553           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4554 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4555 !          do l=1,3
4556 !            ggg(1)=(agg(1,1)*muij(1)+ &
4557 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4558 !            *sss_ele_cut &
4559 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4560 !            ggg(2)=(agg(2,1)*muij(1)+ &
4561 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4562 !            *sss_ele_cut &
4563 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4564 !            ggg(3)=(agg(3,1)*muij(1)+ &
4565 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4566 !            *sss_ele_cut &
4567 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4568            xtemp(1)=xj
4569            xtemp(2)=yj
4570            xtemp(3)=zj
4571
4572            do l=1,3
4573             ggg(l)=(agg(l,1)*muij(1)+ &
4574                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4575             *sss_ele_cut &
4576           *fac_shield(i)*fac_shield(j) &
4577           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4578              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4579
4580
4581             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4582             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4583 !grad            ghalf=0.5d0*ggg(l)
4584 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4585 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4586           enddo
4587             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4588           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4589           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4590
4591             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4592           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4593           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4594
4595 !grad          do k=i+1,j2
4596 !grad            do l=1,3
4597 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4598 !grad            enddo
4599 !grad          enddo
4600 ! Remaining derivatives of eello
4601           do l=1,3
4602             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4603                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4604             *sss_ele_cut &
4605           *fac_shield(i)*fac_shield(j) &
4606           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4607
4608 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4609             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4610                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4611             +aggi1(l,4)*muij(4))&
4612             *sss_ele_cut &
4613           *fac_shield(i)*fac_shield(j) &
4614           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4615
4616 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4617             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4618                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4619             *sss_ele_cut &
4620           *fac_shield(i)*fac_shield(j) &
4621           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4622
4623 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4624             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4625                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4626             +aggj1(l,4)*muij(4))&
4627             *sss_ele_cut &
4628           *fac_shield(i)*fac_shield(j) &
4629          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4630
4631 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4632           enddo
4633           ENDIF
4634 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4635 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4636           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4637              .and. num_conti.le.maxconts) then
4638 !            write (iout,*) i,j," entered corr"
4639 !
4640 ! Calculate the contact function. The ith column of the array JCONT will
4641 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4642 ! greater than I). The arrays FACONT and GACONT will contain the values of
4643 ! the contact function and its derivative.
4644 !           r0ij=1.02D0*rpp(iteli,itelj)
4645 !           r0ij=1.11D0*rpp(iteli,itelj)
4646             r0ij=2.20D0*rpp(iteli,itelj)
4647 !           r0ij=1.55D0*rpp(iteli,itelj)
4648             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4649 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4650             if (fcont.gt.0.0D0) then
4651               num_conti=num_conti+1
4652               if (num_conti.gt.maxconts) then
4653 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4654 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4655                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4656                                ' will skip next contacts for this conf.', num_conti
4657               else
4658                 jcont_hb(num_conti,i)=j
4659 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4660 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4661                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4662                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4663 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4664 !  terms.
4665                 d_cont(num_conti,i)=rij
4666 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4667 !     --- Electrostatic-interaction matrix ---
4668                 a_chuj(1,1,num_conti,i)=a22
4669                 a_chuj(1,2,num_conti,i)=a23
4670                 a_chuj(2,1,num_conti,i)=a32
4671                 a_chuj(2,2,num_conti,i)=a33
4672 !     --- Gradient of rij
4673                 do kkk=1,3
4674                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4675                 enddo
4676                 kkll=0
4677                 do k=1,2
4678                   do l=1,2
4679                     kkll=kkll+1
4680                     do m=1,3
4681                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4682                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4683                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4684                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4685                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4686                     enddo
4687                   enddo
4688                 enddo
4689                 ENDIF
4690                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4691 ! Calculate contact energies
4692                 cosa4=4.0D0*cosa
4693                 wij=cosa-3.0D0*cosb*cosg
4694                 cosbg1=cosb+cosg
4695                 cosbg2=cosb-cosg
4696 !               fac3=dsqrt(-ael6i)/r0ij**3
4697                 fac3=dsqrt(-ael6i)*r3ij
4698 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4699                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4700                 if (ees0tmp.gt.0) then
4701                   ees0pij=dsqrt(ees0tmp)
4702                 else
4703                   ees0pij=0
4704                 endif
4705                 if (shield_mode.eq.0) then
4706                 fac_shield(i)=1.0d0
4707                 fac_shield(j)=1.0d0
4708                 else
4709                 ees0plist(num_conti,i)=j
4710                 endif
4711 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4712                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4713                 if (ees0tmp.gt.0) then
4714                   ees0mij=dsqrt(ees0tmp)
4715                 else
4716                   ees0mij=0
4717                 endif
4718 !               ees0mij=0.0D0
4719                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4720                      *sss_ele_cut &
4721                      *fac_shield(i)*fac_shield(j)
4722 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4723
4724                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4725                      *sss_ele_cut &
4726                      *fac_shield(i)*fac_shield(j)
4727 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4728
4729 ! Diagnostics. Comment out or remove after debugging!
4730 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4731 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4732 !               ees0m(num_conti,i)=0.0D0
4733 ! End diagnostics.
4734 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4735 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4736 ! Angular derivatives of the contact function
4737                 ees0pij1=fac3/ees0pij
4738                 ees0mij1=fac3/ees0mij
4739                 fac3p=-3.0D0*fac3*rrmij
4740                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4741                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4742 !               ees0mij1=0.0D0
4743                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4744                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4745                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4746                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4747                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4748                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4749                 ecosap=ecosa1+ecosa2
4750                 ecosbp=ecosb1+ecosb2
4751                 ecosgp=ecosg1+ecosg2
4752                 ecosam=ecosa1-ecosa2
4753                 ecosbm=ecosb1-ecosb2
4754                 ecosgm=ecosg1-ecosg2
4755 ! Diagnostics
4756 !               ecosap=ecosa1
4757 !               ecosbp=ecosb1
4758 !               ecosgp=ecosg1
4759 !               ecosam=0.0D0
4760 !               ecosbm=0.0D0
4761 !               ecosgm=0.0D0
4762 ! End diagnostics
4763                 facont_hb(num_conti,i)=fcont
4764                 fprimcont=fprimcont/rij
4765 !d              facont_hb(num_conti,i)=1.0D0
4766 ! Following line is for diagnostics.
4767 !d              fprimcont=0.0D0
4768                 do k=1,3
4769                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4770                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4771                 enddo
4772                 do k=1,3
4773                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4774                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4775                 enddo
4776                 gggp(1)=gggp(1)+ees0pijp*xj &
4777                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4778                 gggp(2)=gggp(2)+ees0pijp*yj &
4779                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4780                 gggp(3)=gggp(3)+ees0pijp*zj &
4781                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4782
4783                 gggm(1)=gggm(1)+ees0mijp*xj &
4784                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4785
4786                 gggm(2)=gggm(2)+ees0mijp*yj &
4787                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4788
4789                 gggm(3)=gggm(3)+ees0mijp*zj &
4790                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4791
4792 ! Derivatives due to the contact function
4793                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4794                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4795                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4796                 do k=1,3
4797 !
4798 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4799 !          following the change of gradient-summation algorithm.
4800 !
4801 !grad                  ghalfp=0.5D0*gggp(k)
4802 !grad                  ghalfm=0.5D0*gggm(k)
4803                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4804                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4805                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4806                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4807 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4808
4809
4810                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4811                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4812                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4813                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4814 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4815
4816
4817                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4818                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4819 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4820
4821                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4822                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4823                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4824                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4825 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4826
4827                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4828                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4829                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4830                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4831 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4832
4833                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4834                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4835 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4836
4837                 enddo
4838 ! Diagnostics. Comment out or remove after debugging!
4839 !diag           do k=1,3
4840 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4841 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4842 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4843 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4844 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4845 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4846 !diag           enddo
4847               ENDIF ! wcorr
4848               endif  ! num_conti.le.maxconts
4849             endif  ! fcont.gt.0
4850           endif    ! j.gt.i+1
4851           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4852             do k=1,4
4853               do l=1,3
4854                 ghalf=0.5d0*agg(l,k)
4855                 aggi(l,k)=aggi(l,k)+ghalf
4856                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4857                 aggj(l,k)=aggj(l,k)+ghalf
4858               enddo
4859             enddo
4860             if (j.eq.nres-1 .and. i.lt.j-2) then
4861               do k=1,4
4862                 do l=1,3
4863                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4864                 enddo
4865               enddo
4866             endif
4867           endif
4868  128  continue
4869 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4870       return
4871       end subroutine eelecij
4872 !-----------------------------------------------------------------------------
4873       subroutine eturn3(i,eello_turn3)
4874 ! Third- and fourth-order contributions from turns
4875
4876       use comm_locel
4877 !      implicit real(kind=8) (a-h,o-z)
4878 !      include 'DIMENSIONS'
4879 !      include 'COMMON.IOUNITS'
4880 !      include 'COMMON.GEO'
4881 !      include 'COMMON.VAR'
4882 !      include 'COMMON.LOCAL'
4883 !      include 'COMMON.CHAIN'
4884 !      include 'COMMON.DERIV'
4885 !      include 'COMMON.INTERACT'
4886 !      include 'COMMON.CONTACTS'
4887 !      include 'COMMON.TORSION'
4888 !      include 'COMMON.VECTORS'
4889 !      include 'COMMON.FFIELD'
4890 !      include 'COMMON.CONTROL'
4891       real(kind=8),dimension(3) :: ggg
4892       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4893         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4894        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4895
4896       real(kind=8),dimension(2) :: auxvec,auxvec1
4897 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4898       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4899 !el      integer :: num_conti,j1,j2
4900 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4901 !el        dz_normi,xmedi,ymedi,zmedi
4902
4903 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4904 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4905 !el         num_conti,j1,j2
4906 !el local variables
4907       integer :: i,j,l,k,ilist,iresshield
4908       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj
4909       xj=0.0d0
4910       yj=0.0d0
4911       j=i+2
4912 !      write (iout,*) "eturn3",i,j,j1,j2
4913           zj=(c(3,j)+c(3,j+1))/2.0d0
4914             call to_box(xj,yj,zj)
4915             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4916
4917       a_temp(1,1)=a22
4918       a_temp(1,2)=a23
4919       a_temp(2,1)=a32
4920       a_temp(2,2)=a33
4921 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4922 !
4923 !               Third-order contributions
4924 !
4925 !                 (i+2)o----(i+3)
4926 !                      | |
4927 !                      | |
4928 !                 (i+1)o----i
4929 !
4930 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4931 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4932         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4933         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4934         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4935         call transpose2(auxmat(1,1),auxmat1(1,1))
4936         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4937         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4938         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4939         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4940         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4941
4942         if (shield_mode.eq.0) then
4943         fac_shield(i)=1.0d0
4944         fac_shield(j)=1.0d0
4945         endif
4946
4947         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4948          *fac_shield(i)*fac_shield(j)  &
4949          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4950         eello_t3= &
4951         0.5d0*(pizda(1,1)+pizda(2,2)) &
4952         *fac_shield(i)*fac_shield(j)
4953
4954         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4955                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4956 !C#ifdef NEWCORR
4957 !C Derivatives in theta
4958         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4959        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4960         *fac_shield(i)*fac_shield(j) &
4961         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4962
4963         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4964        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4965         *fac_shield(i)*fac_shield(j) &
4966         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4967
4968
4969 !C#endif
4970
4971
4972
4973           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4974        (shield_mode.gt.0)) then
4975 !C          print *,i,j
4976
4977           do ilist=1,ishield_list(i)
4978            iresshield=shield_list(ilist,i)
4979            do k=1,3
4980            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4981            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4982                    rlocshield &
4983            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4984             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4985              +rlocshield
4986            enddo
4987           enddo
4988           do ilist=1,ishield_list(j)
4989            iresshield=shield_list(ilist,j)
4990            do k=1,3
4991            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4992            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4993                    rlocshield &
4994            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4995            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4996                   +rlocshield
4997
4998            enddo
4999           enddo
5000
5001           do k=1,3
5002             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
5003                    grad_shield(k,i)*eello_t3/fac_shield(i)
5004             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
5005                    grad_shield(k,j)*eello_t3/fac_shield(j)
5006             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
5007                    grad_shield(k,i)*eello_t3/fac_shield(i)
5008             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
5009                    grad_shield(k,j)*eello_t3/fac_shield(j)
5010            enddo
5011            endif
5012
5013 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
5014 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5015 !d     &    ' eello_turn3_num',4*eello_turn3_num
5016 ! Derivatives in gamma(i)
5017         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5018         call transpose2(auxmat2(1,1),auxmat3(1,1))
5019         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5020         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
5021           *fac_shield(i)*fac_shield(j)        &
5022           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5023 ! Derivatives in gamma(i+1)
5024         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5025         call transpose2(auxmat2(1,1),auxmat3(1,1))
5026         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5027         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
5028           +0.5d0*(pizda(1,1)+pizda(2,2))      &
5029           *fac_shield(i)*fac_shield(j)        &
5030           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5031
5032 ! Cartesian derivatives
5033         do l=1,3
5034 !            ghalf1=0.5d0*agg(l,1)
5035 !            ghalf2=0.5d0*agg(l,2)
5036 !            ghalf3=0.5d0*agg(l,3)
5037 !            ghalf4=0.5d0*agg(l,4)
5038           a_temp(1,1)=aggi(l,1)!+ghalf1
5039           a_temp(1,2)=aggi(l,2)!+ghalf2
5040           a_temp(2,1)=aggi(l,3)!+ghalf3
5041           a_temp(2,2)=aggi(l,4)!+ghalf4
5042           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5043           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
5044             +0.5d0*(pizda(1,1)+pizda(2,2))  &
5045           *fac_shield(i)*fac_shield(j)      &
5046           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5047
5048           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5049           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5050           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5051           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5052           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5053           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
5054             +0.5d0*(pizda(1,1)+pizda(2,2))    &
5055           *fac_shield(i)*fac_shield(j)        &
5056           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5057
5058           a_temp(1,1)=aggj(l,1)!+ghalf1
5059           a_temp(1,2)=aggj(l,2)!+ghalf2
5060           a_temp(2,1)=aggj(l,3)!+ghalf3
5061           a_temp(2,2)=aggj(l,4)!+ghalf4
5062           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5063           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
5064             +0.5d0*(pizda(1,1)+pizda(2,2))  &
5065           *fac_shield(i)*fac_shield(j)      &
5066           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5067
5068           a_temp(1,1)=aggj1(l,1)
5069           a_temp(1,2)=aggj1(l,2)
5070           a_temp(2,1)=aggj1(l,3)
5071           a_temp(2,2)=aggj1(l,4)
5072           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5073           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
5074             +0.5d0*(pizda(1,1)+pizda(2,2))    &
5075           *fac_shield(i)*fac_shield(j)        &
5076           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5077         enddo
5078          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
5079           ssgradlipi*eello_t3/4.0d0*lipscale
5080          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
5081           ssgradlipj*eello_t3/4.0d0*lipscale
5082          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
5083           ssgradlipi*eello_t3/4.0d0*lipscale
5084          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
5085           ssgradlipj*eello_t3/4.0d0*lipscale
5086
5087       return
5088       end subroutine eturn3
5089 !-----------------------------------------------------------------------------
5090       subroutine eturn4(i,eello_turn4)
5091 ! Third- and fourth-order contributions from turns
5092
5093       use comm_locel
5094 !      implicit real(kind=8) (a-h,o-z)
5095 !      include 'DIMENSIONS'
5096 !      include 'COMMON.IOUNITS'
5097 !      include 'COMMON.GEO'
5098 !      include 'COMMON.VAR'
5099 !      include 'COMMON.LOCAL'
5100 !      include 'COMMON.CHAIN'
5101 !      include 'COMMON.DERIV'
5102 !      include 'COMMON.INTERACT'
5103 !      include 'COMMON.CONTACTS'
5104 !      include 'COMMON.TORSION'
5105 !      include 'COMMON.VECTORS'
5106 !      include 'COMMON.FFIELD'
5107 !      include 'COMMON.CONTROL'
5108       real(kind=8),dimension(3) :: ggg
5109       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
5110         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
5111         gte1t,gte2t,gte3t,&
5112         gte1a,gtae3,gtae3e2, ae3gte2,&
5113         gtEpizda1,gtEpizda2,gtEpizda3
5114
5115       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
5116        auxgEvec3,auxgvec
5117
5118 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
5119       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
5120 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
5121 !el        dz_normi,xmedi,ymedi,zmedi
5122 !el      integer :: num_conti,j1,j2
5123 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
5124 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
5125 !el          num_conti,j1,j2
5126 !el local variables
5127       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
5128       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
5129          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj
5130       xj=0.0d0
5131       yj=0.0d0
5132       j=i+3
5133 !      if (j.ne.20) return
5134 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5135 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5136 !
5137 !               Fourth-order contributions
5138 !
5139 !                 (i+3)o----(i+4)
5140 !                     /  |
5141 !               (i+2)o   |
5142 !                     \  |
5143 !                 (i+1)o----i
5144 !
5145 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5146 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5147 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5148           zj=(c(3,j)+c(3,j+1))/2.0d0
5149             call to_box(xj,yj,zj)
5150             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
5151
5152
5153         a_temp(1,1)=a22
5154         a_temp(1,2)=a23
5155         a_temp(2,1)=a32
5156         a_temp(2,2)=a33
5157         iti1=i+1
5158         iti2=i+2
5159         iti3=i+3
5160 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5161         call transpose2(EUg(1,1,i+1),e1t(1,1))
5162         call transpose2(Eug(1,1,i+2),e2t(1,1))
5163         call transpose2(Eug(1,1,i+3),e3t(1,1))
5164 !C Ematrix derivative in theta
5165         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5166         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5167         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5168
5169         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5170         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5171         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5172         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5173 !c       auxalary matrix of E i+1
5174         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5175         s1=scalar2(b1(1,iti2),auxvec(1))
5176 !c derivative of theta i+2 with constant i+3
5177         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5178 !c derivative of theta i+2 with constant i+2
5179         gs32=scalar2(b1(1,i+2),auxgvec(1))
5180 !c derivative of E matix in theta of i+1
5181         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5182
5183         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5184         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5185         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5186 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5187         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5188 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5189         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5190         s2=scalar2(b1(1,i+1),auxvec(1))
5191 !c derivative of theta i+1 with constant i+3
5192         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5193 !c derivative of theta i+2 with constant i+1
5194         gs21=scalar2(b1(1,i+1),auxgvec(1))
5195 !c derivative of theta i+3 with constant i+1
5196         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5197
5198         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5199         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5200 !c ae3gte2 is derivative over i+2
5201         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5202
5203         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5204         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5205 !c i+2
5206         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5207 !c i+3
5208         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5209
5210         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5211         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5212         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5213         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5214         if (shield_mode.eq.0) then
5215         fac_shield(i)=1.0
5216         fac_shield(j)=1.0
5217         endif
5218
5219         eello_turn4=eello_turn4-(s1+s2+s3) &
5220         *fac_shield(i)*fac_shield(j)       &
5221         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5222         eello_t4=-(s1+s2+s3)  &
5223           *fac_shield(i)*fac_shield(j)
5224 !C Now derivative over shield:
5225           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5226          (shield_mode.gt.0)) then
5227 !C          print *,i,j
5228
5229           do ilist=1,ishield_list(i)
5230            iresshield=shield_list(ilist,i)
5231            do k=1,3
5232            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5233 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5234            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5235                    rlocshield &
5236             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5237             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5238            +rlocshield
5239            enddo
5240           enddo
5241           do ilist=1,ishield_list(j)
5242            iresshield=shield_list(ilist,j)
5243            do k=1,3
5244 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5245            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5246            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5247                    rlocshield  &
5248            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5249            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5250                   +rlocshield
5251 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5252
5253            enddo
5254           enddo
5255           do k=1,3
5256             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5257                    grad_shield(k,i)*eello_t4/fac_shield(i)
5258             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5259                    grad_shield(k,j)*eello_t4/fac_shield(j)
5260             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5261                    grad_shield(k,i)*eello_t4/fac_shield(i)
5262             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5263                    grad_shield(k,j)*eello_t4/fac_shield(j)
5264 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5265            enddo
5266            endif
5267 #ifdef NEWCORR
5268         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5269                        -(gs13+gsE13+gsEE1)*wturn4&
5270        *fac_shield(i)*fac_shield(j) &
5271        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5272
5273         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5274                          -(gs23+gs21+gsEE2)*wturn4&
5275        *fac_shield(i)*fac_shield(j)&
5276        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5277
5278         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5279                          -(gs32+gsE31+gsEE3)*wturn4&
5280        *fac_shield(i)*fac_shield(j)&
5281        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5282
5283
5284 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5285 !c     &   gs2
5286 #endif
5287         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5288            'eturn4',i,j,-(s1+s2+s3)
5289 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5290 !d     &    ' eello_turn4_num',8*eello_turn4_num
5291 ! Derivatives in gamma(i)
5292         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5293         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5294         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5295         s1=scalar2(b1(1,i+1),auxvec(1))
5296         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5297         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5298         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5299        *fac_shield(i)*fac_shield(j)  &
5300        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5301
5302 ! Derivatives in gamma(i+1)
5303         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5304         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5305         s2=scalar2(b1(1,iti1),auxvec(1))
5306         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5307         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5308         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5309         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5310        *fac_shield(i)*fac_shield(j)  &
5311        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5312
5313 ! Derivatives in gamma(i+2)
5314         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5315         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5316         s1=scalar2(b1(1,iti2),auxvec(1))
5317         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5318         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5319         s2=scalar2(b1(1,iti1),auxvec(1))
5320         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5321         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5322         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5323         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5324        *fac_shield(i)*fac_shield(j)  &
5325        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5326
5327 ! Cartesian derivatives
5328 ! Derivatives of this turn contributions in DC(i+2)
5329         if (j.lt.nres-1) then
5330           do l=1,3
5331             a_temp(1,1)=agg(l,1)
5332             a_temp(1,2)=agg(l,2)
5333             a_temp(2,1)=agg(l,3)
5334             a_temp(2,2)=agg(l,4)
5335             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5336             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5337             s1=scalar2(b1(1,iti2),auxvec(1))
5338             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5339             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5340             s2=scalar2(b1(1,iti1),auxvec(1))
5341             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5342             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5343             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5344             ggg(l)=-(s1+s2+s3)
5345             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5346        *fac_shield(i)*fac_shield(j)  &
5347        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5348
5349           enddo
5350         endif
5351 ! Remaining derivatives of this turn contribution
5352         do l=1,3
5353           a_temp(1,1)=aggi(l,1)
5354           a_temp(1,2)=aggi(l,2)
5355           a_temp(2,1)=aggi(l,3)
5356           a_temp(2,2)=aggi(l,4)
5357           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5358           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5359           s1=scalar2(b1(1,iti2),auxvec(1))
5360           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5361           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5362           s2=scalar2(b1(1,iti1),auxvec(1))
5363           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5364           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5365           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5366           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5367          *fac_shield(i)*fac_shield(j)  &
5368          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5369
5370
5371           a_temp(1,1)=aggi1(l,1)
5372           a_temp(1,2)=aggi1(l,2)
5373           a_temp(2,1)=aggi1(l,3)
5374           a_temp(2,2)=aggi1(l,4)
5375           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5376           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5377           s1=scalar2(b1(1,iti2),auxvec(1))
5378           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5379           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5380           s2=scalar2(b1(1,iti1),auxvec(1))
5381           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5382           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5383           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5384           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5385          *fac_shield(i)*fac_shield(j)  &
5386          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5387
5388
5389           a_temp(1,1)=aggj(l,1)
5390           a_temp(1,2)=aggj(l,2)
5391           a_temp(2,1)=aggj(l,3)
5392           a_temp(2,2)=aggj(l,4)
5393           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5394           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5395           s1=scalar2(b1(1,iti2),auxvec(1))
5396           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5397           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5398           s2=scalar2(b1(1,iti1),auxvec(1))
5399           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5400           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5401           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5402 !        if (j.lt.nres-1) then
5403           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5404          *fac_shield(i)*fac_shield(j)  &
5405          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5406 !        endif
5407
5408           a_temp(1,1)=aggj1(l,1)
5409           a_temp(1,2)=aggj1(l,2)
5410           a_temp(2,1)=aggj1(l,3)
5411           a_temp(2,2)=aggj1(l,4)
5412           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5413           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5414           s1=scalar2(b1(1,iti2),auxvec(1))
5415           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5416           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5417           s2=scalar2(b1(1,iti1),auxvec(1))
5418           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5419           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5420           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5421 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5422 !        if (j.lt.nres-1) then
5423 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5424           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5425          *fac_shield(i)*fac_shield(j)  &
5426          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5427 !            if (shield_mode.gt.0) then
5428 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5429 !            else
5430 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5431 !            endif
5432 !         endif
5433         enddo
5434          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5435           ssgradlipi*eello_t4/4.0d0*lipscale
5436          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5437           ssgradlipj*eello_t4/4.0d0*lipscale
5438          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5439           ssgradlipi*eello_t4/4.0d0*lipscale
5440          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5441           ssgradlipj*eello_t4/4.0d0*lipscale
5442
5443       return
5444       end subroutine eturn4
5445 !-----------------------------------------------------------------------------
5446       subroutine unormderiv(u,ugrad,unorm,ungrad)
5447 ! This subroutine computes the derivatives of a normalized vector u, given
5448 ! the derivatives computed without normalization conditions, ugrad. Returns
5449 ! ungrad.
5450 !      implicit none
5451       real(kind=8),dimension(3) :: u,vec
5452       real(kind=8),dimension(3,3) ::ugrad,ungrad
5453       real(kind=8) :: unorm      !,scalar
5454       integer :: i,j
5455 !      write (2,*) 'ugrad',ugrad
5456 !      write (2,*) 'u',u
5457       do i=1,3
5458         vec(i)=scalar(ugrad(1,i),u(1))
5459       enddo
5460 !      write (2,*) 'vec',vec
5461       do i=1,3
5462         do j=1,3
5463           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5464         enddo
5465       enddo
5466 !      write (2,*) 'ungrad',ungrad
5467       return
5468       end subroutine unormderiv
5469 !-----------------------------------------------------------------------------
5470       subroutine escp_soft_sphere(evdw2,evdw2_14)
5471 !
5472 ! This subroutine calculates the excluded-volume interaction energy between
5473 ! peptide-group centers and side chains and its gradient in virtual-bond and
5474 ! side-chain vectors.
5475 !
5476 !      implicit real(kind=8) (a-h,o-z)
5477 !      include 'DIMENSIONS'
5478 !      include 'COMMON.GEO'
5479 !      include 'COMMON.VAR'
5480 !      include 'COMMON.LOCAL'
5481 !      include 'COMMON.CHAIN'
5482 !      include 'COMMON.DERIV'
5483 !      include 'COMMON.INTERACT'
5484 !      include 'COMMON.FFIELD'
5485 !      include 'COMMON.IOUNITS'
5486 !      include 'COMMON.CONTROL'
5487       real(kind=8),dimension(3) :: ggg
5488 !el local variables
5489       integer :: i,iint,j,k,iteli,itypj
5490       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5491                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5492
5493       evdw2=0.0D0
5494       evdw2_14=0.0d0
5495       r0_scp=4.5d0
5496 !d    print '(a)','Enter ESCP'
5497 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5498       do i=iatscp_s,iatscp_e
5499         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5500         iteli=itel(i)
5501         xi=0.5D0*(c(1,i)+c(1,i+1))
5502         yi=0.5D0*(c(2,i)+c(2,i+1))
5503         zi=0.5D0*(c(3,i)+c(3,i+1))
5504           call to_box(xi,yi,zi)
5505
5506         do iint=1,nscp_gr(i)
5507
5508         do j=iscpstart(i,iint),iscpend(i,iint)
5509           if (itype(j,1).eq.ntyp1) cycle
5510           itypj=iabs(itype(j,1))
5511 ! Uncomment following three lines for SC-p interactions
5512 !         xj=c(1,nres+j)-xi
5513 !         yj=c(2,nres+j)-yi
5514 !         zj=c(3,nres+j)-zi
5515 ! Uncomment following three lines for Ca-p interactions
5516           xj=c(1,j)-xi
5517           yj=c(2,j)-yi
5518           zj=c(3,j)-zi
5519           call to_box(xj,yj,zj)
5520           xj=boxshift(xj-xi,boxxsize)
5521           yj=boxshift(yj-yi,boxysize)
5522           zj=boxshift(zj-zi,boxzsize)
5523           rij=xj*xj+yj*yj+zj*zj
5524           r0ij=r0_scp
5525           r0ijsq=r0ij*r0ij
5526           if (rij.lt.r0ijsq) then
5527             evdwij=0.25d0*(rij-r0ijsq)**2
5528             fac=rij-r0ijsq
5529           else
5530             evdwij=0.0d0
5531             fac=0.0d0
5532           endif
5533           evdw2=evdw2+evdwij
5534 !
5535 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5536 !
5537           ggg(1)=xj*fac
5538           ggg(2)=yj*fac
5539           ggg(3)=zj*fac
5540 !grad          if (j.lt.i) then
5541 !d          write (iout,*) 'j<i'
5542 ! Uncomment following three lines for SC-p interactions
5543 !           do k=1,3
5544 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5545 !           enddo
5546 !grad          else
5547 !d          write (iout,*) 'j>i'
5548 !grad            do k=1,3
5549 !grad              ggg(k)=-ggg(k)
5550 ! Uncomment following line for SC-p interactions
5551 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5552 !grad            enddo
5553 !grad          endif
5554 !grad          do k=1,3
5555 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5556 !grad          enddo
5557 !grad          kstart=min0(i+1,j)
5558 !grad          kend=max0(i-1,j-1)
5559 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5560 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5561 !grad          do k=kstart,kend
5562 !grad            do l=1,3
5563 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5564 !grad            enddo
5565 !grad          enddo
5566           do k=1,3
5567             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5568             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5569           enddo
5570         enddo
5571
5572         enddo ! iint
5573       enddo ! i
5574       return
5575       end subroutine escp_soft_sphere
5576 !-----------------------------------------------------------------------------
5577       subroutine escp(evdw2,evdw2_14)
5578 !
5579 ! This subroutine calculates the excluded-volume interaction energy between
5580 ! peptide-group centers and side chains and its gradient in virtual-bond and
5581 ! side-chain vectors.
5582 !
5583 !      implicit real(kind=8) (a-h,o-z)
5584 !      include 'DIMENSIONS'
5585 !      include 'COMMON.GEO'
5586 !      include 'COMMON.VAR'
5587 !      include 'COMMON.LOCAL'
5588 !      include 'COMMON.CHAIN'
5589 !      include 'COMMON.DERIV'
5590 !      include 'COMMON.INTERACT'
5591 !      include 'COMMON.FFIELD'
5592 !      include 'COMMON.IOUNITS'
5593 !      include 'COMMON.CONTROL'
5594       real(kind=8),dimension(3) :: ggg
5595 !el local variables
5596       integer :: i,iint,j,k,iteli,itypj,subchap,iconta
5597       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5598                    e1,e2,evdwij,rij
5599       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5600                     dist_temp, dist_init
5601       integer xshift,yshift,zshift
5602
5603       evdw2=0.0D0
5604       evdw2_14=0.0d0
5605 !d    print '(a)','Enter ESCP'
5606 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5607 !      do i=iatscp_s,iatscp_e
5608       if (nres_molec(1).eq.0) return
5609        do iconta=g_listscp_start,g_listscp_end
5610 !        print *,"icont",iconta,g_listscp_start,g_listscp_end
5611         i=newcontlistscpi(iconta)
5612         j=newcontlistscpj(iconta)
5613         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5614         iteli=itel(i)
5615         xi=0.5D0*(c(1,i)+c(1,i+1))
5616         yi=0.5D0*(c(2,i)+c(2,i+1))
5617         zi=0.5D0*(c(3,i)+c(3,i+1))
5618         call to_box(xi,yi,zi)
5619 !        print *,itel(i),i,j
5620 !        do iint=1,nscp_gr(i)
5621
5622 !        do j=iscpstart(i,iint),iscpend(i,iint)
5623           itypj=iabs(itype(j,1))
5624           if (itypj.eq.ntyp1) cycle
5625 ! Uncomment following three lines for SC-p interactions
5626 !         xj=c(1,nres+j)-xi
5627 !         yj=c(2,nres+j)-yi
5628 !         zj=c(3,nres+j)-zi
5629 ! Uncomment following three lines for Ca-p interactions
5630 !          xj=c(1,j)-xi
5631 !          yj=c(2,j)-yi
5632 !          zj=c(3,j)-zi
5633           xj=c(1,j)
5634           yj=c(2,j)
5635           zj=c(3,j)
5636
5637           call to_box(xj,yj,zj)
5638           xj=boxshift(xj-xi,boxxsize)
5639           yj=boxshift(yj-yi,boxysize)
5640           zj=boxshift(zj-zi,boxzsize)
5641
5642           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5643           rij=dsqrt(1.0d0/rrij)
5644             sss_ele_cut=sscale_ele(rij)
5645             sss_ele_grad=sscagrad_ele(rij)
5646 !            print *,sss_ele_cut,sss_ele_grad,&
5647 !            (rij),r_cut_ele,rlamb_ele
5648             if (sss_ele_cut.le.0.0) cycle
5649           fac=rrij**expon2
5650           e1=fac*fac*aad(itypj,iteli)
5651           e2=fac*bad(itypj,iteli)
5652           if (iabs(j-i) .le. 2) then
5653             e1=scal14*e1
5654             e2=scal14*e2
5655             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5656           endif
5657           evdwij=e1+e2
5658           evdw2=evdw2+evdwij*sss_ele_cut
5659 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5660 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5661           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5662              'evdw2',i,j,evdwij
5663 !
5664 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5665 !
5666           fac=-(evdwij+e1)*rrij*sss_ele_cut
5667           fac=fac+evdwij*sss_ele_grad/rij/expon
5668           ggg(1)=xj*fac
5669           ggg(2)=yj*fac
5670           ggg(3)=zj*fac
5671 !grad          if (j.lt.i) then
5672 !d          write (iout,*) 'j<i'
5673 ! Uncomment following three lines for SC-p interactions
5674 !           do k=1,3
5675 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5676 !           enddo
5677 !grad          else
5678 !d          write (iout,*) 'j>i'
5679 !grad            do k=1,3
5680 !grad              ggg(k)=-ggg(k)
5681 ! Uncomment following line for SC-p interactions
5682 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5683 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5684 !grad            enddo
5685 !grad          endif
5686 !grad          do k=1,3
5687 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5688 !grad          enddo
5689 !grad          kstart=min0(i+1,j)
5690 !grad          kend=max0(i-1,j-1)
5691 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5692 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5693 !grad          do k=kstart,kend
5694 !grad            do l=1,3
5695 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5696 !grad            enddo
5697 !grad          enddo
5698           do k=1,3
5699             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5700             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5701           enddo
5702 !        enddo
5703
5704 !        enddo ! iint
5705       enddo ! i
5706       do i=1,nct
5707         do j=1,3
5708           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5709           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5710           gradx_scp(j,i)=expon*gradx_scp(j,i)
5711         enddo
5712       enddo
5713 !******************************************************************************
5714 !
5715 !                              N O T E !!!
5716 !
5717 ! To save time the factor EXPON has been extracted from ALL components
5718 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5719 ! use!
5720 !
5721 !******************************************************************************
5722       return
5723       end subroutine escp
5724 !-----------------------------------------------------------------------------
5725       subroutine edis(ehpb)
5726 !
5727 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5728 !
5729 !      implicit real(kind=8) (a-h,o-z)
5730 !      include 'DIMENSIONS'
5731 !      include 'COMMON.SBRIDGE'
5732 !      include 'COMMON.CHAIN'
5733 !      include 'COMMON.DERIV'
5734 !      include 'COMMON.VAR'
5735 !      include 'COMMON.INTERACT'
5736 !      include 'COMMON.IOUNITS'
5737       real(kind=8),dimension(3) :: ggg,vec
5738 !el local variables
5739       integer :: i,j,ii,jj,iii,jjj,k,mnumii,mnumjj
5740       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga,xi,yi,zi,zj,yj,xj
5741
5742       ehpb=0.0D0
5743 !      write(iout,*)'edis: nhpb=',nhpb!,' fbr=',fbr
5744 !      write(iout,*)'link_start=',link_start,' link_end=',link_end
5745       if (link_end.eq.0) return
5746       do i=link_start,link_end
5747 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5748 ! CA-CA distance used in regularization of structure.
5749
5750         ii=ihpb(i)
5751         jj=jhpb(i)
5752 ! iii and jjj point to the residues for which the distance is assigned.
5753         if (ii.gt.nres) then
5754           iii=ii-nres
5755           jjj=jj-nres
5756         else
5757           iii=ii
5758           jjj=jj
5759         endif
5760         do j=1,3
5761          vec(j)=c(j,jj)-c(j,ii)
5762         enddo
5763         mnumii=molnum(iii)
5764         mnumjj=molnum(jjj)
5765         if (energy_dec) write(iout,*) i,ii,jj,mnumii,mnumjj,itype(jjj,mnumjj),itype(iii,mnumii)
5766         if ((itype(iii,mnumii).gt.ntyp_molec(mnumii)).or.(itype(jjj,mnumjj).gt.ntyp_molec(mnumjj))) cycle
5767
5768 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5769 !     &    dhpb(i),dhpb1(i),forcon(i)
5770 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5771 !    distance and angle dependent SS bond potential.
5772 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5773 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5774         if (.not.dyn_ss .and. i.le.nss) then
5775 ! 15/02/13 CC dynamic SSbond - additional check
5776          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5777         iabs(itype(jjj,1)).eq.1) then
5778           call ssbond_ene(iii,jjj,eij)
5779           ehpb=ehpb+2*eij
5780 !          write (iout,*) "eij",eij,iii,jjj
5781          endif
5782         else if (ii.gt.nres .and. jj.gt.nres) then
5783 !c Restraints from contact prediction
5784           dd=dist(ii,jj)
5785           if (constr_dist.eq.11) then
5786             ehpb=ehpb+fordepth(i)**4.0d0 &
5787                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5788             fac=fordepth(i)**4.0d0 &
5789                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5790           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5791             ehpb,fordepth(i),dd
5792            else
5793           if (dhpb1(i).gt.0.0d0) then
5794             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5795             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5796 !c            write (iout,*) "beta nmr",
5797 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5798           else
5799             dd=dist(ii,jj)
5800             rdis=dd-dhpb(i)
5801 !C Get the force constant corresponding to this distance.
5802             waga=forcon(i)
5803 !C Calculate the contribution to energy.
5804             ehpb=ehpb+waga*rdis*rdis
5805 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5806 !C
5807 !C Evaluate gradient.
5808 !C
5809             fac=waga*rdis/dd
5810           endif
5811           endif
5812           do j=1,3
5813             ggg(j)=fac*(c(j,jj)-c(j,ii))
5814           enddo
5815           do j=1,3
5816             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5817             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5818           enddo
5819           do k=1,3
5820             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5821             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5822           enddo
5823         else
5824           dd=dist(ii,jj)
5825
5826           if (constr_dist.eq.11) then
5827             ehpb=ehpb+fordepth(i)**4.0d0 &
5828                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5829             fac=fordepth(i)**4.0d0 &
5830                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5831           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5832          ehpb,fordepth(i),dd
5833            else
5834           if (dhpb1(i).gt.0.0d0) then
5835             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5836             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5837 !c            write (iout,*) "alph nmr",
5838 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5839           else
5840           xi=c(1,ii)
5841           yi=c(2,ii)
5842           zi=c(3,ii)
5843           call to_box(xi,yi,zi)
5844           xj=c(1,jj)
5845           yj=c(2,jj)
5846           zj=c(3,jj)
5847           call to_box(xj,yj,zj)
5848           xj=boxshift(xj-xi,boxxsize)
5849           yj=boxshift(yj-yi,boxysize)
5850           zj=boxshift(zj-zi,boxzsize)
5851           vec(1)=xj
5852           vec(2)=yj
5853           vec(3)=zj
5854           dd=sqrt(xj*xj+yj*yj+zj*zj)
5855             rdis=dd-dhpb(i)
5856 !C Get the force constant corresponding to this distance.
5857             waga=forcon(i)
5858 !C Calculate the contribution to energy.
5859             ehpb=ehpb+waga*rdis*rdis
5860           if (energy_dec) write (iout,'(a6,2i5,5f10.3)') "edis",ii,jj, &
5861          ehpb,dd,dhpb(i),waga,rdis
5862
5863 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5864 !C
5865 !C Evaluate gradient.
5866 !C
5867             fac=waga*rdis/dd
5868           endif
5869           endif
5870
5871             do j=1,3
5872               ggg(j)=fac*vec(j)
5873             enddo
5874 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5875 !C If this is a SC-SC distance, we need to calculate the contributions to the
5876 !C Cartesian gradient in the SC vectors (ghpbx).
5877           if (iii.lt.ii) then
5878           do j=1,3
5879             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5880             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5881           enddo
5882           endif
5883 !cgrad        do j=iii,jjj-1
5884 !cgrad          do k=1,3
5885 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5886 !cgrad          enddo
5887 !cgrad        enddo
5888           do k=1,3
5889             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5890             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5891           enddo
5892         endif
5893       enddo
5894       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5895
5896       return
5897       end subroutine edis
5898 !-----------------------------------------------------------------------------
5899       subroutine ssbond_ene(i,j,eij)
5900 !
5901 ! Calculate the distance and angle dependent SS-bond potential energy
5902 ! using a free-energy function derived based on RHF/6-31G** ab initio
5903 ! calculations of diethyl disulfide.
5904 !
5905 ! A. Liwo and U. Kozlowska, 11/24/03
5906 !
5907 !      implicit real(kind=8) (a-h,o-z)
5908 !      include 'DIMENSIONS'
5909 !      include 'COMMON.SBRIDGE'
5910 !      include 'COMMON.CHAIN'
5911 !      include 'COMMON.DERIV'
5912 !      include 'COMMON.LOCAL'
5913 !      include 'COMMON.INTERACT'
5914 !      include 'COMMON.VAR'
5915 !      include 'COMMON.IOUNITS'
5916       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5917 !el local variables
5918       integer :: i,j,itypi,itypj,k
5919       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5920                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5921                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5922                    cosphi,ggk
5923
5924       itypi=iabs(itype(i,1))
5925       xi=c(1,nres+i)
5926       yi=c(2,nres+i)
5927       zi=c(3,nres+i)
5928           call to_box(xi,yi,zi)
5929
5930       dxi=dc_norm(1,nres+i)
5931       dyi=dc_norm(2,nres+i)
5932       dzi=dc_norm(3,nres+i)
5933 !      dsci_inv=dsc_inv(itypi)
5934       dsci_inv=vbld_inv(nres+i)
5935       itypj=iabs(itype(j,1))
5936 !      dscj_inv=dsc_inv(itypj)
5937       dscj_inv=vbld_inv(nres+j)
5938       xj=c(1,nres+j)
5939       yj=c(2,nres+j)
5940       zj=c(3,nres+j)
5941           call to_box(xj,yj,zj)
5942       xj=boxshift(xj-xi,boxxsize)
5943       yj=boxshift(yj-yi,boxysize)
5944       zj=boxshift(zj-zi,boxzsize)
5945       dxj=dc_norm(1,nres+j)
5946       dyj=dc_norm(2,nres+j)
5947       dzj=dc_norm(3,nres+j)
5948       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5949       rij=dsqrt(rrij)
5950       erij(1)=xj*rij
5951       erij(2)=yj*rij
5952       erij(3)=zj*rij
5953       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5954       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5955       om12=dxi*dxj+dyi*dyj+dzi*dzj
5956       do k=1,3
5957         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5958         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5959       enddo
5960       rij=1.0d0/rij
5961       deltad=rij-d0cm
5962       deltat1=1.0d0-om1
5963       deltat2=1.0d0+om2
5964       deltat12=om2-om1+2.0d0
5965       cosphi=om12-om1*om2
5966       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5967         +akct*deltad*deltat12 &
5968         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5969 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, &
5970 !       " akct",akct," deltad",deltad," deltat",deltat1,deltat2, &
5971 !       " deltat12",deltat12," eij",eij
5972       ed=2*akcm*deltad+akct*deltat12
5973       pom1=akct*deltad
5974       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5975       eom1=-2*akth*deltat1-pom1-om2*pom2
5976       eom2= 2*akth*deltat2+pom1-om1*pom2
5977       eom12=pom2
5978       do k=1,3
5979         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5980         ghpbx(k,i)=ghpbx(k,i)-ggk &
5981                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5982                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5983         ghpbx(k,j)=ghpbx(k,j)+ggk &
5984                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5985                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5986         ghpbc(k,i)=ghpbc(k,i)-ggk
5987         ghpbc(k,j)=ghpbc(k,j)+ggk
5988       enddo
5989 !
5990 ! Calculate the components of the gradient in DC and X
5991 !
5992 !grad      do k=i,j-1
5993 !grad        do l=1,3
5994 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5995 !grad        enddo
5996 !grad      enddo
5997       return
5998       end subroutine ssbond_ene
5999 !-----------------------------------------------------------------------------
6000       subroutine ebond(estr)
6001 !
6002 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6003 !
6004 !      implicit real(kind=8) (a-h,o-z)
6005 !      include 'DIMENSIONS'
6006 !      include 'COMMON.LOCAL'
6007 !      include 'COMMON.GEO'
6008 !      include 'COMMON.INTERACT'
6009 !      include 'COMMON.DERIV'
6010 !      include 'COMMON.VAR'
6011 !      include 'COMMON.CHAIN'
6012 !      include 'COMMON.IOUNITS'
6013 !      include 'COMMON.NAMES'
6014 !      include 'COMMON.FFIELD'
6015 !      include 'COMMON.CONTROL'
6016 !      include 'COMMON.SETUP'
6017       real(kind=8),dimension(3) :: u,ud
6018 !el local variables
6019       integer :: i,j,iti,nbi,k
6020       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
6021                    uprod1,uprod2
6022
6023       estr=0.0d0
6024       estr1=0.0d0
6025 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
6026 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
6027
6028       do i=ibondp_start,ibondp_end
6029 #ifdef FIVEDIAG
6030         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) cycle
6031         diff = vbld(i)-vbldp0
6032 #else
6033         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
6034         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
6035 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6036 !C          do j=1,3
6037 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
6038 !C            *dc(j,i-1)/vbld(i)
6039 !C          enddo
6040 !C          if (energy_dec) write(iout,*) &
6041 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6042         diff = vbld(i)-vbldpDUM
6043         else
6044         diff = vbld(i)-vbldp0
6045         endif
6046 #endif
6047         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
6048            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6049         estr=estr+diff*diff
6050         do j=1,3
6051           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6052         enddo
6053 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6054 !        endif
6055       enddo
6056       estr=0.5d0*AKP*estr+estr1
6057 !      print *,"estr_bb",estr,AKP
6058 !
6059 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6060 !
6061       do i=ibond_start,ibond_end
6062         iti=iabs(itype(i,1))
6063         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
6064         if (iti.ne.10 .and. iti.ne.ntyp1) then
6065           nbi=nbondterm(iti)
6066           if (nbi.eq.1) then
6067             diff=vbld(i+nres)-vbldsc0(1,iti)
6068             if (energy_dec) write (iout,*) &
6069             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
6070             AKSC(1,iti),AKSC(1,iti)*diff*diff
6071             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6072 !            print *,"estr_sc",estr
6073             do j=1,3
6074               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6075             enddo
6076           else
6077             do j=1,nbi
6078               diff=vbld(i+nres)-vbldsc0(j,iti)
6079               ud(j)=aksc(j,iti)*diff
6080               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6081             enddo
6082             uprod=u(1)
6083             do j=2,nbi
6084               uprod=uprod*u(j)
6085             enddo
6086             usum=0.0d0
6087             usumsqder=0.0d0
6088             do j=1,nbi
6089               uprod1=1.0d0
6090               uprod2=1.0d0
6091               do k=1,nbi
6092                 if (k.ne.j) then
6093                   uprod1=uprod1*u(k)
6094                   uprod2=uprod2*u(k)*u(k)
6095                 endif
6096               enddo
6097               usum=usum+uprod1
6098               usumsqder=usumsqder+ud(j)*uprod2
6099             enddo
6100             estr=estr+uprod/usum
6101 !            print *,"estr_sc",estr,i
6102
6103              if (energy_dec) write (iout,*) &
6104             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
6105             AKSC(1,iti),uprod/usum
6106             do j=1,3
6107              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6108             enddo
6109           endif
6110         endif
6111       enddo
6112       return
6113       end subroutine ebond
6114 #ifdef CRYST_THETA
6115 !-----------------------------------------------------------------------------
6116       subroutine ebend(etheta)
6117 !
6118 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6119 ! angles gamma and its derivatives in consecutive thetas and gammas.
6120 !
6121       use comm_calcthet
6122 !      implicit real(kind=8) (a-h,o-z)
6123 !      include 'DIMENSIONS'
6124 !      include 'COMMON.LOCAL'
6125 !      include 'COMMON.GEO'
6126 !      include 'COMMON.INTERACT'
6127 !      include 'COMMON.DERIV'
6128 !      include 'COMMON.VAR'
6129 !      include 'COMMON.CHAIN'
6130 !      include 'COMMON.IOUNITS'
6131 !      include 'COMMON.NAMES'
6132 !      include 'COMMON.FFIELD'
6133 !      include 'COMMON.CONTROL'
6134 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6135 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6136 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6137 !el      integer :: it
6138 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6139 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6140 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6141 !el local variables
6142       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6143        ichir21,ichir22
6144       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6145        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6146        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6147       real(kind=8),dimension(2) :: y,z
6148
6149       delta=0.02d0*pi
6150 !      time11=dexp(-2*time)
6151 !      time12=1.0d0
6152       etheta=0.0D0
6153 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6154       do i=ithet_start,ithet_end
6155         if (itype(i-1,1).eq.ntyp1) cycle
6156 ! Zero the energy function and its derivative at 0 or pi.
6157         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6158         it=itype(i-1,1)
6159         ichir1=isign(1,itype(i-2,1))
6160         ichir2=isign(1,itype(i,1))
6161          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6162          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6163          if (itype(i-1,1).eq.10) then
6164           itype1=isign(10,itype(i-2,1))
6165           ichir11=isign(1,itype(i-2,1))
6166           ichir12=isign(1,itype(i-2,1))
6167           itype2=isign(10,itype(i,1))
6168           ichir21=isign(1,itype(i,1))
6169           ichir22=isign(1,itype(i,1))
6170          endif
6171
6172         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6173 #ifdef OSF
6174           phii=phi(i)
6175           if (phii.ne.phii) phii=150.0
6176 #else
6177           phii=phi(i)
6178 #endif
6179           y(1)=dcos(phii)
6180           y(2)=dsin(phii)
6181         else
6182           y(1)=0.0D0
6183           y(2)=0.0D0
6184         endif
6185         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6186 #ifdef OSF
6187           phii1=phi(i+1)
6188           if (phii1.ne.phii1) phii1=150.0
6189           phii1=pinorm(phii1)
6190           z(1)=cos(phii1)
6191 #else
6192           phii1=phi(i+1)
6193           z(1)=dcos(phii1)
6194 #endif
6195           z(2)=dsin(phii1)
6196         else
6197           z(1)=0.0D0
6198           z(2)=0.0D0
6199         endif
6200 ! Calculate the "mean" value of theta from the part of the distribution
6201 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6202 ! In following comments this theta will be referred to as t_c.
6203         thet_pred_mean=0.0d0
6204         do k=1,2
6205             athetk=athet(k,it,ichir1,ichir2)
6206             bthetk=bthet(k,it,ichir1,ichir2)
6207           if (it.eq.10) then
6208              athetk=athet(k,itype1,ichir11,ichir12)
6209              bthetk=bthet(k,itype2,ichir21,ichir22)
6210           endif
6211          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6212         enddo
6213         dthett=thet_pred_mean*ssd
6214         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6215 ! Derivatives of the "mean" values in gamma1 and gamma2.
6216         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6217                +athet(2,it,ichir1,ichir2)*y(1))*ss
6218         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6219                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6220          if (it.eq.10) then
6221         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6222              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6223         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6224                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6225          endif
6226         if (theta(i).gt.pi-delta) then
6227           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6228                E_tc0)
6229           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6230           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6231           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6232               E_theta)
6233           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6234               E_tc)
6235         else if (theta(i).lt.delta) then
6236           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6237           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6238           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6239               E_theta)
6240           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6241           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6242               E_tc)
6243         else
6244           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6245               E_theta,E_tc)
6246         endif
6247         etheta=etheta+ethetai
6248         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6249             'ebend',i,ethetai
6250         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6251         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6252         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6253       enddo
6254 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6255
6256 ! Ufff.... We've done all this!!!
6257       return
6258       end subroutine ebend
6259 !-----------------------------------------------------------------------------
6260       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6261
6262       use comm_calcthet
6263 !      implicit real(kind=8) (a-h,o-z)
6264 !      include 'DIMENSIONS'
6265 !      include 'COMMON.LOCAL'
6266 !      include 'COMMON.IOUNITS'
6267 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6268 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6269 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6270       integer :: i,j,k
6271       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6272 !el      integer :: it
6273 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6274 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6275 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6276 !el local variables
6277       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6278        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6279
6280 ! Calculate the contributions to both Gaussian lobes.
6281 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6282 ! The "polynomial part" of the "standard deviation" of this part of
6283 ! the distribution.
6284         sig=polthet(3,it)
6285         do j=2,0,-1
6286           sig=sig*thet_pred_mean+polthet(j,it)
6287         enddo
6288 ! Derivative of the "interior part" of the "standard deviation of the"
6289 ! gamma-dependent Gaussian lobe in t_c.
6290         sigtc=3*polthet(3,it)
6291         do j=2,1,-1
6292           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6293         enddo
6294         sigtc=sig*sigtc
6295 ! Set the parameters of both Gaussian lobes of the distribution.
6296 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6297         fac=sig*sig+sigc0(it)
6298         sigcsq=fac+fac
6299         sigc=1.0D0/sigcsq
6300 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6301         sigsqtc=-4.0D0*sigcsq*sigtc
6302 !       print *,i,sig,sigtc,sigsqtc
6303 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6304         sigtc=-sigtc/(fac*fac)
6305 ! Following variable is sigma(t_c)**(-2)
6306         sigcsq=sigcsq*sigcsq
6307         sig0i=sig0(it)
6308         sig0inv=1.0D0/sig0i**2
6309         delthec=thetai-thet_pred_mean
6310         delthe0=thetai-theta0i
6311         term1=-0.5D0*sigcsq*delthec*delthec
6312         term2=-0.5D0*sig0inv*delthe0*delthe0
6313 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6314 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6315 ! to the energy (this being the log of the distribution) at the end of energy
6316 ! term evaluation for this virtual-bond angle.
6317         if (term1.gt.term2) then
6318           termm=term1
6319           term2=dexp(term2-termm)
6320           term1=1.0d0
6321         else
6322           termm=term2
6323           term1=dexp(term1-termm)
6324           term2=1.0d0
6325         endif
6326 ! The ratio between the gamma-independent and gamma-dependent lobes of
6327 ! the distribution is a Gaussian function of thet_pred_mean too.
6328         diffak=gthet(2,it)-thet_pred_mean
6329         ratak=diffak/gthet(3,it)**2
6330         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6331 ! Let's differentiate it in thet_pred_mean NOW.
6332         aktc=ak*ratak
6333 ! Now put together the distribution terms to make complete distribution.
6334         termexp=term1+ak*term2
6335         termpre=sigc+ak*sig0i
6336 ! Contribution of the bending energy from this theta is just the -log of
6337 ! the sum of the contributions from the two lobes and the pre-exponential
6338 ! factor. Simple enough, isn't it?
6339         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6340 ! NOW the derivatives!!!
6341 ! 6/6/97 Take into account the deformation.
6342         E_theta=(delthec*sigcsq*term1 &
6343              +ak*delthe0*sig0inv*term2)/termexp
6344         E_tc=((sigtc+aktc*sig0i)/termpre &
6345             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6346              aktc*term2)/termexp)
6347       return
6348       end subroutine theteng
6349 #else
6350 !-----------------------------------------------------------------------------
6351       subroutine ebend(etheta)
6352 !
6353 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6354 ! angles gamma and its derivatives in consecutive thetas and gammas.
6355 ! ab initio-derived potentials from
6356 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6357 !
6358 !      implicit real(kind=8) (a-h,o-z)
6359 !      include 'DIMENSIONS'
6360 !      include 'COMMON.LOCAL'
6361 !      include 'COMMON.GEO'
6362 !      include 'COMMON.INTERACT'
6363 !      include 'COMMON.DERIV'
6364 !      include 'COMMON.VAR'
6365 !      include 'COMMON.CHAIN'
6366 !      include 'COMMON.IOUNITS'
6367 !      include 'COMMON.NAMES'
6368 !      include 'COMMON.FFIELD'
6369 !      include 'COMMON.CONTROL'
6370       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6371       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6372       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6373       logical :: lprn=.false., lprn1=.false.
6374 !el local variables
6375       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6376       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6377       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6378 ! local variables for constrains
6379       real(kind=8) :: difi,thetiii
6380        integer itheta
6381 !      write(iout,*) "in ebend",ithet_start,ithet_end
6382       call flush(iout)
6383       etheta=0.0D0
6384       do i=ithet_start,ithet_end
6385         if (itype(i-1,1).eq.ntyp1) cycle
6386         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6387         if (iabs(itype(i+1,1)).eq.20) iblock=2
6388         if (iabs(itype(i+1,1)).ne.20) iblock=1
6389         dethetai=0.0d0
6390         dephii=0.0d0
6391         dephii1=0.0d0
6392         theti2=0.5d0*theta(i)
6393         ityp2=ithetyp((itype(i-1,1)))
6394         do k=1,nntheterm
6395           coskt(k)=dcos(k*theti2)
6396           sinkt(k)=dsin(k*theti2)
6397         enddo
6398         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6399 #ifdef OSF
6400           phii=phi(i)
6401           if (phii.ne.phii) phii=150.0
6402 #else
6403           phii=phi(i)
6404 #endif
6405           ityp1=ithetyp((itype(i-2,1)))
6406 ! propagation of chirality for glycine type
6407           do k=1,nsingle
6408             cosph1(k)=dcos(k*phii)
6409             sinph1(k)=dsin(k*phii)
6410           enddo
6411         else
6412           phii=0.0d0
6413           ityp1=ithetyp(itype(i-2,1))
6414           do k=1,nsingle
6415             cosph1(k)=0.0d0
6416             sinph1(k)=0.0d0
6417           enddo
6418         endif
6419         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6420 #ifdef OSF
6421           phii1=phi(i+1)
6422           if (phii1.ne.phii1) phii1=150.0
6423           phii1=pinorm(phii1)
6424 #else
6425           phii1=phi(i+1)
6426 #endif
6427           ityp3=ithetyp((itype(i,1)))
6428           do k=1,nsingle
6429             cosph2(k)=dcos(k*phii1)
6430             sinph2(k)=dsin(k*phii1)
6431           enddo
6432         else
6433           phii1=0.0d0
6434           ityp3=ithetyp(itype(i,1))
6435           do k=1,nsingle
6436             cosph2(k)=0.0d0
6437             sinph2(k)=0.0d0
6438           enddo
6439         endif
6440         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6441         do k=1,ndouble
6442           do l=1,k-1
6443             ccl=cosph1(l)*cosph2(k-l)
6444             ssl=sinph1(l)*sinph2(k-l)
6445             scl=sinph1(l)*cosph2(k-l)
6446             csl=cosph1(l)*sinph2(k-l)
6447             cosph1ph2(l,k)=ccl-ssl
6448             cosph1ph2(k,l)=ccl+ssl
6449             sinph1ph2(l,k)=scl+csl
6450             sinph1ph2(k,l)=scl-csl
6451           enddo
6452         enddo
6453         if (lprn) then
6454         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6455           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6456         write (iout,*) "coskt and sinkt"
6457         do k=1,nntheterm
6458           write (iout,*) k,coskt(k),sinkt(k)
6459         enddo
6460         endif
6461         do k=1,ntheterm
6462           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6463           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6464             *coskt(k)
6465           if (lprn) &
6466           write (iout,*) "k",k,&
6467            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6468            " ethetai",ethetai
6469         enddo
6470         if (lprn) then
6471         write (iout,*) "cosph and sinph"
6472         do k=1,nsingle
6473           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6474         enddo
6475         write (iout,*) "cosph1ph2 and sinph2ph2"
6476         do k=2,ndouble
6477           do l=1,k-1
6478             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6479                sinph1ph2(l,k),sinph1ph2(k,l)
6480           enddo
6481         enddo
6482         write(iout,*) "ethetai",ethetai
6483         endif
6484         do m=1,ntheterm2
6485           do k=1,nsingle
6486             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6487                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6488                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6489                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6490             ethetai=ethetai+sinkt(m)*aux
6491             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6492             dephii=dephii+k*sinkt(m)* &
6493                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6494                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6495             dephii1=dephii1+k*sinkt(m)* &
6496                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6497                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6498             if (lprn) &
6499             write (iout,*) "m",m," k",k," bbthet", &
6500                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6501                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6502                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6503                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6504           enddo
6505         enddo
6506         if (lprn) &
6507         write(iout,*) "ethetai",ethetai
6508         do m=1,ntheterm3
6509           do k=2,ndouble
6510             do l=1,k-1
6511               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6512                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6513                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6514                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6515               ethetai=ethetai+sinkt(m)*aux
6516               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6517               dephii=dephii+l*sinkt(m)* &
6518                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6519                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6520                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6521                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6522               dephii1=dephii1+(k-l)*sinkt(m)* &
6523                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6524                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6525                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6526                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6527               if (lprn) then
6528               write (iout,*) "m",m," k",k," l",l," ffthet",&
6529                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6530                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6531                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6532                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6533                   " ethetai",ethetai
6534               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6535                   cosph1ph2(k,l)*sinkt(m),&
6536                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6537               endif
6538             enddo
6539           enddo
6540         enddo
6541 10      continue
6542 !        lprn1=.true.
6543         if (lprn1) &
6544           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6545          i,theta(i)*rad2deg,phii*rad2deg,&
6546          phii1*rad2deg,ethetai
6547 !        lprn1=.false.
6548         etheta=etheta+ethetai
6549         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6550                                     'ebend',i,ethetai
6551         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6552         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6553         gloc(nphi+i-2,icg)=wang*dethetai
6554       enddo
6555 !-----------thete constrains
6556 !      if (tor_mode.ne.2) then
6557
6558       return
6559       end subroutine ebend
6560 #endif
6561 #ifdef CRYST_SC
6562 !-----------------------------------------------------------------------------
6563       subroutine esc(escloc)
6564 ! Calculate the local energy of a side chain and its derivatives in the
6565 ! corresponding virtual-bond valence angles THETA and the spherical angles
6566 ! ALPHA and OMEGA.
6567 !
6568       use comm_sccalc
6569 !      implicit real(kind=8) (a-h,o-z)
6570 !      include 'DIMENSIONS'
6571 !      include 'COMMON.GEO'
6572 !      include 'COMMON.LOCAL'
6573 !      include 'COMMON.VAR'
6574 !      include 'COMMON.INTERACT'
6575 !      include 'COMMON.DERIV'
6576 !      include 'COMMON.CHAIN'
6577 !      include 'COMMON.IOUNITS'
6578 !      include 'COMMON.NAMES'
6579 !      include 'COMMON.FFIELD'
6580 !      include 'COMMON.CONTROL'
6581       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6582          ddersc0,ddummy,xtemp,temp
6583 !el      real(kind=8) :: time11,time12,time112,theti
6584       real(kind=8) :: escloc,delta
6585 !el      integer :: it,nlobit
6586 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6587 !el local variables
6588       integer :: i,k
6589       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6590        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6591       delta=0.02d0*pi
6592       escloc=0.0D0
6593 !     write (iout,'(a)') 'ESC'
6594       do i=loc_start,loc_end
6595         it=itype(i,1)
6596         if (it.eq.ntyp1) cycle
6597         if (it.eq.10) goto 1
6598         nlobit=nlob(iabs(it))
6599 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6600 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6601         theti=theta(i+1)-pipol
6602         x(1)=dtan(theti)
6603         x(2)=alph(i)
6604         x(3)=omeg(i)
6605
6606         if (x(2).gt.pi-delta) then
6607           xtemp(1)=x(1)
6608           xtemp(2)=pi-delta
6609           xtemp(3)=x(3)
6610           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6611           xtemp(2)=pi
6612           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6613           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6614               escloci,dersc(2))
6615           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6616               ddersc0(1),dersc(1))
6617           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6618               ddersc0(3),dersc(3))
6619           xtemp(2)=pi-delta
6620           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6621           xtemp(2)=pi
6622           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6623           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6624                   dersc0(2),esclocbi,dersc02)
6625           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6626                   dersc12,dersc01)
6627           call splinthet(x(2),0.5d0*delta,ss,ssd)
6628           dersc0(1)=dersc01
6629           dersc0(2)=dersc02
6630           dersc0(3)=0.0d0
6631           do k=1,3
6632             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6633           enddo
6634           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6635 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6636 !    &             esclocbi,ss,ssd
6637           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6638 !         escloci=esclocbi
6639 !         write (iout,*) escloci
6640         else if (x(2).lt.delta) then
6641           xtemp(1)=x(1)
6642           xtemp(2)=delta
6643           xtemp(3)=x(3)
6644           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6645           xtemp(2)=0.0d0
6646           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6647           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6648               escloci,dersc(2))
6649           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6650               ddersc0(1),dersc(1))
6651           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6652               ddersc0(3),dersc(3))
6653           xtemp(2)=delta
6654           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6655           xtemp(2)=0.0d0
6656           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6657           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6658                   dersc0(2),esclocbi,dersc02)
6659           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6660                   dersc12,dersc01)
6661           dersc0(1)=dersc01
6662           dersc0(2)=dersc02
6663           dersc0(3)=0.0d0
6664           call splinthet(x(2),0.5d0*delta,ss,ssd)
6665           do k=1,3
6666             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6667           enddo
6668           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6669 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6670 !    &             esclocbi,ss,ssd
6671           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6672 !         write (iout,*) escloci
6673         else
6674           call enesc(x,escloci,dersc,ddummy,.false.)
6675         endif
6676
6677         escloc=escloc+escloci
6678         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6679            'escloc',i,escloci
6680 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6681
6682         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6683          wscloc*dersc(1)
6684         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6685         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6686     1   continue
6687       enddo
6688       return
6689       end subroutine esc
6690 !-----------------------------------------------------------------------------
6691       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6692
6693       use comm_sccalc
6694 !      implicit real(kind=8) (a-h,o-z)
6695 !      include 'DIMENSIONS'
6696 !      include 'COMMON.GEO'
6697 !      include 'COMMON.LOCAL'
6698 !      include 'COMMON.IOUNITS'
6699 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6700       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6701       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6702       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6703       real(kind=8) :: escloci
6704       logical :: mixed
6705 !el local variables
6706       integer :: j,iii,l,k !el,it,nlobit
6707       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6708 !el       time11,time12,time112
6709 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6710         escloc_i=0.0D0
6711         do j=1,3
6712           dersc(j)=0.0D0
6713           if (mixed) ddersc(j)=0.0d0
6714         enddo
6715         x3=x(3)
6716
6717 ! Because of periodicity of the dependence of the SC energy in omega we have
6718 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6719 ! To avoid underflows, first compute & store the exponents.
6720
6721         do iii=-1,1
6722
6723           x(3)=x3+iii*dwapi
6724
6725           do j=1,nlobit
6726             do k=1,3
6727               z(k)=x(k)-censc(k,j,it)
6728             enddo
6729             do k=1,3
6730               Axk=0.0D0
6731               do l=1,3
6732                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6733               enddo
6734               Ax(k,j,iii)=Axk
6735             enddo
6736             expfac=0.0D0
6737             do k=1,3
6738               expfac=expfac+Ax(k,j,iii)*z(k)
6739             enddo
6740             contr(j,iii)=expfac
6741           enddo ! j
6742
6743         enddo ! iii
6744
6745         x(3)=x3
6746 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6747 ! subsequent NaNs and INFs in energy calculation.
6748 ! Find the largest exponent
6749         emin=contr(1,-1)
6750         do iii=-1,1
6751           do j=1,nlobit
6752             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6753           enddo
6754         enddo
6755         emin=0.5D0*emin
6756 !d      print *,'it=',it,' emin=',emin
6757
6758 ! Compute the contribution to SC energy and derivatives
6759         do iii=-1,1
6760
6761           do j=1,nlobit
6762 #ifdef OSF
6763             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6764             if(adexp.ne.adexp) adexp=1.0
6765             expfac=dexp(adexp)
6766 #else
6767             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6768 #endif
6769 !d          print *,'j=',j,' expfac=',expfac
6770             escloc_i=escloc_i+expfac
6771             do k=1,3
6772               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6773             enddo
6774             if (mixed) then
6775               do k=1,3,2
6776                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6777                   +gaussc(k,2,j,it))*expfac
6778               enddo
6779             endif
6780           enddo
6781
6782         enddo ! iii
6783
6784         dersc(1)=dersc(1)/cos(theti)**2
6785         ddersc(1)=ddersc(1)/cos(theti)**2
6786         ddersc(3)=ddersc(3)
6787
6788         escloci=-(dlog(escloc_i)-emin)
6789         do j=1,3
6790           dersc(j)=dersc(j)/escloc_i
6791         enddo
6792         if (mixed) then
6793           do j=1,3,2
6794             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6795           enddo
6796         endif
6797       return
6798       end subroutine enesc
6799 !-----------------------------------------------------------------------------
6800       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6801
6802       use comm_sccalc
6803 !      implicit real(kind=8) (a-h,o-z)
6804 !      include 'DIMENSIONS'
6805 !      include 'COMMON.GEO'
6806 !      include 'COMMON.LOCAL'
6807 !      include 'COMMON.IOUNITS'
6808 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6809       real(kind=8),dimension(3) :: x,z,dersc
6810       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6811       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6812       real(kind=8) :: escloci,dersc12,emin
6813       logical :: mixed
6814 !el local varables
6815       integer :: j,k,l !el,it,nlobit
6816       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6817
6818       escloc_i=0.0D0
6819
6820       do j=1,3
6821         dersc(j)=0.0D0
6822       enddo
6823
6824       do j=1,nlobit
6825         do k=1,2
6826           z(k)=x(k)-censc(k,j,it)
6827         enddo
6828         z(3)=dwapi
6829         do k=1,3
6830           Axk=0.0D0
6831           do l=1,3
6832             Axk=Axk+gaussc(l,k,j,it)*z(l)
6833           enddo
6834           Ax(k,j)=Axk
6835         enddo
6836         expfac=0.0D0
6837         do k=1,3
6838           expfac=expfac+Ax(k,j)*z(k)
6839         enddo
6840         contr(j)=expfac
6841       enddo ! j
6842
6843 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6844 ! subsequent NaNs and INFs in energy calculation.
6845 ! Find the largest exponent
6846       emin=contr(1)
6847       do j=1,nlobit
6848         if (emin.gt.contr(j)) emin=contr(j)
6849       enddo
6850       emin=0.5D0*emin
6851
6852 ! Compute the contribution to SC energy and derivatives
6853
6854       dersc12=0.0d0
6855       do j=1,nlobit
6856         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6857         escloc_i=escloc_i+expfac
6858         do k=1,2
6859           dersc(k)=dersc(k)+Ax(k,j)*expfac
6860         enddo
6861         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6862                   +gaussc(1,2,j,it))*expfac
6863         dersc(3)=0.0d0
6864       enddo
6865
6866       dersc(1)=dersc(1)/cos(theti)**2
6867       dersc12=dersc12/cos(theti)**2
6868       escloci=-(dlog(escloc_i)-emin)
6869       do j=1,2
6870         dersc(j)=dersc(j)/escloc_i
6871       enddo
6872       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6873       return
6874       end subroutine enesc_bound
6875 #else
6876 !-----------------------------------------------------------------------------
6877       subroutine esc(escloc)
6878 ! Calculate the local energy of a side chain and its derivatives in the
6879 ! corresponding virtual-bond valence angles THETA and the spherical angles
6880 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6881 ! added by Urszula Kozlowska. 07/11/2007
6882 !
6883       use comm_sccalc
6884 !      implicit real(kind=8) (a-h,o-z)
6885 !      include 'DIMENSIONS'
6886 !      include 'COMMON.GEO'
6887 !      include 'COMMON.LOCAL'
6888 !      include 'COMMON.VAR'
6889 !      include 'COMMON.SCROT'
6890 !      include 'COMMON.INTERACT'
6891 !      include 'COMMON.DERIV'
6892 !      include 'COMMON.CHAIN'
6893 !      include 'COMMON.IOUNITS'
6894 !      include 'COMMON.NAMES'
6895 !      include 'COMMON.FFIELD'
6896 !      include 'COMMON.CONTROL'
6897 !      include 'COMMON.VECTORS'
6898       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6899       real(kind=8),dimension(65) :: x
6900       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6901          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6902       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t,gradene
6903       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6904          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6905 !el local variables
6906       integer :: i,j,k,iti !el,it,nlobit
6907       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6908 !el      real(kind=8) :: time11,time12,time112,theti
6909 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6910       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6911                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6912                    sumene1x,sumene2x,sumene3x,sumene4x,&
6913                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6914                    cosfac2xx,sinfac2yy
6915 #ifdef DEBUG
6916       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6917                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6918                    de_dt_num
6919 #endif
6920 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6921
6922       delta=0.02d0*pi
6923       escloc=0.0D0
6924       do i=loc_start,loc_end
6925         gscloc(:,i)=0.0d0
6926         gsclocx(:,i)=0.0d0
6927 !        th_gsclocm1(:,i-1)=0.0d0
6928         if (itype(i,1).eq.ntyp1) cycle
6929         costtab(i+1) =dcos(theta(i+1))
6930         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6931         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6932         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6933         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6934         cosfac=dsqrt(cosfac2)
6935         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6936         sinfac=dsqrt(sinfac2)
6937         it=iabs(itype(i,1))
6938         iti=it
6939         if (iti.eq.ntyp1 .or. iti.eq.10) cycle
6940 !c AL 3/30/2022 handle the cases of an isolated-residue chain
6941         if (i.eq.nnt .and. itype(i+1,1).eq.ntyp1) cycle
6942         if (i.eq.nct .and. itype(i-1,1).eq.ntyp1) cycle
6943 !       costtab(i+1) =dcos(theta(i+1))
6944         if (it.eq.10) goto 1
6945 #ifdef SC_END
6946         if (i.eq.nct .or. itype(i+1,1).eq.ntyp1) then
6947 !c AL 3/30/2022 handle a sidechain of a loose C-end
6948           cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6949           sumene=arotam_end(0,1,iti)+&
6950           tschebyshev(1,nterm_scend(1,iti),arotam_end(1,1,iti),cossc1)
6951           escloc=escloc+sumene
6952           gradene=gradtschebyshev(0,nterm_scend(1,iti)-1,&
6953             arotam_end(1,1,iti),cossc1)
6954           gscloc(:,i-1)=gscloc(:,i-1)+&
6955           vbld_inv(i)*(dC_norm(:,i+nres)-dC_norm(:,i-1)&
6956             *cossc1)*gradene
6957           gsclocx(:,i)=gsclocx(:,i)+vbld_inv(i+nres)*&
6958             (dC_norm(:,i-1)-dC_norm(:,i+nres)*cossc1)*gradene
6959 #ifdef ENERGY_DEC
6960           if (energy_dec) write (2,'(2hC  ,a3,i6,2(a,f10.5))')&
6961           restyp(iti,1),i," angle",rad2deg*dacos(cossc1)," escloc",sumene
6962 #endif
6963         else if (i.eq.nnt .or. itype(i-1,1).eq.ntyp1) then
6964 !c AL 3/30/2022 handle a sidechain of a loose N-end
6965           cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6966           sumene=arotam_end(0,2,iti)+&
6967            tschebyshev(1,nterm_scend(2,iti),arotam_end(1,2,iti),cossc)
6968           escloc=escloc+sumene
6969           gradene=gradtschebyshev(0,nterm_scend(2,iti)-1,&
6970             arotam_end(1,2,iti),cossc)
6971           gscloc(:,i)=gscloc(:,i)+&
6972             vbld_inv(i+1)*(dC_norm(:,i+nres)-dC_norm(:,i)&
6973             *cossc)*gradene
6974           gsclocx(:,i)=gsclocx(:,i)+vbld_inv(i+nres)*&
6975             (dC_norm(:,i)-dC_norm(:,i+nres)*cossc)*gradene
6976 #ifdef ENERGY_DEC
6977           if (energy_dec) write (2,'(2hN  ,a3,i6,2(a,f10.5))')
6978      &     restyp(iti),i," angle",rad2deg*dacos(cossc)," escloc",sumene
6979 #endif
6980         else
6981 #endif
6982 !
6983 !  Compute the axes of tghe local cartesian coordinates system; store in
6984 !   x_prime, y_prime and z_prime
6985 !
6986         do j=1,3
6987           x_prime(j) = 0.00
6988           y_prime(j) = 0.00
6989           z_prime(j) = 0.00
6990         enddo
6991 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6992 !     &   dc_norm(3,i+nres)
6993         do j = 1,3
6994           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6995           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6996         enddo
6997         do j = 1,3
6998           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6999         enddo
7000 !       write (2,*) "i",i
7001 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
7002 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
7003 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
7004 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7005 !      & " xy",scalar(x_prime(1),y_prime(1)),
7006 !      & " xz",scalar(x_prime(1),z_prime(1)),
7007 !      & " yy",scalar(y_prime(1),y_prime(1)),
7008 !      & " yz",scalar(y_prime(1),z_prime(1)),
7009 !      & " zz",scalar(z_prime(1),z_prime(1))
7010 !
7011 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7012 ! to local coordinate system. Store in xx, yy, zz.
7013 !
7014         xx=0.0d0
7015         yy=0.0d0
7016         zz=0.0d0
7017         do j = 1,3
7018           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7019           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7020           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7021         enddo
7022
7023         xxtab(i)=xx
7024         yytab(i)=yy
7025         zztab(i)=zz
7026 !
7027 ! Compute the energy of the ith side cbain
7028 !
7029 !        write (2,*) "xx",xx," yy",yy," zz",zz
7030         it=iabs(itype(i,1))
7031         do j = 1,65
7032           x(j) = sc_parmin(j,it)
7033         enddo
7034 #ifdef CHECK_COORD
7035 !c diagnostics - remove later
7036         xx1 = dcos(alph(2))
7037         yy1 = dsin(alph(2))*dcos(omeg(2))
7038         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
7039         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
7040           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
7041           xx1,yy1,zz1
7042 !,"  --- ", xx_w,yy_w,zz_w
7043 ! end diagnostics
7044 #endif
7045         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7046          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7047          + x(10)*yy*zz
7048         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7049          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7050          + x(20)*yy*zz
7051         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7052          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7053          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7054          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7055          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7056          +x(40)*xx*yy*zz
7057         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7058          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7059          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7060          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7061          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7062          +x(60)*xx*yy*zz
7063         dsc_i   = 0.743d0+x(61)
7064         dp2_i   = 1.9d0+x(62)
7065         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7066                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7067         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7068                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7069         s1=(1+x(63))/(0.1d0 + dscp1)
7070         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7071         s2=(1+x(65))/(0.1d0 + dscp2)
7072         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7073         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
7074       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7075 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7076 !     &   sumene4,
7077 !     &   dscp1,dscp2,sumene
7078 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7079         escloc = escloc + sumene
7080        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
7081         " escloc",sumene,escloc,it,itype(i,1)
7082 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
7083 !     & ,zz,xx,yy
7084 !#define DEBUG
7085 #ifdef DEBUG
7086 !
7087 ! This section to check the numerical derivatives of the energy of ith side
7088 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7089 ! #define DEBUG in the code to turn it on.
7090 !
7091         write (2,*) "sumene               =",sumene
7092         aincr=1.0d-7
7093         xxsave=xx
7094         xx=xx+aincr
7095         write (2,*) xx,yy,zz
7096         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7097         de_dxx_num=(sumenep-sumene)/aincr
7098         xx=xxsave
7099         write (2,*) "xx+ sumene from enesc=",sumenep
7100         yysave=yy
7101         yy=yy+aincr
7102         write (2,*) xx,yy,zz
7103         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7104         de_dyy_num=(sumenep-sumene)/aincr
7105         yy=yysave
7106         write (2,*) "yy+ sumene from enesc=",sumenep
7107         zzsave=zz
7108         zz=zz+aincr
7109         write (2,*) xx,yy,zz
7110         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7111         de_dzz_num=(sumenep-sumene)/aincr
7112         zz=zzsave
7113         write (2,*) "zz+ sumene from enesc=",sumenep
7114         costsave=cost2tab(i+1)
7115         sintsave=sint2tab(i+1)
7116         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7117         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7118         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7119         de_dt_num=(sumenep-sumene)/aincr
7120         write (2,*) " t+ sumene from enesc=",sumenep
7121         cost2tab(i+1)=costsave
7122         sint2tab(i+1)=sintsave
7123 ! End of diagnostics section.
7124 #endif
7125 !
7126 ! Compute the gradient of esc
7127 !
7128 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
7129         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7130         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7131         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7132         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7133         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7134         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7135         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7136         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7137         pom1=(sumene3*sint2tab(i+1)+sumene1) &
7138            *(pom_s1/dscp1+pom_s16*dscp1**4)
7139         pom2=(sumene4*cost2tab(i+1)+sumene2) &
7140            *(pom_s2/dscp2+pom_s26*dscp2**4)
7141         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7142         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
7143         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
7144         +x(40)*yy*zz
7145         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7146         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
7147         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
7148         +x(60)*yy*zz
7149         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
7150               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
7151               +(pom1+pom2)*pom_dx
7152 #ifdef DEBUG
7153         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
7154 #endif
7155 !
7156         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7157         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
7158         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
7159         +x(40)*xx*zz
7160         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7161         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
7162         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
7163         +x(59)*zz**2 +x(60)*xx*zz
7164         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
7165               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
7166               +(pom1-pom2)*pom_dy
7167 #ifdef DEBUG
7168         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
7169 #endif
7170 !
7171         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
7172         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
7173         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
7174         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
7175         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
7176         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
7177         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
7178         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7179 #ifdef DEBUG
7180         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7181 #endif
7182 !
7183         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7184         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7185         +pom1*pom_dt1+pom2*pom_dt2
7186 #ifdef DEBUG
7187         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7188 #endif
7189 !
7190 !
7191        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7192        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7193        cosfac2xx=cosfac2*xx
7194        sinfac2yy=sinfac2*yy
7195        do k = 1,3
7196          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7197             vbld_inv(i+1)
7198          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7199             vbld_inv(i)
7200          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7201          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7202 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7203 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7204 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7205 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7206          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7207          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7208          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7209          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7210          dZZ_Ci1(k)=0.0d0
7211          dZZ_Ci(k)=0.0d0
7212          do j=1,3
7213            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7214            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7215            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7216            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7217          enddo
7218
7219          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7220          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7221          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7222          (z_prime(k)-zz*dC_norm(k,i+nres))
7223 !
7224          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7225          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7226        enddo
7227
7228        do k=1,3
7229          dXX_Ctab(k,i)=dXX_Ci(k)
7230          dXX_C1tab(k,i)=dXX_Ci1(k)
7231          dYY_Ctab(k,i)=dYY_Ci(k)
7232          dYY_C1tab(k,i)=dYY_Ci1(k)
7233          dZZ_Ctab(k,i)=dZZ_Ci(k)
7234          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7235          dXX_XYZtab(k,i)=dXX_XYZ(k)
7236          dYY_XYZtab(k,i)=dYY_XYZ(k)
7237          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7238        enddo
7239
7240        do k = 1,3
7241 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7242 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7243 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7244 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7245 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7246 !     &    dt_dci(k)
7247 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7248 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7249          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7250           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7251          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7252           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7253          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7254           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7255        enddo
7256 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7257 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7258
7259 ! to check gradient call subroutine check_grad
7260 #ifdef SC_END
7261       endif
7262 #endif
7263     1 continue
7264       enddo
7265       return
7266       end subroutine esc
7267 !-----------------------------------------------------------------------------
7268       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7269 !      implicit none
7270       real(kind=8),dimension(65) :: x
7271       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7272         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7273
7274       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7275         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7276         + x(10)*yy*zz
7277       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7278         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7279         + x(20)*yy*zz
7280       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7281         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7282         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7283         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7284         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7285         +x(40)*xx*yy*zz
7286       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7287         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7288         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7289         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7290         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7291         +x(60)*xx*yy*zz
7292       dsc_i   = 0.743d0+x(61)
7293       dp2_i   = 1.9d0+x(62)
7294       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7295                 *(xx*cost2+yy*sint2))
7296       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7297                 *(xx*cost2-yy*sint2))
7298       s1=(1+x(63))/(0.1d0 + dscp1)
7299       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7300       s2=(1+x(65))/(0.1d0 + dscp2)
7301       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7302       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7303        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7304       enesc=sumene
7305       return
7306       end function enesc
7307 #endif
7308 !-----------------------------------------------------------------------------
7309       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7310 !
7311 ! This procedure calculates two-body contact function g(rij) and its derivative:
7312 !
7313 !           eps0ij                                     !       x < -1
7314 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7315 !            0                                         !       x > 1
7316 !
7317 ! where x=(rij-r0ij)/delta
7318 !
7319 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7320 !
7321 !      implicit none
7322       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7323       real(kind=8) :: x,x2,x4,delta
7324 !     delta=0.02D0*r0ij
7325 !      delta=0.2D0*r0ij
7326       x=(rij-r0ij)/delta
7327       if (x.lt.-1.0D0) then
7328         fcont=eps0ij
7329         fprimcont=0.0D0
7330       else if (x.le.1.0D0) then
7331         x2=x*x
7332         x4=x2*x2
7333         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7334         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7335       else
7336         fcont=0.0D0
7337         fprimcont=0.0D0
7338       endif
7339       return
7340       end subroutine gcont
7341 !-----------------------------------------------------------------------------
7342       subroutine splinthet(theti,delta,ss,ssder)
7343 !      implicit real(kind=8) (a-h,o-z)
7344 !      include 'DIMENSIONS'
7345 !      include 'COMMON.VAR'
7346 !      include 'COMMON.GEO'
7347       real(kind=8) :: theti,delta,ss,ssder
7348       real(kind=8) :: thetup,thetlow
7349       thetup=pi-delta
7350       thetlow=delta
7351       if (theti.gt.pipol) then
7352         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7353       else
7354         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7355         ssder=-ssder
7356       endif
7357       return
7358       end subroutine splinthet
7359 !-----------------------------------------------------------------------------
7360       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7361 !      implicit none
7362       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7363       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7364       a1=fprim0*delta/(f1-f0)
7365       a2=3.0d0-2.0d0*a1
7366       a3=a1-2.0d0
7367       ksi=(x-x0)/delta
7368       ksi2=ksi*ksi
7369       ksi3=ksi2*ksi
7370       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7371       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7372       return
7373       end subroutine spline1
7374 !-----------------------------------------------------------------------------
7375       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7376 !      implicit none
7377       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7378       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7379       ksi=(x-x0)/delta
7380       ksi2=ksi*ksi
7381       ksi3=ksi2*ksi
7382       a1=fprim0x*delta
7383       a2=3*(f1x-f0x)-2*fprim0x*delta
7384       a3=fprim0x*delta-2*(f1x-f0x)
7385       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7386       return
7387       end subroutine spline2
7388 !-----------------------------------------------------------------------------
7389 #ifdef CRYST_TOR
7390 !-----------------------------------------------------------------------------
7391       subroutine etor(etors,edihcnstr)
7392 !      implicit real(kind=8) (a-h,o-z)
7393 !      include 'DIMENSIONS'
7394 !      include 'COMMON.VAR'
7395 !      include 'COMMON.GEO'
7396 !      include 'COMMON.LOCAL'
7397 !      include 'COMMON.TORSION'
7398 !      include 'COMMON.INTERACT'
7399 !      include 'COMMON.DERIV'
7400 !      include 'COMMON.CHAIN'
7401 !      include 'COMMON.NAMES'
7402 !      include 'COMMON.IOUNITS'
7403 !      include 'COMMON.FFIELD'
7404 !      include 'COMMON.TORCNSTR'
7405 !      include 'COMMON.CONTROL'
7406       real(kind=8) :: etors,edihcnstr
7407       logical :: lprn
7408 !el local variables
7409       integer :: i,j,
7410       real(kind=8) :: phii,fac,etors_ii
7411
7412 ! Set lprn=.true. for debugging
7413       lprn=.false.
7414 !      lprn=.true.
7415       etors=0.0D0
7416       do i=iphi_start,iphi_end
7417       etors_ii=0.0D0
7418         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7419             .or. itype(i,1).eq.ntyp1) cycle
7420         itori=itortyp(itype(i-2,1))
7421         itori1=itortyp(itype(i-1,1))
7422         phii=phi(i)
7423         gloci=0.0D0
7424 ! Proline-Proline pair is a special case...
7425         if (itori.eq.3 .and. itori1.eq.3) then
7426           if (phii.gt.-dwapi3) then
7427             cosphi=dcos(3*phii)
7428             fac=1.0D0/(1.0D0-cosphi)
7429             etorsi=v1(1,3,3)*fac
7430             etorsi=etorsi+etorsi
7431             etors=etors+etorsi-v1(1,3,3)
7432             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7433             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7434           endif
7435           do j=1,3
7436             v1ij=v1(j+1,itori,itori1)
7437             v2ij=v2(j+1,itori,itori1)
7438             cosphi=dcos(j*phii)
7439             sinphi=dsin(j*phii)
7440             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7441             if (energy_dec) etors_ii=etors_ii+ &
7442                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7443             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7444           enddo
7445         else
7446           do j=1,nterm_old
7447             v1ij=v1(j,itori,itori1)
7448             v2ij=v2(j,itori,itori1)
7449             cosphi=dcos(j*phii)
7450             sinphi=dsin(j*phii)
7451             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7452             if (energy_dec) etors_ii=etors_ii+ &
7453                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7454             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7455           enddo
7456         endif
7457         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7458              'etor',i,etors_ii
7459         if (lprn) &
7460         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7461         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7462         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7463         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7464 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7465       enddo
7466 ! 6/20/98 - dihedral angle constraints
7467       edihcnstr=0.0d0
7468       do i=1,ndih_constr
7469         itori=idih_constr(i)
7470         phii=phi(itori)
7471         difi=phii-phi0(i)
7472         if (difi.gt.drange(i)) then
7473           difi=difi-drange(i)
7474           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7475           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7476         else if (difi.lt.-drange(i)) then
7477           difi=difi+drange(i)
7478           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7479           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7480         endif
7481 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7482 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7483       enddo
7484 !      write (iout,*) 'edihcnstr',edihcnstr
7485       return
7486       end subroutine etor
7487 !-----------------------------------------------------------------------------
7488       subroutine etor_d(etors_d)
7489       real(kind=8) :: etors_d
7490       etors_d=0.0d0
7491       return
7492       end subroutine etor_d
7493 !-----------------------------------------------------------------------------
7494 !c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7495       subroutine e_modeller(ehomology_constr)
7496       real(kind=8) :: ehomology_constr
7497       ehomology_constr=0.0d0
7498       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7499       return
7500       end subroutine e_modeller
7501 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7502 #else
7503 !-----------------------------------------------------------------------------
7504       subroutine etor(etors)
7505 !      implicit real(kind=8) (a-h,o-z)
7506 !      include 'DIMENSIONS'
7507 !      include 'COMMON.VAR'
7508 !      include 'COMMON.GEO'
7509 !      include 'COMMON.LOCAL'
7510 !      include 'COMMON.TORSION'
7511 !      include 'COMMON.INTERACT'
7512 !      include 'COMMON.DERIV'
7513 !      include 'COMMON.CHAIN'
7514 !      include 'COMMON.NAMES'
7515 !      include 'COMMON.IOUNITS'
7516 !      include 'COMMON.FFIELD'
7517 !      include 'COMMON.TORCNSTR'
7518 !      include 'COMMON.CONTROL'
7519       real(kind=8) :: etors,edihcnstr
7520       logical :: lprn
7521 !el local variables
7522       integer :: i,j,iblock,itori,itori1
7523       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7524                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7525 ! Set lprn=.true. for debugging
7526       lprn=.false.
7527 !     lprn=.true.
7528       etors=0.0D0
7529       do i=iphi_start,iphi_end
7530         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7531              .or. itype(i-3,1).eq.ntyp1 &
7532              .or. itype(i,1).eq.ntyp1) cycle
7533         etors_ii=0.0D0
7534          if (iabs(itype(i,1)).eq.20) then
7535          iblock=2
7536          else
7537          iblock=1
7538          endif
7539         itori=itortyp(itype(i-2,1))
7540         itori1=itortyp(itype(i-1,1))
7541         phii=phi(i)
7542         gloci=0.0D0
7543 ! Regular cosine and sine terms
7544         do j=1,nterm(itori,itori1,iblock)
7545           v1ij=v1(j,itori,itori1,iblock)
7546           v2ij=v2(j,itori,itori1,iblock)
7547           cosphi=dcos(j*phii)
7548           sinphi=dsin(j*phii)
7549           etors=etors+v1ij*cosphi+v2ij*sinphi
7550           if (energy_dec) etors_ii=etors_ii+ &
7551                      v1ij*cosphi+v2ij*sinphi
7552           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7553         enddo
7554 ! Lorentz terms
7555 !                         v1
7556 !  E = SUM ----------------------------------- - v1
7557 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7558 !
7559         cosphi=dcos(0.5d0*phii)
7560         sinphi=dsin(0.5d0*phii)
7561         do j=1,nlor(itori,itori1,iblock)
7562           vl1ij=vlor1(j,itori,itori1)
7563           vl2ij=vlor2(j,itori,itori1)
7564           vl3ij=vlor3(j,itori,itori1)
7565           pom=vl2ij*cosphi+vl3ij*sinphi
7566           pom1=1.0d0/(pom*pom+1.0d0)
7567           etors=etors+vl1ij*pom1
7568           if (energy_dec) etors_ii=etors_ii+ &
7569                      vl1ij*pom1
7570           pom=-pom*pom1*pom1
7571           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7572         enddo
7573 ! Subtract the constant term
7574         etors=etors-v0(itori,itori1,iblock)
7575           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7576                'etor',i,etors_ii-v0(itori,itori1,iblock)
7577         if (lprn) &
7578         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7579         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7580         (v1(j,itori,itori1,iblock),j=1,6),&
7581         (v2(j,itori,itori1,iblock),j=1,6)
7582         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7583 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7584       enddo
7585 ! 6/20/98 - dihedral angle constraints
7586       return
7587       end subroutine etor
7588 !C The rigorous attempt to derive energy function
7589 !-------------------------------------------------------------------------------------------
7590       subroutine etor_kcc(etors)
7591       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7592       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7593        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7594        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7595        gradvalst2,etori
7596       logical lprn
7597       integer :: i,j,itori,itori1,nval,k,l
7598 !      lprn=.true.
7599       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7600       etors=0.0D0
7601       do i=iphi_start,iphi_end
7602 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7603 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7604 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7605 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7606         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7607            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7608         itori=itortyp(itype(i-2,1))
7609         itori1=itortyp(itype(i-1,1))
7610         phii=phi(i)
7611         glocig=0.0D0
7612         glocit1=0.0d0
7613         glocit2=0.0d0
7614 !C to avoid multiple devision by 2
7615 !c        theti22=0.5d0*theta(i)
7616 !C theta 12 is the theta_1 /2
7617 !C theta 22 is theta_2 /2
7618 !c        theti12=0.5d0*theta(i-1)
7619 !C and appropriate sinus function
7620         sinthet1=dsin(theta(i-1))
7621         sinthet2=dsin(theta(i))
7622         costhet1=dcos(theta(i-1))
7623         costhet2=dcos(theta(i))
7624 !C to speed up lets store its mutliplication
7625         sint1t2=sinthet2*sinthet1
7626         sint1t2n=1.0d0
7627 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7628 !C +d_n*sin(n*gamma)) *
7629 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7630 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7631         nval=nterm_kcc_Tb(itori,itori1)
7632         c1(0)=0.0d0
7633         c2(0)=0.0d0
7634         c1(1)=1.0d0
7635         c2(1)=1.0d0
7636         do j=2,nval
7637           c1(j)=c1(j-1)*costhet1
7638           c2(j)=c2(j-1)*costhet2
7639         enddo
7640         etori=0.0d0
7641
7642        do j=1,nterm_kcc(itori,itori1)
7643           cosphi=dcos(j*phii)
7644           sinphi=dsin(j*phii)
7645           sint1t2n1=sint1t2n
7646           sint1t2n=sint1t2n*sint1t2
7647           sumvalc=0.0d0
7648           gradvalct1=0.0d0
7649           gradvalct2=0.0d0
7650           do k=1,nval
7651             do l=1,nval
7652               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7653               gradvalct1=gradvalct1+ &
7654                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7655               gradvalct2=gradvalct2+ &
7656                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7657             enddo
7658           enddo
7659           gradvalct1=-gradvalct1*sinthet1
7660           gradvalct2=-gradvalct2*sinthet2
7661           sumvals=0.0d0
7662           gradvalst1=0.0d0
7663           gradvalst2=0.0d0
7664           do k=1,nval
7665             do l=1,nval
7666               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7667               gradvalst1=gradvalst1+ &
7668                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7669               gradvalst2=gradvalst2+ &
7670                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7671             enddo
7672           enddo
7673           gradvalst1=-gradvalst1*sinthet1
7674           gradvalst2=-gradvalst2*sinthet2
7675           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7676           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7677 !C glocig is the gradient local i site in gamma
7678           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7679 !C now gradient over theta_1
7680          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7681         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7682          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7683         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7684         enddo ! j
7685         etors=etors+etori
7686         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7687 !C derivative over theta1
7688         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7689 !C now derivative over theta2
7690         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7691         if (lprn) then
7692          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7693             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7694           write (iout,*) "c1",(c1(k),k=0,nval), &
7695          " c2",(c2(k),k=0,nval)
7696         endif
7697       enddo
7698       return
7699        end  subroutine etor_kcc
7700 !------------------------------------------------------------------------------
7701
7702         subroutine etor_constr(edihcnstr)
7703       real(kind=8) :: etors,edihcnstr
7704       logical :: lprn
7705 !el local variables
7706       integer :: i,j,iblock,itori,itori1
7707       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7708                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7709                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7710
7711       if (raw_psipred) then
7712         do i=idihconstr_start,idihconstr_end
7713           itori=idih_constr(i)
7714           phii=phi(itori)
7715           gaudih_i=vpsipred(1,i)
7716           gauder_i=0.0d0
7717           do j=1,2
7718             s = sdihed(j,i)
7719             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7720             dexpcos_i=dexp(-cos_i*cos_i)
7721             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7722           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7723                  *cos_i*dexpcos_i/s**2
7724           enddo
7725           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7726           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7727           if (energy_dec) &
7728           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7729           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7730           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7731           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7732           -wdihc*dlog(gaudih_i)
7733         enddo
7734       else
7735
7736       do i=idihconstr_start,idihconstr_end
7737         itori=idih_constr(i)
7738         phii=phi(itori)
7739         difi=pinorm(phii-phi0(i))
7740         if (difi.gt.drange(i)) then
7741           difi=difi-drange(i)
7742           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7743           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7744         else if (difi.lt.-drange(i)) then
7745           difi=difi+drange(i)
7746           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7747           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7748         else
7749           difi=0.0
7750         endif
7751       enddo
7752
7753       endif
7754
7755       return
7756
7757       end subroutine etor_constr
7758 !-----------------------------------------------------------------------------
7759       subroutine etor_d(etors_d)
7760 ! 6/23/01 Compute double torsional energy
7761 !      implicit real(kind=8) (a-h,o-z)
7762 !      include 'DIMENSIONS'
7763 !      include 'COMMON.VAR'
7764 !      include 'COMMON.GEO'
7765 !      include 'COMMON.LOCAL'
7766 !      include 'COMMON.TORSION'
7767 !      include 'COMMON.INTERACT'
7768 !      include 'COMMON.DERIV'
7769 !      include 'COMMON.CHAIN'
7770 !      include 'COMMON.NAMES'
7771 !      include 'COMMON.IOUNITS'
7772 !      include 'COMMON.FFIELD'
7773 !      include 'COMMON.TORCNSTR'
7774       real(kind=8) :: etors_d,etors_d_ii
7775       logical :: lprn
7776 !el local variables
7777       integer :: i,j,k,l,itori,itori1,itori2,iblock
7778       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7779                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7780                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7781                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7782 ! Set lprn=.true. for debugging
7783       lprn=.false.
7784 !     lprn=.true.
7785       etors_d=0.0D0
7786 !      write(iout,*) "a tu??"
7787       do i=iphid_start,iphid_end
7788         etors_d_ii=0.0D0
7789         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7790             .or. itype(i-3,1).eq.ntyp1 &
7791             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7792         itori=itortyp(itype(i-2,1))
7793         itori1=itortyp(itype(i-1,1))
7794         itori2=itortyp(itype(i,1))
7795         phii=phi(i)
7796         phii1=phi(i+1)
7797         gloci1=0.0D0
7798         gloci2=0.0D0
7799         iblock=1
7800         if (iabs(itype(i+1,1)).eq.20) iblock=2
7801
7802 ! Regular cosine and sine terms
7803         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7804           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7805           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7806           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7807           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7808           cosphi1=dcos(j*phii)
7809           sinphi1=dsin(j*phii)
7810           cosphi2=dcos(j*phii1)
7811           sinphi2=dsin(j*phii1)
7812           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7813            v2cij*cosphi2+v2sij*sinphi2
7814           if (energy_dec) etors_d_ii=etors_d_ii+ &
7815            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7816           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7817           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7818         enddo
7819         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7820           do l=1,k-1
7821             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7822             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7823             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7824             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7825             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7826             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7827             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7828             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7829             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7830               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7831             if (energy_dec) etors_d_ii=etors_d_ii+ &
7832               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7833               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7834             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7835               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7836             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7837               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7838           enddo
7839         enddo
7840         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7841                             'etor_d',i,etors_d_ii
7842         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7843         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7844       enddo
7845       return
7846       end subroutine etor_d
7847 #endif
7848 !----------------------------------------------------------------------------
7849 !----------------------------------------------------------------------------
7850       subroutine e_modeller(ehomology_constr)
7851 !      implicit none
7852 !      include 'DIMENSIONS'
7853       use MD_data, only: iset
7854       real(kind=8) :: ehomology_constr
7855       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7856       integer katy, odleglosci, test7
7857       real(kind=8) :: odleg, odleg2, odleg3, kat, kat2, kat3
7858       real(kind=8) :: Eval,Erot,min_odl
7859       real(kind=8),dimension(constr_homology) :: distance,distancek,godl,dih_diff,gdih, &
7860       gtheta,dscdiff, &
7861                 uscdiffk,guscdiff2,guscdiff3,&
7862                 theta_diff
7863
7864
7865 !
7866 !     FP - 30/10/2014 Temporary specifications for homology restraints
7867 !
7868       real(kind=8) :: utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,&
7869                       sgtheta
7870       real(kind=8), dimension (nres) :: guscdiff,usc_diff
7871       real(kind=8) :: sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,&
7872       sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,&
7873       betai,sum_sgodl,dij,max_template
7874 !      real(kind=8) :: dist,pinorm
7875 !
7876 !     include 'COMMON.SBRIDGE'
7877 !     include 'COMMON.CHAIN'
7878 !     include 'COMMON.GEO'
7879 !     include 'COMMON.DERIV'
7880 !     include 'COMMON.LOCAL'
7881 !     include 'COMMON.INTERACT'
7882 !     include 'COMMON.VAR'
7883 !     include 'COMMON.IOUNITS'
7884 !      include 'COMMON.MD'
7885 !     include 'COMMON.CONTROL'
7886 !     include 'COMMON.HOMOLOGY'
7887 !     include 'COMMON.QRESTR'
7888 !
7889 !     From subroutine Econstr_back
7890 !
7891 !     include 'COMMON.NAMES'
7892 !     include 'COMMON.TIME1'
7893 !
7894
7895
7896       do i=1,max_template
7897         distancek(i)=9999999.9
7898       enddo
7899
7900
7901       odleg=0.0d0
7902
7903 ! Pseudo-energy and gradient from homology restraints (MODELLER-like
7904 ! function)
7905 ! AL 5/2/14 - Introduce list of restraints
7906 !     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7907 #ifdef DEBUG
7908       write(iout,*) "------- dist restrs start -------"
7909 #endif
7910       do ii = link_start_homo,link_end_homo
7911          i = ires_homo(ii)
7912          j = jres_homo(ii)
7913          dij=dist(i,j)
7914 !        write (iout,*) "dij(",i,j,") =",dij
7915          nexl=0
7916          do k=1,constr_homology
7917 !           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7918            if(.not.l_homo(k,ii)) then
7919              nexl=nexl+1
7920              cycle
7921            endif
7922            distance(k)=odl(k,ii)-dij
7923 !          write (iout,*) "distance(",k,") =",distance(k)
7924 !
7925 !          For Gaussian-type Urestr
7926 !
7927            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7928 !          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7929 !          write (iout,*) "distancek(",k,") =",distancek(k)
7930 !          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7931 !
7932 !          For Lorentzian-type Urestr
7933 !
7934            if (waga_dist.lt.0.0d0) then
7935               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7936               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* &
7937                           (distance(k)**2+sigma_odlir(k,ii)**2))
7938            endif
7939          enddo
7940
7941 !         min_odl=minval(distancek)
7942          if (nexl.gt.0) then
7943            min_odl=0.0d0
7944          else
7945            do kk=1,constr_homology
7946             if(l_homo(kk,ii)) then
7947               min_odl=distancek(kk)
7948               exit
7949             endif
7950            enddo
7951            do kk=1,constr_homology
7952             if (l_homo(kk,ii) .and. distancek(kk).lt.min_odl) &
7953                    min_odl=distancek(kk)
7954            enddo
7955          endif
7956
7957 !        write (iout,* )"min_odl",min_odl
7958 #ifdef DEBUG
7959          write (iout,*) "ij dij",i,j,dij
7960          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7961          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7962          write (iout,* )"min_odl",min_odl
7963 #endif
7964 #ifdef OLDRESTR
7965          odleg2=0.0d0
7966 #else
7967          if (waga_dist.ge.0.0d0) then
7968            odleg2=nexl
7969          else
7970            odleg2=0.0d0
7971          endif
7972 #endif
7973          do k=1,constr_homology
7974 ! Nie wiem po co to liczycie jeszcze raz!
7975 !            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7976 !     &              (2*(sigma_odl(i,j,k))**2))
7977            if(.not.l_homo(k,ii)) cycle
7978            if (waga_dist.ge.0.0d0) then
7979 !
7980 !          For Gaussian-type Urestr
7981 !
7982             godl(k)=dexp(-distancek(k)+min_odl)
7983             odleg2=odleg2+godl(k)
7984 !
7985 !          For Lorentzian-type Urestr
7986 !
7987            else
7988             odleg2=odleg2+distancek(k)
7989            endif
7990
7991 !cc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7992 !cc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7993 !cc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7994 !cc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7995
7996          enddo
7997 !        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7998 !        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7999 #ifdef DEBUG
8000          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8001          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8002 #endif
8003            if (waga_dist.ge.0.0d0) then
8004 !
8005 !          For Gaussian-type Urestr
8006 !
8007               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8008 !
8009 !          For Lorentzian-type Urestr
8010 !
8011            else
8012               odleg=odleg+odleg2/constr_homology
8013            endif
8014 !
8015 !        write (iout,*) "odleg",odleg ! sum of -ln-s
8016 ! Gradient
8017 !
8018 !          For Gaussian-type Urestr
8019 !
8020          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8021          sum_sgodl=0.0d0
8022          do k=1,constr_homology
8023 !            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8024 !     &           *waga_dist)+min_odl
8025 !          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8026 !
8027          if(.not.l_homo(k,ii)) cycle
8028          if (waga_dist.ge.0.0d0) then
8029 !          For Gaussian-type Urestr
8030 !
8031            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8032 !
8033 !          For Lorentzian-type Urestr
8034 !
8035          else
8036            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ &
8037                 sigma_odlir(k,ii)**2)**2)
8038          endif
8039            sum_sgodl=sum_sgodl+sgodl
8040
8041 !            sgodl2=sgodl2+sgodl
8042 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8043 !      write(iout,*) "constr_homology=",constr_homology
8044 !      write(iout,*) i, j, k, "TEST K"
8045          enddo
8046 !         print *, "ok",iset
8047          if (waga_dist.ge.0.0d0) then
8048 !
8049 !          For Gaussian-type Urestr
8050 !
8051             grad_odl3=waga_homology(iset)*waga_dist &
8052                      *sum_sgodl/(sum_godl*dij)
8053 !         print *, "ok"
8054 !
8055 !          For Lorentzian-type Urestr
8056 !
8057          else
8058 ! Original grad expr modified by analogy w Gaussian-type Urestr grad
8059 !           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8060             grad_odl3=-waga_homology(iset)*waga_dist* &
8061                      sum_sgodl/(constr_homology*dij)
8062 !         print *, "ok2"
8063          endif
8064 !
8065 !        grad_odl3=sum_sgodl/(sum_godl*dij)
8066
8067
8068 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8069 !      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8070 !     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8071
8072 !cc      write(iout,*) godl, sgodl, grad_odl3
8073
8074 !          grad_odl=grad_odl+grad_odl3
8075
8076          do jik=1,3
8077             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8078 !cc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8079 !cc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8080 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8081             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8082             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8083 !cc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8084 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8085 !         if (i.eq.25.and.j.eq.27) then
8086 !         write(iout,*) "jik",jik,"i",i,"j",j
8087 !         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8088 !         write(iout,*) "grad_odl3",grad_odl3
8089 !         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8090 !         write(iout,*) "ggodl",ggodl
8091 !         write(iout,*) "ghpbc(",jik,i,")",
8092 !     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8093 !     &                 ghpbc(jik,j)
8094 !         endif
8095          enddo
8096 !cc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8097 !cc     & dLOG(odleg2),"-odleg=", -odleg
8098
8099       enddo ! ii-loop for dist
8100 #ifdef DEBUG
8101       write(iout,*) "------- dist restrs end -------"
8102 !     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8103 !    &     waga_d.eq.1.0d0) call sum_gradient
8104 #endif
8105 ! Pseudo-energy and gradient from dihedral-angle restraints from
8106 ! homology templates
8107 !      write (iout,*) "End of distance loop"
8108 !      call flush(iout)
8109       kat=0.0d0
8110 !      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8111 #ifdef DEBUG
8112       write(iout,*) "------- dih restrs start -------"
8113       do i=idihconstr_start_homo,idihconstr_end_homo
8114         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8115       enddo
8116 #endif
8117       do i=idihconstr_start_homo,idihconstr_end_homo
8118         kat2=0.0d0
8119 !        betai=beta(i,i+1,i+2,i+3)
8120         betai = phi(i)
8121 !       write (iout,*) "betai =",betai
8122         do k=1,constr_homology
8123           dih_diff(k)=pinorm(dih(k,i)-betai)
8124 !d          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8125 !d     &                  ,sigma_dih(k,i)
8126 !          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8127 !     &                                   -(6.28318-dih_diff(i,k))
8128 !          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8129 !     &                                   6.28318+dih_diff(i,k)
8130 #ifdef OLD_DIHED
8131           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8132 #else
8133           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8134 #endif
8135 !         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8136           gdih(k)=dexp(kat3)
8137           kat2=kat2+gdih(k)
8138 !          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8139 !          write(*,*)""
8140         enddo
8141 !       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8142 !       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8143 #ifdef DEBUG
8144         write (iout,*) "i",i," betai",betai," kat2",kat2
8145         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8146 #endif
8147         if (kat2.le.1.0d-14) cycle
8148         kat=kat-dLOG(kat2/constr_homology)
8149 !       write (iout,*) "kat",kat ! sum of -ln-s
8150
8151 !cc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8152 !cc     & dLOG(kat2), "-kat=", -kat
8153
8154 ! ----------------------------------------------------------------------
8155 ! Gradient
8156 ! ----------------------------------------------------------------------
8157
8158         sum_gdih=kat2
8159         sum_sgdih=0.0d0
8160         do k=1,constr_homology
8161 #ifdef OLD_DIHED
8162           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8163 #else
8164           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8165 #endif
8166 !         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8167           sum_sgdih=sum_sgdih+sgdih
8168         enddo
8169 !       grad_dih3=sum_sgdih/sum_gdih
8170         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8171 !         print *, "ok3"
8172
8173 !      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8174 !cc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8175 !cc     & gloc(nphi+i-3,icg)
8176         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8177 !        if (i.eq.25) then
8178 !        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8179 !        endif
8180 !cc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8181 !cc     & gloc(nphi+i-3,icg)
8182
8183       enddo ! i-loop for dih
8184 #ifdef DEBUG
8185       write(iout,*) "------- dih restrs end -------"
8186 #endif
8187
8188 ! Pseudo-energy and gradient for theta angle restraints from
8189 ! homology templates
8190 ! FP 01/15 - inserted from econstr_local_test.F, loop structure
8191 ! adapted
8192
8193 !
8194 !     For constr_homology reference structures (FP)
8195 !
8196 !     Uconst_back_tot=0.0d0
8197       Eval=0.0d0
8198       Erot=0.0d0
8199 !     Econstr_back legacy
8200       do i=1,nres
8201 !     do i=ithet_start,ithet_end
8202        dutheta(i)=0.0d0
8203       enddo
8204 !     do i=loc_start,loc_end
8205       do i=-1,nres
8206         do j=1,3
8207           duscdiff(j,i)=0.0d0
8208           duscdiffx(j,i)=0.0d0
8209         enddo
8210       enddo
8211 !
8212 !     do iref=1,nref
8213 !     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8214 !     write (iout,*) "waga_theta",waga_theta
8215       if (waga_theta.gt.0.0d0) then
8216 #ifdef DEBUG
8217       write (iout,*) "usampl",usampl
8218       write(iout,*) "------- theta restrs start -------"
8219 !     do i=ithet_start,ithet_end
8220 !       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8221 !     enddo
8222 #endif
8223 !     write (iout,*) "maxres",maxres,"nres",nres
8224
8225       do i=ithet_start,ithet_end
8226 !
8227 !     do i=1,nfrag_back
8228 !       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8229 !
8230 ! Deviation of theta angles wrt constr_homology ref structures
8231 !
8232         utheta_i=0.0d0 ! argument of Gaussian for single k
8233         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8234 !       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8235 !       over residues in a fragment
8236 !       write (iout,*) "theta(",i,")=",theta(i)
8237         do k=1,constr_homology
8238 !
8239 !         dtheta_i=theta(j)-thetaref(j,iref)
8240 !         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8241           theta_diff(k)=thetatpl(k,i)-theta(i)
8242 !d          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8243 !d     &                  ,sigma_theta(k,i)
8244
8245 !
8246           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8247 !         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8248           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8249           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8250 !         Gradient for single Gaussian restraint in subr Econstr_back
8251 !         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8252 !
8253         enddo
8254 !       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8255 !       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8256
8257 !
8258 !         Gradient for multiple Gaussian restraint
8259         sum_gtheta=gutheta_i
8260         sum_sgtheta=0.0d0
8261         do k=1,constr_homology
8262 !        New generalized expr for multiple Gaussian from Econstr_back
8263          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8264 !
8265 !        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8266           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8267         enddo
8268 !       Final value of gradient using same var as in Econstr_back
8269         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg) &
8270            +sum_sgtheta/sum_gtheta*waga_theta &
8271                     *waga_homology(iset)
8272 !         print *, "ok4"
8273
8274 !        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8275 !     &               *waga_homology(iset)
8276 !       dutheta(i)=sum_sgtheta/sum_gtheta
8277 !
8278 !       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8279         Eval=Eval-dLOG(gutheta_i/constr_homology)
8280 !       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8281 !       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8282 !       Uconst_back=Uconst_back+utheta(i)
8283       enddo ! (i-loop for theta)
8284 #ifdef DEBUG
8285       write(iout,*) "------- theta restrs end -------"
8286 #endif
8287       endif
8288 !
8289 ! Deviation of local SC geometry
8290 !
8291 ! Separation of two i-loops (instructed by AL - 11/3/2014)
8292 !
8293 !     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8294 !     write (iout,*) "waga_d",waga_d
8295
8296 #ifdef DEBUG
8297       write(iout,*) "------- SC restrs start -------"
8298       write (iout,*) "Initial duscdiff,duscdiffx"
8299       do i=loc_start,loc_end
8300         write (iout,*) i,(duscdiff(jik,i),jik=1,3), &
8301                       (duscdiffx(jik,i),jik=1,3)
8302       enddo
8303 #endif
8304       do i=loc_start,loc_end
8305         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8306         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8307 !       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8308 !       write(iout,*) "xxtab, yytab, zztab"
8309 !       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8310         do k=1,constr_homology
8311 !
8312           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8313 !                                    Original sign inverted for calc of gradients (s. Econstr_back)
8314           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8315           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8316 !         write(iout,*) "dxx, dyy, dzz"
8317 !d          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8318 !
8319           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8320 !         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8321 !         uscdiffk(k)=usc_diff(i)
8322           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8323 !          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8324 !     &       " guscdiff2",guscdiff2(k)
8325           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8326 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8327 !     &      xxref(j),yyref(j),zzref(j)
8328         enddo
8329 !
8330 !       Gradient
8331 !
8332 !       Generalized expression for multiple Gaussian acc to that for a single
8333 !       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8334 !
8335 !       Original implementation
8336 !       sum_guscdiff=guscdiff(i)
8337 !
8338 !       sum_sguscdiff=0.0d0
8339 !       do k=1,constr_homology
8340 !          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8341 !          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8342 !          sum_sguscdiff=sum_sguscdiff+sguscdiff
8343 !       enddo
8344 !
8345 !       Implementation of new expressions for gradient (Jan. 2015)
8346 !
8347 !       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8348         do k=1,constr_homology
8349 !
8350 !       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8351 !       before. Now the drivatives should be correct
8352 !
8353           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8354 !                                  Original sign inverted for calc of gradients (s. Econstr_back)
8355           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8356           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8357           sum_guscdiff=guscdiff2(k)* &!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8358                       sigma_d(k,i) ! for the grad wrt r'
8359 !         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8360
8361 !
8362 !         New implementation
8363          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8364          do jik=1,3
8365             duscdiff(jik,i-1)=duscdiff(jik,i-1)+ &
8366             sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ &
8367             dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8368             duscdiff(jik,i)=duscdiff(jik,i)+ &
8369             sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ &
8370             dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8371             duscdiffx(jik,i)=duscdiffx(jik,i)+ &
8372             sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ &
8373             dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8374 !         print *, "ok5"
8375 !
8376 #ifdef DEBUG
8377 !             write(iout,*) "jik",jik,"i",i
8378              write(iout,*) "dxx, dyy, dzz"
8379              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8380              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8381             write(iout,*) "sum_sguscdiff",sum_guscdiff,waga_homology(iset),waga_d
8382             write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8383             write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8384              write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8385              write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8386              write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8387              write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8388              write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8389              write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8390              write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8391              write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8392             write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8393             write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8394 !            endif
8395 #endif
8396          enddo
8397         enddo
8398 !         print *, "ok6"
8399 !
8400 !       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8401 !        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8402 !
8403 !        write (iout,*) i," uscdiff",uscdiff(i)
8404 !
8405 ! Put together deviations from local geometry
8406
8407 !       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8408 !      &            wfrag_back(3,i,iset)*uscdiff(i)
8409         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8410 !       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8411 !       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8412 !       Uconst_back=Uconst_back+usc_diff(i)
8413 !
8414 !     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8415 !
8416 !     New implment: multiplied by sum_sguscdiff
8417 !
8418
8419       enddo ! (i-loop for dscdiff)
8420
8421 !      endif
8422
8423 #ifdef DEBUG
8424       write(iout,*) "------- SC restrs end -------"
8425         write (iout,*) "------ After SC loop in e_modeller ------"
8426         do i=loc_start,loc_end
8427          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8428          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8429         enddo
8430       if (waga_theta.eq.1.0d0) then
8431       write (iout,*) "in e_modeller after SC restr end: dutheta"
8432       do i=ithet_start,ithet_end
8433         write (iout,*) i,dutheta(i)
8434       enddo
8435       endif
8436       if (waga_d.eq.1.0d0) then
8437       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8438       do i=1,nres
8439         write (iout,*) i,(duscdiff(j,i),j=1,3)
8440         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8441       enddo
8442       endif
8443 #endif
8444
8445 ! Total energy from homology restraints
8446 #ifdef DEBUG
8447       write (iout,*) "odleg",odleg," kat",kat
8448 #endif
8449 !
8450 ! Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8451 !
8452 !     ehomology_constr=odleg+kat
8453 !
8454 !     For Lorentzian-type Urestr
8455 !
8456
8457       if (waga_dist.ge.0.0d0) then
8458 !
8459 !          For Gaussian-type Urestr
8460 !
8461         ehomology_constr=(waga_dist*odleg+waga_angle*kat+ &
8462                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8463 !     write (iout,*) "ehomology_constr=",ehomology_constr
8464 !         print *, "ok7"
8465       else
8466 !
8467 !          For Lorentzian-type Urestr
8468 !
8469         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ &
8470                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8471 !     write (iout,*) "ehomology_constr=",ehomology_constr
8472          print *, "ok8"
8473       endif
8474 #ifdef DEBUG
8475       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, &
8476       "Eval",waga_theta,eval, &
8477         "Erot",waga_d,Erot
8478       write (iout,*) "ehomology_constr",ehomology_constr
8479 #endif
8480       return
8481 !
8482 ! FP 01/15 end
8483 !
8484   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8485   747 format(a12,i4,i4,i4,f8.3,f8.3)
8486   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8487   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8488   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, &
8489             f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8490       end subroutine e_modeller
8491
8492 !----------------------------------------------------------------------------
8493       subroutine ebend_kcc(etheta)
8494       logical lprn
8495       double precision thybt1(maxang_kcc),etheta
8496       integer :: i,iti,j,ihelp
8497       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
8498 !C Set lprn=.true. for debugging
8499       lprn=energy_dec
8500 !c     lprn=.true.
8501 !C      print *,"wchodze kcc"
8502       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8503       etheta=0.0D0
8504       do i=ithet_start,ithet_end
8505 !c        print *,i,itype(i-1),itype(i),itype(i-2)
8506         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
8507        .or.itype(i,1).eq.ntyp1) cycle
8508         iti=iabs(itortyp(itype(i-1,1)))
8509         sinthet=dsin(theta(i))
8510         costhet=dcos(theta(i))
8511         do j=1,nbend_kcc_Tb(iti)
8512           thybt1(j)=v1bend_chyb(j,iti)
8513         enddo
8514         sumth1thyb=v1bend_chyb(0,iti)+ &
8515          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8516         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
8517          sumth1thyb
8518         ihelp=nbend_kcc_Tb(iti)-1
8519         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8520         etheta=etheta+sumth1thyb
8521 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8522         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8523       enddo
8524       return
8525       end subroutine ebend_kcc
8526 !c------------
8527 !c-------------------------------------------------------------------------------------
8528       subroutine etheta_constr(ethetacnstr)
8529       real (kind=8) :: ethetacnstr,thetiii,difi
8530       integer :: i,itheta
8531       ethetacnstr=0.0d0
8532 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8533       do i=ithetaconstr_start,ithetaconstr_end
8534         itheta=itheta_constr(i)
8535         thetiii=theta(itheta)
8536         difi=pinorm(thetiii-theta_constr0(i))
8537         if (difi.gt.theta_drange(i)) then
8538           difi=difi-theta_drange(i)
8539           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8540           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8541          +for_thet_constr(i)*difi**3
8542         else if (difi.lt.-drange(i)) then
8543           difi=difi+drange(i)
8544           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8545           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8546           +for_thet_constr(i)*difi**3
8547         else
8548           difi=0.0
8549         endif
8550        if (energy_dec) then
8551         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
8552          i,itheta,rad2deg*thetiii,&
8553          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
8554          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
8555          gloc(itheta+nphi-2,icg)
8556         endif
8557       enddo
8558       return
8559       end subroutine etheta_constr
8560
8561 !-----------------------------------------------------------------------------
8562       subroutine eback_sc_corr(esccor)
8563 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
8564 !        conformational states; temporarily implemented as differences
8565 !        between UNRES torsional potentials (dependent on three types of
8566 !        residues) and the torsional potentials dependent on all 20 types
8567 !        of residues computed from AM1  energy surfaces of terminally-blocked
8568 !        amino-acid residues.
8569 !      implicit real(kind=8) (a-h,o-z)
8570 !      include 'DIMENSIONS'
8571 !      include 'COMMON.VAR'
8572 !      include 'COMMON.GEO'
8573 !      include 'COMMON.LOCAL'
8574 !      include 'COMMON.TORSION'
8575 !      include 'COMMON.SCCOR'
8576 !      include 'COMMON.INTERACT'
8577 !      include 'COMMON.DERIV'
8578 !      include 'COMMON.CHAIN'
8579 !      include 'COMMON.NAMES'
8580 !      include 'COMMON.IOUNITS'
8581 !      include 'COMMON.FFIELD'
8582 !      include 'COMMON.CONTROL'
8583       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
8584                    cosphi,sinphi
8585       logical :: lprn
8586       integer :: i,interty,j,isccori,isccori1,intertyp
8587 ! Set lprn=.true. for debugging
8588       lprn=.false.
8589 !      lprn=.true.
8590 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8591       esccor=0.0D0
8592       do i=itau_start,itau_end
8593         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
8594         esccor_ii=0.0D0
8595         isccori=isccortyp(itype(i-2,1))
8596         isccori1=isccortyp(itype(i-1,1))
8597
8598 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8599         phii=phi(i)
8600         do intertyp=1,3 !intertyp
8601          esccor_ii=0.0D0
8602 !c Added 09 May 2012 (Adasko)
8603 !c  Intertyp means interaction type of backbone mainchain correlation:
8604 !   1 = SC...Ca...Ca...Ca
8605 !   2 = Ca...Ca...Ca...SC
8606 !   3 = SC...Ca...Ca...SCi
8607         gloci=0.0D0
8608         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
8609             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
8610             (itype(i-1,1).eq.ntyp1))) &
8611           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
8612            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
8613            .or.(itype(i,1).eq.ntyp1))) &
8614           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
8615             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
8616             (itype(i-3,1).eq.ntyp1)))) cycle
8617         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
8618         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
8619        cycle
8620        do j=1,nterm_sccor(isccori,isccori1)
8621           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8622           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8623           cosphi=dcos(j*tauangle(intertyp,i))
8624           sinphi=dsin(j*tauangle(intertyp,i))
8625           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
8626           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8627           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8628         enddo
8629         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
8630                                 'esccor',i,intertyp,esccor_ii
8631 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8632         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8633         if (lprn) &
8634         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
8635         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
8636         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
8637         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8638         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8639        enddo !intertyp
8640       enddo
8641
8642       return
8643       end subroutine eback_sc_corr
8644 !-----------------------------------------------------------------------------
8645       subroutine multibody(ecorr)
8646 ! This subroutine calculates multi-body contributions to energy following
8647 ! the idea of Skolnick et al. If side chains I and J make a contact and
8648 ! at the same time side chains I+1 and J+1 make a contact, an extra
8649 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8650 !      implicit real(kind=8) (a-h,o-z)
8651 !      include 'DIMENSIONS'
8652 !      include 'COMMON.IOUNITS'
8653 !      include 'COMMON.DERIV'
8654 !      include 'COMMON.INTERACT'
8655 !      include 'COMMON.CONTACTS'
8656       real(kind=8),dimension(3) :: gx,gx1
8657       logical :: lprn
8658       real(kind=8) :: ecorr
8659       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
8660 ! Set lprn=.true. for debugging
8661       lprn=.false.
8662
8663       if (lprn) then
8664         write (iout,'(a)') 'Contact function values:'
8665         do i=nnt,nct-2
8666           write (iout,'(i2,20(1x,i2,f10.5))') &
8667               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8668         enddo
8669       endif
8670       ecorr=0.0D0
8671
8672 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8673 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8674       do i=nnt,nct
8675         do j=1,3
8676           gradcorr(j,i)=0.0D0
8677           gradxorr(j,i)=0.0D0
8678         enddo
8679       enddo
8680       do i=nnt,nct-2
8681
8682         DO ISHIFT = 3,4
8683
8684         i1=i+ishift
8685         num_conti=num_cont(i)
8686         num_conti1=num_cont(i1)
8687         do jj=1,num_conti
8688           j=jcont(jj,i)
8689           do kk=1,num_conti1
8690             j1=jcont(kk,i1)
8691             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8692 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8693 !d   &                   ' ishift=',ishift
8694 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8695 ! The system gains extra energy.
8696               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8697             endif   ! j1==j+-ishift
8698           enddo     ! kk
8699         enddo       ! jj
8700
8701         ENDDO ! ISHIFT
8702
8703       enddo         ! i
8704       return
8705       end subroutine multibody
8706 !-----------------------------------------------------------------------------
8707       real(kind=8) function esccorr(i,j,k,l,jj,kk)
8708 !      implicit real(kind=8) (a-h,o-z)
8709 !      include 'DIMENSIONS'
8710 !      include 'COMMON.IOUNITS'
8711 !      include 'COMMON.DERIV'
8712 !      include 'COMMON.INTERACT'
8713 !      include 'COMMON.CONTACTS'
8714       real(kind=8),dimension(3) :: gx,gx1
8715       logical :: lprn
8716       integer :: i,j,k,l,jj,kk,m,ll
8717       real(kind=8) :: eij,ekl
8718       lprn=.false.
8719       eij=facont(jj,i)
8720       ekl=facont(kk,k)
8721 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8722 ! Calculate the multi-body contribution to energy.
8723 ! Calculate multi-body contributions to the gradient.
8724 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8725 !d   & k,l,(gacont(m,kk,k),m=1,3)
8726       do m=1,3
8727         gx(m) =ekl*gacont(m,jj,i)
8728         gx1(m)=eij*gacont(m,kk,k)
8729         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8730         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8731         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8732         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8733       enddo
8734       do m=i,j-1
8735         do ll=1,3
8736           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8737         enddo
8738       enddo
8739       do m=k,l-1
8740         do ll=1,3
8741           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8742         enddo
8743       enddo
8744       esccorr=-eij*ekl
8745       return
8746       end function esccorr
8747 !-----------------------------------------------------------------------------
8748       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8749 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8750 !      implicit real(kind=8) (a-h,o-z)
8751 !      include 'DIMENSIONS'
8752 !      include 'COMMON.IOUNITS'
8753 #ifdef MPI
8754       include "mpif.h"
8755 !      integer :: maxconts !max_cont=maxconts  =nres/4
8756       integer,parameter :: max_dim=26
8757       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8758       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8759 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8760 !el      common /przechowalnia/ zapas
8761       integer :: status(MPI_STATUS_SIZE)
8762       integer,dimension((nres/4)*2) :: req !maxconts*2
8763       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
8764 #endif
8765 !      include 'COMMON.SETUP'
8766 !      include 'COMMON.FFIELD'
8767 !      include 'COMMON.DERIV'
8768 !      include 'COMMON.INTERACT'
8769 !      include 'COMMON.CONTACTS'
8770 !      include 'COMMON.CONTROL'
8771 !      include 'COMMON.LOCAL'
8772       real(kind=8),dimension(3) :: gx,gx1
8773       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
8774       logical :: lprn,ldone
8775 !el local variables
8776       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
8777               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
8778
8779 ! Set lprn=.true. for debugging
8780       lprn=.false.
8781 #ifdef MPI
8782 !      maxconts=nres/4
8783       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8784       n_corr=0
8785       n_corr1=0
8786       if (nfgtasks.le.1) goto 30
8787       if (lprn) then
8788         write (iout,'(a)') 'Contact function values before RECEIVE:'
8789         do i=nnt,nct-2
8790           write (iout,'(2i3,50(1x,i2,f5.2))') &
8791           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8792           j=1,num_cont_hb(i))
8793         enddo
8794       endif
8795       call flush(iout)
8796       do i=1,ntask_cont_from
8797         ncont_recv(i)=0
8798       enddo
8799       do i=1,ntask_cont_to
8800         ncont_sent(i)=0
8801       enddo
8802 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8803 !     & ntask_cont_to
8804 ! Make the list of contacts to send to send to other procesors
8805 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8806 !      call flush(iout)
8807       do i=iturn3_start,iturn3_end
8808 !        write (iout,*) "make contact list turn3",i," num_cont",
8809 !     &    num_cont_hb(i)
8810         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8811       enddo
8812       do i=iturn4_start,iturn4_end
8813 !        write (iout,*) "make contact list turn4",i," num_cont",
8814 !     &   num_cont_hb(i)
8815         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8816       enddo
8817       do ii=1,nat_sent
8818         i=iat_sent(ii)
8819 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8820 !     &    num_cont_hb(i)
8821         do j=1,num_cont_hb(i)
8822         do k=1,4
8823           jjc=jcont_hb(j,i)
8824           iproc=iint_sent_local(k,jjc,ii)
8825 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8826           if (iproc.gt.0) then
8827             ncont_sent(iproc)=ncont_sent(iproc)+1
8828             nn=ncont_sent(iproc)
8829             zapas(1,nn,iproc)=i
8830             zapas(2,nn,iproc)=jjc
8831             zapas(3,nn,iproc)=facont_hb(j,i)
8832             zapas(4,nn,iproc)=ees0p(j,i)
8833             zapas(5,nn,iproc)=ees0m(j,i)
8834             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8835             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8836             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8837             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8838             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8839             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8840             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8841             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8842             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8843             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8844             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8845             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8846             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8847             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8848             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8849             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8850             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8851             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8852             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8853             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8854             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8855           endif
8856         enddo
8857         enddo
8858       enddo
8859       if (lprn) then
8860       write (iout,*) &
8861         "Numbers of contacts to be sent to other processors",&
8862         (ncont_sent(i),i=1,ntask_cont_to)
8863       write (iout,*) "Contacts sent"
8864       do ii=1,ntask_cont_to
8865         nn=ncont_sent(ii)
8866         iproc=itask_cont_to(ii)
8867         write (iout,*) nn," contacts to processor",iproc,&
8868          " of CONT_TO_COMM group"
8869         do i=1,nn
8870           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8871         enddo
8872       enddo
8873       call flush(iout)
8874       endif
8875       CorrelType=477
8876       CorrelID=fg_rank+1
8877       CorrelType1=478
8878       CorrelID1=nfgtasks+fg_rank+1
8879       ireq=0
8880 ! Receive the numbers of needed contacts from other processors
8881       do ii=1,ntask_cont_from
8882         iproc=itask_cont_from(ii)
8883         ireq=ireq+1
8884         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8885           FG_COMM,req(ireq),IERR)
8886       enddo
8887 !      write (iout,*) "IRECV ended"
8888 !      call flush(iout)
8889 ! Send the number of contacts needed by other processors
8890       do ii=1,ntask_cont_to
8891         iproc=itask_cont_to(ii)
8892         ireq=ireq+1
8893         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8894           FG_COMM,req(ireq),IERR)
8895       enddo
8896 !      write (iout,*) "ISEND ended"
8897 !      write (iout,*) "number of requests (nn)",ireq
8898       call flush(iout)
8899       if (ireq.gt.0) &
8900         call MPI_Waitall(ireq,req,status_array,ierr)
8901 !      write (iout,*)
8902 !     &  "Numbers of contacts to be received from other processors",
8903 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8904 !      call flush(iout)
8905 ! Receive contacts
8906       ireq=0
8907       do ii=1,ntask_cont_from
8908         iproc=itask_cont_from(ii)
8909         nn=ncont_recv(ii)
8910 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8911 !     &   " of CONT_TO_COMM group"
8912         call flush(iout)
8913         if (nn.gt.0) then
8914           ireq=ireq+1
8915           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8916           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8917 !          write (iout,*) "ireq,req",ireq,req(ireq)
8918         endif
8919       enddo
8920 ! Send the contacts to processors that need them
8921       do ii=1,ntask_cont_to
8922         iproc=itask_cont_to(ii)
8923         nn=ncont_sent(ii)
8924 !        write (iout,*) nn," contacts to processor",iproc,
8925 !     &   " of CONT_TO_COMM group"
8926         if (nn.gt.0) then
8927           ireq=ireq+1
8928           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8929             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8930 !          write (iout,*) "ireq,req",ireq,req(ireq)
8931 !          do i=1,nn
8932 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8933 !          enddo
8934         endif
8935       enddo
8936 !      write (iout,*) "number of requests (contacts)",ireq
8937 !      write (iout,*) "req",(req(i),i=1,4)
8938 !      call flush(iout)
8939       if (ireq.gt.0) &
8940        call MPI_Waitall(ireq,req,status_array,ierr)
8941       do iii=1,ntask_cont_from
8942         iproc=itask_cont_from(iii)
8943         nn=ncont_recv(iii)
8944         if (lprn) then
8945         write (iout,*) "Received",nn," contacts from processor",iproc,&
8946          " of CONT_FROM_COMM group"
8947         call flush(iout)
8948         do i=1,nn
8949           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8950         enddo
8951         call flush(iout)
8952         endif
8953         do i=1,nn
8954           ii=zapas_recv(1,i,iii)
8955 ! Flag the received contacts to prevent double-counting
8956           jj=-zapas_recv(2,i,iii)
8957 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8958 !          call flush(iout)
8959           nnn=num_cont_hb(ii)+1
8960           num_cont_hb(ii)=nnn
8961           jcont_hb(nnn,ii)=jj
8962           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8963           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8964           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8965           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8966           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8967           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8968           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8969           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8970           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8971           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8972           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8973           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8974           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8975           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8976           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8977           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8978           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8979           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8980           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8981           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8982           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8983           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8984           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8985           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8986         enddo
8987       enddo
8988       call flush(iout)
8989       if (lprn) then
8990         write (iout,'(a)') 'Contact function values after receive:'
8991         do i=nnt,nct-2
8992           write (iout,'(2i3,50(1x,i3,f5.2))') &
8993           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8994           j=1,num_cont_hb(i))
8995         enddo
8996         call flush(iout)
8997       endif
8998    30 continue
8999 #endif
9000       if (lprn) then
9001         write (iout,'(a)') 'Contact function values:'
9002         do i=nnt,nct-2
9003           write (iout,'(2i3,50(1x,i3,f5.2))') &
9004           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
9005           j=1,num_cont_hb(i))
9006         enddo
9007       endif
9008       ecorr=0.0D0
9009
9010 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
9011 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
9012 ! Remove the loop below after debugging !!!
9013       do i=nnt,nct
9014         do j=1,3
9015           gradcorr(j,i)=0.0D0
9016           gradxorr(j,i)=0.0D0
9017         enddo
9018       enddo
9019 ! Calculate the local-electrostatic correlation terms
9020       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9021         i1=i+1
9022         num_conti=num_cont_hb(i)
9023         num_conti1=num_cont_hb(i+1)
9024         do jj=1,num_conti
9025           j=jcont_hb(jj,i)
9026           jp=iabs(j)
9027           do kk=1,num_conti1
9028             j1=jcont_hb(kk,i1)
9029             jp1=iabs(j1)
9030 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
9031 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
9032             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
9033                 .or. j.lt.0 .and. j1.gt.0) .and. &
9034                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9035 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9036 ! The system gains extra energy.
9037               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9038               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
9039                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9040               n_corr=n_corr+1
9041             else if (j1.eq.j) then
9042 ! Contacts I-J and I-(J+1) occur simultaneously.
9043 ! The system loses extra energy.
9044 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9045             endif
9046           enddo ! kk
9047           do kk=1,num_conti
9048             j1=jcont_hb(kk,i)
9049 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9050 !    &         ' jj=',jj,' kk=',kk
9051             if (j1.eq.j+1) then
9052 ! Contacts I-J and (I+1)-J occur simultaneously.
9053 ! The system loses extra energy.
9054 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9055             endif ! j1==j+1
9056           enddo ! kk
9057         enddo ! jj
9058       enddo ! i
9059       return
9060       end subroutine multibody_hb
9061 !-----------------------------------------------------------------------------
9062       subroutine add_hb_contact(ii,jj,itask)
9063 !      implicit real(kind=8) (a-h,o-z)
9064 !      include "DIMENSIONS"
9065 !      include "COMMON.IOUNITS"
9066 !      include "COMMON.CONTACTS"
9067 !      integer,parameter :: maxconts=nres/4
9068       integer,parameter :: max_dim=26
9069       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
9070 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
9071 !      common /przechowalnia/ zapas
9072       integer :: i,j,ii,jj,iproc,nn,jjc
9073       integer,dimension(4) :: itask
9074 !      write (iout,*) "itask",itask
9075       do i=1,2
9076         iproc=itask(i)
9077         if (iproc.gt.0) then
9078           do j=1,num_cont_hb(ii)
9079             jjc=jcont_hb(j,ii)
9080 !            write (iout,*) "i",ii," j",jj," jjc",jjc
9081             if (jjc.eq.jj) then
9082               ncont_sent(iproc)=ncont_sent(iproc)+1
9083               nn=ncont_sent(iproc)
9084               zapas(1,nn,iproc)=ii
9085               zapas(2,nn,iproc)=jjc
9086               zapas(3,nn,iproc)=facont_hb(j,ii)
9087               zapas(4,nn,iproc)=ees0p(j,ii)
9088               zapas(5,nn,iproc)=ees0m(j,ii)
9089               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9090               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9091               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9092               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9093               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9094               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9095               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9096               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9097               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9098               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9099               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9100               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9101               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9102               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9103               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9104               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9105               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9106               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9107               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9108               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9109               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9110               exit
9111             endif
9112           enddo
9113         endif
9114       enddo
9115       return
9116       end subroutine add_hb_contact
9117 !-----------------------------------------------------------------------------
9118       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
9119 ! This subroutine calculates multi-body contributions to hydrogen-bonding
9120 !      implicit real(kind=8) (a-h,o-z)
9121 !      include 'DIMENSIONS'
9122 !      include 'COMMON.IOUNITS'
9123       integer,parameter :: max_dim=70
9124 #ifdef MPI
9125       include "mpif.h"
9126 !      integer :: maxconts !max_cont=maxconts=nres/4
9127       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9128       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
9129 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
9130 !      common /przechowalnia/ zapas
9131       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
9132         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
9133         ierr,iii,nnn
9134 #endif
9135 !      include 'COMMON.SETUP'
9136 !      include 'COMMON.FFIELD'
9137 !      include 'COMMON.DERIV'
9138 !      include 'COMMON.LOCAL'
9139 !      include 'COMMON.INTERACT'
9140 !      include 'COMMON.CONTACTS'
9141 !      include 'COMMON.CHAIN'
9142 !      include 'COMMON.CONTROL'
9143       real(kind=8),dimension(3) :: gx,gx1
9144       integer,dimension(nres) :: num_cont_hb_old
9145       logical :: lprn,ldone
9146 !EL      double precision eello4,eello5,eelo6,eello_turn6
9147 !EL      external eello4,eello5,eello6,eello_turn6
9148 !el local variables
9149       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
9150               j1,jp1,i1,num_conti1
9151       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
9152       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
9153
9154 ! Set lprn=.true. for debugging
9155       lprn=.false.
9156       eturn6=0.0d0
9157 #ifdef MPI
9158 !      maxconts=nres/4
9159       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
9160       do i=1,nres
9161         num_cont_hb_old(i)=num_cont_hb(i)
9162       enddo
9163       n_corr=0
9164       n_corr1=0
9165       if (nfgtasks.le.1) goto 30
9166       if (lprn) then
9167         write (iout,'(a)') 'Contact function values before RECEIVE:'
9168         do i=nnt,nct-2
9169           write (iout,'(2i3,50(1x,i2,f5.2))') &
9170           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
9171           j=1,num_cont_hb(i))
9172         enddo
9173       endif
9174       call flush(iout)
9175       do i=1,ntask_cont_from
9176         ncont_recv(i)=0
9177       enddo
9178       do i=1,ntask_cont_to
9179         ncont_sent(i)=0
9180       enddo
9181 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9182 !     & ntask_cont_to
9183 ! Make the list of contacts to send to send to other procesors
9184       do i=iturn3_start,iturn3_end
9185 !        write (iout,*) "make contact list turn3",i," num_cont",
9186 !     &    num_cont_hb(i)
9187         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9188       enddo
9189       do i=iturn4_start,iturn4_end
9190 !        write (iout,*) "make contact list turn4",i," num_cont",
9191 !     &   num_cont_hb(i)
9192         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9193       enddo
9194       do ii=1,nat_sent
9195         i=iat_sent(ii)
9196 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
9197 !     &    num_cont_hb(i)
9198         do j=1,num_cont_hb(i)
9199         do k=1,4
9200           jjc=jcont_hb(j,i)
9201           iproc=iint_sent_local(k,jjc,ii)
9202 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9203           if (iproc.ne.0) then
9204             ncont_sent(iproc)=ncont_sent(iproc)+1
9205             nn=ncont_sent(iproc)
9206             zapas(1,nn,iproc)=i
9207             zapas(2,nn,iproc)=jjc
9208             zapas(3,nn,iproc)=d_cont(j,i)
9209             ind=3
9210             do kk=1,3
9211               ind=ind+1
9212               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9213             enddo
9214             do kk=1,2
9215               do ll=1,2
9216                 ind=ind+1
9217                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9218               enddo
9219             enddo
9220             do jj=1,5
9221               do kk=1,3
9222                 do ll=1,2
9223                   do mm=1,2
9224                     ind=ind+1
9225                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9226                   enddo
9227                 enddo
9228               enddo
9229             enddo
9230           endif
9231         enddo
9232         enddo
9233       enddo
9234       if (lprn) then
9235       write (iout,*) &
9236         "Numbers of contacts to be sent to other processors",&
9237         (ncont_sent(i),i=1,ntask_cont_to)
9238       write (iout,*) "Contacts sent"
9239       do ii=1,ntask_cont_to
9240         nn=ncont_sent(ii)
9241         iproc=itask_cont_to(ii)
9242         write (iout,*) nn," contacts to processor",iproc,&
9243          " of CONT_TO_COMM group"
9244         do i=1,nn
9245           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9246         enddo
9247       enddo
9248       call flush(iout)
9249       endif
9250       CorrelType=477
9251       CorrelID=fg_rank+1
9252       CorrelType1=478
9253       CorrelID1=nfgtasks+fg_rank+1
9254       ireq=0
9255 ! Receive the numbers of needed contacts from other processors
9256       do ii=1,ntask_cont_from
9257         iproc=itask_cont_from(ii)
9258         ireq=ireq+1
9259         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
9260           FG_COMM,req(ireq),IERR)
9261       enddo
9262 !      write (iout,*) "IRECV ended"
9263 !      call flush(iout)
9264 ! Send the number of contacts needed by other processors
9265       do ii=1,ntask_cont_to
9266         iproc=itask_cont_to(ii)
9267         ireq=ireq+1
9268         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
9269           FG_COMM,req(ireq),IERR)
9270       enddo
9271 !      write (iout,*) "ISEND ended"
9272 !      write (iout,*) "number of requests (nn)",ireq
9273       call flush(iout)
9274       if (ireq.gt.0) &
9275         call MPI_Waitall(ireq,req,status_array,ierr)
9276 !      write (iout,*)
9277 !     &  "Numbers of contacts to be received from other processors",
9278 !     &  (ncont_recv(i),i=1,ntask_cont_from)
9279 !      call flush(iout)
9280 ! Receive contacts
9281       ireq=0
9282       do ii=1,ntask_cont_from
9283         iproc=itask_cont_from(ii)
9284         nn=ncont_recv(ii)
9285 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9286 !     &   " of CONT_TO_COMM group"
9287         call flush(iout)
9288         if (nn.gt.0) then
9289           ireq=ireq+1
9290           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
9291           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9292 !          write (iout,*) "ireq,req",ireq,req(ireq)
9293         endif
9294       enddo
9295 ! Send the contacts to processors that need them
9296       do ii=1,ntask_cont_to
9297         iproc=itask_cont_to(ii)
9298         nn=ncont_sent(ii)
9299 !        write (iout,*) nn," contacts to processor",iproc,
9300 !     &   " of CONT_TO_COMM group"
9301         if (nn.gt.0) then
9302           ireq=ireq+1
9303           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
9304             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9305 !          write (iout,*) "ireq,req",ireq,req(ireq)
9306 !          do i=1,nn
9307 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9308 !          enddo
9309         endif
9310       enddo
9311 !      write (iout,*) "number of requests (contacts)",ireq
9312 !      write (iout,*) "req",(req(i),i=1,4)
9313 !      call flush(iout)
9314       if (ireq.gt.0) &
9315        call MPI_Waitall(ireq,req,status_array,ierr)
9316       do iii=1,ntask_cont_from
9317         iproc=itask_cont_from(iii)
9318         nn=ncont_recv(iii)
9319         if (lprn) then
9320         write (iout,*) "Received",nn," contacts from processor",iproc,&
9321          " of CONT_FROM_COMM group"
9322         call flush(iout)
9323         do i=1,nn
9324           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9325         enddo
9326         call flush(iout)
9327         endif
9328         do i=1,nn
9329           ii=zapas_recv(1,i,iii)
9330 ! Flag the received contacts to prevent double-counting
9331           jj=-zapas_recv(2,i,iii)
9332 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9333 !          call flush(iout)
9334           nnn=num_cont_hb(ii)+1
9335           num_cont_hb(ii)=nnn
9336           jcont_hb(nnn,ii)=jj
9337           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9338           ind=3
9339           do kk=1,3
9340             ind=ind+1
9341             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9342           enddo
9343           do kk=1,2
9344             do ll=1,2
9345               ind=ind+1
9346               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9347             enddo
9348           enddo
9349           do jj=1,5
9350             do kk=1,3
9351               do ll=1,2
9352                 do mm=1,2
9353                   ind=ind+1
9354                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9355                 enddo
9356               enddo
9357             enddo
9358           enddo
9359         enddo
9360       enddo
9361       call flush(iout)
9362       if (lprn) then
9363         write (iout,'(a)') 'Contact function values after receive:'
9364         do i=nnt,nct-2
9365           write (iout,'(2i3,50(1x,i3,5f6.3))') &
9366           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9367           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9368         enddo
9369         call flush(iout)
9370       endif
9371    30 continue
9372 #endif
9373       if (lprn) then
9374         write (iout,'(a)') 'Contact function values:'
9375         do i=nnt,nct-2
9376           write (iout,'(2i3,50(1x,i2,5f6.3))') &
9377           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9378           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9379         enddo
9380       endif
9381       ecorr=0.0D0
9382       ecorr5=0.0d0
9383       ecorr6=0.0d0
9384
9385 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
9386 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
9387 ! Remove the loop below after debugging !!!
9388       do i=nnt,nct
9389         do j=1,3
9390           gradcorr(j,i)=0.0D0
9391           gradxorr(j,i)=0.0D0
9392         enddo
9393       enddo
9394 ! Calculate the dipole-dipole interaction energies
9395       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9396       do i=iatel_s,iatel_e+1
9397         num_conti=num_cont_hb(i)
9398         do jj=1,num_conti
9399           j=jcont_hb(jj,i)
9400 #ifdef MOMENT
9401           call dipole(i,j,jj)
9402 #endif
9403         enddo
9404       enddo
9405       endif
9406 ! Calculate the local-electrostatic correlation terms
9407 !                write (iout,*) "gradcorr5 in eello5 before loop"
9408 !                do iii=1,nres
9409 !                  write (iout,'(i5,3f10.5)')
9410 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9411 !                enddo
9412       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9413 !        write (iout,*) "corr loop i",i
9414         i1=i+1
9415         num_conti=num_cont_hb(i)
9416         num_conti1=num_cont_hb(i+1)
9417         do jj=1,num_conti
9418           j=jcont_hb(jj,i)
9419           jp=iabs(j)
9420           do kk=1,num_conti1
9421             j1=jcont_hb(kk,i1)
9422             jp1=iabs(j1)
9423 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9424 !     &         ' jj=',jj,' kk=',kk
9425 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
9426             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
9427                 .or. j.lt.0 .and. j1.gt.0) .and. &
9428                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9429 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9430 ! The system gains extra energy.
9431               n_corr=n_corr+1
9432               sqd1=dsqrt(d_cont(jj,i))
9433               sqd2=dsqrt(d_cont(kk,i1))
9434               sred_geom = sqd1*sqd2
9435               IF (sred_geom.lt.cutoff_corr) THEN
9436                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
9437                   ekont,fprimcont)
9438 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9439 !d     &         ' jj=',jj,' kk=',kk
9440                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9441                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9442                 do l=1,3
9443                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9444                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9445                 enddo
9446                 n_corr1=n_corr1+1
9447 !d               write (iout,*) 'sred_geom=',sred_geom,
9448 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
9449 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9450 !d               write (iout,*) "g_contij",g_contij
9451 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9452 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9453                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9454                 if (wcorr4.gt.0.0d0) &
9455                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9456                   if (energy_dec.and.wcorr4.gt.0.0d0) &
9457                        write (iout,'(a6,4i5,0pf7.3)') &
9458                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9459 !                write (iout,*) "gradcorr5 before eello5"
9460 !                do iii=1,nres
9461 !                  write (iout,'(i5,3f10.5)')
9462 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9463 !                enddo
9464                 if (wcorr5.gt.0.0d0) &
9465                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9466 !                write (iout,*) "gradcorr5 after eello5"
9467 !                do iii=1,nres
9468 !                  write (iout,'(i5,3f10.5)')
9469 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9470 !                enddo
9471                   if (energy_dec.and.wcorr5.gt.0.0d0) &
9472                        write (iout,'(a6,4i5,0pf7.3)') &
9473                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9474 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9475 !d                write(2,*)'ijkl',i,jp,i+1,jp1
9476                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
9477                      .or. wturn6.eq.0.0d0))then
9478 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9479                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9480                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9481                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9482 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9483 !d     &            'ecorr6=',ecorr6
9484 !d                write (iout,'(4e15.5)') sred_geom,
9485 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9486 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9487 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9488                 else if (wturn6.gt.0.0d0 &
9489                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9490 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9491                   eturn6=eturn6+eello_turn6(i,jj,kk)
9492                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9493                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9494 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
9495                 endif
9496               ENDIF
9497 1111          continue
9498             endif
9499           enddo ! kk
9500         enddo ! jj
9501       enddo ! i
9502       do i=1,nres
9503         num_cont_hb(i)=num_cont_hb_old(i)
9504       enddo
9505 !                write (iout,*) "gradcorr5 in eello5"
9506 !                do iii=1,nres
9507 !                  write (iout,'(i5,3f10.5)')
9508 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9509 !                enddo
9510       return
9511       end subroutine multibody_eello
9512 !-----------------------------------------------------------------------------
9513       subroutine add_hb_contact_eello(ii,jj,itask)
9514 !      implicit real(kind=8) (a-h,o-z)
9515 !      include "DIMENSIONS"
9516 !      include "COMMON.IOUNITS"
9517 !      include "COMMON.CONTACTS"
9518 !      integer,parameter :: maxconts=nres/4
9519       integer,parameter :: max_dim=70
9520       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
9521 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
9522 !      common /przechowalnia/ zapas
9523
9524       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
9525       integer,dimension(4) ::itask
9526 !      write (iout,*) "itask",itask
9527       do i=1,2
9528         iproc=itask(i)
9529         if (iproc.gt.0) then
9530           do j=1,num_cont_hb(ii)
9531             jjc=jcont_hb(j,ii)
9532 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9533             if (jjc.eq.jj) then
9534               ncont_sent(iproc)=ncont_sent(iproc)+1
9535               nn=ncont_sent(iproc)
9536               zapas(1,nn,iproc)=ii
9537               zapas(2,nn,iproc)=jjc
9538               zapas(3,nn,iproc)=d_cont(j,ii)
9539               ind=3
9540               do kk=1,3
9541                 ind=ind+1
9542                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9543               enddo
9544               do kk=1,2
9545                 do ll=1,2
9546                   ind=ind+1
9547                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9548                 enddo
9549               enddo
9550               do jj=1,5
9551                 do kk=1,3
9552                   do ll=1,2
9553                     do mm=1,2
9554                       ind=ind+1
9555                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9556                     enddo
9557                   enddo
9558                 enddo
9559               enddo
9560               exit
9561             endif
9562           enddo
9563         endif
9564       enddo
9565       return
9566       end subroutine add_hb_contact_eello
9567 !-----------------------------------------------------------------------------
9568       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9569 !      implicit real(kind=8) (a-h,o-z)
9570 !      include 'DIMENSIONS'
9571 !      include 'COMMON.IOUNITS'
9572 !      include 'COMMON.DERIV'
9573 !      include 'COMMON.INTERACT'
9574 !      include 'COMMON.CONTACTS'
9575       real(kind=8),dimension(3) :: gx,gx1
9576       logical :: lprn
9577 !el local variables
9578       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
9579       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
9580                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
9581                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
9582                    rlocshield
9583
9584       lprn=.false.
9585       eij=facont_hb(jj,i)
9586       ekl=facont_hb(kk,k)
9587       ees0pij=ees0p(jj,i)
9588       ees0pkl=ees0p(kk,k)
9589       ees0mij=ees0m(jj,i)
9590       ees0mkl=ees0m(kk,k)
9591       ekont=eij*ekl
9592       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9593 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9594 ! Following 4 lines for diagnostics.
9595 !d    ees0pkl=0.0D0
9596 !d    ees0pij=1.0D0
9597 !d    ees0mkl=0.0D0
9598 !d    ees0mij=1.0D0
9599 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9600 !     & 'Contacts ',i,j,
9601 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9602 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9603 !     & 'gradcorr_long'
9604 ! Calculate the multi-body contribution to energy.
9605 !      ecorr=ecorr+ekont*ees
9606 ! Calculate multi-body contributions to the gradient.
9607       coeffpees0pij=coeffp*ees0pij
9608       coeffmees0mij=coeffm*ees0mij
9609       coeffpees0pkl=coeffp*ees0pkl
9610       coeffmees0mkl=coeffm*ees0mkl
9611       do ll=1,3
9612 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9613         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
9614         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
9615         coeffmees0mkl*gacontm_hb1(ll,jj,i))
9616         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
9617         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
9618         coeffmees0mkl*gacontm_hb2(ll,jj,i))
9619 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9620         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
9621         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
9622         coeffmees0mij*gacontm_hb1(ll,kk,k))
9623         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
9624         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
9625         coeffmees0mij*gacontm_hb2(ll,kk,k))
9626         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
9627            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
9628            coeffmees0mkl*gacontm_hb3(ll,jj,i))
9629         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9630         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9631         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
9632            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
9633            coeffmees0mij*gacontm_hb3(ll,kk,k))
9634         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9635         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9636 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9637       enddo
9638 !      write (iout,*)
9639 !grad      do m=i+1,j-1
9640 !grad        do ll=1,3
9641 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9642 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9643 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9644 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9645 !grad        enddo
9646 !grad      enddo
9647 !grad      do m=k+1,l-1
9648 !grad        do ll=1,3
9649 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9650 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
9651 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9652 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9653 !grad        enddo
9654 !grad      enddo
9655 !      write (iout,*) "ehbcorr",ekont*ees
9656       ehbcorr=ekont*ees
9657       if (shield_mode.gt.0) then
9658        j=ees0plist(jj,i)
9659        l=ees0plist(kk,k)
9660 !C        print *,i,j,fac_shield(i),fac_shield(j),
9661 !C     &fac_shield(k),fac_shield(l)
9662         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
9663            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9664           do ilist=1,ishield_list(i)
9665            iresshield=shield_list(ilist,i)
9666            do m=1,3
9667            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9668            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9669                    rlocshield  &
9670             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9671             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9672             +rlocshield
9673            enddo
9674           enddo
9675           do ilist=1,ishield_list(j)
9676            iresshield=shield_list(ilist,j)
9677            do m=1,3
9678            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9679            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9680                    rlocshield &
9681             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9682            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9683             +rlocshield
9684            enddo
9685           enddo
9686
9687           do ilist=1,ishield_list(k)
9688            iresshield=shield_list(ilist,k)
9689            do m=1,3
9690            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9691            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9692                    rlocshield &
9693             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9694            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9695             +rlocshield
9696            enddo
9697           enddo
9698           do ilist=1,ishield_list(l)
9699            iresshield=shield_list(ilist,l)
9700            do m=1,3
9701            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9702            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9703                    rlocshield &
9704             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9705            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9706             +rlocshield
9707            enddo
9708           enddo
9709           do m=1,3
9710             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
9711                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9712             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
9713                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9714             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
9715                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9716             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
9717                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9718
9719             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
9720                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9721             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
9722                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9723             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
9724                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9725             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
9726                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9727
9728            enddo
9729       endif
9730       endif
9731       return
9732       end function ehbcorr
9733 #ifdef MOMENT
9734 !-----------------------------------------------------------------------------
9735       subroutine dipole(i,j,jj)
9736 !      implicit real(kind=8) (a-h,o-z)
9737 !      include 'DIMENSIONS'
9738 !      include 'COMMON.IOUNITS'
9739 !      include 'COMMON.CHAIN'
9740 !      include 'COMMON.FFIELD'
9741 !      include 'COMMON.DERIV'
9742 !      include 'COMMON.INTERACT'
9743 !      include 'COMMON.CONTACTS'
9744 !      include 'COMMON.TORSION'
9745 !      include 'COMMON.VAR'
9746 !      include 'COMMON.GEO'
9747       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
9748       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
9749       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
9750
9751       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
9752       allocate(dipderx(3,5,4,maxconts,nres))
9753 !
9754
9755       iti1 = itortyp(itype(i+1,1))
9756       if (j.lt.nres-1) then
9757         itj1 = itype2loc(itype(j+1,1))
9758       else
9759         itj1=nloctyp
9760       endif
9761       do iii=1,2
9762         dipi(iii,1)=Ub2(iii,i)
9763         dipderi(iii)=Ub2der(iii,i)
9764         dipi(iii,2)=b1(iii,iti1)
9765         dipj(iii,1)=Ub2(iii,j)
9766         dipderj(iii)=Ub2der(iii,j)
9767         dipj(iii,2)=b1(iii,itj1)
9768       enddo
9769       kkk=0
9770       do iii=1,2
9771         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9772         do jjj=1,2
9773           kkk=kkk+1
9774           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9775         enddo
9776       enddo
9777       do kkk=1,5
9778         do lll=1,3
9779           mmm=0
9780           do iii=1,2
9781             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
9782               auxvec(1))
9783             do jjj=1,2
9784               mmm=mmm+1
9785               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9786             enddo
9787           enddo
9788         enddo
9789       enddo
9790       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9791       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9792       do iii=1,2
9793         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9794       enddo
9795       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9796       do iii=1,2
9797         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9798       enddo
9799       return
9800       end subroutine dipole
9801 #endif
9802 !-----------------------------------------------------------------------------
9803       subroutine calc_eello(i,j,k,l,jj,kk)
9804 !
9805 ! This subroutine computes matrices and vectors needed to calculate
9806 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
9807 !
9808       use comm_kut
9809 !      implicit real(kind=8) (a-h,o-z)
9810 !      include 'DIMENSIONS'
9811 !      include 'COMMON.IOUNITS'
9812 !      include 'COMMON.CHAIN'
9813 !      include 'COMMON.DERIV'
9814 !      include 'COMMON.INTERACT'
9815 !      include 'COMMON.CONTACTS'
9816 !      include 'COMMON.TORSION'
9817 !      include 'COMMON.VAR'
9818 !      include 'COMMON.GEO'
9819 !      include 'COMMON.FFIELD'
9820       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9821       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9822       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9823               itj1
9824 !el      logical :: lprn
9825 !el      common /kutas/ lprn
9826 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9827 !d     & ' jj=',jj,' kk=',kk
9828 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9829 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9830 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9831       do iii=1,2
9832         do jjj=1,2
9833           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9834           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9835         enddo
9836       enddo
9837       call transpose2(aa1(1,1),aa1t(1,1))
9838       call transpose2(aa2(1,1),aa2t(1,1))
9839       do kkk=1,5
9840         do lll=1,3
9841           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9842             aa1tder(1,1,lll,kkk))
9843           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9844             aa2tder(1,1,lll,kkk))
9845         enddo
9846       enddo
9847       if (l.eq.j+1) then
9848 ! parallel orientation of the two CA-CA-CA frames.
9849         if (i.gt.1) then
9850           iti=itortyp(itype(i,1))
9851         else
9852           iti=ntortyp+1
9853         endif
9854         itk1=itortyp(itype(k+1,1))
9855         itj=itortyp(itype(j,1))
9856         if (l.lt.nres-1) then
9857           itl1=itortyp(itype(l+1,1))
9858         else
9859           itl1=ntortyp+1
9860         endif
9861 ! A1 kernel(j+1) A2T
9862 !d        do iii=1,2
9863 !d          write (iout,'(3f10.5,5x,3f10.5)')
9864 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9865 !d        enddo
9866         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9867          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9868          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9869 ! Following matrices are needed only for 6-th order cumulants
9870         IF (wcorr6.gt.0.0d0) THEN
9871         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9872          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9873          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9874         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9875          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9876          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9877          ADtEAderx(1,1,1,1,1,1))
9878         lprn=.false.
9879         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9880          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9881          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9882          ADtEA1derx(1,1,1,1,1,1))
9883         ENDIF
9884 ! End 6-th order cumulants
9885 !d        lprn=.false.
9886 !d        if (lprn) then
9887 !d        write (2,*) 'In calc_eello6'
9888 !d        do iii=1,2
9889 !d          write (2,*) 'iii=',iii
9890 !d          do kkk=1,5
9891 !d            write (2,*) 'kkk=',kkk
9892 !d            do jjj=1,2
9893 !d              write (2,'(3(2f10.5),5x)')
9894 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9895 !d            enddo
9896 !d          enddo
9897 !d        enddo
9898 !d        endif
9899         call transpose2(EUgder(1,1,k),auxmat(1,1))
9900         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9901         call transpose2(EUg(1,1,k),auxmat(1,1))
9902         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9903         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9904         do iii=1,2
9905           do kkk=1,5
9906             do lll=1,3
9907               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9908                 EAEAderx(1,1,lll,kkk,iii,1))
9909             enddo
9910           enddo
9911         enddo
9912 ! A1T kernel(i+1) A2
9913         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9914          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9915          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9916 ! Following matrices are needed only for 6-th order cumulants
9917         IF (wcorr6.gt.0.0d0) THEN
9918         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9919          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9920          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9921         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9922          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9923          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9924          ADtEAderx(1,1,1,1,1,2))
9925         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9926          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9927          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9928          ADtEA1derx(1,1,1,1,1,2))
9929         ENDIF
9930 ! End 6-th order cumulants
9931         call transpose2(EUgder(1,1,l),auxmat(1,1))
9932         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9933         call transpose2(EUg(1,1,l),auxmat(1,1))
9934         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9935         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9936         do iii=1,2
9937           do kkk=1,5
9938             do lll=1,3
9939               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9940                 EAEAderx(1,1,lll,kkk,iii,2))
9941             enddo
9942           enddo
9943         enddo
9944 ! AEAb1 and AEAb2
9945 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9946 ! They are needed only when the fifth- or the sixth-order cumulants are
9947 ! indluded.
9948         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9949         call transpose2(AEA(1,1,1),auxmat(1,1))
9950         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9951         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9952         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9953         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9954         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9955         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9956         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9957         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9958         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9959         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9960         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9961         call transpose2(AEA(1,1,2),auxmat(1,1))
9962         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9963         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9964         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9965         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9966         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9967         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9968         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9969         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9970         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9971         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9972         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9973 ! Calculate the Cartesian derivatives of the vectors.
9974         do iii=1,2
9975           do kkk=1,5
9976             do lll=1,3
9977               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9978               call matvec2(auxmat(1,1),b1(1,iti),&
9979                 AEAb1derx(1,lll,kkk,iii,1,1))
9980               call matvec2(auxmat(1,1),Ub2(1,i),&
9981                 AEAb2derx(1,lll,kkk,iii,1,1))
9982               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9983                 AEAb1derx(1,lll,kkk,iii,2,1))
9984               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9985                 AEAb2derx(1,lll,kkk,iii,2,1))
9986               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9987               call matvec2(auxmat(1,1),b1(1,itj),&
9988                 AEAb1derx(1,lll,kkk,iii,1,2))
9989               call matvec2(auxmat(1,1),Ub2(1,j),&
9990                 AEAb2derx(1,lll,kkk,iii,1,2))
9991               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9992                 AEAb1derx(1,lll,kkk,iii,2,2))
9993               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9994                 AEAb2derx(1,lll,kkk,iii,2,2))
9995             enddo
9996           enddo
9997         enddo
9998         ENDIF
9999 ! End vectors
10000       else
10001 ! Antiparallel orientation of the two CA-CA-CA frames.
10002         if (i.gt.1) then
10003           iti=itortyp(itype(i,1))
10004         else
10005           iti=ntortyp+1
10006         endif
10007         itk1=itortyp(itype(k+1,1))
10008         itl=itortyp(itype(l,1))
10009         itj=itortyp(itype(j,1))
10010         if (j.lt.nres-1) then
10011           itj1=itortyp(itype(j+1,1))
10012         else
10013           itj1=ntortyp+1
10014         endif
10015 ! A2 kernel(j-1)T A1T
10016         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
10017          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
10018          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10019 ! Following matrices are needed only for 6-th order cumulants
10020         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
10021            j.eq.i+4 .and. l.eq.i+3)) THEN
10022         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
10023          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
10024          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10025         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
10026          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
10027          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
10028          ADtEAderx(1,1,1,1,1,1))
10029         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
10030          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
10031          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
10032          ADtEA1derx(1,1,1,1,1,1))
10033         ENDIF
10034 ! End 6-th order cumulants
10035         call transpose2(EUgder(1,1,k),auxmat(1,1))
10036         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10037         call transpose2(EUg(1,1,k),auxmat(1,1))
10038         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10039         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10040         do iii=1,2
10041           do kkk=1,5
10042             do lll=1,3
10043               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
10044                 EAEAderx(1,1,lll,kkk,iii,1))
10045             enddo
10046           enddo
10047         enddo
10048 ! A2T kernel(i+1)T A1
10049         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
10050          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
10051          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10052 ! Following matrices are needed only for 6-th order cumulants
10053         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
10054            j.eq.i+4 .and. l.eq.i+3)) THEN
10055         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
10056          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
10057          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10058         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
10059          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
10060          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
10061          ADtEAderx(1,1,1,1,1,2))
10062         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
10063          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
10064          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
10065          ADtEA1derx(1,1,1,1,1,2))
10066         ENDIF
10067 ! End 6-th order cumulants
10068         call transpose2(EUgder(1,1,j),auxmat(1,1))
10069         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10070         call transpose2(EUg(1,1,j),auxmat(1,1))
10071         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10072         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10073         do iii=1,2
10074           do kkk=1,5
10075             do lll=1,3
10076               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10077                 EAEAderx(1,1,lll,kkk,iii,2))
10078             enddo
10079           enddo
10080         enddo
10081 ! AEAb1 and AEAb2
10082 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10083 ! They are needed only when the fifth- or the sixth-order cumulants are
10084 ! indluded.
10085         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
10086           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10087         call transpose2(AEA(1,1,1),auxmat(1,1))
10088         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
10089         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10090         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10091         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10092         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
10093         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10094         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
10095         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
10096         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10097         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10098         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10099         call transpose2(AEA(1,1,2),auxmat(1,1))
10100         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
10101         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10102         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10103         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10104         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
10105         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10106         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
10107         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
10108         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10109         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10110         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10111 ! Calculate the Cartesian derivatives of the vectors.
10112         do iii=1,2
10113           do kkk=1,5
10114             do lll=1,3
10115               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10116               call matvec2(auxmat(1,1),b1(1,iti),&
10117                 AEAb1derx(1,lll,kkk,iii,1,1))
10118               call matvec2(auxmat(1,1),Ub2(1,i),&
10119                 AEAb2derx(1,lll,kkk,iii,1,1))
10120               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10121                 AEAb1derx(1,lll,kkk,iii,2,1))
10122               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
10123                 AEAb2derx(1,lll,kkk,iii,2,1))
10124               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10125               call matvec2(auxmat(1,1),b1(1,itl),&
10126                 AEAb1derx(1,lll,kkk,iii,1,2))
10127               call matvec2(auxmat(1,1),Ub2(1,l),&
10128                 AEAb2derx(1,lll,kkk,iii,1,2))
10129               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
10130                 AEAb1derx(1,lll,kkk,iii,2,2))
10131               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
10132                 AEAb2derx(1,lll,kkk,iii,2,2))
10133             enddo
10134           enddo
10135         enddo
10136         ENDIF
10137 ! End vectors
10138       endif
10139       return
10140       end subroutine calc_eello
10141 !-----------------------------------------------------------------------------
10142       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
10143       use comm_kut
10144       implicit none
10145       integer :: nderg
10146       logical :: transp
10147       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
10148       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
10149       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
10150       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
10151       integer :: iii,kkk,lll
10152       integer :: jjj,mmm
10153 !el      logical :: lprn
10154 !el      common /kutas/ lprn
10155       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10156       do iii=1,nderg
10157         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
10158           AKAderg(1,1,iii))
10159       enddo
10160 !d      if (lprn) write (2,*) 'In kernel'
10161       do kkk=1,5
10162 !d        if (lprn) write (2,*) 'kkk=',kkk
10163         do lll=1,3
10164           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
10165             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10166 !d          if (lprn) then
10167 !d            write (2,*) 'lll=',lll
10168 !d            write (2,*) 'iii=1'
10169 !d            do jjj=1,2
10170 !d              write (2,'(3(2f10.5),5x)')
10171 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10172 !d            enddo
10173 !d          endif
10174           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
10175             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10176 !d          if (lprn) then
10177 !d            write (2,*) 'lll=',lll
10178 !d            write (2,*) 'iii=2'
10179 !d            do jjj=1,2
10180 !d              write (2,'(3(2f10.5),5x)')
10181 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10182 !d            enddo
10183 !d          endif
10184         enddo
10185       enddo
10186       return
10187       end subroutine kernel
10188 !-----------------------------------------------------------------------------
10189       real(kind=8) function eello4(i,j,k,l,jj,kk)
10190 !      implicit real(kind=8) (a-h,o-z)
10191 !      include 'DIMENSIONS'
10192 !      include 'COMMON.IOUNITS'
10193 !      include 'COMMON.CHAIN'
10194 !      include 'COMMON.DERIV'
10195 !      include 'COMMON.INTERACT'
10196 !      include 'COMMON.CONTACTS'
10197 !      include 'COMMON.TORSION'
10198 !      include 'COMMON.VAR'
10199 !      include 'COMMON.GEO'
10200       real(kind=8),dimension(2,2) :: pizda
10201       real(kind=8),dimension(3) :: ggg1,ggg2
10202       real(kind=8) ::  eel4,glongij,glongkl
10203       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
10204 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10205 !d        eello4=0.0d0
10206 !d        return
10207 !d      endif
10208 !d      print *,'eello4:',i,j,k,l,jj,kk
10209 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
10210 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
10211 !old      eij=facont_hb(jj,i)
10212 !old      ekl=facont_hb(kk,k)
10213 !old      ekont=eij*ekl
10214       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10215 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10216       gcorr_loc(k-1)=gcorr_loc(k-1) &
10217          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10218       if (l.eq.j+1) then
10219         gcorr_loc(l-1)=gcorr_loc(l-1) &
10220            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10221       else
10222         gcorr_loc(j-1)=gcorr_loc(j-1) &
10223            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10224       endif
10225       do iii=1,2
10226         do kkk=1,5
10227           do lll=1,3
10228             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
10229                               -EAEAderx(2,2,lll,kkk,iii,1)
10230 !d            derx(lll,kkk,iii)=0.0d0
10231           enddo
10232         enddo
10233       enddo
10234 !d      gcorr_loc(l-1)=0.0d0
10235 !d      gcorr_loc(j-1)=0.0d0
10236 !d      gcorr_loc(k-1)=0.0d0
10237 !d      eel4=1.0d0
10238 !d      write (iout,*)'Contacts have occurred for peptide groups',
10239 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10240 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10241       if (j.lt.nres-1) then
10242         j1=j+1
10243         j2=j-1
10244       else
10245         j1=j-1
10246         j2=j-2
10247       endif
10248       if (l.lt.nres-1) then
10249         l1=l+1
10250         l2=l-1
10251       else
10252         l1=l-1
10253         l2=l-2
10254       endif
10255       do ll=1,3
10256 !grad        ggg1(ll)=eel4*g_contij(ll,1)
10257 !grad        ggg2(ll)=eel4*g_contij(ll,2)
10258         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10259         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10260 !grad        ghalf=0.5d0*ggg1(ll)
10261         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10262         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10263         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10264         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10265         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10266         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10267 !grad        ghalf=0.5d0*ggg2(ll)
10268         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10269         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10270         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10271         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10272         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10273         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10274       enddo
10275 !grad      do m=i+1,j-1
10276 !grad        do ll=1,3
10277 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10278 !grad        enddo
10279 !grad      enddo
10280 !grad      do m=k+1,l-1
10281 !grad        do ll=1,3
10282 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10283 !grad        enddo
10284 !grad      enddo
10285 !grad      do m=i+2,j2
10286 !grad        do ll=1,3
10287 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10288 !grad        enddo
10289 !grad      enddo
10290 !grad      do m=k+2,l2
10291 !grad        do ll=1,3
10292 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10293 !grad        enddo
10294 !grad      enddo
10295 !d      do iii=1,nres-3
10296 !d        write (2,*) iii,gcorr_loc(iii)
10297 !d      enddo
10298       eello4=ekont*eel4
10299 !d      write (2,*) 'ekont',ekont
10300 !d      write (iout,*) 'eello4',ekont*eel4
10301       return
10302       end function eello4
10303 !-----------------------------------------------------------------------------
10304       real(kind=8) function eello5(i,j,k,l,jj,kk)
10305 !      implicit real(kind=8) (a-h,o-z)
10306 !      include 'DIMENSIONS'
10307 !      include 'COMMON.IOUNITS'
10308 !      include 'COMMON.CHAIN'
10309 !      include 'COMMON.DERIV'
10310 !      include 'COMMON.INTERACT'
10311 !      include 'COMMON.CONTACTS'
10312 !      include 'COMMON.TORSION'
10313 !      include 'COMMON.VAR'
10314 !      include 'COMMON.GEO'
10315       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10316       real(kind=8),dimension(2) :: vv
10317       real(kind=8),dimension(3) :: ggg1,ggg2
10318       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
10319       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
10320       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
10321 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10322 !                                                                              C
10323 !                            Parallel chains                                   C
10324 !                                                                              C
10325 !          o             o                   o             o                   C
10326 !         /l\           / \             \   / \           / \   /              C
10327 !        /   \         /   \             \ /   \         /   \ /               C
10328 !       j| o |l1       | o |                o| o |         | o |o                C
10329 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10330 !      \i/   \         /   \ /             /   \         /   \                 C
10331 !       o    k1             o                                                  C
10332 !         (I)          (II)                (III)          (IV)                 C
10333 !                                                                              C
10334 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10335 !                                                                              C
10336 !                            Antiparallel chains                               C
10337 !                                                                              C
10338 !          o             o                   o             o                   C
10339 !         /j\           / \             \   / \           / \   /              C
10340 !        /   \         /   \             \ /   \         /   \ /               C
10341 !      j1| o |l        | o |                o| o |         | o |o                C
10342 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10343 !      \i/   \         /   \ /             /   \         /   \                 C
10344 !       o     k1            o                                                  C
10345 !         (I)          (II)                (III)          (IV)                 C
10346 !                                                                              C
10347 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10348 !                                                                              C
10349 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
10350 !                                                                              C
10351 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10352 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10353 !d        eello5=0.0d0
10354 !d        return
10355 !d      endif
10356 !d      write (iout,*)
10357 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10358 !d     &   ' and',k,l
10359       itk=itortyp(itype(k,1))
10360       itl=itortyp(itype(l,1))
10361       itj=itortyp(itype(j,1))
10362       eello5_1=0.0d0
10363       eello5_2=0.0d0
10364       eello5_3=0.0d0
10365       eello5_4=0.0d0
10366 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10367 !d     &   eel5_3_num,eel5_4_num)
10368       do iii=1,2
10369         do kkk=1,5
10370           do lll=1,3
10371             derx(lll,kkk,iii)=0.0d0
10372           enddo
10373         enddo
10374       enddo
10375 !d      eij=facont_hb(jj,i)
10376 !d      ekl=facont_hb(kk,k)
10377 !d      ekont=eij*ekl
10378 !d      write (iout,*)'Contacts have occurred for peptide groups',
10379 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
10380 !d      goto 1111
10381 ! Contribution from the graph I.
10382 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10383 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10384       call transpose2(EUg(1,1,k),auxmat(1,1))
10385       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10386       vv(1)=pizda(1,1)-pizda(2,2)
10387       vv(2)=pizda(1,2)+pizda(2,1)
10388       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
10389        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10390 ! Explicit gradient in virtual-dihedral angles.
10391       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
10392        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
10393        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10394       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10395       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10396       vv(1)=pizda(1,1)-pizda(2,2)
10397       vv(2)=pizda(1,2)+pizda(2,1)
10398       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10399        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
10400        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10401       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10402       vv(1)=pizda(1,1)-pizda(2,2)
10403       vv(2)=pizda(1,2)+pizda(2,1)
10404       if (l.eq.j+1) then
10405         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10406          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10407          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10408       else
10409         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10410          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10411          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10412       endif
10413 ! Cartesian gradient
10414       do iii=1,2
10415         do kkk=1,5
10416           do lll=1,3
10417             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10418               pizda(1,1))
10419             vv(1)=pizda(1,1)-pizda(2,2)
10420             vv(2)=pizda(1,2)+pizda(2,1)
10421             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10422              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
10423              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10424           enddo
10425         enddo
10426       enddo
10427 !      goto 1112
10428 !1111  continue
10429 ! Contribution from graph II
10430       call transpose2(EE(1,1,itk),auxmat(1,1))
10431       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10432       vv(1)=pizda(1,1)+pizda(2,2)
10433       vv(2)=pizda(2,1)-pizda(1,2)
10434       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
10435        -0.5d0*scalar2(vv(1),Ctobr(1,k))
10436 ! Explicit gradient in virtual-dihedral angles.
10437       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10438        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10439       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10440       vv(1)=pizda(1,1)+pizda(2,2)
10441       vv(2)=pizda(2,1)-pizda(1,2)
10442       if (l.eq.j+1) then
10443         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10444          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10445          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10446       else
10447         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10448          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10449          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10450       endif
10451 ! Cartesian gradient
10452       do iii=1,2
10453         do kkk=1,5
10454           do lll=1,3
10455             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
10456               pizda(1,1))
10457             vv(1)=pizda(1,1)+pizda(2,2)
10458             vv(2)=pizda(2,1)-pizda(1,2)
10459             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10460              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
10461              -0.5d0*scalar2(vv(1),Ctobr(1,k))
10462           enddo
10463         enddo
10464       enddo
10465 !d      goto 1112
10466 !d1111  continue
10467       if (l.eq.j+1) then
10468 !d        goto 1110
10469 ! Parallel orientation
10470 ! Contribution from graph III
10471         call transpose2(EUg(1,1,l),auxmat(1,1))
10472         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10473         vv(1)=pizda(1,1)-pizda(2,2)
10474         vv(2)=pizda(1,2)+pizda(2,1)
10475         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
10476          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10477 ! Explicit gradient in virtual-dihedral angles.
10478         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10479          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
10480          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10481         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10482         vv(1)=pizda(1,1)-pizda(2,2)
10483         vv(2)=pizda(1,2)+pizda(2,1)
10484         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10485          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
10486          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10487         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10488         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10489         vv(1)=pizda(1,1)-pizda(2,2)
10490         vv(2)=pizda(1,2)+pizda(2,1)
10491         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10492          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
10493          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10494 ! Cartesian gradient
10495         do iii=1,2
10496           do kkk=1,5
10497             do lll=1,3
10498               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10499                 pizda(1,1))
10500               vv(1)=pizda(1,1)-pizda(2,2)
10501               vv(2)=pizda(1,2)+pizda(2,1)
10502               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10503                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
10504                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10505             enddo
10506           enddo
10507         enddo
10508 !d        goto 1112
10509 ! Contribution from graph IV
10510 !d1110    continue
10511         call transpose2(EE(1,1,itl),auxmat(1,1))
10512         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10513         vv(1)=pizda(1,1)+pizda(2,2)
10514         vv(2)=pizda(2,1)-pizda(1,2)
10515         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
10516          -0.5d0*scalar2(vv(1),Ctobr(1,l))
10517 ! Explicit gradient in virtual-dihedral angles.
10518         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10519          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10520         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10521         vv(1)=pizda(1,1)+pizda(2,2)
10522         vv(2)=pizda(2,1)-pizda(1,2)
10523         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10524          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
10525          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10526 ! Cartesian gradient
10527         do iii=1,2
10528           do kkk=1,5
10529             do lll=1,3
10530               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10531                 pizda(1,1))
10532               vv(1)=pizda(1,1)+pizda(2,2)
10533               vv(2)=pizda(2,1)-pizda(1,2)
10534               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10535                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
10536                -0.5d0*scalar2(vv(1),Ctobr(1,l))
10537             enddo
10538           enddo
10539         enddo
10540       else
10541 ! Antiparallel orientation
10542 ! Contribution from graph III
10543 !        goto 1110
10544         call transpose2(EUg(1,1,j),auxmat(1,1))
10545         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10546         vv(1)=pizda(1,1)-pizda(2,2)
10547         vv(2)=pizda(1,2)+pizda(2,1)
10548         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
10549          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10550 ! Explicit gradient in virtual-dihedral angles.
10551         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10552          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
10553          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10554         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10555         vv(1)=pizda(1,1)-pizda(2,2)
10556         vv(2)=pizda(1,2)+pizda(2,1)
10557         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10558          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
10559          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10560         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10561         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10562         vv(1)=pizda(1,1)-pizda(2,2)
10563         vv(2)=pizda(1,2)+pizda(2,1)
10564         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10565          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
10566          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10567 ! Cartesian gradient
10568         do iii=1,2
10569           do kkk=1,5
10570             do lll=1,3
10571               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10572                 pizda(1,1))
10573               vv(1)=pizda(1,1)-pizda(2,2)
10574               vv(2)=pizda(1,2)+pizda(2,1)
10575               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10576                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
10577                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10578             enddo
10579           enddo
10580         enddo
10581 !d        goto 1112
10582 ! Contribution from graph IV
10583 1110    continue
10584         call transpose2(EE(1,1,itj),auxmat(1,1))
10585         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10586         vv(1)=pizda(1,1)+pizda(2,2)
10587         vv(2)=pizda(2,1)-pizda(1,2)
10588         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
10589          -0.5d0*scalar2(vv(1),Ctobr(1,j))
10590 ! Explicit gradient in virtual-dihedral angles.
10591         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10592          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10593         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10594         vv(1)=pizda(1,1)+pizda(2,2)
10595         vv(2)=pizda(2,1)-pizda(1,2)
10596         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10597          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
10598          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10599 ! Cartesian gradient
10600         do iii=1,2
10601           do kkk=1,5
10602             do lll=1,3
10603               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10604                 pizda(1,1))
10605               vv(1)=pizda(1,1)+pizda(2,2)
10606               vv(2)=pizda(2,1)-pizda(1,2)
10607               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10608                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
10609                -0.5d0*scalar2(vv(1),Ctobr(1,j))
10610             enddo
10611           enddo
10612         enddo
10613       endif
10614 1112  continue
10615       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10616 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10617 !d        write (2,*) 'ijkl',i,j,k,l
10618 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10619 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10620 !d      endif
10621 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10622 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10623 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10624 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10625       if (j.lt.nres-1) then
10626         j1=j+1
10627         j2=j-1
10628       else
10629         j1=j-1
10630         j2=j-2
10631       endif
10632       if (l.lt.nres-1) then
10633         l1=l+1
10634         l2=l-1
10635       else
10636         l1=l-1
10637         l2=l-2
10638       endif
10639 !d      eij=1.0d0
10640 !d      ekl=1.0d0
10641 !d      ekont=1.0d0
10642 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10643 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
10644 !        summed up outside the subrouine as for the other subroutines
10645 !        handling long-range interactions. The old code is commented out
10646 !        with "cgrad" to keep track of changes.
10647       do ll=1,3
10648 !grad        ggg1(ll)=eel5*g_contij(ll,1)
10649 !grad        ggg2(ll)=eel5*g_contij(ll,2)
10650         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10651         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10652 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10653 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10654 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10655 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10656 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10657 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10658 !     &   gradcorr5ij,
10659 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10660 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10661 !grad        ghalf=0.5d0*ggg1(ll)
10662 !d        ghalf=0.0d0
10663         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10664         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10665         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10666         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10667         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10668         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10669 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10670 !grad        ghalf=0.5d0*ggg2(ll)
10671         ghalf=0.0d0
10672         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
10673         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10674         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
10675         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10676         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10677         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10678       enddo
10679 !d      goto 1112
10680 !grad      do m=i+1,j-1
10681 !grad        do ll=1,3
10682 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10683 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10684 !grad        enddo
10685 !grad      enddo
10686 !grad      do m=k+1,l-1
10687 !grad        do ll=1,3
10688 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10689 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10690 !grad        enddo
10691 !grad      enddo
10692 !1112  continue
10693 !grad      do m=i+2,j2
10694 !grad        do ll=1,3
10695 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10696 !grad        enddo
10697 !grad      enddo
10698 !grad      do m=k+2,l2
10699 !grad        do ll=1,3
10700 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10701 !grad        enddo
10702 !grad      enddo
10703 !d      do iii=1,nres-3
10704 !d        write (2,*) iii,g_corr5_loc(iii)
10705 !d      enddo
10706       eello5=ekont*eel5
10707 !d      write (2,*) 'ekont',ekont
10708 !d      write (iout,*) 'eello5',ekont*eel5
10709       return
10710       end function eello5
10711 !-----------------------------------------------------------------------------
10712       real(kind=8) function eello6(i,j,k,l,jj,kk)
10713 !      implicit real(kind=8) (a-h,o-z)
10714 !      include 'DIMENSIONS'
10715 !      include 'COMMON.IOUNITS'
10716 !      include 'COMMON.CHAIN'
10717 !      include 'COMMON.DERIV'
10718 !      include 'COMMON.INTERACT'
10719 !      include 'COMMON.CONTACTS'
10720 !      include 'COMMON.TORSION'
10721 !      include 'COMMON.VAR'
10722 !      include 'COMMON.GEO'
10723 !      include 'COMMON.FFIELD'
10724       real(kind=8),dimension(3) :: ggg1,ggg2
10725       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
10726                    eello6_6,eel6
10727       real(kind=8) :: gradcorr6ij,gradcorr6kl
10728       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
10729 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10730 !d        eello6=0.0d0
10731 !d        return
10732 !d      endif
10733 !d      write (iout,*)
10734 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10735 !d     &   ' and',k,l
10736       eello6_1=0.0d0
10737       eello6_2=0.0d0
10738       eello6_3=0.0d0
10739       eello6_4=0.0d0
10740       eello6_5=0.0d0
10741       eello6_6=0.0d0
10742 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10743 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10744       do iii=1,2
10745         do kkk=1,5
10746           do lll=1,3
10747             derx(lll,kkk,iii)=0.0d0
10748           enddo
10749         enddo
10750       enddo
10751 !d      eij=facont_hb(jj,i)
10752 !d      ekl=facont_hb(kk,k)
10753 !d      ekont=eij*ekl
10754 !d      eij=1.0d0
10755 !d      ekl=1.0d0
10756 !d      ekont=1.0d0
10757       if (l.eq.j+1) then
10758         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10759         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10760         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10761         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10762         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10763         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10764       else
10765         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10766         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10767         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10768         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10769         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10770           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10771         else
10772           eello6_5=0.0d0
10773         endif
10774         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10775       endif
10776 ! If turn contributions are considered, they will be handled separately.
10777       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10778 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10779 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10780 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10781 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10782 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10783 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10784 !d      goto 1112
10785       if (j.lt.nres-1) then
10786         j1=j+1
10787         j2=j-1
10788       else
10789         j1=j-1
10790         j2=j-2
10791       endif
10792       if (l.lt.nres-1) then
10793         l1=l+1
10794         l2=l-1
10795       else
10796         l1=l-1
10797         l2=l-2
10798       endif
10799       do ll=1,3
10800 !grad        ggg1(ll)=eel6*g_contij(ll,1)
10801 !grad        ggg2(ll)=eel6*g_contij(ll,2)
10802 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10803 !grad        ghalf=0.5d0*ggg1(ll)
10804 !d        ghalf=0.0d0
10805         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10806         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10807         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10808         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10809         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10810         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10811         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10812         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10813 !grad        ghalf=0.5d0*ggg2(ll)
10814 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10815 !d        ghalf=0.0d0
10816         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10817         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10818         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10819         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10820         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10821         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10822       enddo
10823 !d      goto 1112
10824 !grad      do m=i+1,j-1
10825 !grad        do ll=1,3
10826 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10827 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10828 !grad        enddo
10829 !grad      enddo
10830 !grad      do m=k+1,l-1
10831 !grad        do ll=1,3
10832 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10833 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10834 !grad        enddo
10835 !grad      enddo
10836 !grad1112  continue
10837 !grad      do m=i+2,j2
10838 !grad        do ll=1,3
10839 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10840 !grad        enddo
10841 !grad      enddo
10842 !grad      do m=k+2,l2
10843 !grad        do ll=1,3
10844 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10845 !grad        enddo
10846 !grad      enddo
10847 !d      do iii=1,nres-3
10848 !d        write (2,*) iii,g_corr6_loc(iii)
10849 !d      enddo
10850       eello6=ekont*eel6
10851 !d      write (2,*) 'ekont',ekont
10852 !d      write (iout,*) 'eello6',ekont*eel6
10853       return
10854       end function eello6
10855 !-----------------------------------------------------------------------------
10856       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10857       use comm_kut
10858 !      implicit real(kind=8) (a-h,o-z)
10859 !      include 'DIMENSIONS'
10860 !      include 'COMMON.IOUNITS'
10861 !      include 'COMMON.CHAIN'
10862 !      include 'COMMON.DERIV'
10863 !      include 'COMMON.INTERACT'
10864 !      include 'COMMON.CONTACTS'
10865 !      include 'COMMON.TORSION'
10866 !      include 'COMMON.VAR'
10867 !      include 'COMMON.GEO'
10868       real(kind=8),dimension(2) :: vv,vv1
10869       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10870       logical :: swap
10871 !el      logical :: lprn
10872 !el      common /kutas/ lprn
10873       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10874       real(kind=8) :: s1,s2,s3,s4,s5
10875 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10876 !                                                                              C
10877 !      Parallel       Antiparallel                                             C
10878 !                                                                              C
10879 !          o             o                                                     C
10880 !         /l\           /j\                                                    C
10881 !        /   \         /   \                                                   C
10882 !       /| o |         | o |\                                                  C
10883 !     \ j|/k\|  /   \  |/k\|l /                                                C
10884 !      \ /   \ /     \ /   \ /                                                 C
10885 !       o     o       o     o                                                  C
10886 !       i             i                                                        C
10887 !                                                                              C
10888 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10889       itk=itortyp(itype(k,1))
10890       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10891       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10892       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10893       call transpose2(EUgC(1,1,k),auxmat(1,1))
10894       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10895       vv1(1)=pizda1(1,1)-pizda1(2,2)
10896       vv1(2)=pizda1(1,2)+pizda1(2,1)
10897       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10898       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10899       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10900       s5=scalar2(vv(1),Dtobr2(1,i))
10901 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10902       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10903       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10904        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10905        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10906        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10907        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10908        +scalar2(vv(1),Dtobr2der(1,i)))
10909       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10910       vv1(1)=pizda1(1,1)-pizda1(2,2)
10911       vv1(2)=pizda1(1,2)+pizda1(2,1)
10912       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10913       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10914       if (l.eq.j+1) then
10915         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10916        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10917        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10918        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10919        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10920       else
10921         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10922        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10923        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10924        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10925        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10926       endif
10927       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10928       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10929       vv1(1)=pizda1(1,1)-pizda1(2,2)
10930       vv1(2)=pizda1(1,2)+pizda1(2,1)
10931       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10932        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10933        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10934        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10935       do iii=1,2
10936         if (swap) then
10937           ind=3-iii
10938         else
10939           ind=iii
10940         endif
10941         do kkk=1,5
10942           do lll=1,3
10943             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10944             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10945             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10946             call transpose2(EUgC(1,1,k),auxmat(1,1))
10947             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10948               pizda1(1,1))
10949             vv1(1)=pizda1(1,1)-pizda1(2,2)
10950             vv1(2)=pizda1(1,2)+pizda1(2,1)
10951             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10952             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10953              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10954             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10955              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10956             s5=scalar2(vv(1),Dtobr2(1,i))
10957             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10958           enddo
10959         enddo
10960       enddo
10961       return
10962       end function eello6_graph1
10963 !-----------------------------------------------------------------------------
10964       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10965       use comm_kut
10966 !      implicit real(kind=8) (a-h,o-z)
10967 !      include 'DIMENSIONS'
10968 !      include 'COMMON.IOUNITS'
10969 !      include 'COMMON.CHAIN'
10970 !      include 'COMMON.DERIV'
10971 !      include 'COMMON.INTERACT'
10972 !      include 'COMMON.CONTACTS'
10973 !      include 'COMMON.TORSION'
10974 !      include 'COMMON.VAR'
10975 !      include 'COMMON.GEO'
10976       logical :: swap
10977       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10978       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10979 !el      logical :: lprn
10980 !el      common /kutas/ lprn
10981       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10982       real(kind=8) :: s2,s3,s4
10983 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10984 !                                                                              C
10985 !      Parallel       Antiparallel                                             C
10986 !                                                                              C
10987 !          o             o                                                     C
10988 !     \   /l\           /j\   /                                                C
10989 !      \ /   \         /   \ /                                                 C
10990 !       o| o |         | o |o                                                  C
10991 !     \ j|/k\|      \  |/k\|l                                                  C
10992 !      \ /   \       \ /   \                                                   C
10993 !       o             o                                                        C
10994 !       i             i                                                        C
10995 !                                                                              C
10996 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10997 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10998 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10999 !           but not in a cluster cumulant
11000 #ifdef MOMENT
11001       s1=dip(1,jj,i)*dip(1,kk,k)
11002 #endif
11003       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11004       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11005       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11006       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11007       call transpose2(EUg(1,1,k),auxmat(1,1))
11008       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11009       vv(1)=pizda(1,1)-pizda(2,2)
11010       vv(2)=pizda(1,2)+pizda(2,1)
11011       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11012 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11013 #ifdef MOMENT
11014       eello6_graph2=-(s1+s2+s3+s4)
11015 #else
11016       eello6_graph2=-(s2+s3+s4)
11017 #endif
11018 !      eello6_graph2=-s3
11019 ! Derivatives in gamma(i-1)
11020       if (i.gt.1) then
11021 #ifdef MOMENT
11022         s1=dipderg(1,jj,i)*dip(1,kk,k)
11023 #endif
11024         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11025         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11026         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11027         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11028 #ifdef MOMENT
11029         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11030 #else
11031         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11032 #endif
11033 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11034       endif
11035 ! Derivatives in gamma(k-1)
11036 #ifdef MOMENT
11037       s1=dip(1,jj,i)*dipderg(1,kk,k)
11038 #endif
11039       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11040       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11041       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11042       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11043       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11044       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11045       vv(1)=pizda(1,1)-pizda(2,2)
11046       vv(2)=pizda(1,2)+pizda(2,1)
11047       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11048 #ifdef MOMENT
11049       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11050 #else
11051       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11052 #endif
11053 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11054 ! Derivatives in gamma(j-1) or gamma(l-1)
11055       if (j.gt.1) then
11056 #ifdef MOMENT
11057         s1=dipderg(3,jj,i)*dip(1,kk,k)
11058 #endif
11059         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11060         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11061         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11062         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11063         vv(1)=pizda(1,1)-pizda(2,2)
11064         vv(2)=pizda(1,2)+pizda(2,1)
11065         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11066 #ifdef MOMENT
11067         if (swap) then
11068           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11069         else
11070           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11071         endif
11072 #endif
11073         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11074 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11075       endif
11076 ! Derivatives in gamma(l-1) or gamma(j-1)
11077       if (l.gt.1) then
11078 #ifdef MOMENT
11079         s1=dip(1,jj,i)*dipderg(3,kk,k)
11080 #endif
11081         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11082         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11083         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11084         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11085         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11086         vv(1)=pizda(1,1)-pizda(2,2)
11087         vv(2)=pizda(1,2)+pizda(2,1)
11088         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11089 #ifdef MOMENT
11090         if (swap) then
11091           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11092         else
11093           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11094         endif
11095 #endif
11096         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11097 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11098       endif
11099 ! Cartesian derivatives.
11100       if (lprn) then
11101         write (2,*) 'In eello6_graph2'
11102         do iii=1,2
11103           write (2,*) 'iii=',iii
11104           do kkk=1,5
11105             write (2,*) 'kkk=',kkk
11106             do jjj=1,2
11107               write (2,'(3(2f10.5),5x)') &
11108               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11109             enddo
11110           enddo
11111         enddo
11112       endif
11113       do iii=1,2
11114         do kkk=1,5
11115           do lll=1,3
11116 #ifdef MOMENT
11117             if (iii.eq.1) then
11118               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11119             else
11120               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11121             endif
11122 #endif
11123             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
11124               auxvec(1))
11125             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11126             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
11127               auxvec(1))
11128             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11129             call transpose2(EUg(1,1,k),auxmat(1,1))
11130             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
11131               pizda(1,1))
11132             vv(1)=pizda(1,1)-pizda(2,2)
11133             vv(2)=pizda(1,2)+pizda(2,1)
11134             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11135 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11136 #ifdef MOMENT
11137             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11138 #else
11139             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11140 #endif
11141             if (swap) then
11142               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11143             else
11144               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11145             endif
11146           enddo
11147         enddo
11148       enddo
11149       return
11150       end function eello6_graph2
11151 !-----------------------------------------------------------------------------
11152       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
11153 !      implicit real(kind=8) (a-h,o-z)
11154 !      include 'DIMENSIONS'
11155 !      include 'COMMON.IOUNITS'
11156 !      include 'COMMON.CHAIN'
11157 !      include 'COMMON.DERIV'
11158 !      include 'COMMON.INTERACT'
11159 !      include 'COMMON.CONTACTS'
11160 !      include 'COMMON.TORSION'
11161 !      include 'COMMON.VAR'
11162 !      include 'COMMON.GEO'
11163       real(kind=8),dimension(2) :: vv,auxvec
11164       real(kind=8),dimension(2,2) :: pizda,auxmat
11165       logical :: swap
11166       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
11167       real(kind=8) :: s1,s2,s3,s4
11168 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11169 !                                                                              C
11170 !      Parallel       Antiparallel                                             C
11171 !                                                                              C
11172 !          o             o                                                     C
11173 !         /l\   /   \   /j\                                                    C
11174 !        /   \ /     \ /   \                                                   C
11175 !       /| o |o       o| o |\                                                  C
11176 !       j|/k\|  /      |/k\|l /                                                C
11177 !        /   \ /       /   \ /                                                 C
11178 !       /     o       /     o                                                  C
11179 !       i             i                                                        C
11180 !                                                                              C
11181 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11182 !
11183 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
11184 !           energy moment and not to the cluster cumulant.
11185       iti=itortyp(itype(i,1))
11186       if (j.lt.nres-1) then
11187         itj1=itortyp(itype(j+1,1))
11188       else
11189         itj1=ntortyp+1
11190       endif
11191       itk=itortyp(itype(k,1))
11192       itk1=itortyp(itype(k+1,1))
11193       if (l.lt.nres-1) then
11194         itl1=itortyp(itype(l+1,1))
11195       else
11196         itl1=ntortyp+1
11197       endif
11198 #ifdef MOMENT
11199       s1=dip(4,jj,i)*dip(4,kk,k)
11200 #endif
11201       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
11202       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
11203       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
11204       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
11205       call transpose2(EE(1,1,itk),auxmat(1,1))
11206       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11207       vv(1)=pizda(1,1)+pizda(2,2)
11208       vv(2)=pizda(2,1)-pizda(1,2)
11209       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11210 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11211 !d     & "sum",-(s2+s3+s4)
11212 #ifdef MOMENT
11213       eello6_graph3=-(s1+s2+s3+s4)
11214 #else
11215       eello6_graph3=-(s2+s3+s4)
11216 #endif
11217 !      eello6_graph3=-s4
11218 ! Derivatives in gamma(k-1)
11219       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
11220       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
11221       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11222       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11223 ! Derivatives in gamma(l-1)
11224       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
11225       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
11226       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11227       vv(1)=pizda(1,1)+pizda(2,2)
11228       vv(2)=pizda(2,1)-pizda(1,2)
11229       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11230       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11231 ! Cartesian derivatives.
11232       do iii=1,2
11233         do kkk=1,5
11234           do lll=1,3
11235 #ifdef MOMENT
11236             if (iii.eq.1) then
11237               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11238             else
11239               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11240             endif
11241 #endif
11242             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
11243               auxvec(1))
11244             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
11245             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
11246               auxvec(1))
11247             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
11248             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
11249               pizda(1,1))
11250             vv(1)=pizda(1,1)+pizda(2,2)
11251             vv(2)=pizda(2,1)-pizda(1,2)
11252             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11253 #ifdef MOMENT
11254             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11255 #else
11256             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11257 #endif
11258             if (swap) then
11259               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11260             else
11261               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11262             endif
11263 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11264           enddo
11265         enddo
11266       enddo
11267       return
11268       end function eello6_graph3
11269 !-----------------------------------------------------------------------------
11270       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11271 !      implicit real(kind=8) (a-h,o-z)
11272 !      include 'DIMENSIONS'
11273 !      include 'COMMON.IOUNITS'
11274 !      include 'COMMON.CHAIN'
11275 !      include 'COMMON.DERIV'
11276 !      include 'COMMON.INTERACT'
11277 !      include 'COMMON.CONTACTS'
11278 !      include 'COMMON.TORSION'
11279 !      include 'COMMON.VAR'
11280 !      include 'COMMON.GEO'
11281 !      include 'COMMON.FFIELD'
11282       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
11283       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
11284       logical :: swap
11285       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
11286               iii,kkk,lll
11287       real(kind=8) :: s1,s2,s3,s4
11288 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11289 !                                                                              C
11290 !      Parallel       Antiparallel                                             C
11291 !                                                                              C
11292 !          o             o                                                     C
11293 !         /l\   /   \   /j\                                                    C
11294 !        /   \ /     \ /   \                                                   C
11295 !       /| o |o       o| o |\                                                  C
11296 !     \ j|/k\|      \  |/k\|l                                                  C
11297 !      \ /   \       \ /   \                                                   C
11298 !       o     \       o     \                                                  C
11299 !       i             i                                                        C
11300 !                                                                              C
11301 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11302 !
11303 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
11304 !           energy moment and not to the cluster cumulant.
11305 !d      write (2,*) 'eello_graph4: wturn6',wturn6
11306       iti=itortyp(itype(i,1))
11307       itj=itortyp(itype(j,1))
11308       if (j.lt.nres-1) then
11309         itj1=itortyp(itype(j+1,1))
11310       else
11311         itj1=ntortyp+1
11312       endif
11313       itk=itortyp(itype(k,1))
11314       if (k.lt.nres-1) then
11315         itk1=itortyp(itype(k+1,1))
11316       else
11317         itk1=ntortyp+1
11318       endif
11319       itl=itortyp(itype(l,1))
11320       if (l.lt.nres-1) then
11321         itl1=itortyp(itype(l+1,1))
11322       else
11323         itl1=ntortyp+1
11324       endif
11325 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11326 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11327 !d     & ' itl',itl,' itl1',itl1
11328 #ifdef MOMENT
11329       if (imat.eq.1) then
11330         s1=dip(3,jj,i)*dip(3,kk,k)
11331       else
11332         s1=dip(2,jj,j)*dip(2,kk,l)
11333       endif
11334 #endif
11335       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11336       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11337       if (j.eq.l+1) then
11338         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
11339         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11340       else
11341         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
11342         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11343       endif
11344       call transpose2(EUg(1,1,k),auxmat(1,1))
11345       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11346       vv(1)=pizda(1,1)-pizda(2,2)
11347       vv(2)=pizda(2,1)+pizda(1,2)
11348       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11349 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11350 #ifdef MOMENT
11351       eello6_graph4=-(s1+s2+s3+s4)
11352 #else
11353       eello6_graph4=-(s2+s3+s4)
11354 #endif
11355 ! Derivatives in gamma(i-1)
11356       if (i.gt.1) then
11357 #ifdef MOMENT
11358         if (imat.eq.1) then
11359           s1=dipderg(2,jj,i)*dip(3,kk,k)
11360         else
11361           s1=dipderg(4,jj,j)*dip(2,kk,l)
11362         endif
11363 #endif
11364         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11365         if (j.eq.l+1) then
11366           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
11367           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11368         else
11369           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
11370           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11371         endif
11372         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11373         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11374 !d          write (2,*) 'turn6 derivatives'
11375 #ifdef MOMENT
11376           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11377 #else
11378           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11379 #endif
11380         else
11381 #ifdef MOMENT
11382           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11383 #else
11384           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11385 #endif
11386         endif
11387       endif
11388 ! Derivatives in gamma(k-1)
11389 #ifdef MOMENT
11390       if (imat.eq.1) then
11391         s1=dip(3,jj,i)*dipderg(2,kk,k)
11392       else
11393         s1=dip(2,jj,j)*dipderg(4,kk,l)
11394       endif
11395 #endif
11396       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11397       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11398       if (j.eq.l+1) then
11399         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
11400         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11401       else
11402         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
11403         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11404       endif
11405       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11406       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11407       vv(1)=pizda(1,1)-pizda(2,2)
11408       vv(2)=pizda(2,1)+pizda(1,2)
11409       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11410       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11411 #ifdef MOMENT
11412         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11413 #else
11414         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11415 #endif
11416       else
11417 #ifdef MOMENT
11418         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11419 #else
11420         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11421 #endif
11422       endif
11423 ! Derivatives in gamma(j-1) or gamma(l-1)
11424       if (l.eq.j+1 .and. l.gt.1) then
11425         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11426         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11427         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11428         vv(1)=pizda(1,1)-pizda(2,2)
11429         vv(2)=pizda(2,1)+pizda(1,2)
11430         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11431         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11432       else if (j.gt.1) then
11433         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11434         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11435         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11436         vv(1)=pizda(1,1)-pizda(2,2)
11437         vv(2)=pizda(2,1)+pizda(1,2)
11438         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11439         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11440           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11441         else
11442           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11443         endif
11444       endif
11445 ! Cartesian derivatives.
11446       do iii=1,2
11447         do kkk=1,5
11448           do lll=1,3
11449 #ifdef MOMENT
11450             if (iii.eq.1) then
11451               if (imat.eq.1) then
11452                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11453               else
11454                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11455               endif
11456             else
11457               if (imat.eq.1) then
11458                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11459               else
11460                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11461               endif
11462             endif
11463 #endif
11464             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
11465               auxvec(1))
11466             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11467             if (j.eq.l+1) then
11468               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11469                 b1(1,itj1),auxvec(1))
11470               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
11471             else
11472               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11473                 b1(1,itl1),auxvec(1))
11474               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
11475             endif
11476             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
11477               pizda(1,1))
11478             vv(1)=pizda(1,1)-pizda(2,2)
11479             vv(2)=pizda(2,1)+pizda(1,2)
11480             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11481             if (swap) then
11482               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11483 #ifdef MOMENT
11484                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11485                    -(s1+s2+s4)
11486 #else
11487                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11488                    -(s2+s4)
11489 #endif
11490                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11491               else
11492 #ifdef MOMENT
11493                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11494 #else
11495                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11496 #endif
11497                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11498               endif
11499             else
11500 #ifdef MOMENT
11501               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11502 #else
11503               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11504 #endif
11505               if (l.eq.j+1) then
11506                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11507               else
11508                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11509               endif
11510             endif
11511           enddo
11512         enddo
11513       enddo
11514       return
11515       end function eello6_graph4
11516 !-----------------------------------------------------------------------------
11517       real(kind=8) function eello_turn6(i,jj,kk)
11518 !      implicit real(kind=8) (a-h,o-z)
11519 !      include 'DIMENSIONS'
11520 !      include 'COMMON.IOUNITS'
11521 !      include 'COMMON.CHAIN'
11522 !      include 'COMMON.DERIV'
11523 !      include 'COMMON.INTERACT'
11524 !      include 'COMMON.CONTACTS'
11525 !      include 'COMMON.TORSION'
11526 !      include 'COMMON.VAR'
11527 !      include 'COMMON.GEO'
11528       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
11529       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
11530       real(kind=8),dimension(3) :: ggg1,ggg2
11531       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
11532       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
11533 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11534 !           the respective energy moment and not to the cluster cumulant.
11535 !el local variables
11536       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
11537       integer :: j1,j2,l1,l2,ll
11538       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
11539       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
11540       s1=0.0d0
11541       s8=0.0d0
11542       s13=0.0d0
11543 !
11544       eello_turn6=0.0d0
11545       j=i+4
11546       k=i+1
11547       l=i+3
11548       iti=itortyp(itype(i,1))
11549       itk=itortyp(itype(k,1))
11550       itk1=itortyp(itype(k+1,1))
11551       itl=itortyp(itype(l,1))
11552       itj=itortyp(itype(j,1))
11553 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11554 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
11555 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11556 !d        eello6=0.0d0
11557 !d        return
11558 !d      endif
11559 !d      write (iout,*)
11560 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11561 !d     &   ' and',k,l
11562 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
11563       do iii=1,2
11564         do kkk=1,5
11565           do lll=1,3
11566             derx_turn(lll,kkk,iii)=0.0d0
11567           enddo
11568         enddo
11569       enddo
11570 !d      eij=1.0d0
11571 !d      ekl=1.0d0
11572 !d      ekont=1.0d0
11573       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11574 !d      eello6_5=0.0d0
11575 !d      write (2,*) 'eello6_5',eello6_5
11576 #ifdef MOMENT
11577       call transpose2(AEA(1,1,1),auxmat(1,1))
11578       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11579       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
11580       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11581 #endif
11582       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11583       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11584       s2 = scalar2(b1(1,itk),vtemp1(1))
11585 #ifdef MOMENT
11586       call transpose2(AEA(1,1,2),atemp(1,1))
11587       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11588       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11589       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11590 #endif
11591       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11592       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11593       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11594 #ifdef MOMENT
11595       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11596       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11597       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11598       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11599       ss13 = scalar2(b1(1,itk),vtemp4(1))
11600       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11601 #endif
11602 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11603 !      s1=0.0d0
11604 !      s2=0.0d0
11605 !      s8=0.0d0
11606 !      s12=0.0d0
11607 !      s13=0.0d0
11608       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11609 ! Derivatives in gamma(i+2)
11610       s1d =0.0d0
11611       s8d =0.0d0
11612 #ifdef MOMENT
11613       call transpose2(AEA(1,1,1),auxmatd(1,1))
11614       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11615       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11616       call transpose2(AEAderg(1,1,2),atempd(1,1))
11617       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11618       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11619 #endif
11620       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11621       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11622       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11623 !      s1d=0.0d0
11624 !      s2d=0.0d0
11625 !      s8d=0.0d0
11626 !      s12d=0.0d0
11627 !      s13d=0.0d0
11628       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11629 ! Derivatives in gamma(i+3)
11630 #ifdef MOMENT
11631       call transpose2(AEA(1,1,1),auxmatd(1,1))
11632       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11633       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
11634       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11635 #endif
11636       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
11637       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11638       s2d = scalar2(b1(1,itk),vtemp1d(1))
11639 #ifdef MOMENT
11640       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11641       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11642 #endif
11643       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11644 #ifdef MOMENT
11645       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11646       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11647       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11648 #endif
11649 !      s1d=0.0d0
11650 !      s2d=0.0d0
11651 !      s8d=0.0d0
11652 !      s12d=0.0d0
11653 !      s13d=0.0d0
11654 #ifdef MOMENT
11655       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11656                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11657 #else
11658       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11659                     -0.5d0*ekont*(s2d+s12d)
11660 #endif
11661 ! Derivatives in gamma(i+4)
11662       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11663       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11664       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11665 #ifdef MOMENT
11666       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11667       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11668       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11669 #endif
11670 !      s1d=0.0d0
11671 !      s2d=0.0d0
11672 !      s8d=0.0d0
11673 !      s12d=0.0d0
11674 !      s13d=0.0d0
11675 #ifdef MOMENT
11676       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11677 #else
11678       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11679 #endif
11680 ! Derivatives in gamma(i+5)
11681 #ifdef MOMENT
11682       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11683       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11684       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11685 #endif
11686       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
11687       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11688       s2d = scalar2(b1(1,itk),vtemp1d(1))
11689 #ifdef MOMENT
11690       call transpose2(AEA(1,1,2),atempd(1,1))
11691       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11692       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11693 #endif
11694       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11695       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11696 #ifdef MOMENT
11697       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11698       ss13d = scalar2(b1(1,itk),vtemp4d(1))
11699       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11700 #endif
11701 !      s1d=0.0d0
11702 !      s2d=0.0d0
11703 !      s8d=0.0d0
11704 !      s12d=0.0d0
11705 !      s13d=0.0d0
11706 #ifdef MOMENT
11707       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11708                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11709 #else
11710       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11711                     -0.5d0*ekont*(s2d+s12d)
11712 #endif
11713 ! Cartesian derivatives
11714       do iii=1,2
11715         do kkk=1,5
11716           do lll=1,3
11717 #ifdef MOMENT
11718             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11719             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11720             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11721 #endif
11722             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11723             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
11724                 vtemp1d(1))
11725             s2d = scalar2(b1(1,itk),vtemp1d(1))
11726 #ifdef MOMENT
11727             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11728             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11729             s8d = -(atempd(1,1)+atempd(2,2))* &
11730                  scalar2(cc(1,1,itl),vtemp2(1))
11731 #endif
11732             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
11733                  auxmatd(1,1))
11734             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11735             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11736 !      s1d=0.0d0
11737 !      s2d=0.0d0
11738 !      s8d=0.0d0
11739 !      s12d=0.0d0
11740 !      s13d=0.0d0
11741 #ifdef MOMENT
11742             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11743               - 0.5d0*(s1d+s2d)
11744 #else
11745             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11746               - 0.5d0*s2d
11747 #endif
11748 #ifdef MOMENT
11749             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11750               - 0.5d0*(s8d+s12d)
11751 #else
11752             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11753               - 0.5d0*s12d
11754 #endif
11755           enddo
11756         enddo
11757       enddo
11758 #ifdef MOMENT
11759       do kkk=1,5
11760         do lll=1,3
11761           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
11762             achuj_tempd(1,1))
11763           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11764           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11765           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11766           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11767           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
11768             vtemp4d(1))
11769           ss13d = scalar2(b1(1,itk),vtemp4d(1))
11770           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11771           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11772         enddo
11773       enddo
11774 #endif
11775 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11776 !d     &  16*eel_turn6_num
11777 !d      goto 1112
11778       if (j.lt.nres-1) then
11779         j1=j+1
11780         j2=j-1
11781       else
11782         j1=j-1
11783         j2=j-2
11784       endif
11785       if (l.lt.nres-1) then
11786         l1=l+1
11787         l2=l-1
11788       else
11789         l1=l-1
11790         l2=l-2
11791       endif
11792       do ll=1,3
11793 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11794 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11795 !grad        ghalf=0.5d0*ggg1(ll)
11796 !d        ghalf=0.0d0
11797         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11798         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11799         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
11800           +ekont*derx_turn(ll,2,1)
11801         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11802         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
11803           +ekont*derx_turn(ll,4,1)
11804         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11805         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11806         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11807 !grad        ghalf=0.5d0*ggg2(ll)
11808 !d        ghalf=0.0d0
11809         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
11810           +ekont*derx_turn(ll,2,2)
11811         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11812         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
11813           +ekont*derx_turn(ll,4,2)
11814         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11815         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11816         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11817       enddo
11818 !d      goto 1112
11819 !grad      do m=i+1,j-1
11820 !grad        do ll=1,3
11821 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11822 !grad        enddo
11823 !grad      enddo
11824 !grad      do m=k+1,l-1
11825 !grad        do ll=1,3
11826 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11827 !grad        enddo
11828 !grad      enddo
11829 !grad1112  continue
11830 !grad      do m=i+2,j2
11831 !grad        do ll=1,3
11832 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11833 !grad        enddo
11834 !grad      enddo
11835 !grad      do m=k+2,l2
11836 !grad        do ll=1,3
11837 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11838 !grad        enddo
11839 !grad      enddo
11840 !d      do iii=1,nres-3
11841 !d        write (2,*) iii,g_corr6_loc(iii)
11842 !d      enddo
11843       eello_turn6=ekont*eel_turn6
11844 !d      write (2,*) 'ekont',ekont
11845 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11846       return
11847       end function eello_turn6
11848 !-----------------------------------------------------------------------------
11849       subroutine MATVEC2(A1,V1,V2)
11850 !DIR$ INLINEALWAYS MATVEC2
11851 #ifndef OSF
11852 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11853 #endif
11854 !      implicit real(kind=8) (a-h,o-z)
11855 !      include 'DIMENSIONS'
11856       real(kind=8),dimension(2) :: V1,V2
11857       real(kind=8),dimension(2,2) :: A1
11858       real(kind=8) :: vaux1,vaux2
11859 !      DO 1 I=1,2
11860 !        VI=0.0
11861 !        DO 3 K=1,2
11862 !    3     VI=VI+A1(I,K)*V1(K)
11863 !        Vaux(I)=VI
11864 !    1 CONTINUE
11865
11866       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11867       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11868
11869       v2(1)=vaux1
11870       v2(2)=vaux2
11871       end subroutine MATVEC2
11872 !-----------------------------------------------------------------------------
11873       subroutine MATMAT2(A1,A2,A3)
11874 #ifndef OSF
11875 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11876 #endif
11877 !      implicit real(kind=8) (a-h,o-z)
11878 !      include 'DIMENSIONS'
11879       real(kind=8),dimension(2,2) :: A1,A2,A3
11880       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11881 !      DIMENSION AI3(2,2)
11882 !        DO  J=1,2
11883 !          A3IJ=0.0
11884 !          DO K=1,2
11885 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11886 !          enddo
11887 !          A3(I,J)=A3IJ
11888 !       enddo
11889 !      enddo
11890
11891       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11892       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11893       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11894       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11895
11896       A3(1,1)=AI3_11
11897       A3(2,1)=AI3_21
11898       A3(1,2)=AI3_12
11899       A3(2,2)=AI3_22
11900       end subroutine MATMAT2
11901 !-----------------------------------------------------------------------------
11902       real(kind=8) function scalar2(u,v)
11903 !DIR$ INLINEALWAYS scalar2
11904       implicit none
11905       real(kind=8),dimension(2) :: u,v
11906       real(kind=8) :: sc
11907       integer :: i
11908       scalar2=u(1)*v(1)+u(2)*v(2)
11909       return
11910       end function scalar2
11911 !-----------------------------------------------------------------------------
11912       subroutine transpose2(a,at)
11913 !DIR$ INLINEALWAYS transpose2
11914 #ifndef OSF
11915 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11916 #endif
11917       implicit none
11918       real(kind=8),dimension(2,2) :: a,at
11919       at(1,1)=a(1,1)
11920       at(1,2)=a(2,1)
11921       at(2,1)=a(1,2)
11922       at(2,2)=a(2,2)
11923       return
11924       end subroutine transpose2
11925 !-----------------------------------------------------------------------------
11926       subroutine transpose(n,a,at)
11927       implicit none
11928       integer :: n,i,j
11929       real(kind=8),dimension(n,n) :: a,at
11930       do i=1,n
11931         do j=1,n
11932           at(j,i)=a(i,j)
11933         enddo
11934       enddo
11935       return
11936       end subroutine transpose
11937 !-----------------------------------------------------------------------------
11938       subroutine prodmat3(a1,a2,kk,transp,prod)
11939 !DIR$ INLINEALWAYS prodmat3
11940 #ifndef OSF
11941 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11942 #endif
11943       implicit none
11944       integer :: i,j
11945       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11946       logical :: transp
11947 !rc      double precision auxmat(2,2),prod_(2,2)
11948
11949       if (transp) then
11950 !rc        call transpose2(kk(1,1),auxmat(1,1))
11951 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11952 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11953
11954            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11955        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11956            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11957        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11958            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11959        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11960            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11961        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11962
11963       else
11964 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11965 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11966
11967            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11968         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11969            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11970         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11971            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11972         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11973            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11974         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11975
11976       endif
11977 !      call transpose2(a2(1,1),a2t(1,1))
11978
11979 !rc      print *,transp
11980 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11981 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11982
11983       return
11984       end subroutine prodmat3
11985 !-----------------------------------------------------------------------------
11986 ! energy_p_new_barrier.F
11987 !-----------------------------------------------------------------------------
11988       subroutine sum_gradient
11989 !      implicit real(kind=8) (a-h,o-z)
11990       use io_base, only: pdbout
11991 !      include 'DIMENSIONS'
11992 #ifndef ISNAN
11993       external proc_proc
11994 #ifdef WINPGI
11995 !MS$ATTRIBUTES C ::  proc_proc
11996 #endif
11997 #endif
11998 #ifdef MPI
11999       include 'mpif.h'
12000 #endif
12001       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
12002                    gloc_scbuf !(3,maxres)
12003
12004       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
12005 !#endif
12006 !el local variables
12007       integer :: i,j,k,ierror,ierr
12008       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
12009                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
12010                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
12011                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
12012                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
12013                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
12014                    gsccorr_max,gsccorrx_max,time00
12015
12016 !      include 'COMMON.SETUP'
12017 !      include 'COMMON.IOUNITS'
12018 !      include 'COMMON.FFIELD'
12019 !      include 'COMMON.DERIV'
12020 !      include 'COMMON.INTERACT'
12021 !      include 'COMMON.SBRIDGE'
12022 !      include 'COMMON.CHAIN'
12023 !      include 'COMMON.VAR'
12024 !      include 'COMMON.CONTROL'
12025 !      include 'COMMON.TIME1'
12026 !      include 'COMMON.MAXGRAD'
12027 !      include 'COMMON.SCCOR'
12028 #ifdef TIMING
12029       time01=MPI_Wtime()
12030 #endif
12031 !#define DEBUG
12032 #ifdef DEBUG
12033       write (iout,*) "sum_gradient gvdwc, gvdwx"
12034       do i=1,nres
12035         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
12036          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
12037       enddo
12038       call flush(iout)
12039 #endif
12040 #ifdef MPI
12041         gradbufc=0.0d0
12042         gradbufx=0.0d0
12043         gradbufc_sum=0.0d0
12044         gloc_scbuf=0.0d0
12045         glocbuf=0.0d0
12046 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
12047         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
12048           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
12049 #endif
12050 !
12051 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
12052 !            in virtual-bond-vector coordinates
12053 !
12054 #ifdef DEBUG
12055 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
12056 !      do i=1,nres-1
12057 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
12058 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
12059 !      enddo
12060 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
12061 !      do i=1,nres-1
12062 !        write (iout,'(i5,3f10.5,2x,f10.5)')
12063 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
12064 !      enddo
12065 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
12066 !      do i=1,nres
12067 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
12068 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
12069 !         (gvdwc_scpp(j,i),j=1,3)
12070 !      enddo
12071 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
12072 !      do i=1,nres
12073 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
12074 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
12075 !         (gelc_loc_long(j,i),j=1,3)
12076 !      enddo
12077       call flush(iout)
12078 #endif
12079 #ifdef SPLITELE
12080       do i=0,nct
12081         do j=1,3
12082           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
12083                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
12084                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
12085                       wel_loc*gel_loc_long(j,i)+ &
12086                       wcorr*gradcorr_long(j,i)+ &
12087                       wcorr5*gradcorr5_long(j,i)+ &
12088                       wcorr6*gradcorr6_long(j,i)+ &
12089                       wturn6*gcorr6_turn_long(j,i)+ &
12090                       wstrain*ghpbc(j,i) &
12091                      +wliptran*gliptranc(j,i) &
12092                      +gradafm(j,i) &
12093                      +welec*gshieldc(j,i) &
12094                      +wcorr*gshieldc_ec(j,i) &
12095                      +wturn3*gshieldc_t3(j,i)&
12096                      +wturn4*gshieldc_t4(j,i)&
12097                      +wel_loc*gshieldc_ll(j,i)&
12098                      +wtube*gg_tube(j,i) &
12099                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
12100                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
12101                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
12102                      wcorr_nucl*gradcorr_nucl(j,i)&
12103                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
12104                      wcatprot* gradpepcat(j,i)+ &
12105                      wcatcat*gradcatcat(j,i)+   &
12106                      wscbase*gvdwc_scbase(j,i)+ &
12107                      wpepbase*gvdwc_pepbase(j,i)+&
12108                      wscpho*gvdwc_scpho(j,i)+   &
12109                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)+ &
12110                      gradlipbond(j,i)+gradlipang(j,i)+gradliplj(j,i)+gradlipelec(j,i)+&
12111                      wcat_tran*gradcattranc(j,i)+gradcatangc(j,i)
12112
12113
12114
12115
12116
12117         enddo
12118       enddo
12119 #else
12120       do i=0,nct
12121         do j=1,3
12122           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
12123                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
12124                       welec*gelc_long(j,i)+ &
12125                       wbond*gradb(j,i)+ &
12126                       wel_loc*gel_loc_long(j,i)+ &
12127                       wcorr*gradcorr_long(j,i)+ &
12128                       wcorr5*gradcorr5_long(j,i)+ &
12129                       wcorr6*gradcorr6_long(j,i)+ &
12130                       wturn6*gcorr6_turn_long(j,i)+ &
12131                       wstrain*ghpbc(j,i) &
12132                      +wliptran*gliptranc(j,i) &
12133                      +gradafm(j,i) &
12134                      +welec*gshieldc(j,i)&
12135                      +wcorr*gshieldc_ec(j,i) &
12136                      +wturn4*gshieldc_t4(j,i) &
12137                      +wel_loc*gshieldc_ll(j,i)&
12138                      +wtube*gg_tube(j,i) &
12139                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
12140                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
12141                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
12142                      wcorr_nucl*gradcorr_nucl(j,i) &
12143                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
12144                      wcatprot* gradpepcat(j,i)+ &
12145                      wcatcat*gradcatcat(j,i)+   &
12146                      wscbase*gvdwc_scbase(j,i)+ &
12147                      wpepbase*gvdwc_pepbase(j,i)+&
12148                      wscpho*gvdwc_scpho(j,i)+&
12149                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)+&
12150                      gradlipbond(j,i)+gradlipang(j,i)+gradliplj(j,i)+gradlipelec(j,i)+&
12151                      wcat_tran*gradcattranc(j,i)+gradcatangc(j,i)
12152
12153
12154
12155         enddo
12156       enddo
12157 #endif
12158 #ifdef MPI
12159       if (nfgtasks.gt.1) then
12160       time00=MPI_Wtime()
12161 #ifdef DEBUG
12162       write (iout,*) "gradbufc before allreduce"
12163       do i=1,nres
12164         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
12165       enddo
12166       call flush(iout)
12167 #endif
12168       do i=0,nres
12169         do j=1,3
12170           gradbufc_sum(j,i)=gradbufc(j,i)
12171         enddo
12172       enddo
12173 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
12174 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12175 !      time_reduce=time_reduce+MPI_Wtime()-time00
12176 #ifdef DEBUG
12177 !      write (iout,*) "gradbufc_sum after allreduce"
12178 !      do i=1,nres
12179 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
12180 !      enddo
12181 !      call flush(iout)
12182 #endif
12183 #ifdef TIMING
12184 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
12185 #endif
12186       do i=0,nres
12187         do k=1,3
12188           gradbufc(k,i)=0.0d0
12189         enddo
12190       enddo
12191 #ifdef DEBUG
12192       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
12193       write (iout,*) (i," jgrad_start",jgrad_start(i),&
12194                         " jgrad_end  ",jgrad_end(i),&
12195                         i=igrad_start,igrad_end)
12196 #endif
12197 !
12198 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
12199 ! do not parallelize this part.
12200 !
12201 !      do i=igrad_start,igrad_end
12202 !        do j=jgrad_start(i),jgrad_end(i)
12203 !          do k=1,3
12204 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
12205 !          enddo
12206 !        enddo
12207 !      enddo
12208       do j=1,3
12209         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
12210       enddo
12211       do i=nres-2,-1,-1
12212         do j=1,3
12213           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
12214         enddo
12215       enddo
12216 #ifdef DEBUG
12217       write (iout,*) "gradbufc after summing"
12218       do i=1,nres
12219         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
12220       enddo
12221       call flush(iout)
12222 #endif
12223       else
12224 #endif
12225 !el#define DEBUG
12226 #ifdef DEBUG
12227       write (iout,*) "gradbufc"
12228       do i=1,nres
12229         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
12230       enddo
12231       call flush(iout)
12232 #endif
12233 !el#undef DEBUG
12234       do i=-1,nres
12235         do j=1,3
12236           gradbufc_sum(j,i)=gradbufc(j,i)
12237           gradbufc(j,i)=0.0d0
12238         enddo
12239       enddo
12240       do j=1,3
12241         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
12242       enddo
12243       do i=nres-2,-1,-1
12244         do j=1,3
12245           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
12246         enddo
12247       enddo
12248 !      do i=nnt,nres-1
12249 !        do k=1,3
12250 !          gradbufc(k,i)=0.0d0
12251 !        enddo
12252 !        do j=i+1,nres
12253 !          do k=1,3
12254 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
12255 !          enddo
12256 !        enddo
12257 !      enddo
12258 !el#define DEBUG
12259 #ifdef DEBUG
12260       write (iout,*) "gradbufc after summing"
12261       do i=1,nres
12262         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
12263       enddo
12264       call flush(iout)
12265 #endif
12266 !el#undef DEBUG
12267 #ifdef MPI
12268       endif
12269 #endif
12270       do k=1,3
12271         gradbufc(k,nres)=0.0d0
12272       enddo
12273 !el----------------
12274 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
12275 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
12276 !el-----------------
12277       do i=-1,nct
12278         do j=1,3
12279 #ifdef SPLITELE
12280           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
12281                       wel_loc*gel_loc(j,i)+ &
12282                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
12283                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
12284                       wel_loc*gel_loc_long(j,i)+ &
12285                       wcorr*gradcorr_long(j,i)+ &
12286                       wcorr5*gradcorr5_long(j,i)+ &
12287                       wcorr6*gradcorr6_long(j,i)+ &
12288                       wturn6*gcorr6_turn_long(j,i))+ &
12289                       wbond*gradb(j,i)+ &
12290                       wcorr*gradcorr(j,i)+ &
12291                       wturn3*gcorr3_turn(j,i)+ &
12292                       wturn4*gcorr4_turn(j,i)+ &
12293                       wcorr5*gradcorr5(j,i)+ &
12294                       wcorr6*gradcorr6(j,i)+ &
12295                       wturn6*gcorr6_turn(j,i)+ &
12296                       wsccor*gsccorc(j,i) &
12297                      +wscloc*gscloc(j,i)  &
12298                      +wliptran*gliptranc(j,i) &
12299                      +gradafm(j,i) &
12300                      +welec*gshieldc(j,i) &
12301                      +welec*gshieldc_loc(j,i) &
12302                      +wcorr*gshieldc_ec(j,i) &
12303                      +wcorr*gshieldc_loc_ec(j,i) &
12304                      +wturn3*gshieldc_t3(j,i) &
12305                      +wturn3*gshieldc_loc_t3(j,i) &
12306                      +wturn4*gshieldc_t4(j,i) &
12307                      +wturn4*gshieldc_loc_t4(j,i) &
12308                      +wel_loc*gshieldc_ll(j,i) &
12309                      +wel_loc*gshieldc_loc_ll(j,i) &
12310                      +wtube*gg_tube(j,i) &
12311                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12312                      +wvdwpsb*gvdwpsb1(j,i))&
12313                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)!&
12314 !                     + gradcattranc(j,i)
12315 !                      if (i.eq.21) then
12316 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
12317 !                      wturn4*gshieldc_t4(j,i), &
12318 !                     wturn4*gshieldc_loc_t4(j,i)
12319 !                       endif
12320 !                 if ((i.le.2).and.(i.ge.1))
12321 !                       print *,gradc(j,i,icg),&
12322 !                      gradbufc(j,i),welec*gelc(j,i), &
12323 !                      wel_loc*gel_loc(j,i), &
12324 !                      wscp*gvdwc_scpp(j,i), &
12325 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
12326 !                      wel_loc*gel_loc_long(j,i), &
12327 !                      wcorr*gradcorr_long(j,i), &
12328 !                      wcorr5*gradcorr5_long(j,i), &
12329 !                      wcorr6*gradcorr6_long(j,i), &
12330 !                      wturn6*gcorr6_turn_long(j,i), &
12331 !                      wbond*gradb(j,i), &
12332 !                      wcorr*gradcorr(j,i), &
12333 !                      wturn3*gcorr3_turn(j,i), &
12334 !                      wturn4*gcorr4_turn(j,i), &
12335 !                      wcorr5*gradcorr5(j,i), &
12336 !                      wcorr6*gradcorr6(j,i), &
12337 !                      wturn6*gcorr6_turn(j,i), &
12338 !                      wsccor*gsccorc(j,i) &
12339 !                     ,wscloc*gscloc(j,i)  &
12340 !                     ,wliptran*gliptranc(j,i) &
12341 !                    ,gradafm(j,i) &
12342 !                     ,welec*gshieldc(j,i) &
12343 !                     ,welec*gshieldc_loc(j,i) &
12344 !                     ,wcorr*gshieldc_ec(j,i) &
12345 !                     ,wcorr*gshieldc_loc_ec(j,i) &
12346 !                     ,wturn3*gshieldc_t3(j,i) &
12347 !                     ,wturn3*gshieldc_loc_t3(j,i) &
12348 !                     ,wturn4*gshieldc_t4(j,i) &
12349 !                     ,wturn4*gshieldc_loc_t4(j,i) &
12350 !                     ,wel_loc*gshieldc_ll(j,i) &
12351 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
12352 !                     ,wtube*gg_tube(j,i) &
12353 !                     ,wbond_nucl*gradb_nucl(j,i) &
12354 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
12355 !                     wvdwpsb*gvdwpsb1(j,i)&
12356 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
12357 !
12358
12359 #else
12360           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
12361                       wel_loc*gel_loc(j,i)+ &
12362                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
12363                       welec*gelc_long(j,i)+ &
12364                       wel_loc*gel_loc_long(j,i)+ &
12365 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
12366                       wcorr5*gradcorr5_long(j,i)+ &
12367                       wcorr6*gradcorr6_long(j,i)+ &
12368                       wturn6*gcorr6_turn_long(j,i))+ &
12369                       wbond*gradb(j,i)+ &
12370                       wcorr*gradcorr(j,i)+ &
12371                       wturn3*gcorr3_turn(j,i)+ &
12372                       wturn4*gcorr4_turn(j,i)+ &
12373                       wcorr5*gradcorr5(j,i)+ &
12374                       wcorr6*gradcorr6(j,i)+ &
12375                       wturn6*gcorr6_turn(j,i)+ &
12376                       wsccor*gsccorc(j,i) &
12377                      +wscloc*gscloc(j,i) &
12378                      +gradafm(j,i) &
12379                      +wliptran*gliptranc(j,i) &
12380                      +welec*gshieldc(j,i) &
12381                      +welec*gshieldc_loc(j,i) &
12382                      +wcorr*gshieldc_ec(j,i) &
12383                      +wcorr*gshieldc_loc_ec(j,i) &
12384                      +wturn3*gshieldc_t3(j,i) &
12385                      +wturn3*gshieldc_loc_t3(j,i) &
12386                      +wturn4*gshieldc_t4(j,i) &
12387                      +wturn4*gshieldc_loc_t4(j,i) &
12388                      +wel_loc*gshieldc_ll(j,i) &
12389                      +wel_loc*gshieldc_loc_ll(j,i) &
12390                      +wtube*gg_tube(j,i) &
12391                      +wbond_nucl*gradb_nucl(j,i) &
12392                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12393                      +wvdwpsb*gvdwpsb1(j,i))&
12394                      +wsbloc*gsbloc(j,i)+wcatnucl*gradnuclcat(j,i)!&
12395 !                     + gradcattranc(j,i)
12396
12397
12398
12399
12400 #endif
12401           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
12402                         wbond*gradbx(j,i)+ &
12403                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
12404                         wsccor*gsccorx(j,i) &
12405                        +wscloc*gsclocx(j,i) &
12406                        +wliptran*gliptranx(j,i) &
12407                        +welec*gshieldx(j,i)     &
12408                        +wcorr*gshieldx_ec(j,i)  &
12409                        +wturn3*gshieldx_t3(j,i) &
12410                        +wturn4*gshieldx_t4(j,i) &
12411                        +wel_loc*gshieldx_ll(j,i)&
12412                        +wtube*gg_tube_sc(j,i)   &
12413                        +wbond_nucl*gradbx_nucl(j,i) &
12414                        +wvdwsb*gvdwsbx(j,i) &
12415                        +welsb*gelsbx(j,i) &
12416                        +wcorr_nucl*gradxorr_nucl(j,i)&
12417                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
12418                        +wsbloc*gsblocx(j,i) &
12419                        +wcatprot* gradpepcatx(j,i)&
12420                        +wscbase*gvdwx_scbase(j,i) &
12421                        +wpepbase*gvdwx_pepbase(j,i)&
12422                        +wscpho*gvdwx_scpho(j,i)+wcatnucl*gradnuclcatx(j,i)&
12423                        +wcat_tran*gradcattranx(j,i)+gradcatangx(j,i)
12424 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
12425
12426         enddo
12427       enddo
12428 !      write(iout,*), "const_homol",constr_homology
12429       if (constr_homology.gt.0) then
12430         do i=1,nct
12431           do j=1,3
12432             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
12433 !            write(iout,*) "duscdiff",duscdiff(j,i)
12434             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
12435           enddo
12436         enddo
12437       endif
12438 !#define DEBUG
12439 #ifdef DEBUG
12440       write (iout,*) "gloc before adding corr"
12441       do i=1,4*nres
12442         write (iout,*) i,gloc(i,icg)
12443       enddo
12444 #endif
12445       do i=1,nres-3
12446         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
12447          +wcorr5*g_corr5_loc(i) &
12448          +wcorr6*g_corr6_loc(i) &
12449          +wturn4*gel_loc_turn4(i) &
12450          +wturn3*gel_loc_turn3(i) &
12451          +wturn6*gel_loc_turn6(i) &
12452          +wel_loc*gel_loc_loc(i)
12453       enddo
12454 #ifdef DEBUG
12455       write (iout,*) "gloc after adding corr"
12456       do i=1,4*nres
12457         write (iout,*) i,gloc(i,icg)
12458       enddo
12459 #endif
12460 !#undef DEBUG
12461 #ifdef MPI
12462       if (nfgtasks.gt.1) then
12463         do j=1,3
12464           do i=0,nres
12465             gradbufc(j,i)=gradc(j,i,icg)
12466             gradbufx(j,i)=gradx(j,i,icg)
12467           enddo
12468         enddo
12469         do i=1,4*nres
12470           glocbuf(i)=gloc(i,icg)
12471         enddo
12472 !#define DEBUG
12473 #ifdef DEBUG
12474       write (iout,*) "gloc_sc before reduce"
12475       do i=1,nres
12476        do j=1,1
12477         write (iout,*) i,j,gloc_sc(j,i,icg)
12478        enddo
12479       enddo
12480 #endif
12481 !#undef DEBUG
12482         do i=0,nres
12483          do j=1,3
12484           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
12485          enddo
12486         enddo
12487         time00=MPI_Wtime()
12488         call MPI_Barrier(FG_COMM,IERR)
12489         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
12490         time00=MPI_Wtime()
12491         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
12492           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12493         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
12494           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12495         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
12496           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12497         time_reduce=time_reduce+MPI_Wtime()-time00
12498         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
12499           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12500         time_reduce=time_reduce+MPI_Wtime()-time00
12501 !#define DEBUG
12502 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
12503 #ifdef DEBUG
12504       write (iout,*) "gloc_sc after reduce"
12505       do i=0,nres
12506        do j=1,1
12507         write (iout,*) i,j,gloc_sc(j,i,icg)
12508        enddo
12509       enddo
12510 #endif
12511 !#undef DEBUG
12512 #ifdef DEBUG
12513       write (iout,*) "gloc after reduce"
12514       do i=1,4*nres
12515         write (iout,*) i,gloc(i,icg)
12516       enddo
12517 #endif
12518       endif
12519 #endif
12520       if (gnorm_check) then
12521 !
12522 ! Compute the maximum elements of the gradient
12523 !
12524       gvdwc_max=0.0d0
12525       gvdwc_scp_max=0.0d0
12526       gelc_max=0.0d0
12527       gvdwpp_max=0.0d0
12528       gradb_max=0.0d0
12529       ghpbc_max=0.0d0
12530       gradcorr_max=0.0d0
12531       gel_loc_max=0.0d0
12532       gcorr3_turn_max=0.0d0
12533       gcorr4_turn_max=0.0d0
12534       gradcorr5_max=0.0d0
12535       gradcorr6_max=0.0d0
12536       gcorr6_turn_max=0.0d0
12537       gsccorc_max=0.0d0
12538       gscloc_max=0.0d0
12539       gvdwx_max=0.0d0
12540       gradx_scp_max=0.0d0
12541       ghpbx_max=0.0d0
12542       gradxorr_max=0.0d0
12543       gsccorx_max=0.0d0
12544       gsclocx_max=0.0d0
12545       do i=1,nct
12546         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
12547         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
12548         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
12549         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
12550          gvdwc_scp_max=gvdwc_scp_norm
12551         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
12552         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
12553         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
12554         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
12555         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
12556         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
12557         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
12558         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
12559         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
12560         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
12561         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
12562         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
12563         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
12564           gcorr3_turn(1,i)))
12565         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
12566           gcorr3_turn_max=gcorr3_turn_norm
12567         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
12568           gcorr4_turn(1,i)))
12569         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
12570           gcorr4_turn_max=gcorr4_turn_norm
12571         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
12572         if (gradcorr5_norm.gt.gradcorr5_max) &
12573           gradcorr5_max=gradcorr5_norm
12574         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
12575         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
12576         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
12577           gcorr6_turn(1,i)))
12578         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
12579           gcorr6_turn_max=gcorr6_turn_norm
12580         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
12581         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
12582         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
12583         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
12584         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
12585         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
12586         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
12587         if (gradx_scp_norm.gt.gradx_scp_max) &
12588           gradx_scp_max=gradx_scp_norm
12589         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
12590         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
12591         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
12592         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
12593         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
12594         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
12595         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
12596         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
12597       enddo
12598       if (gradout) then
12599 #ifdef AIX
12600         open(istat,file=statname,position="append")
12601 #else
12602         open(istat,file=statname,access="append")
12603 #endif
12604         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
12605            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
12606            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
12607            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
12608            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
12609            gsccorx_max,gsclocx_max
12610         close(istat)
12611         if (gvdwc_max.gt.1.0d4) then
12612           write (iout,*) "gvdwc gvdwx gradb gradbx"
12613           do i=nnt,nct
12614             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
12615               gradb(j,i),gradbx(j,i),j=1,3)
12616           enddo
12617           call pdbout(0.0d0,'cipiszcze',iout)
12618           call flush(iout)
12619         endif
12620       endif
12621       endif
12622 !#define DEBUG
12623 #ifdef DEBUG
12624       write (iout,*) "gradc gradx gloc"
12625       do i=1,nres
12626         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
12627          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
12628       enddo
12629 #endif
12630 !#undef DEBUG
12631 #ifdef TIMING
12632       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
12633 #endif
12634       return
12635       end subroutine sum_gradient
12636 !-----------------------------------------------------------------------------
12637       subroutine sc_grad
12638 !      implicit real(kind=8) (a-h,o-z)
12639       use calc_data
12640 !      include 'DIMENSIONS'
12641 !      include 'COMMON.CHAIN'
12642 !      include 'COMMON.DERIV'
12643 !      include 'COMMON.CALC'
12644 !      include 'COMMON.IOUNITS'
12645       real(kind=8), dimension(3) :: dcosom1,dcosom2
12646 !      print *,"wchodze"
12647       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12648           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12649       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12650           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12651
12652       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12653            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12654            +dCAVdOM12+ dGCLdOM12
12655 ! diagnostics only
12656 !      eom1=0.0d0
12657 !      eom2=0.0d0
12658 !      eom12=evdwij*eps1_om12
12659 ! end diagnostics
12660 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
12661 !       " sigder",sigder
12662 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
12663 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
12664 !C      print *,sss_ele_cut,'in sc_grad'
12665       do k=1,3
12666         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12667         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
12668       enddo
12669       do k=1,3
12670         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
12671 !C      print *,'gg',k,gg(k)
12672        enddo
12673 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12674 !      write (iout,*) "gg",(gg(k),k=1,3)
12675       do k=1,3
12676         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
12677                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12678                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
12679                   *sss_ele_cut
12680
12681         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
12682                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12683                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
12684                   *sss_ele_cut
12685
12686 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12687 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12688 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12689 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12690       enddo
12691 !
12692 ! Calculate the components of the gradient in DC and X
12693 !
12694 !grad      do k=i,j-1
12695 !grad        do l=1,3
12696 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
12697 !grad        enddo
12698 !grad      enddo
12699       do l=1,3
12700         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
12701         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
12702       enddo
12703       return
12704       end subroutine sc_grad
12705
12706       subroutine sc_grad_cat
12707       use calc_data
12708       real(kind=8), dimension(3) :: dcosom1,dcosom2
12709       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12710           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12711       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12712           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12713
12714       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12715            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12716            +dCAVdOM12+ dGCLdOM12
12717 ! diagnostics only
12718 !      eom1=0.0d0
12719 !      eom2=0.0d0
12720 !      eom12=evdwij*eps1_om12
12721 ! end diagnostics
12722
12723       do k=1,3
12724         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12725         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
12726       enddo
12727       do k=1,3
12728         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
12729 !      print *,'gg',k,gg(k)
12730        enddo
12731 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12732 !      write (iout,*) "gg",(gg(k),k=1,3)
12733       do k=1,3
12734         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
12735                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
12736                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12737
12738 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
12739 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
12740 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
12741
12742 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12743 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12744 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12745 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12746       enddo
12747 !
12748 ! Calculate the components of the gradient in DC and X
12749 !
12750       do l=1,3
12751         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
12752         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
12753       enddo
12754       end subroutine sc_grad_cat
12755
12756       subroutine sc_grad_cat_pep
12757       use calc_data
12758       real(kind=8), dimension(3) :: dcosom1,dcosom2
12759       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12760           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12761       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12762           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12763
12764       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12765            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12766            +dCAVdOM12+ dGCLdOM12
12767 ! diagnostics only
12768 !      eom1=0.0d0
12769 !      eom2=0.0d0
12770 !      eom12=evdwij*eps1_om12
12771 ! end diagnostics
12772
12773       do k=1,3
12774         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
12775         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
12776         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
12777         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
12778                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
12779                  *dsci_inv*2.0 &
12780                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12781         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
12782                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
12783                  *dsci_inv*2.0 &
12784                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12785         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
12786       enddo
12787       end subroutine sc_grad_cat_pep
12788
12789 #ifdef CRYST_THETA
12790 !-----------------------------------------------------------------------------
12791       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
12792
12793       use comm_calcthet
12794 !      implicit real(kind=8) (a-h,o-z)
12795 !      include 'DIMENSIONS'
12796 !      include 'COMMON.LOCAL'
12797 !      include 'COMMON.IOUNITS'
12798 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
12799 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12800 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
12801       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
12802       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
12803 !el      integer :: it
12804 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
12805 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12806 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
12807 !el local variables
12808
12809       delthec=thetai-thet_pred_mean
12810       delthe0=thetai-theta0i
12811 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
12812       t3 = thetai-thet_pred_mean
12813       t6 = t3**2
12814       t9 = term1
12815       t12 = t3*sigcsq
12816       t14 = t12+t6*sigsqtc
12817       t16 = 1.0d0
12818       t21 = thetai-theta0i
12819       t23 = t21**2
12820       t26 = term2
12821       t27 = t21*t26
12822       t32 = termexp
12823       t40 = t32**2
12824       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
12825        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12826        *(-t12*t9-ak*sig0inv*t27)
12827       return
12828       end subroutine mixder
12829 #endif
12830 !-----------------------------------------------------------------------------
12831 ! cartder.F
12832 !-----------------------------------------------------------------------------
12833       subroutine cartder
12834 !-----------------------------------------------------------------------------
12835 ! This subroutine calculates the derivatives of the consecutive virtual
12836 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12837 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12838 ! in the angles alpha and omega, describing the location of a side chain
12839 ! in its local coordinate system.
12840 !
12841 ! The derivatives are stored in the following arrays:
12842 !
12843 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12844 ! The structure is as follows:
12845 !
12846 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12847 ! 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)
12848 !         . . . . . . . . . . . .  . . . . . .
12849 ! 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)
12850 !                          .
12851 !                          .
12852 !                          .
12853 ! 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)
12854 !
12855 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12856 ! The structure is same as above.
12857 !
12858 ! DCDS - the derivatives of the side chain vectors in the local spherical
12859 ! andgles alph and omega:
12860 !
12861 ! 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)
12862 ! 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)
12863 !                          .
12864 !                          .
12865 !                          .
12866 ! 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)
12867 !
12868 ! Version of March '95, based on an early version of November '91.
12869 !
12870 !**********************************************************************
12871 !      implicit real(kind=8) (a-h,o-z)
12872 !      include 'DIMENSIONS'
12873 !      include 'COMMON.VAR'
12874 !      include 'COMMON.CHAIN'
12875 !      include 'COMMON.DERIV'
12876 !      include 'COMMON.GEO'
12877 !      include 'COMMON.LOCAL'
12878 !      include 'COMMON.INTERACT'
12879       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12880       real(kind=8),dimension(3,3) :: dp,temp
12881 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12882       real(kind=8),dimension(3) :: xx,xx1
12883 !el local variables
12884       integer :: i,k,l,j,m,ind,ind1,jjj
12885       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12886                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12887                  sint2,xp,yp,xxp,yyp,zzp,dj
12888
12889 !      common /przechowalnia/ fromto
12890 #ifdef FIVEDIAG
12891       if(.not. allocated(fromto)) allocate(fromto(3,3))
12892 #else
12893       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12894 #endif
12895 ! get the position of the jth ijth fragment of the chain coordinate system
12896 ! in the fromto array.
12897 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12898 !
12899 !      maxdim=(nres-1)*(nres-2)/2
12900 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12901 ! calculate the derivatives of transformation matrix elements in theta
12902 !
12903
12904 !el      call flush(iout) !el
12905       do i=1,nres-2
12906         rdt(1,1,i)=-rt(1,2,i)
12907         rdt(1,2,i)= rt(1,1,i)
12908         rdt(1,3,i)= 0.0d0
12909         rdt(2,1,i)=-rt(2,2,i)
12910         rdt(2,2,i)= rt(2,1,i)
12911         rdt(2,3,i)= 0.0d0
12912         rdt(3,1,i)=-rt(3,2,i)
12913         rdt(3,2,i)= rt(3,1,i)
12914         rdt(3,3,i)= 0.0d0
12915       enddo
12916 !
12917 ! derivatives in phi
12918 !
12919       do i=2,nres-2
12920         drt(1,1,i)= 0.0d0
12921         drt(1,2,i)= 0.0d0
12922         drt(1,3,i)= 0.0d0
12923         drt(2,1,i)= rt(3,1,i)
12924         drt(2,2,i)= rt(3,2,i)
12925         drt(2,3,i)= rt(3,3,i)
12926         drt(3,1,i)=-rt(2,1,i)
12927         drt(3,2,i)=-rt(2,2,i)
12928         drt(3,3,i)=-rt(2,3,i)
12929       enddo
12930 !
12931 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12932 !
12933 #ifndef FIVEDIAG
12934       do i=2,nres-2
12935         ind=indmat(i,i+1)
12936         do k=1,3
12937           do l=1,3
12938             temp(k,l)=rt(k,l,i)
12939           enddo
12940         enddo
12941         do k=1,3
12942           do l=1,3
12943             fromto(k,l,ind)=temp(k,l)
12944           enddo
12945         enddo
12946
12947         do j=i+1,nres-2
12948           ind=indmat(i,j+1)
12949           do k=1,3
12950             do l=1,3
12951               dpkl=0.0d0
12952               do m=1,3
12953                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12954               enddo
12955               dp(k,l)=dpkl
12956               fromto(k,l,ind)=dpkl
12957             enddo
12958           enddo
12959           do k=1,3
12960             do l=1,3
12961               temp(k,l)=dp(k,l)
12962             enddo
12963           enddo
12964         enddo
12965       enddo
12966 #endif
12967 !
12968 ! Calculate derivatives.
12969 !
12970       ind1=0
12971       do i=1,nres-2
12972       ind1=ind1+1
12973 !
12974 ! Derivatives of DC(i+1) in theta(i+2)
12975 !
12976         do j=1,3
12977           do k=1,2
12978             dpjk=0.0D0
12979             do l=1,3
12980               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12981             enddo
12982             dp(j,k)=dpjk
12983             prordt(j,k,i)=dp(j,k)
12984           enddo
12985           dp(j,3)=0.0D0
12986           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12987         enddo
12988 !
12989 ! Derivatives of SC(i+1) in theta(i+2)
12990 !
12991         xx1(1)=-0.5D0*xloc(2,i+1)
12992         xx1(2)= 0.5D0*xloc(1,i+1)
12993         do j=1,3
12994           xj=0.0D0
12995           do k=1,2
12996             xj=xj+r(j,k,i)*xx1(k)
12997           enddo
12998           xx(j)=xj
12999         enddo
13000         do j=1,3
13001           rj=0.0D0
13002           do k=1,3
13003             rj=rj+prod(j,k,i)*xx(k)
13004           enddo
13005           dxdv(j,ind1)=rj
13006         enddo
13007 !
13008 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
13009 ! than the other off-diagonal derivatives.
13010 !
13011         do j=1,3
13012           dxoiij=0.0D0
13013           do k=1,3
13014             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
13015           enddo
13016           dxdv(j,ind1+1)=dxoiij
13017         enddo
13018 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
13019 !
13020 ! Derivatives of DC(i+1) in phi(i+2)
13021 !
13022         do j=1,3
13023           do k=1,3
13024             dpjk=0.0
13025             do l=2,3
13026               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
13027             enddo
13028             dp(j,k)=dpjk
13029             prodrt(j,k,i)=dp(j,k)
13030           enddo
13031           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
13032         enddo
13033 !
13034 ! Derivatives of SC(i+1) in phi(i+2)
13035 !
13036         xx(1)= 0.0D0
13037         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
13038         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
13039         do j=1,3
13040           rj=0.0D0
13041           do k=2,3
13042             rj=rj+prod(j,k,i)*xx(k)
13043           enddo
13044           dxdv(j+3,ind1)=-rj
13045         enddo
13046 !
13047 ! Derivatives of SC(i+1) in phi(i+3).
13048 !
13049         do j=1,3
13050           dxoiij=0.0D0
13051           do k=1,3
13052             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
13053           enddo
13054           dxdv(j+3,ind1+1)=dxoiij
13055         enddo
13056 !
13057 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
13058 ! theta(nres) and phi(i+3) thru phi(nres).
13059 !
13060         do j=i+1,nres-2
13061         ind1=ind1+1
13062         ind=indmat(i+1,j+1)
13063 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
13064 #ifdef FIVEDIAG
13065           call build_fromto(i+1,j+1,fromto)
13066 !c          write(iout,'(7hfromto 9f10.5)')((fromto(k,l),l=1,3),k=1,3)
13067           do k=1,3
13068             do l=1,3
13069               tempkl=0.0D0
13070               do m=1,2
13071                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l)
13072               enddo
13073               temp(k,l)=tempkl
13074             enddo
13075           enddo
13076 #else
13077           do k=1,3
13078             do l=1,3
13079               tempkl=0.0D0
13080               do m=1,2
13081                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
13082               enddo
13083               temp(k,l)=tempkl
13084             enddo
13085           enddo
13086 #endif
13087 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
13088 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
13089 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
13090 ! Derivatives of virtual-bond vectors in theta
13091           do k=1,3
13092             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
13093           enddo
13094 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
13095 ! Derivatives of SC vectors in theta
13096           do k=1,3
13097             dxoijk=0.0D0
13098             do l=1,3
13099               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
13100             enddo
13101             dxdv(k,ind1+1)=dxoijk
13102           enddo
13103 !
13104 !--- Calculate the derivatives in phi
13105 !
13106 #ifdef FIVEDIAG
13107           do k=1,3
13108             do l=1,3
13109               tempkl=0.0D0
13110               do m=1,3
13111                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l)
13112               enddo
13113               temp(k,l)=tempkl
13114             enddo
13115           enddo
13116 #else
13117           do k=1,3
13118             do l=1,3
13119               tempkl=0.0D0
13120               do m=1,3
13121                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
13122               enddo
13123               temp(k,l)=tempkl
13124             enddo
13125           enddo
13126 #endif
13127
13128
13129           do k=1,3
13130             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
13131         enddo
13132           do k=1,3
13133             dxoijk=0.0D0
13134             do l=1,3
13135               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
13136             enddo
13137             dxdv(k+3,ind1+1)=dxoijk
13138           enddo
13139         enddo
13140       enddo
13141 !
13142 ! Derivatives in alpha and omega:
13143 !
13144       do i=2,nres-1
13145 !       dsci=dsc(itype(i,1))
13146         dsci=vbld(i+nres)
13147 #ifdef OSF
13148         alphi=alph(i)
13149         omegi=omeg(i)
13150         if(alphi.ne.alphi) alphi=100.0
13151         if(omegi.ne.omegi) omegi=-100.0
13152 #else
13153       alphi=alph(i)
13154       omegi=omeg(i)
13155 #endif
13156 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
13157       cosalphi=dcos(alphi)
13158       sinalphi=dsin(alphi)
13159       cosomegi=dcos(omegi)
13160       sinomegi=dsin(omegi)
13161       temp(1,1)=-dsci*sinalphi
13162       temp(2,1)= dsci*cosalphi*cosomegi
13163       temp(3,1)=-dsci*cosalphi*sinomegi
13164       temp(1,2)=0.0D0
13165       temp(2,2)=-dsci*sinalphi*sinomegi
13166       temp(3,2)=-dsci*sinalphi*cosomegi
13167       theta2=pi-0.5D0*theta(i+1)
13168       cost2=dcos(theta2)
13169       sint2=dsin(theta2)
13170       jjj=0
13171 !d      print *,((temp(l,k),l=1,3),k=1,2)
13172         do j=1,2
13173         xp=temp(1,j)
13174         yp=temp(2,j)
13175         xxp= xp*cost2+yp*sint2
13176         yyp=-xp*sint2+yp*cost2
13177         zzp=temp(3,j)
13178         xx(1)=xxp
13179         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
13180         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
13181         do k=1,3
13182           dj=0.0D0
13183           do l=1,3
13184             dj=dj+prod(k,l,i-1)*xx(l)
13185             enddo
13186           dxds(jjj+k,i)=dj
13187           enddo
13188         jjj=jjj+3
13189       enddo
13190       enddo
13191       return
13192       end subroutine cartder
13193 #ifdef FIVEDIAG
13194       subroutine build_fromto(i,j,fromto)
13195       implicit none
13196       integer i,j,jj,k,l,m
13197       double precision fromto(3,3),temp(3,3),dp(3,3)
13198       double precision dpkl
13199       save temp
13200 !
13201 ! generate the matrix products of type r(i)t(i)...r(j)t(j) on the fly
13202 !
13203 !      write (iout,*) "temp on entry"
13204 !      write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
13205 !      do i=2,nres-2
13206 !        ind=indmat(i,i+1)
13207       if (j.eq.i+1) then
13208         do k=1,3
13209           do l=1,3
13210             temp(k,l)=rt(k,l,i)
13211           enddo
13212         enddo
13213         do k=1,3
13214           do l=1,3
13215             fromto(k,l)=temp(k,l)
13216           enddo
13217         enddo
13218       else
13219 !        do j=i+1,nres-2
13220 !          ind=indmat(i,j+1)
13221           do k=1,3
13222             do l=1,3
13223               dpkl=0.0d0
13224               do m=1,3
13225                 dpkl=dpkl+temp(k,m)*rt(m,l,j-1)
13226               enddo
13227               dp(k,l)=dpkl
13228               fromto(k,l)=dpkl
13229             enddo
13230           enddo
13231           do k=1,3
13232             do l=1,3
13233               temp(k,l)=dp(k,l)
13234             enddo
13235           enddo
13236       endif
13237 !      write (iout,*) "temp upon exit"
13238 !      write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
13239 !        enddo
13240 !      enddo
13241       return
13242       end subroutine build_fromto
13243 #endif
13244
13245 !-----------------------------------------------------------------------------
13246 ! checkder_p.F
13247 !-----------------------------------------------------------------------------
13248       subroutine check_cartgrad
13249 ! Check the gradient of Cartesian coordinates in internal coordinates.
13250 !      implicit real(kind=8) (a-h,o-z)
13251 !      include 'DIMENSIONS'
13252 !      include 'COMMON.IOUNITS'
13253 !      include 'COMMON.VAR'
13254 !      include 'COMMON.CHAIN'
13255 !      include 'COMMON.GEO'
13256 !      include 'COMMON.LOCAL'
13257 !      include 'COMMON.DERIV'
13258       real(kind=8),dimension(6,nres) :: temp
13259       real(kind=8),dimension(3) :: xx,gg
13260       integer :: i,k,j,ii
13261       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
13262 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
13263 !
13264 ! Check the gradient of the virtual-bond and SC vectors in the internal
13265 ! coordinates.
13266 !
13267       aincr=1.0d-6
13268       aincr2=5.0d-7
13269       call cartder
13270       write (iout,'(a)') '**************** dx/dalpha'
13271       write (iout,'(a)')
13272       do i=2,nres-1
13273       alphi=alph(i)
13274       alph(i)=alph(i)+aincr
13275       do k=1,3
13276         temp(k,i)=dc(k,nres+i)
13277         enddo
13278       call chainbuild
13279       do k=1,3
13280         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
13281         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
13282         enddo
13283         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
13284         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
13285         write (iout,'(a)')
13286       alph(i)=alphi
13287       call chainbuild
13288       enddo
13289       write (iout,'(a)')
13290       write (iout,'(a)') '**************** dx/domega'
13291       write (iout,'(a)')
13292       do i=2,nres-1
13293       omegi=omeg(i)
13294       omeg(i)=omeg(i)+aincr
13295       do k=1,3
13296         temp(k,i)=dc(k,nres+i)
13297         enddo
13298       call chainbuild
13299       do k=1,3
13300           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
13301           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
13302                 (aincr*dabs(dxds(k+3,i))+aincr))
13303         enddo
13304         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
13305             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
13306         write (iout,'(a)')
13307       omeg(i)=omegi
13308       call chainbuild
13309       enddo
13310       write (iout,'(a)')
13311       write (iout,'(a)') '**************** dx/dtheta'
13312       write (iout,'(a)')
13313       do i=3,nres
13314       theti=theta(i)
13315         theta(i)=theta(i)+aincr
13316         do j=i-1,nres-1
13317           do k=1,3
13318             temp(k,j)=dc(k,nres+j)
13319           enddo
13320         enddo
13321         call chainbuild
13322         do j=i-1,nres-1
13323         ii = indmat(i-2,j)
13324 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
13325         do k=1,3
13326           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
13327           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
13328                   (aincr*dabs(dxdv(k,ii))+aincr))
13329           enddo
13330           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13331               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
13332           write(iout,'(a)')
13333         enddo
13334         write (iout,'(a)')
13335         theta(i)=theti
13336         call chainbuild
13337       enddo
13338       write (iout,'(a)') '***************** dx/dphi'
13339       write (iout,'(a)')
13340       do i=4,nres
13341         phi(i)=phi(i)+aincr
13342         do j=i-1,nres-1
13343           do k=1,3
13344             temp(k,j)=dc(k,nres+j)
13345           enddo
13346         enddo
13347         call chainbuild
13348         do j=i-1,nres-1
13349         ii = indmat(i-2,j)
13350 !         print *,'ii=',ii
13351         do k=1,3
13352           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
13353             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
13354                   (aincr*dabs(dxdv(k+3,ii))+aincr))
13355           enddo
13356           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13357               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13358           write(iout,'(a)')
13359         enddo
13360         phi(i)=phi(i)-aincr
13361         call chainbuild
13362       enddo
13363       write (iout,'(a)') '****************** ddc/dtheta'
13364       do i=1,nres-2
13365         thet=theta(i+2)
13366         theta(i+2)=thet+aincr
13367         do j=i,nres
13368           do k=1,3
13369             temp(k,j)=dc(k,j)
13370           enddo
13371         enddo
13372         call chainbuild
13373         do j=i+1,nres-1
13374         ii = indmat(i,j)
13375 !         print *,'ii=',ii
13376         do k=1,3
13377           gg(k)=(dc(k,j)-temp(k,j))/aincr
13378           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
13379                  (aincr*dabs(dcdv(k,ii))+aincr))
13380           enddo
13381           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13382                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
13383         write (iout,'(a)')
13384         enddo
13385         do j=1,nres
13386           do k=1,3
13387             dc(k,j)=temp(k,j)
13388           enddo
13389         enddo
13390         theta(i+2)=thet
13391       enddo
13392       write (iout,'(a)') '******************* ddc/dphi'
13393       do i=1,nres-3
13394         phii=phi(i+3)
13395         phi(i+3)=phii+aincr
13396         do j=1,nres
13397           do k=1,3
13398             temp(k,j)=dc(k,j)
13399           enddo
13400         enddo
13401         call chainbuild
13402         do j=i+2,nres-1
13403         ii = indmat(i+1,j)
13404 !         print *,'ii=',ii
13405         do k=1,3
13406           gg(k)=(dc(k,j)-temp(k,j))/aincr
13407             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
13408                  (aincr*dabs(dcdv(k+3,ii))+aincr))
13409           enddo
13410           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13411                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13412         write (iout,'(a)')
13413         enddo
13414         do j=1,nres
13415           do k=1,3
13416             dc(k,j)=temp(k,j)
13417           enddo
13418         enddo
13419         phi(i+3)=phii
13420       enddo
13421       return
13422       end subroutine check_cartgrad
13423 !-----------------------------------------------------------------------------
13424       subroutine check_ecart
13425 ! Check the gradient of the energy in Cartesian coordinates.
13426 !     implicit real(kind=8) (a-h,o-z)
13427 !     include 'DIMENSIONS'
13428 !     include 'COMMON.CHAIN'
13429 !     include 'COMMON.DERIV'
13430 !     include 'COMMON.IOUNITS'
13431 !     include 'COMMON.VAR'
13432 !     include 'COMMON.CONTACTS'
13433       use comm_srutu
13434 !#ifdef LBFGS
13435 !      use minimm, only: funcgrad
13436 !#endif
13437 !el      integer :: icall
13438 !el      common /srutu/ icall
13439 !      real(kind=8) :: funcgrad
13440       real(kind=8),dimension(6) :: ggg
13441       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13442       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13443       real(kind=8),dimension(6,nres) :: grad_s
13444       real(kind=8),dimension(0:n_ene) :: energia,energia1
13445       integer :: uiparm(1)
13446       real(kind=8) :: urparm(1)
13447 !EL      external fdum
13448       integer :: nf,i,j,k
13449       real(kind=8) :: aincr,etot,etot1,ff
13450       icg=1
13451       nf=0
13452       nfl=0
13453       call zerograd
13454       aincr=1.0D-5
13455       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
13456       nf=0
13457       icall=0
13458       call geom_to_var(nvar,x)
13459       call etotal(energia)
13460       etot=energia(0)
13461 #ifdef LBFGS
13462       ff=funcgrad(x,g)
13463 #else
13464 !el      call enerprint(energia)
13465       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
13466 #endif
13467       icall =1
13468       do i=1,nres
13469         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13470       enddo
13471       do i=1,nres
13472       do j=1,3
13473         grad_s(j,i)=gradc(j,i,icg)
13474         grad_s(j+3,i)=gradx(j,i,icg)
13475         enddo
13476       enddo
13477       call flush(iout)
13478       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13479       do i=1,nres
13480         do j=1,3
13481         xx(j)=c(j,i+nres)
13482         ddc(j)=dc(j,i)
13483         ddx(j)=dc(j,i+nres)
13484         enddo
13485       do j=1,3
13486         dc(j,i)=dc(j,i)+aincr
13487         do k=i+1,nres
13488           c(j,k)=c(j,k)+aincr
13489           c(j,k+nres)=c(j,k+nres)+aincr
13490           enddo
13491           call zerograd
13492           call etotal(energia1)
13493           etot1=energia1(0)
13494         ggg(j)=(etot1-etot)/aincr
13495         dc(j,i)=ddc(j)
13496         do k=i+1,nres
13497           c(j,k)=c(j,k)-aincr
13498           c(j,k+nres)=c(j,k+nres)-aincr
13499           enddo
13500         enddo
13501       do j=1,3
13502         c(j,i+nres)=c(j,i+nres)+aincr
13503         dc(j,i+nres)=dc(j,i+nres)+aincr
13504           call zerograd
13505           call etotal(energia1)
13506           etot1=energia1(0)
13507         ggg(j+3)=(etot1-etot)/aincr
13508         c(j,i+nres)=xx(j)
13509         dc(j,i+nres)=ddx(j)
13510         enddo
13511       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
13512          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
13513       enddo
13514       return
13515       end subroutine check_ecart
13516 #ifdef CARGRAD
13517 !-----------------------------------------------------------------------------
13518       subroutine check_ecartint
13519 ! Check the gradient of the energy in Cartesian coordinates.
13520       use io_base, only: intout
13521       use MD_data, only: iset
13522 !      implicit real*8 (a-h,o-z)
13523 !      include 'DIMENSIONS'
13524 !      include 'COMMON.CONTROL'
13525 !      include 'COMMON.CHAIN'
13526 !      include 'COMMON.DERIV'
13527 !      include 'COMMON.IOUNITS'
13528 !      include 'COMMON.VAR'
13529 !      include 'COMMON.CONTACTS'
13530 !      include 'COMMON.MD'
13531 !      include 'COMMON.LOCAL'
13532 !      include 'COMMON.SPLITELE'
13533       use comm_srutu
13534 !el      integer :: icall
13535 !el      common /srutu/ icall
13536       real(kind=8),dimension(6) :: ggg,ggg1
13537       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
13538       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13539       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
13540       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13541       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13542       real(kind=8),dimension(0:n_ene) :: energia,energia1
13543       integer :: uiparm(1)
13544       real(kind=8) :: urparm(1)
13545 !EL      external fdum
13546       integer :: i,j,k,nf
13547       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13548                    etot21,etot22
13549       r_cut=2.0d0
13550       rlambd=0.3d0
13551       icg=1
13552       nf=0
13553       nfl=0
13554       if (iset.eq.0) iset=1
13555       call intout
13556 !      call intcartderiv
13557 !      call checkintcartgrad
13558       call zerograd
13559       aincr=1.0D-5
13560       write(iout,*) 'Calling CHECK_ECARTINT.,kupa'
13561       nf=0
13562       icall=0
13563       call geom_to_var(nvar,x)
13564       write (iout,*) "split_ene ",split_ene
13565       call flush(iout)
13566       if (.not.split_ene) then
13567         call zerograd
13568         call etotal(energia)
13569         etot=energia(0)
13570         call cartgrad
13571 #ifdef FIVEDIAG
13572         call grad_transform
13573 #endif
13574         icall =1
13575         do i=1,nres
13576           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13577         enddo
13578         do j=1,3
13579           grad_s(j,0)=gcart(j,0)
13580         enddo
13581         do i=1,nres
13582           do j=1,3
13583             grad_s(j,i)=gcart(j,i)
13584             grad_s(j+3,i)=gxcart(j,i)
13585         write(iout,*) "before movement analytical gradient"
13586
13587           enddo
13588         enddo
13589         do i=1,nres
13590           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13591           (gxcart(j,i),j=1,3)
13592         enddo
13593
13594       else
13595 !- split gradient check
13596         call zerograd
13597         call etotal_long(energia)
13598 !el        call enerprint(energia)
13599         call cartgrad
13600 #ifdef FIVEDIAG
13601         call grad_transform
13602 #endif
13603         icall =1
13604         do i=1,nres
13605           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13606           (gxcart(j,i),j=1,3)
13607         enddo
13608         do j=1,3
13609           grad_s(j,0)=gcart(j,0)
13610         enddo
13611         do i=1,nres
13612           do j=1,3
13613             grad_s(j,i)=gcart(j,i)
13614             grad_s(j+3,i)=gxcart(j,i)
13615           enddo
13616         enddo
13617         call zerograd
13618         call etotal_short(energia)
13619         call enerprint(energia)
13620         call cartgrad
13621 #ifdef FIVEDIAG
13622         call grad_transform
13623 #endif
13624
13625         icall =1
13626         do i=1,nres
13627           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13628           (gxcart(j,i),j=1,3)
13629         enddo
13630         do j=1,3
13631           grad_s1(j,0)=gcart(j,0)
13632         enddo
13633         do i=1,nres
13634           do j=1,3
13635             grad_s1(j,i)=gcart(j,i)
13636             grad_s1(j+3,i)=gxcart(j,i)
13637           enddo
13638         enddo
13639       endif
13640       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13641 #ifdef FIVEDIAG
13642       do i=1,nres
13643 #else
13644       do i=nnt,nct
13645 #endif
13646         do j=1,3
13647           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
13648           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
13649         ddc(j)=c(j,i)
13650         ddx(j)=c(j,i+nres)
13651           dcnorm_safe1(j)=dc_norm(j,i-1)
13652           dcnorm_safe2(j)=dc_norm(j,i)
13653           dxnorm_safe(j)=dc_norm(j,i+nres)
13654         enddo
13655       do j=1,3
13656         c(j,i)=ddc(j)+aincr
13657           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
13658           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
13659           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13660           dc(j,i)=c(j,i+1)-c(j,i)
13661           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13662           call int_from_cart1(.false.)
13663           if (.not.split_ene) then
13664            call zerograd
13665             call etotal(energia1)
13666             etot1=energia1(0)
13667 !            write (iout,*) "ij",i,j," etot1",etot1
13668           else
13669 !- split gradient
13670             call etotal_long(energia1)
13671             etot11=energia1(0)
13672             call etotal_short(energia1)
13673             etot12=energia1(0)
13674           endif
13675 !- end split gradient
13676 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13677         c(j,i)=ddc(j)-aincr
13678           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
13679           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
13680           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13681           dc(j,i)=c(j,i+1)-c(j,i)
13682           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13683           call int_from_cart1(.false.)
13684           if (.not.split_ene) then
13685             call zerograd
13686             call etotal(energia1)
13687             etot2=energia1(0)
13688 !            write (iout,*) "ij",i,j," etot2",etot2
13689           ggg(j)=(etot1-etot2)/(2*aincr)
13690           else
13691 !- split gradient
13692             call etotal_long(energia1)
13693             etot21=energia1(0)
13694           ggg(j)=(etot11-etot21)/(2*aincr)
13695             call etotal_short(energia1)
13696             etot22=energia1(0)
13697           ggg1(j)=(etot12-etot22)/(2*aincr)
13698 !- end split gradient
13699 !            write (iout,*) "etot21",etot21," etot22",etot22
13700           endif
13701 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13702         c(j,i)=ddc(j)
13703           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
13704           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
13705           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13706           dc(j,i)=c(j,i+1)-c(j,i)
13707           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13708           dc_norm(j,i-1)=dcnorm_safe1(j)
13709           dc_norm(j,i)=dcnorm_safe2(j)
13710           dc_norm(j,i+nres)=dxnorm_safe(j)
13711         enddo
13712       do j=1,3
13713         c(j,i+nres)=ddx(j)+aincr
13714           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13715           call int_from_cart1(.false.)
13716           if (.not.split_ene) then
13717             call zerograd
13718             call etotal(energia1)
13719             etot1=energia1(0)
13720           else
13721 !- split gradient
13722             call etotal_long(energia1)
13723             etot11=energia1(0)
13724             call etotal_short(energia1)
13725             etot12=energia1(0)
13726           endif
13727 !- end split gradient
13728         c(j,i+nres)=ddx(j)-aincr
13729           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13730           call int_from_cart1(.false.)
13731           if (.not.split_ene) then
13732            call zerograd
13733            call etotal(energia1)
13734             etot2=energia1(0)
13735           ggg(j+3)=(etot1-etot2)/(2*aincr)
13736           else
13737 !- split gradient
13738             call etotal_long(energia1)
13739             etot21=energia1(0)
13740           ggg(j+3)=(etot11-etot21)/(2*aincr)
13741             call etotal_short(energia1)
13742             etot22=energia1(0)
13743           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13744 !- end split gradient
13745           endif
13746 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13747         c(j,i+nres)=ddx(j)
13748           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13749           dc_norm(j,i+nres)=dxnorm_safe(j)
13750           call int_from_cart1(.false.)
13751         enddo
13752       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13753          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13754         if (split_ene) then
13755           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13756          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13757          k=1,6)
13758          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13759          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13760          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13761         endif
13762       enddo
13763       return
13764       end subroutine check_ecartint
13765 #else
13766 !-----------------------------------------------------------------------------
13767       subroutine check_ecartint
13768 ! Check the gradient of the energy in Cartesian coordinates.
13769       use io_base, only: intout
13770       use MD_data, only: iset
13771 !      implicit real*8 (a-h,o-z)
13772 !      include 'DIMENSIONS'
13773 !      include 'COMMON.CONTROL'
13774 !      include 'COMMON.CHAIN'
13775 !      include 'COMMON.DERIV'
13776 !      include 'COMMON.IOUNITS'
13777 !      include 'COMMON.VAR'
13778 !      include 'COMMON.CONTACTS'
13779 !      include 'COMMON.MD'
13780 !      include 'COMMON.LOCAL'
13781 !      include 'COMMON.SPLITELE'
13782       use comm_srutu
13783 !el      integer :: icall
13784 !el      common /srutu/ icall
13785       real(kind=8),dimension(6) :: ggg,ggg1
13786       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13787       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13788       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
13789       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13790       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13791       real(kind=8),dimension(0:n_ene) :: energia,energia1
13792       integer :: uiparm(1)
13793       real(kind=8) :: urparm(1)
13794 !EL      external fdum
13795       integer :: i,j,k,nf
13796       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13797                    etot21,etot22
13798       r_cut=2.0d0
13799       rlambd=0.3d0
13800       icg=1
13801       nf=0
13802       nfl=0
13803       if (iset.eq.0) iset=1
13804       call intout
13805 !      call intcartderiv
13806 !      call checkintcartgrad
13807       call zerograd
13808       aincr=1.0D-6
13809       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
13810       nf=0
13811       icall=0
13812       call geom_to_var(nvar,x)
13813       if (.not.split_ene) then
13814         call etotal(energia)
13815         etot=energia(0)
13816 !        call enerprint(energia)
13817         call cartgrad
13818         icall =1
13819         do i=1,nres
13820           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13821         enddo
13822         do j=1,3
13823           grad_s(j,0)=gcart(j,0)
13824           grad_s(j+3,0)=gxcart(j,0)
13825         enddo
13826         do i=1,nres
13827           do j=1,3
13828             grad_s(j,i)=gcart(j,i)
13829             grad_s(j+3,i)=gxcart(j,i)
13830           enddo
13831         enddo
13832         write(iout,*) "before movement analytical gradient"
13833         do i=1,nres
13834           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13835           (gxcart(j,i),j=1,3)
13836         enddo
13837
13838       else
13839 !- split gradient check
13840         call zerograd
13841         call etotal_long(energia)
13842 !el        call enerprint(energia)
13843         call cartgrad
13844         icall =1
13845         do i=1,nres
13846           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13847           (gxcart(j,i),j=1,3)
13848         enddo
13849         do j=1,3
13850           grad_s(j,0)=gcart(j,0)
13851         enddo
13852         do i=1,nres
13853           do j=1,3
13854             grad_s(j,i)=gcart(j,i)
13855 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
13856             grad_s(j+3,i)=gxcart(j,i)
13857           enddo
13858         enddo
13859         call zerograd
13860         call etotal_short(energia)
13861 !el        call enerprint(energia)
13862         call cartgrad
13863         icall =1
13864         do i=1,nres
13865           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13866           (gxcart(j,i),j=1,3)
13867         enddo
13868         do j=1,3
13869           grad_s1(j,0)=gcart(j,0)
13870         enddo
13871         do i=1,nres
13872           do j=1,3
13873             grad_s1(j,i)=gcart(j,i)
13874             grad_s1(j+3,i)=gxcart(j,i)
13875           enddo
13876         enddo
13877       endif
13878       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13879       do i=0,nres
13880         do j=1,3
13881         xx(j)=c(j,i+nres)
13882         ddc(j)=dc(j,i)
13883         ddx(j)=dc(j,i+nres)
13884           do k=1,3
13885             dcnorm_safe(k)=dc_norm(k,i)
13886             dxnorm_safe(k)=dc_norm(k,i+nres)
13887           enddo
13888         enddo
13889       do j=1,3
13890         dc(j,i)=ddc(j)+aincr
13891           call chainbuild_cart
13892 #ifdef MPI
13893 ! Broadcast the order to compute internal coordinates to the slaves.
13894 !          if (nfgtasks.gt.1)
13895 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
13896 #endif
13897 !          call int_from_cart1(.false.)
13898           if (.not.split_ene) then
13899            call zerograd
13900             call etotal(energia1)
13901             etot1=energia1(0)
13902 !            call enerprint(energia1)
13903           else
13904 !- split gradient
13905             call etotal_long(energia1)
13906             etot11=energia1(0)
13907             call etotal_short(energia1)
13908             etot12=energia1(0)
13909 !            write (iout,*) "etot11",etot11," etot12",etot12
13910           endif
13911 !- end split gradient
13912 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13913         dc(j,i)=ddc(j)-aincr
13914           call chainbuild_cart
13915 !          call int_from_cart1(.false.)
13916           if (.not.split_ene) then
13917                   call zerograd
13918             call etotal(energia1)
13919 !            call enerprint(energia1)
13920             etot2=energia1(0)
13921           ggg(j)=(etot1-etot2)/(2*aincr)
13922           else
13923 !- split gradient
13924             call etotal_long(energia1)
13925             etot21=energia1(0)
13926           ggg(j)=(etot11-etot21)/(2*aincr)
13927             call etotal_short(energia1)
13928             etot22=energia1(0)
13929           ggg1(j)=(etot12-etot22)/(2*aincr)
13930 !- end split gradient
13931 !            write (iout,*) "etot21",etot21," etot22",etot22
13932           endif
13933 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13934         dc(j,i)=ddc(j)
13935           call chainbuild_cart
13936         enddo
13937       do j=1,3
13938         dc(j,i+nres)=ddx(j)+aincr
13939           call chainbuild_cart
13940 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
13941 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13942 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13943 !          write (iout,*) "dxnormnorm",dsqrt(
13944 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13945 !          write (iout,*) "dxnormnormsafe",dsqrt(
13946 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13947 !          write (iout,*)
13948           if (.not.split_ene) then
13949             call zerograd
13950             call etotal(energia1)
13951 !            call enerprint(energia1)
13952             etot1=energia1(0)
13953 !            print *,"ene",energia1(0),energia1(57)
13954           else
13955 !- split gradient
13956             call etotal_long(energia1)
13957             etot11=energia1(0)
13958             call etotal_short(energia1)
13959             etot12=energia1(0)
13960           endif
13961 !- end split gradient
13962 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13963         dc(j,i+nres)=ddx(j)-aincr
13964           call chainbuild_cart
13965 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13966 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13967 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13968 !          write (iout,*)
13969 !          write (iout,*) "dxnormnorm",dsqrt(
13970 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13971 !          write (iout,*) "dxnormnormsafe",dsqrt(
13972 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13973           if (.not.split_ene) then
13974             call zerograd
13975             call etotal(energia1)
13976             etot2=energia1(0)
13977 !            call enerprint(energia1)
13978 !            print *,"ene",energia1(0),energia1(57)
13979           ggg(j+3)=(etot1-etot2)/(2*aincr)
13980           else
13981 !- split gradient
13982             call etotal_long(energia1)
13983             etot21=energia1(0)
13984           ggg(j+3)=(etot11-etot21)/(2*aincr)
13985             call etotal_short(energia1)
13986             etot22=energia1(0)
13987           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13988 !- end split gradient
13989           endif
13990 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13991         dc(j,i+nres)=ddx(j)
13992           call chainbuild_cart
13993         enddo
13994       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13995          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13996         if (split_ene) then
13997           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13998          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13999          k=1,6)
14000          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
14001          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
14002          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
14003         endif
14004       enddo
14005       return
14006       end subroutine check_ecartint
14007 #endif
14008 !-----------------------------------------------------------------------------
14009       subroutine check_eint
14010 ! Check the gradient of energy in internal coordinates.
14011 !      implicit real(kind=8) (a-h,o-z)
14012 !      include 'DIMENSIONS'
14013 !      include 'COMMON.CHAIN'
14014 !      include 'COMMON.DERIV'
14015 !      include 'COMMON.IOUNITS'
14016 !      include 'COMMON.VAR'
14017 !      include 'COMMON.GEO'
14018       use comm_srutu
14019 !#ifdef LBFGS
14020 !      use minimm, only : funcgrad
14021 !#endif
14022 !el      integer :: icall
14023 !el      common /srutu/ icall
14024 !      real(kind=8) :: funcgrad
14025       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
14026       integer :: uiparm(1)
14027       real(kind=8) :: urparm(1)
14028       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
14029       character(len=6) :: key
14030 !EL      external fdum
14031       integer :: i,ii,nf
14032       real(kind=8) :: xi,aincr,etot,etot1,etot2,ff
14033       call zerograd
14034       aincr=1.0D-7
14035       print '(a)','Calling CHECK_INT.'
14036       nf=0
14037       nfl=0
14038       icg=1
14039       call geom_to_var(nvar,x)
14040       call var_to_geom(nvar,x)
14041       call chainbuild
14042       icall=1
14043 !      print *,'ICG=',ICG
14044       call etotal(energia)
14045       etot = energia(0)
14046 !el      call enerprint(energia)
14047 !      print *,'ICG=',ICG
14048 #ifdef MPL
14049       if (MyID.ne.BossID) then
14050         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
14051         nf=x(nvar+1)
14052         nfl=x(nvar+2)
14053         icg=x(nvar+3)
14054       endif
14055 #endif
14056       nf=1
14057       nfl=3
14058 #ifdef LBFGS
14059       ff=funcgrad(x,gana)
14060 #else
14061
14062 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
14063       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
14064 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
14065 #endif
14066       icall=1
14067       do i=1,nvar
14068         xi=x(i)
14069         x(i)=xi-0.5D0*aincr
14070         call var_to_geom(nvar,x)
14071         call chainbuild
14072         call etotal(energia1)
14073         etot1=energia1(0)
14074         x(i)=xi+0.5D0*aincr
14075         call var_to_geom(nvar,x)
14076         call chainbuild
14077         call etotal(energia2)
14078         etot2=energia2(0)
14079         gg(i)=(etot2-etot1)/aincr
14080         write (iout,*) i,etot1,etot2
14081         x(i)=xi
14082       enddo
14083       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
14084           '     RelDiff*100% '
14085       do i=1,nvar
14086         if (i.le.nphi) then
14087           ii=i
14088           key = ' phi'
14089         else if (i.le.nphi+ntheta) then
14090           ii=i-nphi
14091           key=' theta'
14092         else if (i.le.nphi+ntheta+nside) then
14093            ii=i-(nphi+ntheta)
14094            key=' alpha'
14095         else
14096            ii=i-(nphi+ntheta+nside)
14097            key=' omega'
14098         endif
14099         write (iout,'(i3,a,i3,3(1pd16.6))') &
14100        i,key,ii,gg(i),gana(i),&
14101        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
14102       enddo
14103       return
14104       end subroutine check_eint
14105 !-----------------------------------------------------------------------------
14106 ! econstr_local.F
14107 !-----------------------------------------------------------------------------
14108       subroutine Econstr_back
14109 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
14110 !      implicit real(kind=8) (a-h,o-z)
14111 !      include 'DIMENSIONS'
14112 !      include 'COMMON.CONTROL'
14113 !      include 'COMMON.VAR'
14114 !      include 'COMMON.MD'
14115       use MD_data
14116 !#ifndef LANG0
14117 !      include 'COMMON.LANGEVIN'
14118 !#else
14119 !      include 'COMMON.LANGEVIN.lang0'
14120 !#endif
14121 !      include 'COMMON.CHAIN'
14122 !      include 'COMMON.DERIV'
14123 !      include 'COMMON.GEO'
14124 !      include 'COMMON.LOCAL'
14125 !      include 'COMMON.INTERACT'
14126 !      include 'COMMON.IOUNITS'
14127 !      include 'COMMON.NAMES'
14128 !      include 'COMMON.TIME1'
14129       integer :: i,j,ii,k
14130       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
14131
14132       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
14133       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
14134       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
14135
14136       Uconst_back=0.0d0
14137       do i=1,nres
14138         dutheta(i)=0.0d0
14139         dugamma(i)=0.0d0
14140         do j=1,3
14141           duscdiff(j,i)=0.0d0
14142           duscdiffx(j,i)=0.0d0
14143         enddo
14144       enddo
14145       do i=1,nfrag_back
14146         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
14147 !
14148 ! Deviations from theta angles
14149 !
14150         utheta_i=0.0d0
14151         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
14152           dtheta_i=theta(j)-thetaref(j)
14153           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
14154           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
14155         enddo
14156         utheta(i)=utheta_i/(ii-1)
14157 !
14158 ! Deviations from gamma angles
14159 !
14160         ugamma_i=0.0d0
14161         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
14162           dgamma_i=pinorm(phi(j)-phiref(j))
14163 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
14164           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
14165           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
14166 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
14167         enddo
14168         ugamma(i)=ugamma_i/(ii-2)
14169 !
14170 ! Deviations from local SC geometry
14171 !
14172         uscdiff(i)=0.0d0
14173         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
14174           dxx=xxtab(j)-xxref(j)
14175           dyy=yytab(j)-yyref(j)
14176           dzz=zztab(j)-zzref(j)
14177           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
14178           do k=1,3
14179             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
14180              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
14181              (ii-1)
14182             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
14183              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
14184              (ii-1)
14185             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
14186            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
14187             /(ii-1)
14188           enddo
14189 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
14190 !     &      xxref(j),yyref(j),zzref(j)
14191         enddo
14192         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
14193 !        write (iout,*) i," uscdiff",uscdiff(i)
14194 !
14195 ! Put together deviations from local geometry
14196 !
14197         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
14198           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
14199 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
14200 !     &   " uconst_back",uconst_back
14201         utheta(i)=dsqrt(utheta(i))
14202         ugamma(i)=dsqrt(ugamma(i))
14203         uscdiff(i)=dsqrt(uscdiff(i))
14204       enddo
14205       return
14206       end subroutine Econstr_back
14207 !-----------------------------------------------------------------------------
14208 ! energy_p_new-sep_barrier.F
14209 !-----------------------------------------------------------------------------
14210       real(kind=8) function sscale(r)
14211 !      include "COMMON.SPLITELE"
14212       real(kind=8) :: r,gamm
14213       if(r.lt.r_cut-rlamb) then
14214         sscale=1.0d0
14215       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
14216         gamm=(r-(r_cut-rlamb))/rlamb
14217         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14218       else
14219         sscale=0d0
14220       endif
14221       return
14222       end function sscale
14223       real(kind=8) function sscale_grad(r)
14224 !      include "COMMON.SPLITELE"
14225       real(kind=8) :: r,gamm
14226       if(r.lt.r_cut-rlamb) then
14227         sscale_grad=0.0d0
14228       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
14229         gamm=(r-(r_cut-rlamb))/rlamb
14230         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
14231       else
14232         sscale_grad=0d0
14233       endif
14234       return
14235       end function sscale_grad
14236 !SCALINING MARTINI
14237       real(kind=8) function sscale_martini(r)
14238 !      include "COMMON.SPLITELE"
14239       real(kind=8) :: r,gamm
14240 !      print *,"here2",r_cut_mart,r
14241       if(r.lt.r_cut_mart-rlamb_mart) then
14242         sscale_martini=1.0d0
14243       else if(r.le.r_cut_mart.and.r.ge.r_cut_mart-rlamb_mart) then
14244         gamm=(r-(r_cut_mart-rlamb_mart))/rlamb_mart
14245         sscale_martini=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14246       else
14247         sscale_martini=0.0d0
14248       endif
14249       return
14250       end function sscale_martini
14251       real(kind=8) function sscale_grad_martini(r)
14252 !      include "COMMON.SPLITELE"
14253       real(kind=8) :: r,gamm
14254       if(r.lt.r_cut_mart-rlamb_mart) then
14255         sscale_grad_martini=0.0d0
14256       else if(r.le.r_cut_mart.and.r.ge.r_cut_mart-rlamb_mart) then
14257         gamm=(r-(r_cut_mart-rlamb_mart))/rlamb_mart
14258         sscale_grad_martini=gamm*(6*gamm-6.0d0)/rlamb_mart
14259       else
14260         sscale_grad_martini=0.0d0
14261       endif
14262       return
14263       end function sscale_grad_martini
14264       real(kind=8) function sscale_martini_angle(r)
14265 !      include "COMMON.SPLITELE"
14266       real(kind=8) :: r,gamm,r_cut_angle,rlamb_angle
14267 !      print *,"here2",r_cut_angle,r
14268        r_cut_angle=3.12d0
14269        rlamb_angle=0.1d0
14270       if(r.lt.r_cut_angle-rlamb_angle) then
14271         sscale_martini_angle=1.0d0
14272       else if(r.le.r_cut_angle.and.r.ge.r_cut_angle-rlamb_angle) then
14273         gamm=(r-(r_cut_angle-rlamb_angle))/rlamb_angle
14274         sscale_martini_angle=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14275       else
14276         sscale_martini_angle=0.0d0
14277       endif
14278       return
14279       end function sscale_martini_angle
14280       real(kind=8) function sscale_grad_martini_angle(r)
14281 !      include "COMMON.SPLITELE"
14282       real(kind=8) :: r,gamm,r_cut_angle,rlamb_angle
14283        r_cut_angle=3.12d0
14284        rlamb_angle=0.1d0
14285       if(r.lt.r_cut_angle-rlamb_angle) then
14286         sscale_grad_martini_angle=0.0d0
14287       else if(r.le.r_cut_angle.and.r.ge.r_cut_angle-rlamb_angle) then
14288         gamm=(r-(r_cut_angle-rlamb_angle))/rlamb_angle
14289         sscale_grad_martini_angle=gamm*(6*gamm-6.0d0)/rlamb_angle
14290       else
14291         sscale_grad_martini_angle=0.0d0
14292       endif
14293       return
14294       end function sscale_grad_martini_angle
14295
14296
14297 !!!!!!!!!! PBCSCALE
14298       real(kind=8) function sscale_ele(r)
14299 !      include "COMMON.SPLITELE"
14300       real(kind=8) :: r,gamm
14301       if(r.lt.r_cut_ele-rlamb_ele) then
14302         sscale_ele=1.0d0
14303       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
14304         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
14305         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14306       else
14307         sscale_ele=0d0
14308       endif
14309       return
14310       end function sscale_ele
14311
14312       real(kind=8)  function sscagrad_ele(r)
14313       real(kind=8) :: r,gamm
14314 !      include "COMMON.SPLITELE"
14315       if(r.lt.r_cut_ele-rlamb_ele) then
14316         sscagrad_ele=0.0d0
14317       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
14318         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
14319         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
14320       else
14321         sscagrad_ele=0.0d0
14322       endif
14323       return
14324       end function sscagrad_ele
14325 !!!!!!!!!! PBCSCALE
14326       real(kind=8) function sscale2(r,r_cc,r_ll)
14327 !      include "COMMON.SPLITELE"
14328       real(kind=8) :: r,gamm,r_cc,r_ll
14329       if(r.lt.r_cc-r_ll) then
14330         sscale2=1.0d0
14331       else if(r.le.r_cc.and.r.ge.r_cc-r_ll) then
14332         gamm=(r-(r_cc-r_ll))/r_ll
14333         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14334       else
14335         sscale2=0d0
14336       endif
14337       return
14338       end function sscale2
14339
14340       real(kind=8)  function sscagrad2(r,r_cc,r_ll)
14341       real(kind=8) :: r,gamm,r_cc,r_ll
14342 !      include "COMMON.SPLITELE"
14343       if(r.lt.r_cc-r_ll) then
14344         sscagrad2=0.0d0
14345       else if(r.le.r_cc.and.r.ge.r_cc-r_ll) then
14346         gamm=(r-(r_cc-r_ll))/r_ll
14347         sscagrad2=gamm*(6*gamm-6.0d0)/r_ll
14348       else
14349         sscagrad2=0.0d0
14350       endif
14351       return
14352       end function sscagrad2
14353
14354       real(kind=8) function sscalelip(r)
14355       real(kind=8) r,gamm
14356         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
14357       return
14358       end function sscalelip
14359 !C-----------------------------------------------------------------------
14360       real(kind=8) function sscagradlip(r)
14361       real(kind=8) r,gamm
14362         sscagradlip=r*(6.0d0*r-6.0d0)
14363       return
14364       end function sscagradlip
14365
14366 !!!!!!!!!!!!!!!
14367 !-----------------------------------------------------------------------------
14368       subroutine elj_long(evdw)
14369 !
14370 ! This subroutine calculates the interaction energy of nonbonded side chains
14371 ! assuming the LJ potential of interaction.
14372 !
14373 !      implicit real(kind=8) (a-h,o-z)
14374 !      include 'DIMENSIONS'
14375 !      include 'COMMON.GEO'
14376 !      include 'COMMON.VAR'
14377 !      include 'COMMON.LOCAL'
14378 !      include 'COMMON.CHAIN'
14379 !      include 'COMMON.DERIV'
14380 !      include 'COMMON.INTERACT'
14381 !      include 'COMMON.TORSION'
14382 !      include 'COMMON.SBRIDGE'
14383 !      include 'COMMON.NAMES'
14384 !      include 'COMMON.IOUNITS'
14385 !      include 'COMMON.CONTACTS'
14386       real(kind=8),parameter :: accur=1.0d-10
14387       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14388 !el local variables
14389       integer :: i,iint,j,k,itypi,itypi1,itypj
14390       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
14391       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
14392                       sslipj,ssgradlipj,aa,bb
14393 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
14394       evdw=0.0D0
14395       do i=iatsc_s,iatsc_e
14396         itypi=itype(i,1)
14397         if (itypi.eq.ntyp1) cycle
14398         itypi1=itype(i+1,1)
14399         xi=c(1,nres+i)
14400         yi=c(2,nres+i)
14401         zi=c(3,nres+i)
14402         call to_box(xi,yi,zi)
14403         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14404 !
14405 ! Calculate SC interaction energy.
14406 !
14407         do iint=1,nint_gr(i)
14408 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
14409 !d   &                  'iend=',iend(i,iint)
14410           do j=istart(i,iint),iend(i,iint)
14411             itypj=itype(j,1)
14412             if (itypj.eq.ntyp1) cycle
14413             xj=c(1,nres+j)-xi
14414             yj=c(2,nres+j)-yi
14415             zj=c(3,nres+j)-zi
14416             call to_box(xj,yj,zj)
14417             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14418             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14419              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14420             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14421              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14422             xj=boxshift(xj-xi,boxxsize)
14423             yj=boxshift(yj-yi,boxysize)
14424             zj=boxshift(zj-zi,boxzsize)
14425             rij=xj*xj+yj*yj+zj*zj
14426             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
14427             if (sss.lt.1.0d0) then
14428               rrij=1.0D0/rij
14429               eps0ij=eps(itypi,itypj)
14430               fac=rrij**expon2
14431               e1=fac*fac*aa_aq(itypi,itypj)
14432               e2=fac*bb_aq(itypi,itypj)
14433               evdwij=e1+e2
14434               evdw=evdw+(1.0d0-sss)*evdwij
14435 !
14436 ! Calculate the components of the gradient in DC and X
14437 !
14438               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
14439               gg(1)=xj*fac
14440               gg(2)=yj*fac
14441               gg(3)=zj*fac
14442               do k=1,3
14443                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14444                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14445                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14446                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14447               enddo
14448             endif
14449           enddo      ! j
14450         enddo        ! iint
14451       enddo          ! i
14452       do i=1,nct
14453         do j=1,3
14454           gvdwc(j,i)=expon*gvdwc(j,i)
14455           gvdwx(j,i)=expon*gvdwx(j,i)
14456         enddo
14457       enddo
14458 !******************************************************************************
14459 !
14460 !                              N O T E !!!
14461 !
14462 ! To save time, the factor of EXPON has been extracted from ALL components
14463 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14464 ! use!
14465 !
14466 !******************************************************************************
14467       return
14468       end subroutine elj_long
14469 !-----------------------------------------------------------------------------
14470       subroutine elj_short(evdw)
14471 !
14472 ! This subroutine calculates the interaction energy of nonbonded side chains
14473 ! assuming the LJ potential of interaction.
14474 !
14475 !      implicit real(kind=8) (a-h,o-z)
14476 !      include 'DIMENSIONS'
14477 !      include 'COMMON.GEO'
14478 !      include 'COMMON.VAR'
14479 !      include 'COMMON.LOCAL'
14480 !      include 'COMMON.CHAIN'
14481 !      include 'COMMON.DERIV'
14482 !      include 'COMMON.INTERACT'
14483 !      include 'COMMON.TORSION'
14484 !      include 'COMMON.SBRIDGE'
14485 !      include 'COMMON.NAMES'
14486 !      include 'COMMON.IOUNITS'
14487 !      include 'COMMON.CONTACTS'
14488       real(kind=8),parameter :: accur=1.0d-10
14489       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14490 !el local variables
14491       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
14492       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
14493       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
14494                       sslipj,ssgradlipj
14495 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
14496       evdw=0.0D0
14497       do i=iatsc_s,iatsc_e
14498         itypi=itype(i,1)
14499         if (itypi.eq.ntyp1) cycle
14500         itypi1=itype(i+1,1)
14501         xi=c(1,nres+i)
14502         yi=c(2,nres+i)
14503         zi=c(3,nres+i)
14504         call to_box(xi,yi,zi)
14505         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14506 ! Change 12/1/95
14507         num_conti=0
14508 !
14509 ! Calculate SC interaction energy.
14510 !
14511         do iint=1,nint_gr(i)
14512 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
14513 !d   &                  'iend=',iend(i,iint)
14514           do j=istart(i,iint),iend(i,iint)
14515             itypj=itype(j,1)
14516             if (itypj.eq.ntyp1) cycle
14517             xj=c(1,nres+j)-xi
14518             yj=c(2,nres+j)-yi
14519             zj=c(3,nres+j)-zi
14520 ! Change 12/1/95 to calculate four-body interactions
14521             rij=xj*xj+yj*yj+zj*zj
14522             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
14523             if (sss.gt.0.0d0) then
14524               rrij=1.0D0/rij
14525               eps0ij=eps(itypi,itypj)
14526               fac=rrij**expon2
14527               e1=fac*fac*aa_aq(itypi,itypj)
14528               e2=fac*bb_aq(itypi,itypj)
14529               evdwij=e1+e2
14530               evdw=evdw+sss*evdwij
14531 !
14532 ! Calculate the components of the gradient in DC and X
14533 !
14534               fac=-rrij*(e1+evdwij)*sss
14535               gg(1)=xj*fac
14536               gg(2)=yj*fac
14537               gg(3)=zj*fac
14538               do k=1,3
14539                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14540                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14541                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14542                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14543               enddo
14544             endif
14545           enddo      ! j
14546         enddo        ! iint
14547       enddo          ! i
14548       do i=1,nct
14549         do j=1,3
14550           gvdwc(j,i)=expon*gvdwc(j,i)
14551           gvdwx(j,i)=expon*gvdwx(j,i)
14552         enddo
14553       enddo
14554 !******************************************************************************
14555 !
14556 !                              N O T E !!!
14557 !
14558 ! To save time, the factor of EXPON has been extracted from ALL components
14559 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14560 ! use!
14561 !
14562 !******************************************************************************
14563       return
14564       end subroutine elj_short
14565 !-----------------------------------------------------------------------------
14566       subroutine eljk_long(evdw)
14567 !
14568 ! This subroutine calculates the interaction energy of nonbonded side chains
14569 ! assuming the LJK potential of interaction.
14570 !
14571 !      implicit real(kind=8) (a-h,o-z)
14572 !      include 'DIMENSIONS'
14573 !      include 'COMMON.GEO'
14574 !      include 'COMMON.VAR'
14575 !      include 'COMMON.LOCAL'
14576 !      include 'COMMON.CHAIN'
14577 !      include 'COMMON.DERIV'
14578 !      include 'COMMON.INTERACT'
14579 !      include 'COMMON.IOUNITS'
14580 !      include 'COMMON.NAMES'
14581       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14582       logical :: scheck
14583 !el local variables
14584       integer :: i,iint,j,k,itypi,itypi1,itypj
14585       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14586                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
14587 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14588       evdw=0.0D0
14589       do i=iatsc_s,iatsc_e
14590         itypi=itype(i,1)
14591         if (itypi.eq.ntyp1) cycle
14592         itypi1=itype(i+1,1)
14593         xi=c(1,nres+i)
14594         yi=c(2,nres+i)
14595         zi=c(3,nres+i)
14596           call to_box(xi,yi,zi)
14597
14598 !
14599 ! Calculate SC interaction energy.
14600 !
14601         do iint=1,nint_gr(i)
14602           do j=istart(i,iint),iend(i,iint)
14603             itypj=itype(j,1)
14604             if (itypj.eq.ntyp1) cycle
14605             xj=c(1,nres+j)-xi
14606             yj=c(2,nres+j)-yi
14607             zj=c(3,nres+j)-zi
14608           call to_box(xj,yj,zj)
14609       xj=boxshift(xj-xi,boxxsize)
14610       yj=boxshift(yj-yi,boxysize)
14611       zj=boxshift(zj-zi,boxzsize)
14612
14613             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14614             fac_augm=rrij**expon
14615             e_augm=augm(itypi,itypj)*fac_augm
14616             r_inv_ij=dsqrt(rrij)
14617             rij=1.0D0/r_inv_ij
14618             sss=sscale(rij/sigma(itypi,itypj))
14619             if (sss.lt.1.0d0) then
14620               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14621               fac=r_shift_inv**expon
14622               e1=fac*fac*aa_aq(itypi,itypj)
14623               e2=fac*bb_aq(itypi,itypj)
14624               evdwij=e_augm+e1+e2
14625 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14626 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14627 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14628 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14629 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14630 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14631 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14632               evdw=evdw+(1.0d0-sss)*evdwij
14633 !
14634 ! Calculate the components of the gradient in DC and X
14635 !
14636               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14637               fac=fac*(1.0d0-sss)
14638               gg(1)=xj*fac
14639               gg(2)=yj*fac
14640               gg(3)=zj*fac
14641               do k=1,3
14642                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14643                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14644                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14645                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14646               enddo
14647             endif
14648           enddo      ! j
14649         enddo        ! iint
14650       enddo          ! i
14651       do i=1,nct
14652         do j=1,3
14653           gvdwc(j,i)=expon*gvdwc(j,i)
14654           gvdwx(j,i)=expon*gvdwx(j,i)
14655         enddo
14656       enddo
14657       return
14658       end subroutine eljk_long
14659 !-----------------------------------------------------------------------------
14660       subroutine eljk_short(evdw)
14661 !
14662 ! This subroutine calculates the interaction energy of nonbonded side chains
14663 ! assuming the LJK potential of interaction.
14664 !
14665 !      implicit real(kind=8) (a-h,o-z)
14666 !      include 'DIMENSIONS'
14667 !      include 'COMMON.GEO'
14668 !      include 'COMMON.VAR'
14669 !      include 'COMMON.LOCAL'
14670 !      include 'COMMON.CHAIN'
14671 !      include 'COMMON.DERIV'
14672 !      include 'COMMON.INTERACT'
14673 !      include 'COMMON.IOUNITS'
14674 !      include 'COMMON.NAMES'
14675       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14676       logical :: scheck
14677 !el local variables
14678       integer :: i,iint,j,k,itypi,itypi1,itypj
14679       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14680                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
14681                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14682 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14683       evdw=0.0D0
14684       do i=iatsc_s,iatsc_e
14685         itypi=itype(i,1)
14686         if (itypi.eq.ntyp1) cycle
14687         itypi1=itype(i+1,1)
14688         xi=c(1,nres+i)
14689         yi=c(2,nres+i)
14690         zi=c(3,nres+i)
14691         call to_box(xi,yi,zi)
14692         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14693 !
14694 ! Calculate SC interaction energy.
14695 !
14696         do iint=1,nint_gr(i)
14697           do j=istart(i,iint),iend(i,iint)
14698             itypj=itype(j,1)
14699             if (itypj.eq.ntyp1) cycle
14700             xj=c(1,nres+j)-xi
14701             yj=c(2,nres+j)-yi
14702             zj=c(3,nres+j)-zi
14703             call to_box(xj,yj,zj)
14704             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14705             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14706              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14707             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14708              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14709             xj=boxshift(xj-xi,boxxsize)
14710             yj=boxshift(yj-yi,boxysize)
14711             zj=boxshift(zj-zi,boxzsize)
14712             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14713             fac_augm=rrij**expon
14714             e_augm=augm(itypi,itypj)*fac_augm
14715             r_inv_ij=dsqrt(rrij)
14716             rij=1.0D0/r_inv_ij
14717             sss=sscale(rij/sigma(itypi,itypj))
14718             if (sss.gt.0.0d0) then
14719               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14720               fac=r_shift_inv**expon
14721               e1=fac*fac*aa_aq(itypi,itypj)
14722               e2=fac*bb_aq(itypi,itypj)
14723               evdwij=e_augm+e1+e2
14724 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14725 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14726 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14727 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14728 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14729 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14730 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14731               evdw=evdw+sss*evdwij
14732 !
14733 ! Calculate the components of the gradient in DC and X
14734 !
14735               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14736               fac=fac*sss
14737               gg(1)=xj*fac
14738               gg(2)=yj*fac
14739               gg(3)=zj*fac
14740               do k=1,3
14741                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14742                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14743                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14744                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14745               enddo
14746             endif
14747           enddo      ! j
14748         enddo        ! iint
14749       enddo          ! i
14750       do i=1,nct
14751         do j=1,3
14752           gvdwc(j,i)=expon*gvdwc(j,i)
14753           gvdwx(j,i)=expon*gvdwx(j,i)
14754         enddo
14755       enddo
14756       return
14757       end subroutine eljk_short
14758 !-----------------------------------------------------------------------------
14759        subroutine ebp_long(evdw)
14760 ! This subroutine calculates the interaction energy of nonbonded side chains
14761 ! assuming the Berne-Pechukas potential of interaction.
14762 !
14763        use calc_data
14764 !      implicit real(kind=8) (a-h,o-z)
14765 !      include 'DIMENSIONS'
14766 !      include 'COMMON.GEO'
14767 !      include 'COMMON.VAR'
14768 !      include 'COMMON.LOCAL'
14769 !      include 'COMMON.CHAIN'
14770 !      include 'COMMON.DERIV'
14771 !      include 'COMMON.NAMES'
14772 !      include 'COMMON.INTERACT'
14773 !      include 'COMMON.IOUNITS'
14774 !      include 'COMMON.CALC'
14775        use comm_srutu
14776 !el      integer :: icall
14777 !el      common /srutu/ icall
14778 !     double precision rrsave(maxdim)
14779         logical :: lprn
14780 !el local variables
14781         integer :: iint,itypi,itypi1,itypj
14782         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
14783                         sslipj,ssgradlipj,aa,bb
14784         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
14785         evdw=0.0D0
14786 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14787         evdw=0.0D0
14788 !     if (icall.eq.0) then
14789 !       lprn=.true.
14790 !     else
14791       lprn=.false.
14792 !     endif
14793 !el      ind=0
14794       do i=iatsc_s,iatsc_e
14795       itypi=itype(i,1)
14796       if (itypi.eq.ntyp1) cycle
14797       itypi1=itype(i+1,1)
14798       xi=c(1,nres+i)
14799       yi=c(2,nres+i)
14800       zi=c(3,nres+i)
14801         call to_box(xi,yi,zi)
14802         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14803       dxi=dc_norm(1,nres+i)
14804       dyi=dc_norm(2,nres+i)
14805       dzi=dc_norm(3,nres+i)
14806 !        dsci_inv=dsc_inv(itypi)
14807       dsci_inv=vbld_inv(i+nres)
14808 !
14809 ! Calculate SC interaction energy.
14810 !
14811       do iint=1,nint_gr(i)
14812       do j=istart(i,iint),iend(i,iint)
14813 !el            ind=ind+1
14814       itypj=itype(j,1)
14815       if (itypj.eq.ntyp1) cycle
14816 !            dscj_inv=dsc_inv(itypj)
14817       dscj_inv=vbld_inv(j+nres)
14818 !chi1=chi(itypi,itypj)
14819 !chi2=chi(itypj,itypi)
14820 !chi12=chi1*chi2
14821 !chip1=chip(itypi)
14822       alf1=alp(itypi)
14823       alf2=alp(itypj)
14824       alf12=0.5D0*(alf1+alf2)
14825         xj=c(1,nres+j)-xi
14826         yj=c(2,nres+j)-yi
14827         zj=c(3,nres+j)-zi
14828             call to_box(xj,yj,zj)
14829             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14830             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14831              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14832             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14833              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14834             xj=boxshift(xj-xi,boxxsize)
14835             yj=boxshift(yj-yi,boxysize)
14836             zj=boxshift(zj-zi,boxzsize)
14837         dxj=dc_norm(1,nres+j)
14838         dyj=dc_norm(2,nres+j)
14839         dzj=dc_norm(3,nres+j)
14840         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14841         rij=dsqrt(rrij)
14842       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14843
14844         if (sss.lt.1.0d0) then
14845
14846         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14847         call sc_angular
14848         ! Calculate whole angle-dependent part of epsilon and contributions
14849         ! to its derivatives
14850         fac=(rrij*sigsq)**expon2
14851         e1=fac*fac*aa_aq(itypi,itypj)
14852         e2=fac*bb_aq(itypi,itypj)
14853       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14854         eps2der=evdwij*eps3rt
14855         eps3der=evdwij*eps2rt
14856         evdwij=evdwij*eps2rt*eps3rt
14857       evdw=evdw+evdwij*(1.0d0-sss)
14858         if (lprn) then
14859         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14860       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14861         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14862         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14863         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14864         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14865         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14866         !d     &          evdwij
14867         endif
14868         ! Calculate gradient components.
14869         e1=e1*eps1*eps2rt**2*eps3rt**2
14870       fac=-expon*(e1+evdwij)
14871         sigder=fac/sigsq
14872         fac=rrij*fac
14873         ! Calculate radial part of the gradient
14874         gg(1)=xj*fac
14875         gg(2)=yj*fac
14876         gg(3)=zj*fac
14877         ! Calculate the angular part of the gradient and sum add the contributions
14878         ! to the appropriate components of the Cartesian gradient.
14879       call sc_grad_scale(1.0d0-sss)
14880         endif
14881         enddo      ! j
14882         enddo        ! iint
14883         enddo          ! i
14884         !     stop
14885         return
14886         end subroutine ebp_long
14887         !-----------------------------------------------------------------------------
14888       subroutine ebp_short(evdw)
14889         !
14890         ! This subroutine calculates the interaction energy of nonbonded side chains
14891         ! assuming the Berne-Pechukas potential of interaction.
14892         !
14893         use calc_data
14894 !      implicit real(kind=8) (a-h,o-z)
14895         !      include 'DIMENSIONS'
14896         !      include 'COMMON.GEO'
14897         !      include 'COMMON.VAR'
14898         !      include 'COMMON.LOCAL'
14899         !      include 'COMMON.CHAIN'
14900         !      include 'COMMON.DERIV'
14901         !      include 'COMMON.NAMES'
14902         !      include 'COMMON.INTERACT'
14903         !      include 'COMMON.IOUNITS'
14904         !      include 'COMMON.CALC'
14905         use comm_srutu
14906         !el      integer :: icall
14907         !el      common /srutu/ icall
14908 !     double precision rrsave(maxdim)
14909         logical :: lprn
14910         !el local variables
14911         integer :: iint,itypi,itypi1,itypj
14912         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
14913         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
14914         sslipi,ssgradlipi,sslipj,ssgradlipj
14915         evdw=0.0D0
14916         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14917         evdw=0.0D0
14918         !     if (icall.eq.0) then
14919         !       lprn=.true.
14920         !     else
14921         lprn=.false.
14922         !     endif
14923         !el      ind=0
14924         do i=iatsc_s,iatsc_e
14925       itypi=itype(i,1)
14926         if (itypi.eq.ntyp1) cycle
14927         itypi1=itype(i+1,1)
14928         xi=c(1,nres+i)
14929         yi=c(2,nres+i)
14930         zi=c(3,nres+i)
14931         call to_box(xi,yi,zi)
14932       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14933
14934         dxi=dc_norm(1,nres+i)
14935         dyi=dc_norm(2,nres+i)
14936         dzi=dc_norm(3,nres+i)
14937         !        dsci_inv=dsc_inv(itypi)
14938       dsci_inv=vbld_inv(i+nres)
14939         !
14940         ! Calculate SC interaction energy.
14941         !
14942         do iint=1,nint_gr(i)
14943       do j=istart(i,iint),iend(i,iint)
14944         !el            ind=ind+1
14945       itypj=itype(j,1)
14946         if (itypj.eq.ntyp1) cycle
14947         !            dscj_inv=dsc_inv(itypj)
14948         dscj_inv=vbld_inv(j+nres)
14949         chi1=chi(itypi,itypj)
14950       chi2=chi(itypj,itypi)
14951         chi12=chi1*chi2
14952         chip1=chip(itypi)
14953       chip2=chip(itypj)
14954         chip12=chip1*chip2
14955         alf1=alp(itypi)
14956         alf2=alp(itypj)
14957       alf12=0.5D0*(alf1+alf2)
14958         xj=c(1,nres+j)-xi
14959         yj=c(2,nres+j)-yi
14960         zj=c(3,nres+j)-zi
14961         call to_box(xj,yj,zj)
14962       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14963         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14964         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14965         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14966              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14967             xj=boxshift(xj-xi,boxxsize)
14968             yj=boxshift(yj-yi,boxysize)
14969             zj=boxshift(zj-zi,boxzsize)
14970             dxj=dc_norm(1,nres+j)
14971             dyj=dc_norm(2,nres+j)
14972             dzj=dc_norm(3,nres+j)
14973             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14974             rij=dsqrt(rrij)
14975             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14976
14977             if (sss.gt.0.0d0) then
14978
14979 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14980               call sc_angular
14981 ! Calculate whole angle-dependent part of epsilon and contributions
14982 ! to its derivatives
14983               fac=(rrij*sigsq)**expon2
14984               e1=fac*fac*aa_aq(itypi,itypj)
14985               e2=fac*bb_aq(itypi,itypj)
14986               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14987               eps2der=evdwij*eps3rt
14988               eps3der=evdwij*eps2rt
14989               evdwij=evdwij*eps2rt*eps3rt
14990               evdw=evdw+evdwij*sss
14991               if (lprn) then
14992               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14993               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14994 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14995 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14996 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14997 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14998 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14999 !d     &          evdwij
15000               endif
15001 ! Calculate gradient components.
15002               e1=e1*eps1*eps2rt**2*eps3rt**2
15003               fac=-expon*(e1+evdwij)
15004               sigder=fac/sigsq
15005               fac=rrij*fac
15006 ! Calculate radial part of the gradient
15007               gg(1)=xj*fac
15008               gg(2)=yj*fac
15009               gg(3)=zj*fac
15010 ! Calculate the angular part of the gradient and sum add the contributions
15011 ! to the appropriate components of the Cartesian gradient.
15012               call sc_grad_scale(sss)
15013             endif
15014           enddo      ! j
15015         enddo        ! iint
15016       enddo          ! i
15017 !     stop
15018       return
15019       end subroutine ebp_short
15020 !-----------------------------------------------------------------------------
15021       subroutine egb_long(evdw)
15022 !
15023 ! This subroutine calculates the interaction energy of nonbonded side chains
15024 ! assuming the Gay-Berne potential of interaction.
15025 !
15026       use calc_data
15027 !      implicit real(kind=8) (a-h,o-z)
15028 !      include 'DIMENSIONS'
15029 !      include 'COMMON.GEO'
15030 !      include 'COMMON.VAR'
15031 !      include 'COMMON.LOCAL'
15032 !      include 'COMMON.CHAIN'
15033 !      include 'COMMON.DERIV'
15034 !      include 'COMMON.NAMES'
15035 !      include 'COMMON.INTERACT'
15036 !      include 'COMMON.IOUNITS'
15037 !      include 'COMMON.CALC'
15038 !      include 'COMMON.CONTROL'
15039       logical :: lprn
15040 !el local variables
15041       integer :: iint,itypi,itypi1,itypj,subchap
15042       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
15043       real(kind=8) :: sss,e1,e2,evdw,sss_grad
15044       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15045                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
15046                     ssgradlipi,ssgradlipj
15047
15048
15049       evdw=0.0D0
15050 !cccc      energy_dec=.false.
15051 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15052       evdw=0.0D0
15053       lprn=.false.
15054 !     if (icall.eq.0) lprn=.false.
15055 !el      ind=0
15056       do i=iatsc_s,iatsc_e
15057         itypi=itype(i,1)
15058         if (itypi.eq.ntyp1) cycle
15059         itypi1=itype(i+1,1)
15060         xi=c(1,nres+i)
15061         yi=c(2,nres+i)
15062         zi=c(3,nres+i)
15063         call to_box(xi,yi,zi)
15064         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15065         dxi=dc_norm(1,nres+i)
15066         dyi=dc_norm(2,nres+i)
15067         dzi=dc_norm(3,nres+i)
15068 !        dsci_inv=dsc_inv(itypi)
15069         dsci_inv=vbld_inv(i+nres)
15070 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
15071 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
15072 !
15073 ! Calculate SC interaction energy.
15074 !
15075         do iint=1,nint_gr(i)
15076           do j=istart(i,iint),iend(i,iint)
15077             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
15078 !              call dyn_ssbond_ene(i,j,evdwij)
15079 !              evdw=evdw+evdwij
15080 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15081 !                              'evdw',i,j,evdwij,' ss'
15082 !              if (energy_dec) write (iout,*) &
15083 !                              'evdw',i,j,evdwij,' ss'
15084 !             do k=j+1,iend(i,iint)
15085 !C search over all next residues
15086 !              if (dyn_ss_mask(k)) then
15087 !C check if they are cysteins
15088 !C              write(iout,*) 'k=',k
15089
15090 !c              write(iout,*) "PRZED TRI", evdwij
15091 !               evdwij_przed_tri=evdwij
15092 !              call triple_ssbond_ene(i,j,k,evdwij)
15093 !c               if(evdwij_przed_tri.ne.evdwij) then
15094 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
15095 !c               endif
15096
15097 !c              write(iout,*) "PO TRI", evdwij
15098 !C call the energy function that removes the artifical triple disulfide
15099 !C bond the soubroutine is located in ssMD.F
15100 !              evdw=evdw+evdwij
15101               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15102                             'evdw',i,j,evdwij,'tss'
15103 !              endif!dyn_ss_mask(k)
15104 !             enddo! k
15105
15106             ELSE
15107 !el            ind=ind+1
15108             itypj=itype(j,1)
15109             if (itypj.eq.ntyp1) cycle
15110 !            dscj_inv=dsc_inv(itypj)
15111             dscj_inv=vbld_inv(j+nres)
15112 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
15113 !     &       1.0d0/vbld(j+nres)
15114 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
15115             sig0ij=sigma(itypi,itypj)
15116             chi1=chi(itypi,itypj)
15117             chi2=chi(itypj,itypi)
15118             chi12=chi1*chi2
15119             chip1=chip(itypi)
15120             chip2=chip(itypj)
15121             chip12=chip1*chip2
15122             alf1=alp(itypi)
15123             alf2=alp(itypj)
15124             alf12=0.5D0*(alf1+alf2)
15125             xj=c(1,nres+j)
15126             yj=c(2,nres+j)
15127             zj=c(3,nres+j)
15128 ! Searching for nearest neighbour
15129             call to_box(xj,yj,zj)
15130             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15131             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15132              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15133             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15134              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15135             xj=boxshift(xj-xi,boxxsize)
15136             yj=boxshift(yj-yi,boxysize)
15137             zj=boxshift(zj-zi,boxzsize)
15138             dxj=dc_norm(1,nres+j)
15139             dyj=dc_norm(2,nres+j)
15140             dzj=dc_norm(3,nres+j)
15141             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15142             rij=dsqrt(rrij)
15143             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15144             sss_ele_cut=sscale_ele(1.0d0/(rij))
15145             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
15146             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
15147             if (sss_ele_cut.le.0.0) cycle
15148             if (sss.lt.1.0d0) then
15149
15150 ! Calculate angle-dependent terms of energy and contributions to their
15151 ! derivatives.
15152               call sc_angular
15153               sigsq=1.0D0/sigsq
15154               sig=sig0ij*dsqrt(sigsq)
15155               rij_shift=1.0D0/rij-sig+sig0ij
15156 ! for diagnostics; uncomment
15157 !              rij_shift=1.2*sig0ij
15158 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15159               if (rij_shift.le.0.0D0) then
15160                 evdw=1.0D20
15161 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
15162 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
15163 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
15164                 return
15165               endif
15166               sigder=-sig*sigsq
15167 !---------------------------------------------------------------
15168               rij_shift=1.0D0/rij_shift
15169               fac=rij_shift**expon
15170               e1=fac*fac*aa
15171               e2=fac*bb
15172               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15173               eps2der=evdwij*eps3rt
15174               eps3der=evdwij*eps2rt
15175 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
15176 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
15177               evdwij=evdwij*eps2rt*eps3rt
15178               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
15179               if (lprn) then
15180               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15181               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15182               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15183                 restyp(itypi,1),i,restyp(itypj,1),j,&
15184                 epsi,sigm,chi1,chi2,chip1,chip2,&
15185                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
15186                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15187                 evdwij
15188               endif
15189
15190               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15191                               'evdw',i,j,evdwij
15192 !              if (energy_dec) write (iout,*) &
15193 !                              'evdw',i,j,evdwij,"egb_long"
15194
15195 ! Calculate gradient components.
15196               e1=e1*eps1*eps2rt**2*eps3rt**2
15197               fac=-expon*(e1+evdwij)*rij_shift
15198               sigder=fac*sigder
15199               fac=rij*fac
15200               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
15201               *rij-sss_grad/(1.0-sss)*rij  &
15202             /sigmaii(itypi,itypj))
15203 !              fac=0.0d0
15204 ! Calculate the radial part of the gradient
15205               gg(1)=xj*fac
15206               gg(2)=yj*fac
15207               gg(3)=zj*fac
15208 ! Calculate angular part of the gradient.
15209               call sc_grad_scale(1.0d0-sss)
15210             ENDIF    !mask_dyn_ss
15211             endif
15212           enddo      ! j
15213         enddo        ! iint
15214       enddo          ! i
15215 !      write (iout,*) "Number of loop steps in EGB:",ind
15216 !ccc      energy_dec=.false.
15217       return
15218       end subroutine egb_long
15219 !-----------------------------------------------------------------------------
15220       subroutine egb_short(evdw)
15221 !
15222 ! This subroutine calculates the interaction energy of nonbonded side chains
15223 ! assuming the Gay-Berne potential of interaction.
15224 !
15225       use calc_data
15226 !      implicit real(kind=8) (a-h,o-z)
15227 !      include 'DIMENSIONS'
15228 !      include 'COMMON.GEO'
15229 !      include 'COMMON.VAR'
15230 !      include 'COMMON.LOCAL'
15231 !      include 'COMMON.CHAIN'
15232 !      include 'COMMON.DERIV'
15233 !      include 'COMMON.NAMES'
15234 !      include 'COMMON.INTERACT'
15235 !      include 'COMMON.IOUNITS'
15236 !      include 'COMMON.CALC'
15237 !      include 'COMMON.CONTROL'
15238       logical :: lprn
15239 !el local variables
15240       integer :: iint,itypi,itypi1,itypj,subchap,countss
15241       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
15242       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
15243       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15244                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
15245                     ssgradlipi,ssgradlipj
15246       evdw=0.0D0
15247 !cccc      energy_dec=.false.
15248 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15249       evdw=0.0D0
15250       lprn=.false.
15251       countss=0
15252 !     if (icall.eq.0) lprn=.false.
15253 !el      ind=0
15254       do i=iatsc_s,iatsc_e
15255         itypi=itype(i,1)
15256         if (itypi.eq.ntyp1) cycle
15257         itypi1=itype(i+1,1)
15258         xi=c(1,nres+i)
15259         yi=c(2,nres+i)
15260         zi=c(3,nres+i)
15261         call to_box(xi,yi,zi)
15262         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15263
15264         dxi=dc_norm(1,nres+i)
15265         dyi=dc_norm(2,nres+i)
15266         dzi=dc_norm(3,nres+i)
15267 !        dsci_inv=dsc_inv(itypi)
15268         dsci_inv=vbld_inv(i+nres)
15269
15270         dxi=dc_norm(1,nres+i)
15271         dyi=dc_norm(2,nres+i)
15272         dzi=dc_norm(3,nres+i)
15273 !        dsci_inv=dsc_inv(itypi)
15274         dsci_inv=vbld_inv(i+nres)
15275         do iint=1,nint_gr(i)
15276           do j=istart(i,iint),iend(i,iint)
15277             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
15278               countss=countss+1
15279               call dyn_ssbond_ene(i,j,evdwij,countss)
15280               evdw=evdw+evdwij
15281               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15282                               'evdw',i,j,evdwij,' ss'
15283              do k=j+1,iend(i,iint)
15284 !C search over all next residues
15285               if (dyn_ss_mask(k)) then
15286 !C check if they are cysteins
15287 !C              write(iout,*) 'k=',k
15288
15289 !c              write(iout,*) "PRZED TRI", evdwij
15290 !               evdwij_przed_tri=evdwij
15291               call triple_ssbond_ene(i,j,k,evdwij)
15292 !c               if(evdwij_przed_tri.ne.evdwij) then
15293 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
15294 !c               endif
15295
15296 !c              write(iout,*) "PO TRI", evdwij
15297 !C call the energy function that removes the artifical triple disulfide
15298 !C bond the soubroutine is located in ssMD.F
15299               evdw=evdw+evdwij
15300               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15301                             'evdw',i,j,evdwij,'tss'
15302               endif!dyn_ss_mask(k)
15303              enddo! k
15304             ELSE
15305
15306 !          typj=itype(j,1)
15307             if (itypj.eq.ntyp1) cycle
15308 !            dscj_inv=dsc_inv(itypj)
15309             dscj_inv=vbld_inv(j+nres)
15310             dscj_inv=dsc_inv(itypj)
15311 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
15312 !     &       1.0d0/vbld(j+nres)
15313 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
15314             sig0ij=sigma(itypi,itypj)
15315             chi1=chi(itypi,itypj)
15316             chi2=chi(itypj,itypi)
15317             chi12=chi1*chi2
15318             chip1=chip(itypi)
15319             chip2=chip(itypj)
15320             chip12=chip1*chip2
15321             alf1=alp(itypi)
15322             alf2=alp(itypj)
15323             alf12=0.5D0*(alf1+alf2)
15324 !            xj=c(1,nres+j)-xi
15325 !            yj=c(2,nres+j)-yi
15326 !            zj=c(3,nres+j)-zi
15327             xj=c(1,nres+j)
15328             yj=c(2,nres+j)
15329             zj=c(3,nres+j)
15330 ! Searching for nearest neighbour
15331             call to_box(xj,yj,zj)
15332             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15333             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15334              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15335             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15336              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15337             xj=boxshift(xj-xi,boxxsize)
15338             yj=boxshift(yj-yi,boxysize)
15339             zj=boxshift(zj-zi,boxzsize)
15340             dxj=dc_norm(1,nres+j)
15341             dyj=dc_norm(2,nres+j)
15342             dzj=dc_norm(3,nres+j)
15343             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15344             rij=dsqrt(rrij)
15345             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15346             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
15347             sss_ele_cut=sscale_ele(1.0d0/(rij))
15348             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
15349             if (sss_ele_cut.le.0.0) cycle
15350
15351             if (sss.gt.0.0d0) then
15352
15353 ! Calculate angle-dependent terms of energy and contributions to their
15354 ! derivatives.
15355               call sc_angular
15356               sigsq=1.0D0/sigsq
15357               sig=sig0ij*dsqrt(sigsq)
15358               rij_shift=1.0D0/rij-sig+sig0ij
15359 ! for diagnostics; uncomment
15360 !              rij_shift=1.2*sig0ij
15361 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15362               if (rij_shift.le.0.0D0) then
15363                 evdw=1.0D20
15364 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
15365 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
15366 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
15367                 return
15368               endif
15369               sigder=-sig*sigsq
15370 !---------------------------------------------------------------
15371               rij_shift=1.0D0/rij_shift
15372               fac=rij_shift**expon
15373               e1=fac*fac*aa
15374               e2=fac*bb
15375               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15376               eps2der=evdwij*eps3rt
15377               eps3der=evdwij*eps2rt
15378 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
15379 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
15380               evdwij=evdwij*eps2rt*eps3rt
15381               evdw=evdw+evdwij*sss*sss_ele_cut
15382               if (lprn) then
15383               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15384               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15385               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15386                 restyp(itypi,1),i,restyp(itypj,1),j,&
15387                 epsi,sigm,chi1,chi2,chip1,chip2,&
15388                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
15389                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15390                 evdwij
15391               endif
15392
15393               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15394                               'evdw',i,j,evdwij
15395 !              if (energy_dec) write (iout,*) &
15396 !                              'evdw',i,j,evdwij,"egb_short"
15397
15398 ! Calculate gradient components.
15399               e1=e1*eps1*eps2rt**2*eps3rt**2
15400               fac=-expon*(e1+evdwij)*rij_shift
15401               sigder=fac*sigder
15402               fac=rij*fac
15403               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
15404             *rij+sss_grad/sss*rij  &
15405             /sigmaii(itypi,itypj))
15406
15407 !              fac=0.0d0
15408 ! Calculate the radial part of the gradient
15409               gg(1)=xj*fac
15410               gg(2)=yj*fac
15411               gg(3)=zj*fac
15412 ! Calculate angular part of the gradient.
15413               call sc_grad_scale(sss)
15414             endif
15415           ENDIF !mask_dyn_ss
15416           enddo      ! j
15417         enddo        ! iint
15418       enddo          ! i
15419 !      write (iout,*) "Number of loop steps in EGB:",ind
15420 !ccc      energy_dec=.false.
15421       return
15422       end subroutine egb_short
15423 !-----------------------------------------------------------------------------
15424       subroutine egbv_long(evdw)
15425 !
15426 ! This subroutine calculates the interaction energy of nonbonded side chains
15427 ! assuming the Gay-Berne-Vorobjev potential of interaction.
15428 !
15429       use calc_data
15430 !      implicit real(kind=8) (a-h,o-z)
15431 !      include 'DIMENSIONS'
15432 !      include 'COMMON.GEO'
15433 !      include 'COMMON.VAR'
15434 !      include 'COMMON.LOCAL'
15435 !      include 'COMMON.CHAIN'
15436 !      include 'COMMON.DERIV'
15437 !      include 'COMMON.NAMES'
15438 !      include 'COMMON.INTERACT'
15439 !      include 'COMMON.IOUNITS'
15440 !      include 'COMMON.CALC'
15441       use comm_srutu
15442 !el      integer :: icall
15443 !el      common /srutu/ icall
15444       logical :: lprn
15445 !el local variables
15446       integer :: iint,itypi,itypi1,itypj
15447       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
15448                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
15449       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
15450       evdw=0.0D0
15451 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15452       evdw=0.0D0
15453       lprn=.false.
15454 !     if (icall.eq.0) lprn=.true.
15455 !el      ind=0
15456       do i=iatsc_s,iatsc_e
15457         itypi=itype(i,1)
15458         if (itypi.eq.ntyp1) cycle
15459         itypi1=itype(i+1,1)
15460         xi=c(1,nres+i)
15461         yi=c(2,nres+i)
15462         zi=c(3,nres+i)
15463         call to_box(xi,yi,zi)
15464         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15465         dxi=dc_norm(1,nres+i)
15466         dyi=dc_norm(2,nres+i)
15467         dzi=dc_norm(3,nres+i)
15468
15469 !        dsci_inv=dsc_inv(itypi)
15470         dsci_inv=vbld_inv(i+nres)
15471 !
15472 ! Calculate SC interaction energy.
15473 !
15474         do iint=1,nint_gr(i)
15475           do j=istart(i,iint),iend(i,iint)
15476 !el            ind=ind+1
15477             itypj=itype(j,1)
15478             if (itypj.eq.ntyp1) cycle
15479 !            dscj_inv=dsc_inv(itypj)
15480             dscj_inv=vbld_inv(j+nres)
15481             sig0ij=sigma(itypi,itypj)
15482             r0ij=r0(itypi,itypj)
15483             chi1=chi(itypi,itypj)
15484             chi2=chi(itypj,itypi)
15485             chi12=chi1*chi2
15486             chip1=chip(itypi)
15487             chip2=chip(itypj)
15488             chip12=chip1*chip2
15489             alf1=alp(itypi)
15490             alf2=alp(itypj)
15491             alf12=0.5D0*(alf1+alf2)
15492             xj=c(1,nres+j)-xi
15493             yj=c(2,nres+j)-yi
15494             zj=c(3,nres+j)-zi
15495             call to_box(xj,yj,zj)
15496             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15497             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15498             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15499             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15500             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15501             xj=boxshift(xj-xi,boxxsize)
15502             yj=boxshift(yj-yi,boxysize)
15503             zj=boxshift(zj-zi,boxzsize)
15504             dxj=dc_norm(1,nres+j)
15505             dyj=dc_norm(2,nres+j)
15506             dzj=dc_norm(3,nres+j)
15507             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15508             rij=dsqrt(rrij)
15509
15510             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15511
15512             if (sss.lt.1.0d0) then
15513
15514 ! Calculate angle-dependent terms of energy and contributions to their
15515 ! derivatives.
15516               call sc_angular
15517               sigsq=1.0D0/sigsq
15518               sig=sig0ij*dsqrt(sigsq)
15519               rij_shift=1.0D0/rij-sig+r0ij
15520 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15521               if (rij_shift.le.0.0D0) then
15522                 evdw=1.0D20
15523                 return
15524               endif
15525               sigder=-sig*sigsq
15526 !---------------------------------------------------------------
15527               rij_shift=1.0D0/rij_shift
15528               fac=rij_shift**expon
15529               e1=fac*fac*aa_aq(itypi,itypj)
15530               e2=fac*bb_aq(itypi,itypj)
15531               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15532               eps2der=evdwij*eps3rt
15533               eps3der=evdwij*eps2rt
15534               fac_augm=rrij**expon
15535               e_augm=augm(itypi,itypj)*fac_augm
15536               evdwij=evdwij*eps2rt*eps3rt
15537               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
15538               if (lprn) then
15539               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15540               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15541               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15542                 restyp(itypi,1),i,restyp(itypj,1),j,&
15543                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15544                 chi1,chi2,chip1,chip2,&
15545                 eps1,eps2rt**2,eps3rt**2,&
15546                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15547                 evdwij+e_augm
15548               endif
15549 ! Calculate gradient components.
15550               e1=e1*eps1*eps2rt**2*eps3rt**2
15551               fac=-expon*(e1+evdwij)*rij_shift
15552               sigder=fac*sigder
15553               fac=rij*fac-2*expon*rrij*e_augm
15554 ! Calculate the radial part of the gradient
15555               gg(1)=xj*fac
15556               gg(2)=yj*fac
15557               gg(3)=zj*fac
15558 ! Calculate angular part of the gradient.
15559               call sc_grad_scale(1.0d0-sss)
15560             endif
15561           enddo      ! j
15562         enddo        ! iint
15563       enddo          ! i
15564       end subroutine egbv_long
15565 !-----------------------------------------------------------------------------
15566       subroutine egbv_short(evdw)
15567 !
15568 ! This subroutine calculates the interaction energy of nonbonded side chains
15569 ! assuming the Gay-Berne-Vorobjev potential of interaction.
15570 !
15571       use calc_data
15572 !      implicit real(kind=8) (a-h,o-z)
15573 !      include 'DIMENSIONS'
15574 !      include 'COMMON.GEO'
15575 !      include 'COMMON.VAR'
15576 !      include 'COMMON.LOCAL'
15577 !      include 'COMMON.CHAIN'
15578 !      include 'COMMON.DERIV'
15579 !      include 'COMMON.NAMES'
15580 !      include 'COMMON.INTERACT'
15581 !      include 'COMMON.IOUNITS'
15582 !      include 'COMMON.CALC'
15583       use comm_srutu
15584 !el      integer :: icall
15585 !el      common /srutu/ icall
15586       logical :: lprn
15587 !el local variables
15588       integer :: iint,itypi,itypi1,itypj
15589       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
15590                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
15591       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
15592       evdw=0.0D0
15593 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15594       evdw=0.0D0
15595       lprn=.false.
15596 !     if (icall.eq.0) lprn=.true.
15597 !el      ind=0
15598       do i=iatsc_s,iatsc_e
15599         itypi=itype(i,1)
15600         if (itypi.eq.ntyp1) cycle
15601         itypi1=itype(i+1,1)
15602         xi=c(1,nres+i)
15603         yi=c(2,nres+i)
15604         zi=c(3,nres+i)
15605         dxi=dc_norm(1,nres+i)
15606         dyi=dc_norm(2,nres+i)
15607         dzi=dc_norm(3,nres+i)
15608         call to_box(xi,yi,zi)
15609         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15610 !        dsci_inv=dsc_inv(itypi)
15611         dsci_inv=vbld_inv(i+nres)
15612 !
15613 ! Calculate SC interaction energy.
15614 !
15615         do iint=1,nint_gr(i)
15616           do j=istart(i,iint),iend(i,iint)
15617 !el            ind=ind+1
15618             itypj=itype(j,1)
15619             if (itypj.eq.ntyp1) cycle
15620 !            dscj_inv=dsc_inv(itypj)
15621             dscj_inv=vbld_inv(j+nres)
15622             sig0ij=sigma(itypi,itypj)
15623             r0ij=r0(itypi,itypj)
15624             chi1=chi(itypi,itypj)
15625             chi2=chi(itypj,itypi)
15626             chi12=chi1*chi2
15627             chip1=chip(itypi)
15628             chip2=chip(itypj)
15629             chip12=chip1*chip2
15630             alf1=alp(itypi)
15631             alf2=alp(itypj)
15632             alf12=0.5D0*(alf1+alf2)
15633             xj=c(1,nres+j)-xi
15634             yj=c(2,nres+j)-yi
15635             zj=c(3,nres+j)-zi
15636             call to_box(xj,yj,zj)
15637             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15638             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15639             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15640             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15641             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15642             xj=boxshift(xj-xi,boxxsize)
15643             yj=boxshift(yj-yi,boxysize)
15644             zj=boxshift(zj-zi,boxzsize)
15645             dxj=dc_norm(1,nres+j)
15646             dyj=dc_norm(2,nres+j)
15647             dzj=dc_norm(3,nres+j)
15648             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15649             rij=dsqrt(rrij)
15650
15651             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15652
15653             if (sss.gt.0.0d0) then
15654
15655 ! Calculate angle-dependent terms of energy and contributions to their
15656 ! derivatives.
15657               call sc_angular
15658               sigsq=1.0D0/sigsq
15659               sig=sig0ij*dsqrt(sigsq)
15660               rij_shift=1.0D0/rij-sig+r0ij
15661 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15662               if (rij_shift.le.0.0D0) then
15663                 evdw=1.0D20
15664                 return
15665               endif
15666               sigder=-sig*sigsq
15667 !---------------------------------------------------------------
15668               rij_shift=1.0D0/rij_shift
15669               fac=rij_shift**expon
15670               e1=fac*fac*aa_aq(itypi,itypj)
15671               e2=fac*bb_aq(itypi,itypj)
15672               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15673               eps2der=evdwij*eps3rt
15674               eps3der=evdwij*eps2rt
15675               fac_augm=rrij**expon
15676               e_augm=augm(itypi,itypj)*fac_augm
15677               evdwij=evdwij*eps2rt*eps3rt
15678               evdw=evdw+(evdwij+e_augm)*sss
15679               if (lprn) then
15680               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15681               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15682               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15683                 restyp(itypi,1),i,restyp(itypj,1),j,&
15684                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15685                 chi1,chi2,chip1,chip2,&
15686                 eps1,eps2rt**2,eps3rt**2,&
15687                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15688                 evdwij+e_augm
15689               endif
15690 ! Calculate gradient components.
15691               e1=e1*eps1*eps2rt**2*eps3rt**2
15692               fac=-expon*(e1+evdwij)*rij_shift
15693               sigder=fac*sigder
15694               fac=rij*fac-2*expon*rrij*e_augm
15695 ! Calculate the radial part of the gradient
15696               gg(1)=xj*fac
15697               gg(2)=yj*fac
15698               gg(3)=zj*fac
15699 ! Calculate angular part of the gradient.
15700               call sc_grad_scale(sss)
15701             endif
15702           enddo      ! j
15703         enddo        ! iint
15704       enddo          ! i
15705       end subroutine egbv_short
15706 !-----------------------------------------------------------------------------
15707       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15708 !
15709 ! This subroutine calculates the average interaction energy and its gradient
15710 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
15711 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
15712 ! The potential depends both on the distance of peptide-group centers and on
15713 ! the orientation of the CA-CA virtual bonds.
15714 !
15715 !      implicit real(kind=8) (a-h,o-z)
15716
15717       use comm_locel
15718 #ifdef MPI
15719       include 'mpif.h'
15720 #endif
15721 !      include 'DIMENSIONS'
15722 !      include 'COMMON.CONTROL'
15723 !      include 'COMMON.SETUP'
15724 !      include 'COMMON.IOUNITS'
15725 !      include 'COMMON.GEO'
15726 !      include 'COMMON.VAR'
15727 !      include 'COMMON.LOCAL'
15728 !      include 'COMMON.CHAIN'
15729 !      include 'COMMON.DERIV'
15730 !      include 'COMMON.INTERACT'
15731 !      include 'COMMON.CONTACTS'
15732 !      include 'COMMON.TORSION'
15733 !      include 'COMMON.VECTORS'
15734 !      include 'COMMON.FFIELD'
15735 !      include 'COMMON.TIME1'
15736       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
15737       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
15738       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15739 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15740       real(kind=8),dimension(4) :: muij
15741 !el      integer :: num_conti,j1,j2
15742 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15743 !el                   dz_normi,xmedi,ymedi,zmedi
15744 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15745 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15746 !el          num_conti,j1,j2
15747 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15748 #ifdef MOMENT
15749       real(kind=8) :: scal_el=1.0d0
15750 #else
15751       real(kind=8) :: scal_el=0.5d0
15752 #endif
15753 ! 12/13/98
15754 ! 13-go grudnia roku pamietnego...
15755       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15756                                              0.0d0,1.0d0,0.0d0,&
15757                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15758 !el local variables
15759       integer :: i,j,k
15760       real(kind=8) :: fac
15761       real(kind=8) :: dxj,dyj,dzj
15762       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
15763
15764 !      allocate(num_cont_hb(nres)) !(maxres)
15765 !d      write(iout,*) 'In EELEC'
15766 !d      do i=1,nloctyp
15767 !d        write(iout,*) 'Type',i
15768 !d        write(iout,*) 'B1',B1(:,i)
15769 !d        write(iout,*) 'B2',B2(:,i)
15770 !d        write(iout,*) 'CC',CC(:,:,i)
15771 !d        write(iout,*) 'DD',DD(:,:,i)
15772 !d        write(iout,*) 'EE',EE(:,:,i)
15773 !d      enddo
15774 !d      call check_vecgrad
15775 !d      stop
15776       if (icheckgrad.eq.1) then
15777         do i=1,nres-1
15778           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
15779           do k=1,3
15780             dc_norm(k,i)=dc(k,i)*fac
15781           enddo
15782 !          write (iout,*) 'i',i,' fac',fac
15783         enddo
15784       endif
15785       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15786           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
15787           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
15788 !        call vec_and_deriv
15789 #ifdef TIMING
15790         time01=MPI_Wtime()
15791 #endif
15792 !        print *, "before set matrices"
15793         call set_matrices
15794 !        print *,"after set martices"
15795 #ifdef TIMING
15796         time_mat=time_mat+MPI_Wtime()-time01
15797 #endif
15798       endif
15799 !d      do i=1,nres-1
15800 !d        write (iout,*) 'i=',i
15801 !d        do k=1,3
15802 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
15803 !d        enddo
15804 !d        do k=1,3
15805 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
15806 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
15807 !d        enddo
15808 !d      enddo
15809       t_eelecij=0.0d0
15810       ees=0.0D0
15811       evdw1=0.0D0
15812       eel_loc=0.0d0
15813       eello_turn3=0.0d0
15814       eello_turn4=0.0d0
15815 !el      ind=0
15816       do i=1,nres
15817         num_cont_hb(i)=0
15818       enddo
15819 !d      print '(a)','Enter EELEC'
15820 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
15821 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
15822 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
15823       do i=1,nres
15824         gel_loc_loc(i)=0.0d0
15825         gcorr_loc(i)=0.0d0
15826       enddo
15827 !
15828 !
15829 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
15830 !
15831 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
15832 !
15833       do i=iturn3_start,iturn3_end
15834         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
15835         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
15836         dxi=dc(1,i)
15837         dyi=dc(2,i)
15838         dzi=dc(3,i)
15839         dx_normi=dc_norm(1,i)
15840         dy_normi=dc_norm(2,i)
15841         dz_normi=dc_norm(3,i)
15842         xmedi=c(1,i)+0.5d0*dxi
15843         ymedi=c(2,i)+0.5d0*dyi
15844         zmedi=c(3,i)+0.5d0*dzi
15845         call to_box(xmedi,ymedi,zmedi)
15846         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15847         num_conti=0
15848         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
15849         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
15850         num_cont_hb(i)=num_conti
15851       enddo
15852       do i=iturn4_start,iturn4_end
15853         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
15854           .or. itype(i+3,1).eq.ntyp1 &
15855           .or. itype(i+4,1).eq.ntyp1) cycle
15856         dxi=dc(1,i)
15857         dyi=dc(2,i)
15858         dzi=dc(3,i)
15859         dx_normi=dc_norm(1,i)
15860         dy_normi=dc_norm(2,i)
15861         dz_normi=dc_norm(3,i)
15862         xmedi=c(1,i)+0.5d0*dxi
15863         ymedi=c(2,i)+0.5d0*dyi
15864         zmedi=c(3,i)+0.5d0*dzi
15865
15866         call to_box(xmedi,ymedi,zmedi)
15867         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15868
15869         num_conti=num_cont_hb(i)
15870         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
15871         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
15872           call eturn4(i,eello_turn4)
15873         num_cont_hb(i)=num_conti
15874       enddo   ! i
15875 !
15876 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
15877 !
15878       do i=iatel_s,iatel_e
15879         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15880         dxi=dc(1,i)
15881         dyi=dc(2,i)
15882         dzi=dc(3,i)
15883         dx_normi=dc_norm(1,i)
15884         dy_normi=dc_norm(2,i)
15885         dz_normi=dc_norm(3,i)
15886         xmedi=c(1,i)+0.5d0*dxi
15887         ymedi=c(2,i)+0.5d0*dyi
15888         zmedi=c(3,i)+0.5d0*dzi
15889         call to_box(xmedi,ymedi,zmedi)
15890         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15891 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
15892         num_conti=num_cont_hb(i)
15893         do j=ielstart(i),ielend(i)
15894           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15895           call eelecij_scale(i,j,ees,evdw1,eel_loc)
15896         enddo ! j
15897         num_cont_hb(i)=num_conti
15898       enddo   ! i
15899 !      write (iout,*) "Number of loop steps in EELEC:",ind
15900 !d      do i=1,nres
15901 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
15902 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
15903 !d      enddo
15904 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
15905 !cc      eel_loc=eel_loc+eello_turn3
15906 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
15907       return
15908       end subroutine eelec_scale
15909 !-----------------------------------------------------------------------------
15910       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
15911 !      implicit real(kind=8) (a-h,o-z)
15912
15913       use comm_locel
15914 !      include 'DIMENSIONS'
15915 #ifdef MPI
15916       include "mpif.h"
15917 #endif
15918 !      include 'COMMON.CONTROL'
15919 !      include 'COMMON.IOUNITS'
15920 !      include 'COMMON.GEO'
15921 !      include 'COMMON.VAR'
15922 !      include 'COMMON.LOCAL'
15923 !      include 'COMMON.CHAIN'
15924 !      include 'COMMON.DERIV'
15925 !      include 'COMMON.INTERACT'
15926 !      include 'COMMON.CONTACTS'
15927 !      include 'COMMON.TORSION'
15928 !      include 'COMMON.VECTORS'
15929 !      include 'COMMON.FFIELD'
15930 !      include 'COMMON.TIME1'
15931       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
15932       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
15933       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15934 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15935       real(kind=8),dimension(4) :: muij
15936       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15937                     dist_temp, dist_init,sss_grad
15938       integer xshift,yshift,zshift
15939
15940 !el      integer :: num_conti,j1,j2
15941 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15942 !el                   dz_normi,xmedi,ymedi,zmedi
15943 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15944 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15945 !el          num_conti,j1,j2
15946 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15947 #ifdef MOMENT
15948       real(kind=8) :: scal_el=1.0d0
15949 #else
15950       real(kind=8) :: scal_el=0.5d0
15951 #endif
15952 ! 12/13/98
15953 ! 13-go grudnia roku pamietnego...
15954       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15955                                              0.0d0,1.0d0,0.0d0,&
15956                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15957 !el local variables
15958       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15959       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15960       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15961       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15962       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15963       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15964       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15965                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15966                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15967                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15968                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15969                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
15970 !      integer :: maxconts
15971 !      maxconts = nres/4
15972 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15973 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15974 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15975 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15976 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15977 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15978 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15979 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15980 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15981 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15982 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15983 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15984 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15985
15986 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15987 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15988
15989 #ifdef MPI
15990           time00=MPI_Wtime()
15991 #endif
15992 !d      write (iout,*) "eelecij",i,j
15993 !el          ind=ind+1
15994           iteli=itel(i)
15995           itelj=itel(j)
15996           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15997           aaa=app(iteli,itelj)
15998           bbb=bpp(iteli,itelj)
15999           ael6i=ael6(iteli,itelj)
16000           ael3i=ael3(iteli,itelj)
16001           dxj=dc(1,j)
16002           dyj=dc(2,j)
16003           dzj=dc(3,j)
16004           dx_normj=dc_norm(1,j)
16005           dy_normj=dc_norm(2,j)
16006           dz_normj=dc_norm(3,j)
16007 !          xj=c(1,j)+0.5D0*dxj-xmedi
16008 !          yj=c(2,j)+0.5D0*dyj-ymedi
16009 !          zj=c(3,j)+0.5D0*dzj-zmedi
16010           xj=c(1,j)+0.5D0*dxj
16011           yj=c(2,j)+0.5D0*dyj
16012           zj=c(3,j)+0.5D0*dzj
16013           call to_box(xj,yj,zj)
16014           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
16015           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
16016           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
16017           xj=boxshift(xj-xmedi,boxxsize)
16018           yj=boxshift(yj-ymedi,boxysize)
16019           zj=boxshift(zj-zmedi,boxzsize)
16020           rij=xj*xj+yj*yj+zj*zj
16021           rrmij=1.0D0/rij
16022           rij=dsqrt(rij)
16023           rmij=1.0D0/rij
16024 ! For extracting the short-range part of Evdwpp
16025           sss=sscale(rij/rpp(iteli,itelj))
16026             sss_ele_cut=sscale_ele(rij)
16027             sss_ele_grad=sscagrad_ele(rij)
16028             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
16029 !             sss_ele_cut=1.0d0
16030 !             sss_ele_grad=0.0d0
16031             if (sss_ele_cut.le.0.0) go to 128
16032
16033           r3ij=rrmij*rmij
16034           r6ij=r3ij*r3ij
16035           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
16036           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
16037           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
16038           fac=cosa-3.0D0*cosb*cosg
16039           ev1=aaa*r6ij*r6ij
16040 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
16041           if (j.eq.i+2) ev1=scal_el*ev1
16042           ev2=bbb*r6ij
16043           fac3=ael6i*r6ij
16044           fac4=ael3i*r3ij
16045           evdwij=ev1+ev2
16046           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
16047           el2=fac4*fac
16048           eesij=el1+el2
16049 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
16050           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
16051           ees=ees+eesij*sss_ele_cut
16052           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
16053 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
16054 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
16055 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
16056 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
16057
16058           if (energy_dec) then
16059               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
16060               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
16061           endif
16062
16063 !
16064 ! Calculate contributions to the Cartesian gradient.
16065 !
16066 #ifdef SPLITELE
16067           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
16068           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
16069           fac1=fac
16070           erij(1)=xj*rmij
16071           erij(2)=yj*rmij
16072           erij(3)=zj*rmij
16073 !
16074 ! Radial derivatives. First process both termini of the fragment (i,j)
16075 !
16076           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
16077           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
16078           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
16079 !          do k=1,3
16080 !            ghalf=0.5D0*ggg(k)
16081 !            gelc(k,i)=gelc(k,i)+ghalf
16082 !            gelc(k,j)=gelc(k,j)+ghalf
16083 !          enddo
16084 ! 9/28/08 AL Gradient compotents will be summed only at the end
16085           do k=1,3
16086             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
16087             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
16088           enddo
16089 !
16090 ! Loop over residues i+1 thru j-1.
16091 !
16092 !grad          do k=i+1,j-1
16093 !grad            do l=1,3
16094 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
16095 !grad            enddo
16096 !grad          enddo
16097           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
16098           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
16099           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
16100           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
16101           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
16102           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
16103 !          do k=1,3
16104 !            ghalf=0.5D0*ggg(k)
16105 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
16106 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
16107 !          enddo
16108 ! 9/28/08 AL Gradient compotents will be summed only at the end
16109           do k=1,3
16110             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16111             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16112           enddo
16113 !
16114 ! Loop over residues i+1 thru j-1.
16115 !
16116 !grad          do k=i+1,j-1
16117 !grad            do l=1,3
16118 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
16119 !grad            enddo
16120 !grad          enddo
16121 #else
16122           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
16123           facel=(el1+eesij)*sss_ele_cut
16124           fac1=fac
16125           fac=-3*rrmij*(facvdw+facvdw+facel)
16126           erij(1)=xj*rmij
16127           erij(2)=yj*rmij
16128           erij(3)=zj*rmij
16129 !
16130 ! Radial derivatives. First process both termini of the fragment (i,j)
16131 !
16132           ggg(1)=fac*xj
16133           ggg(2)=fac*yj
16134           ggg(3)=fac*zj
16135 !          do k=1,3
16136 !            ghalf=0.5D0*ggg(k)
16137 !            gelc(k,i)=gelc(k,i)+ghalf
16138 !            gelc(k,j)=gelc(k,j)+ghalf
16139 !          enddo
16140 ! 9/28/08 AL Gradient compotents will be summed only at the end
16141           do k=1,3
16142             gelc_long(k,j)=gelc(k,j)+ggg(k)
16143             gelc_long(k,i)=gelc(k,i)-ggg(k)
16144           enddo
16145 !
16146 ! Loop over residues i+1 thru j-1.
16147 !
16148 !grad          do k=i+1,j-1
16149 !grad            do l=1,3
16150 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
16151 !grad            enddo
16152 !grad          enddo
16153 ! 9/28/08 AL Gradient compotents will be summed only at the end
16154           ggg(1)=facvdw*xj
16155           ggg(2)=facvdw*yj
16156           ggg(3)=facvdw*zj
16157           do k=1,3
16158             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16159             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16160           enddo
16161 #endif
16162 !
16163 ! Angular part
16164 !
16165           ecosa=2.0D0*fac3*fac1+fac4
16166           fac4=-3.0D0*fac4
16167           fac3=-6.0D0*fac3
16168           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
16169           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
16170           do k=1,3
16171             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
16172             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
16173           enddo
16174 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
16175 !d   &          (dcosg(k),k=1,3)
16176           do k=1,3
16177             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
16178           enddo
16179 !          do k=1,3
16180 !            ghalf=0.5D0*ggg(k)
16181 !            gelc(k,i)=gelc(k,i)+ghalf
16182 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
16183 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16184 !            gelc(k,j)=gelc(k,j)+ghalf
16185 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
16186 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16187 !          enddo
16188 !grad          do k=i+1,j-1
16189 !grad            do l=1,3
16190 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
16191 !grad            enddo
16192 !grad          enddo
16193           do k=1,3
16194             gelc(k,i)=gelc(k,i) &
16195                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16196                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
16197                      *sss_ele_cut
16198             gelc(k,j)=gelc(k,j) &
16199                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16200                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
16201                      *sss_ele_cut
16202             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
16203             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
16204           enddo
16205           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
16206               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
16207               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
16208 !
16209 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
16210 !   energy of a peptide unit is assumed in the form of a second-order
16211 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
16212 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
16213 !   are computed for EVERY pair of non-contiguous peptide groups.
16214 !
16215           if (j.lt.nres-1) then
16216             j1=j+1
16217             j2=j-1
16218           else
16219             j1=j-1
16220             j2=j-2
16221           endif
16222           kkk=0
16223           do k=1,2
16224             do l=1,2
16225               kkk=kkk+1
16226               muij(kkk)=mu(k,i)*mu(l,j)
16227             enddo
16228           enddo
16229 !d         write (iout,*) 'EELEC: i',i,' j',j
16230 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
16231 !d          write(iout,*) 'muij',muij
16232           ury=scalar(uy(1,i),erij)
16233           urz=scalar(uz(1,i),erij)
16234           vry=scalar(uy(1,j),erij)
16235           vrz=scalar(uz(1,j),erij)
16236           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
16237           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
16238           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
16239           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
16240           fac=dsqrt(-ael6i)*r3ij
16241           a22=a22*fac
16242           a23=a23*fac
16243           a32=a32*fac
16244           a33=a33*fac
16245 !d          write (iout,'(4i5,4f10.5)')
16246 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
16247 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
16248 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
16249 !d     &      uy(:,j),uz(:,j)
16250 !d          write (iout,'(4f10.5)')
16251 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
16252 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
16253 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
16254 !d           write (iout,'(9f10.5/)')
16255 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
16256 ! Derivatives of the elements of A in virtual-bond vectors
16257           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
16258           do k=1,3
16259             uryg(k,1)=scalar(erder(1,k),uy(1,i))
16260             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
16261             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
16262             urzg(k,1)=scalar(erder(1,k),uz(1,i))
16263             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
16264             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
16265             vryg(k,1)=scalar(erder(1,k),uy(1,j))
16266             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
16267             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
16268             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
16269             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
16270             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
16271           enddo
16272 ! Compute radial contributions to the gradient
16273           facr=-3.0d0*rrmij
16274           a22der=a22*facr
16275           a23der=a23*facr
16276           a32der=a32*facr
16277           a33der=a33*facr
16278           agg(1,1)=a22der*xj
16279           agg(2,1)=a22der*yj
16280           agg(3,1)=a22der*zj
16281           agg(1,2)=a23der*xj
16282           agg(2,2)=a23der*yj
16283           agg(3,2)=a23der*zj
16284           agg(1,3)=a32der*xj
16285           agg(2,3)=a32der*yj
16286           agg(3,3)=a32der*zj
16287           agg(1,4)=a33der*xj
16288           agg(2,4)=a33der*yj
16289           agg(3,4)=a33der*zj
16290 ! Add the contributions coming from er
16291           fac3=-3.0d0*fac
16292           do k=1,3
16293             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
16294             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
16295             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
16296             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
16297           enddo
16298           do k=1,3
16299 ! Derivatives in DC(i)
16300 !grad            ghalf1=0.5d0*agg(k,1)
16301 !grad            ghalf2=0.5d0*agg(k,2)
16302 !grad            ghalf3=0.5d0*agg(k,3)
16303 !grad            ghalf4=0.5d0*agg(k,4)
16304             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
16305             -3.0d0*uryg(k,2)*vry)!+ghalf1
16306             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
16307             -3.0d0*uryg(k,2)*vrz)!+ghalf2
16308             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
16309             -3.0d0*urzg(k,2)*vry)!+ghalf3
16310             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
16311             -3.0d0*urzg(k,2)*vrz)!+ghalf4
16312 ! Derivatives in DC(i+1)
16313             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
16314             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
16315             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
16316             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
16317             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
16318             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
16319             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
16320             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
16321 ! Derivatives in DC(j)
16322             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
16323             -3.0d0*vryg(k,2)*ury)!+ghalf1
16324             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
16325             -3.0d0*vrzg(k,2)*ury)!+ghalf2
16326             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
16327             -3.0d0*vryg(k,2)*urz)!+ghalf3
16328             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
16329             -3.0d0*vrzg(k,2)*urz)!+ghalf4
16330 ! Derivatives in DC(j+1) or DC(nres-1)
16331             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
16332             -3.0d0*vryg(k,3)*ury)
16333             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
16334             -3.0d0*vrzg(k,3)*ury)
16335             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
16336             -3.0d0*vryg(k,3)*urz)
16337             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
16338             -3.0d0*vrzg(k,3)*urz)
16339 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
16340 !grad              do l=1,4
16341 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
16342 !grad              enddo
16343 !grad            endif
16344           enddo
16345           acipa(1,1)=a22
16346           acipa(1,2)=a23
16347           acipa(2,1)=a32
16348           acipa(2,2)=a33
16349           a22=-a22
16350           a23=-a23
16351           do l=1,2
16352             do k=1,3
16353               agg(k,l)=-agg(k,l)
16354               aggi(k,l)=-aggi(k,l)
16355               aggi1(k,l)=-aggi1(k,l)
16356               aggj(k,l)=-aggj(k,l)
16357               aggj1(k,l)=-aggj1(k,l)
16358             enddo
16359           enddo
16360           if (j.lt.nres-1) then
16361             a22=-a22
16362             a32=-a32
16363             do l=1,3,2
16364               do k=1,3
16365                 agg(k,l)=-agg(k,l)
16366                 aggi(k,l)=-aggi(k,l)
16367                 aggi1(k,l)=-aggi1(k,l)
16368                 aggj(k,l)=-aggj(k,l)
16369                 aggj1(k,l)=-aggj1(k,l)
16370               enddo
16371             enddo
16372           else
16373             a22=-a22
16374             a23=-a23
16375             a32=-a32
16376             a33=-a33
16377             do l=1,4
16378               do k=1,3
16379                 agg(k,l)=-agg(k,l)
16380                 aggi(k,l)=-aggi(k,l)
16381                 aggi1(k,l)=-aggi1(k,l)
16382                 aggj(k,l)=-aggj(k,l)
16383                 aggj1(k,l)=-aggj1(k,l)
16384               enddo
16385             enddo
16386           endif
16387           ENDIF ! WCORR
16388           IF (wel_loc.gt.0.0d0) THEN
16389 ! Contribution to the local-electrostatic energy coming from the i-j pair
16390           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
16391            +a33*muij(4)
16392 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
16393 !           print *,"EELLOC",i,gel_loc_loc(i-1)
16394           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
16395                   'eelloc',i,j,eel_loc_ij
16396 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
16397
16398           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
16399 ! Partial derivatives in virtual-bond dihedral angles gamma
16400           if (i.gt.1) &
16401           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
16402                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
16403                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
16404                  *sss_ele_cut
16405           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
16406                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
16407                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
16408                  *sss_ele_cut
16409            xtemp(1)=xj
16410            xtemp(2)=yj
16411            xtemp(3)=zj
16412
16413 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
16414           do l=1,3
16415             ggg(l)=(agg(l,1)*muij(1)+ &
16416                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
16417             *sss_ele_cut &
16418              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
16419
16420             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
16421             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
16422 !grad            ghalf=0.5d0*ggg(l)
16423 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
16424 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
16425           enddo
16426 !grad          do k=i+1,j2
16427 !grad            do l=1,3
16428 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
16429 !grad            enddo
16430 !grad          enddo
16431 ! Remaining derivatives of eello
16432           do l=1,3
16433             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
16434                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
16435             *sss_ele_cut
16436
16437             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
16438                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
16439             *sss_ele_cut
16440
16441             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
16442                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
16443             *sss_ele_cut
16444
16445             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
16446                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
16447             *sss_ele_cut
16448
16449           enddo
16450           ENDIF
16451 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
16452 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
16453           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
16454              .and. num_conti.le.maxconts) then
16455 !            write (iout,*) i,j," entered corr"
16456 !
16457 ! Calculate the contact function. The ith column of the array JCONT will
16458 ! contain the numbers of atoms that make contacts with the atom I (of numbers
16459 ! greater than I). The arrays FACONT and GACONT will contain the values of
16460 ! the contact function and its derivative.
16461 !           r0ij=1.02D0*rpp(iteli,itelj)
16462 !           r0ij=1.11D0*rpp(iteli,itelj)
16463             r0ij=2.20D0*rpp(iteli,itelj)
16464 !           r0ij=1.55D0*rpp(iteli,itelj)
16465             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
16466 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
16467             if (fcont.gt.0.0D0) then
16468               num_conti=num_conti+1
16469               if (num_conti.gt.maxconts) then
16470 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
16471                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
16472                                ' will skip next contacts for this conf.',num_conti
16473               else
16474                 jcont_hb(num_conti,i)=j
16475 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
16476 !d     &           " jcont_hb",jcont_hb(num_conti,i)
16477                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
16478                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
16479 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
16480 !  terms.
16481                 d_cont(num_conti,i)=rij
16482 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
16483 !     --- Electrostatic-interaction matrix ---
16484                 a_chuj(1,1,num_conti,i)=a22
16485                 a_chuj(1,2,num_conti,i)=a23
16486                 a_chuj(2,1,num_conti,i)=a32
16487                 a_chuj(2,2,num_conti,i)=a33
16488 !     --- Gradient of rij
16489                 do kkk=1,3
16490                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
16491                 enddo
16492                 kkll=0
16493                 do k=1,2
16494                   do l=1,2
16495                     kkll=kkll+1
16496                     do m=1,3
16497                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
16498                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
16499                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
16500                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
16501                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
16502                     enddo
16503                   enddo
16504                 enddo
16505                 ENDIF
16506                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
16507 ! Calculate contact energies
16508                 cosa4=4.0D0*cosa
16509                 wij=cosa-3.0D0*cosb*cosg
16510                 cosbg1=cosb+cosg
16511                 cosbg2=cosb-cosg
16512 !               fac3=dsqrt(-ael6i)/r0ij**3
16513                 fac3=dsqrt(-ael6i)*r3ij
16514 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
16515                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
16516                 if (ees0tmp.gt.0) then
16517                   ees0pij=dsqrt(ees0tmp)
16518                 else
16519                   ees0pij=0
16520                 endif
16521 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
16522                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
16523                 if (ees0tmp.gt.0) then
16524                   ees0mij=dsqrt(ees0tmp)
16525                 else
16526                   ees0mij=0
16527                 endif
16528 !               ees0mij=0.0D0
16529                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
16530                      *sss_ele_cut
16531
16532                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
16533                      *sss_ele_cut
16534
16535 ! Diagnostics. Comment out or remove after debugging!
16536 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
16537 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
16538 !               ees0m(num_conti,i)=0.0D0
16539 ! End diagnostics.
16540 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
16541 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
16542 ! Angular derivatives of the contact function
16543                 ees0pij1=fac3/ees0pij
16544                 ees0mij1=fac3/ees0mij
16545                 fac3p=-3.0D0*fac3*rrmij
16546                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
16547                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
16548 !               ees0mij1=0.0D0
16549                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
16550                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
16551                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
16552                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
16553                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
16554                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
16555                 ecosap=ecosa1+ecosa2
16556                 ecosbp=ecosb1+ecosb2
16557                 ecosgp=ecosg1+ecosg2
16558                 ecosam=ecosa1-ecosa2
16559                 ecosbm=ecosb1-ecosb2
16560                 ecosgm=ecosg1-ecosg2
16561 ! Diagnostics
16562 !               ecosap=ecosa1
16563 !               ecosbp=ecosb1
16564 !               ecosgp=ecosg1
16565 !               ecosam=0.0D0
16566 !               ecosbm=0.0D0
16567 !               ecosgm=0.0D0
16568 ! End diagnostics
16569                 facont_hb(num_conti,i)=fcont
16570                 fprimcont=fprimcont/rij
16571 !d              facont_hb(num_conti,i)=1.0D0
16572 ! Following line is for diagnostics.
16573 !d              fprimcont=0.0D0
16574                 do k=1,3
16575                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
16576                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
16577                 enddo
16578                 do k=1,3
16579                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
16580                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
16581                 enddo
16582 !                gggp(1)=gggp(1)+ees0pijp*xj
16583 !                gggp(2)=gggp(2)+ees0pijp*yj
16584 !                gggp(3)=gggp(3)+ees0pijp*zj
16585 !                gggm(1)=gggm(1)+ees0mijp*xj
16586 !                gggm(2)=gggm(2)+ees0mijp*yj
16587 !                gggm(3)=gggm(3)+ees0mijp*zj
16588                 gggp(1)=gggp(1)+ees0pijp*xj &
16589                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16590                 gggp(2)=gggp(2)+ees0pijp*yj &
16591                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16592                 gggp(3)=gggp(3)+ees0pijp*zj &
16593                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16594
16595                 gggm(1)=gggm(1)+ees0mijp*xj &
16596                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16597
16598                 gggm(2)=gggm(2)+ees0mijp*yj &
16599                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16600
16601                 gggm(3)=gggm(3)+ees0mijp*zj &
16602                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16603
16604 ! Derivatives due to the contact function
16605                 gacont_hbr(1,num_conti,i)=fprimcont*xj
16606                 gacont_hbr(2,num_conti,i)=fprimcont*yj
16607                 gacont_hbr(3,num_conti,i)=fprimcont*zj
16608                 do k=1,3
16609 !
16610 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
16611 !          following the change of gradient-summation algorithm.
16612 !
16613 !grad                  ghalfp=0.5D0*gggp(k)
16614 !grad                  ghalfm=0.5D0*gggm(k)
16615 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
16616 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16617 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16618 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
16619 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16620 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16621 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
16622 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
16623 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16624 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16625 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
16626 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16627 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16628 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
16629                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
16630                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16631                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16632                      *sss_ele_cut
16633
16634                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
16635                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16636                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
16637                      *sss_ele_cut
16638
16639                   gacontp_hb3(k,num_conti,i)=gggp(k) &
16640                      *sss_ele_cut
16641
16642                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
16643                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16644                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16645                      *sss_ele_cut
16646
16647                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
16648                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16649                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
16650                      *sss_ele_cut
16651
16652                   gacontm_hb3(k,num_conti,i)=gggm(k) &
16653                      *sss_ele_cut
16654
16655                 enddo
16656               ENDIF ! wcorr
16657               endif  ! num_conti.le.maxconts
16658             endif  ! fcont.gt.0
16659           endif    ! j.gt.i+1
16660           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
16661             do k=1,4
16662               do l=1,3
16663                 ghalf=0.5d0*agg(l,k)
16664                 aggi(l,k)=aggi(l,k)+ghalf
16665                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
16666                 aggj(l,k)=aggj(l,k)+ghalf
16667               enddo
16668             enddo
16669             if (j.eq.nres-1 .and. i.lt.j-2) then
16670               do k=1,4
16671                 do l=1,3
16672                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
16673                 enddo
16674               enddo
16675             endif
16676           endif
16677  128      continue
16678 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
16679       return
16680       end subroutine eelecij_scale
16681 !-----------------------------------------------------------------------------
16682       subroutine evdwpp_short(evdw1)
16683 !
16684 ! Compute Evdwpp
16685 !
16686 !      implicit real(kind=8) (a-h,o-z)
16687 !      include 'DIMENSIONS'
16688 !      include 'COMMON.CONTROL'
16689 !      include 'COMMON.IOUNITS'
16690 !      include 'COMMON.GEO'
16691 !      include 'COMMON.VAR'
16692 !      include 'COMMON.LOCAL'
16693 !      include 'COMMON.CHAIN'
16694 !      include 'COMMON.DERIV'
16695 !      include 'COMMON.INTERACT'
16696 !      include 'COMMON.CONTACTS'
16697 !      include 'COMMON.TORSION'
16698 !      include 'COMMON.VECTORS'
16699 !      include 'COMMON.FFIELD'
16700       real(kind=8),dimension(3) :: ggg
16701 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
16702 #ifdef MOMENT
16703       real(kind=8) :: scal_el=1.0d0
16704 #else
16705       real(kind=8) :: scal_el=0.5d0
16706 #endif
16707 !el local variables
16708       integer :: i,j,k,iteli,itelj,num_conti,isubchap
16709       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
16710       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
16711                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
16712                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
16713       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16714                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
16715                    sslipj,ssgradlipj,faclipij2
16716       integer xshift,yshift,zshift
16717
16718
16719       evdw1=0.0D0
16720 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
16721 !     & " iatel_e_vdw",iatel_e_vdw
16722       call flush(iout)
16723       do i=iatel_s_vdw,iatel_e_vdw
16724         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
16725         dxi=dc(1,i)
16726         dyi=dc(2,i)
16727         dzi=dc(3,i)
16728         dx_normi=dc_norm(1,i)
16729         dy_normi=dc_norm(2,i)
16730         dz_normi=dc_norm(3,i)
16731         xmedi=c(1,i)+0.5d0*dxi
16732         ymedi=c(2,i)+0.5d0*dyi
16733         zmedi=c(3,i)+0.5d0*dzi
16734         call to_box(xmedi,ymedi,zmedi)
16735         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
16736         num_conti=0
16737 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
16738 !     &   ' ielend',ielend_vdw(i)
16739         call flush(iout)
16740         do j=ielstart_vdw(i),ielend_vdw(i)
16741           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
16742 !el          ind=ind+1
16743           iteli=itel(i)
16744           itelj=itel(j)
16745           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
16746           aaa=app(iteli,itelj)
16747           bbb=bpp(iteli,itelj)
16748           dxj=dc(1,j)
16749           dyj=dc(2,j)
16750           dzj=dc(3,j)
16751           dx_normj=dc_norm(1,j)
16752           dy_normj=dc_norm(2,j)
16753           dz_normj=dc_norm(3,j)
16754 !          xj=c(1,j)+0.5D0*dxj-xmedi
16755 !          yj=c(2,j)+0.5D0*dyj-ymedi
16756 !          zj=c(3,j)+0.5D0*dzj-zmedi
16757           xj=c(1,j)+0.5D0*dxj
16758           yj=c(2,j)+0.5D0*dyj
16759           zj=c(3,j)+0.5D0*dzj
16760           call to_box(xj,yj,zj)
16761           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
16762           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
16763           xj=boxshift(xj-xmedi,boxxsize)
16764           yj=boxshift(yj-ymedi,boxysize)
16765           zj=boxshift(zj-zmedi,boxzsize)
16766           rij=xj*xj+yj*yj+zj*zj
16767           rrmij=1.0D0/rij
16768           rij=dsqrt(rij)
16769           sss=sscale(rij/rpp(iteli,itelj))
16770             sss_ele_cut=sscale_ele(rij)
16771             sss_ele_grad=sscagrad_ele(rij)
16772             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
16773             if (sss_ele_cut.le.0.0) cycle
16774           if (sss.gt.0.0d0) then
16775             rmij=1.0D0/rij
16776             r3ij=rrmij*rmij
16777             r6ij=r3ij*r3ij
16778             ev1=aaa*r6ij*r6ij
16779 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
16780             if (j.eq.i+2) ev1=scal_el*ev1
16781             ev2=bbb*r6ij
16782             evdwij=ev1+ev2
16783             if (energy_dec) then
16784               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
16785             endif
16786             evdw1=evdw1+evdwij*sss*sss_ele_cut
16787 !
16788 ! Calculate contributions to the Cartesian gradient.
16789 !
16790             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
16791 !            ggg(1)=facvdw*xj
16792 !            ggg(2)=facvdw*yj
16793 !            ggg(3)=facvdw*zj
16794           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
16795           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
16796           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
16797           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
16798           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
16799           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
16800
16801             do k=1,3
16802               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16803               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16804             enddo
16805           endif
16806         enddo ! j
16807       enddo   ! i
16808       return
16809       end subroutine evdwpp_short
16810 !-----------------------------------------------------------------------------
16811       subroutine escp_long(evdw2,evdw2_14)
16812 !
16813 ! This subroutine calculates the excluded-volume interaction energy between
16814 ! peptide-group centers and side chains and its gradient in virtual-bond and
16815 ! side-chain vectors.
16816 !
16817 !      implicit real(kind=8) (a-h,o-z)
16818 !      include 'DIMENSIONS'
16819 !      include 'COMMON.GEO'
16820 !      include 'COMMON.VAR'
16821 !      include 'COMMON.LOCAL'
16822 !      include 'COMMON.CHAIN'
16823 !      include 'COMMON.DERIV'
16824 !      include 'COMMON.INTERACT'
16825 !      include 'COMMON.FFIELD'
16826 !      include 'COMMON.IOUNITS'
16827 !      include 'COMMON.CONTROL'
16828       real(kind=8),dimension(3) :: ggg
16829 !el local variables
16830       integer :: i,iint,j,k,iteli,itypj,subchap
16831       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16832       real(kind=8) :: evdw2,evdw2_14,evdwij
16833       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16834                     dist_temp, dist_init
16835
16836       evdw2=0.0D0
16837       evdw2_14=0.0d0
16838 !d    print '(a)','Enter ESCP'
16839 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16840       do i=iatscp_s,iatscp_e
16841         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16842         iteli=itel(i)
16843         xi=0.5D0*(c(1,i)+c(1,i+1))
16844         yi=0.5D0*(c(2,i)+c(2,i+1))
16845         zi=0.5D0*(c(3,i)+c(3,i+1))
16846         call to_box(xi,yi,zi)
16847         do iint=1,nscp_gr(i)
16848
16849         do j=iscpstart(i,iint),iscpend(i,iint)
16850           itypj=itype(j,1)
16851           if (itypj.eq.ntyp1) cycle
16852 ! Uncomment following three lines for SC-p interactions
16853 !         xj=c(1,nres+j)-xi
16854 !         yj=c(2,nres+j)-yi
16855 !         zj=c(3,nres+j)-zi
16856 ! Uncomment following three lines for Ca-p interactions
16857           xj=c(1,j)
16858           yj=c(2,j)
16859           zj=c(3,j)
16860           call to_box(xj,yj,zj)
16861           xj=boxshift(xj-xi,boxxsize)
16862           yj=boxshift(yj-yi,boxysize)
16863           zj=boxshift(zj-zi,boxzsize)
16864           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16865
16866           rij=dsqrt(1.0d0/rrij)
16867             sss_ele_cut=sscale_ele(rij)
16868             sss_ele_grad=sscagrad_ele(rij)
16869 !            print *,sss_ele_cut,sss_ele_grad,&
16870 !            (rij),r_cut_ele,rlamb_ele
16871             if (sss_ele_cut.le.0.0) cycle
16872           sss=sscale((rij/rscp(itypj,iteli)))
16873           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16874           if (sss.lt.1.0d0) then
16875
16876             fac=rrij**expon2
16877             e1=fac*fac*aad(itypj,iteli)
16878             e2=fac*bad(itypj,iteli)
16879             if (iabs(j-i) .le. 2) then
16880               e1=scal14*e1
16881               e2=scal14*e2
16882               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16883             endif
16884             evdwij=e1+e2
16885             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16886             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16887                 'evdw2',i,j,sss,evdwij
16888 !
16889 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16890 !
16891             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16892             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16893             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16894             ggg(1)=xj*fac
16895             ggg(2)=yj*fac
16896             ggg(3)=zj*fac
16897 ! Uncomment following three lines for SC-p interactions
16898 !           do k=1,3
16899 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16900 !           enddo
16901 ! Uncomment following line for SC-p interactions
16902 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16903             do k=1,3
16904               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16905               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16906             enddo
16907           endif
16908         enddo
16909
16910         enddo ! iint
16911       enddo ! i
16912       do i=1,nct
16913         do j=1,3
16914           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16915           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16916           gradx_scp(j,i)=expon*gradx_scp(j,i)
16917         enddo
16918       enddo
16919 !******************************************************************************
16920 !
16921 !                              N O T E !!!
16922 !
16923 ! To save time the factor EXPON has been extracted from ALL components
16924 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16925 ! use!
16926 !
16927 !******************************************************************************
16928       return
16929       end subroutine escp_long
16930 !-----------------------------------------------------------------------------
16931       subroutine escp_short(evdw2,evdw2_14)
16932 !
16933 ! This subroutine calculates the excluded-volume interaction energy between
16934 ! peptide-group centers and side chains and its gradient in virtual-bond and
16935 ! side-chain vectors.
16936 !
16937 !      implicit real(kind=8) (a-h,o-z)
16938 !      include 'DIMENSIONS'
16939 !      include 'COMMON.GEO'
16940 !      include 'COMMON.VAR'
16941 !      include 'COMMON.LOCAL'
16942 !      include 'COMMON.CHAIN'
16943 !      include 'COMMON.DERIV'
16944 !      include 'COMMON.INTERACT'
16945 !      include 'COMMON.FFIELD'
16946 !      include 'COMMON.IOUNITS'
16947 !      include 'COMMON.CONTROL'
16948       real(kind=8),dimension(3) :: ggg
16949 !el local variables
16950       integer :: i,iint,j,k,iteli,itypj,subchap
16951       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16952       real(kind=8) :: evdw2,evdw2_14,evdwij
16953       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16954                     dist_temp, dist_init
16955
16956       evdw2=0.0D0
16957       evdw2_14=0.0d0
16958 !d    print '(a)','Enter ESCP'
16959 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16960       do i=iatscp_s,iatscp_e
16961         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16962         iteli=itel(i)
16963         xi=0.5D0*(c(1,i)+c(1,i+1))
16964         yi=0.5D0*(c(2,i)+c(2,i+1))
16965         zi=0.5D0*(c(3,i)+c(3,i+1))
16966         call to_box(xi,yi,zi)
16967         if (zi.lt.0) zi=zi+boxzsize
16968
16969         do iint=1,nscp_gr(i)
16970
16971         do j=iscpstart(i,iint),iscpend(i,iint)
16972           itypj=itype(j,1)
16973           if (itypj.eq.ntyp1) cycle
16974 ! Uncomment following three lines for SC-p interactions
16975 !         xj=c(1,nres+j)-xi
16976 !         yj=c(2,nres+j)-yi
16977 !         zj=c(3,nres+j)-zi
16978 ! Uncomment following three lines for Ca-p interactions
16979 !          xj=c(1,j)-xi
16980 !          yj=c(2,j)-yi
16981 !          zj=c(3,j)-zi
16982           xj=c(1,j)
16983           yj=c(2,j)
16984           zj=c(3,j)
16985           call to_box(xj,yj,zj)
16986           xj=boxshift(xj-xi,boxxsize)
16987           yj=boxshift(yj-yi,boxysize)
16988           zj=boxshift(zj-zi,boxzsize)
16989           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16990           rij=dsqrt(1.0d0/rrij)
16991             sss_ele_cut=sscale_ele(rij)
16992             sss_ele_grad=sscagrad_ele(rij)
16993 !            print *,sss_ele_cut,sss_ele_grad,&
16994 !            (rij),r_cut_ele,rlamb_ele
16995             if (sss_ele_cut.le.0.0) cycle
16996           sss=sscale(rij/rscp(itypj,iteli))
16997           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16998           if (sss.gt.0.0d0) then
16999
17000             fac=rrij**expon2
17001             e1=fac*fac*aad(itypj,iteli)
17002             e2=fac*bad(itypj,iteli)
17003             if (iabs(j-i) .le. 2) then
17004               e1=scal14*e1
17005               e2=scal14*e2
17006               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
17007             endif
17008             evdwij=e1+e2
17009             evdw2=evdw2+evdwij*sss*sss_ele_cut
17010             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
17011                 'evdw2',i,j,sss,evdwij
17012 !
17013 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
17014 !
17015             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
17016             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
17017             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
17018
17019             ggg(1)=xj*fac
17020             ggg(2)=yj*fac
17021             ggg(3)=zj*fac
17022 ! Uncomment following three lines for SC-p interactions
17023 !           do k=1,3
17024 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
17025 !           enddo
17026 ! Uncomment following line for SC-p interactions
17027 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
17028             do k=1,3
17029               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
17030               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
17031             enddo
17032           endif
17033         enddo
17034
17035         enddo ! iint
17036       enddo ! i
17037       do i=1,nct
17038         do j=1,3
17039           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
17040           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
17041           gradx_scp(j,i)=expon*gradx_scp(j,i)
17042         enddo
17043       enddo
17044 !******************************************************************************
17045 !
17046 !                              N O T E !!!
17047 !
17048 ! To save time the factor EXPON has been extracted from ALL components
17049 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
17050 ! use!
17051 !
17052 !******************************************************************************
17053       return
17054       end subroutine escp_short
17055 !-----------------------------------------------------------------------------
17056 ! energy_p_new-sep_barrier.F
17057 !-----------------------------------------------------------------------------
17058       subroutine sc_grad_scale(scalfac)
17059 !      implicit real(kind=8) (a-h,o-z)
17060       use calc_data
17061 !      include 'DIMENSIONS'
17062 !      include 'COMMON.CHAIN'
17063 !      include 'COMMON.DERIV'
17064 !      include 'COMMON.CALC'
17065 !      include 'COMMON.IOUNITS'
17066       real(kind=8),dimension(3) :: dcosom1,dcosom2
17067       real(kind=8) :: scalfac
17068 !el local variables
17069 !      integer :: i,j,k,l
17070
17071       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17072       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17073       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
17074            -2.0D0*alf12*eps3der+sigder*sigsq_om12
17075 ! diagnostics only
17076 !      eom1=0.0d0
17077 !      eom2=0.0d0
17078 !      eom12=evdwij*eps1_om12
17079 ! end diagnostics
17080 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
17081 !     &  " sigder",sigder
17082 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
17083 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
17084       do k=1,3
17085         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
17086         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
17087       enddo
17088       do k=1,3
17089         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
17090          *sss_ele_cut
17091       enddo
17092 !      write (iout,*) "gg",(gg(k),k=1,3)
17093       do k=1,3
17094         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17095                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17096                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
17097                  *sss_ele_cut
17098         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17099                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17100                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
17101          *sss_ele_cut
17102 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
17103 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17104 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
17105 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17106       enddo
17107 !
17108 ! Calculate the components of the gradient in DC and X
17109 !
17110       do l=1,3
17111         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17112         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17113       enddo
17114       return
17115       end subroutine sc_grad_scale
17116 !-----------------------------------------------------------------------------
17117 ! energy_split-sep.F
17118 !-----------------------------------------------------------------------------
17119       subroutine etotal_long(energia)
17120 !
17121 ! Compute the long-range slow-varying contributions to the energy
17122 !
17123 !      implicit real(kind=8) (a-h,o-z)
17124 !      include 'DIMENSIONS'
17125       use MD_data, only: totT,usampl,eq_time
17126 #ifndef ISNAN
17127       external proc_proc
17128 #ifdef WINPGI
17129 !MS$ATTRIBUTES C ::  proc_proc
17130 #endif
17131 #endif
17132 #ifdef MPI
17133       include "mpif.h"
17134       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
17135 #endif
17136 !      include 'COMMON.SETUP'
17137 !      include 'COMMON.IOUNITS'
17138 !      include 'COMMON.FFIELD'
17139 !      include 'COMMON.DERIV'
17140 !      include 'COMMON.INTERACT'
17141 !      include 'COMMON.SBRIDGE'
17142 !      include 'COMMON.CHAIN'
17143 !      include 'COMMON.VAR'
17144 !      include 'COMMON.LOCAL'
17145 !      include 'COMMON.MD'
17146       real(kind=8),dimension(0:n_ene) :: energia
17147 !el local variables
17148       integer :: i,n_corr,n_corr1,ierror,ierr
17149       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
17150                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
17151                   ecorr,ecorr5,ecorr6,eturn6,time00, ehomology_constr
17152 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
17153 !elwrite(iout,*)"in etotal long"
17154
17155       if (modecalc.eq.12.or.modecalc.eq.14) then
17156 #ifdef MPI
17157 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
17158 #else
17159         call int_from_cart1(.false.)
17160 #endif
17161       endif
17162 !elwrite(iout,*)"in etotal long"
17163       ehomology_constr=0.0d0
17164 #ifdef MPI
17165 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
17166 !     & " absolute rank",myrank," nfgtasks",nfgtasks
17167       call flush(iout)
17168       if (nfgtasks.gt.1) then
17169         time00=MPI_Wtime()
17170 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
17171         if (fg_rank.eq.0) then
17172           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
17173 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
17174 !          call flush(iout)
17175 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
17176 ! FG slaves as WEIGHTS array.
17177           weights_(1)=wsc
17178           weights_(2)=wscp
17179           weights_(3)=welec
17180           weights_(4)=wcorr
17181           weights_(5)=wcorr5
17182           weights_(6)=wcorr6
17183           weights_(7)=wel_loc
17184           weights_(8)=wturn3
17185           weights_(9)=wturn4
17186           weights_(10)=wturn6
17187           weights_(11)=wang
17188           weights_(12)=wscloc
17189           weights_(13)=wtor
17190           weights_(14)=wtor_d
17191           weights_(15)=wstrain
17192           weights_(16)=wvdwpp
17193           weights_(17)=wbond
17194           weights_(18)=scal14
17195           weights_(21)=wsccor
17196 ! FG Master broadcasts the WEIGHTS_ array
17197           call MPI_Bcast(weights_(1),n_ene,&
17198               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17199         else
17200 ! FG slaves receive the WEIGHTS array
17201           call MPI_Bcast(weights(1),n_ene,&
17202               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17203           wsc=weights(1)
17204           wscp=weights(2)
17205           welec=weights(3)
17206           wcorr=weights(4)
17207           wcorr5=weights(5)
17208           wcorr6=weights(6)
17209           wel_loc=weights(7)
17210           wturn3=weights(8)
17211           wturn4=weights(9)
17212           wturn6=weights(10)
17213           wang=weights(11)
17214           wscloc=weights(12)
17215           wtor=weights(13)
17216           wtor_d=weights(14)
17217           wstrain=weights(15)
17218           wvdwpp=weights(16)
17219           wbond=weights(17)
17220           scal14=weights(18)
17221           wsccor=weights(21)
17222         endif
17223         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
17224           king,FG_COMM,IERR)
17225          time_Bcast=time_Bcast+MPI_Wtime()-time00
17226          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
17227 !        call chainbuild_cart
17228 !        call int_from_cart1(.false.)
17229       endif
17230 !      write (iout,*) 'Processor',myrank,
17231 !     &  ' calling etotal_short ipot=',ipot
17232 !      call flush(iout)
17233 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
17234 #endif
17235 !d    print *,'nnt=',nnt,' nct=',nct
17236 !
17237 !elwrite(iout,*)"in etotal long"
17238 ! Compute the side-chain and electrostatic interaction energy
17239 !
17240       goto (101,102,103,104,105,106) ipot
17241 ! Lennard-Jones potential.
17242   101 call elj_long(evdw)
17243 !d    print '(a)','Exit ELJ'
17244       goto 107
17245 ! Lennard-Jones-Kihara potential (shifted).
17246   102 call eljk_long(evdw)
17247       goto 107
17248 ! Berne-Pechukas potential (dilated LJ, angular dependence).
17249   103 call ebp_long(evdw)
17250       goto 107
17251 ! Gay-Berne potential (shifted LJ, angular dependence).
17252   104 call egb_long(evdw)
17253       goto 107
17254 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
17255   105 call egbv_long(evdw)
17256       goto 107
17257 ! Soft-sphere potential
17258   106 call e_softsphere(evdw)
17259 !
17260 ! Calculate electrostatic (H-bonding) energy of the main chain.
17261 !
17262   107 continue
17263       call vec_and_deriv
17264       if (ipot.lt.6) then
17265 #ifdef SPLITELE
17266          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
17267              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
17268              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
17269              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
17270 #else
17271          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
17272              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
17273              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
17274              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
17275 #endif
17276            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
17277          else
17278             ees=0
17279             evdw1=0
17280             eel_loc=0
17281             eello_turn3=0
17282             eello_turn4=0
17283          endif
17284       else
17285 !        write (iout,*) "Soft-spheer ELEC potential"
17286         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
17287          eello_turn4)
17288       endif
17289 !
17290 ! Calculate excluded-volume interaction energy between peptide groups
17291 ! and side chains.
17292 !
17293       if (ipot.lt.6) then
17294        if(wscp.gt.0d0) then
17295         call escp_long(evdw2,evdw2_14)
17296        else
17297         evdw2=0
17298         evdw2_14=0
17299        endif
17300       else
17301         call escp_soft_sphere(evdw2,evdw2_14)
17302       endif
17303 !
17304 ! 12/1/95 Multi-body terms
17305 !
17306       n_corr=0
17307       n_corr1=0
17308       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
17309           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
17310          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
17311 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
17312 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
17313       else
17314          ecorr=0.0d0
17315          ecorr5=0.0d0
17316          ecorr6=0.0d0
17317          eturn6=0.0d0
17318       endif
17319       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
17320          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
17321       endif
17322 !
17323 ! If performing constraint dynamics, call the constraint energy
17324 !  after the equilibration time
17325       if(usampl.and.totT.gt.eq_time) then
17326          call EconstrQ
17327          call Econstr_back
17328       else
17329          Uconst=0.0d0
17330          Uconst_back=0.0d0
17331       endif
17332 !
17333 ! Sum the energies
17334 !
17335       do i=1,n_ene
17336         energia(i)=0.0d0
17337       enddo
17338       energia(1)=evdw
17339 #ifdef SCP14
17340       energia(2)=evdw2-evdw2_14
17341       energia(18)=evdw2_14
17342 #else
17343       energia(2)=evdw2
17344       energia(18)=0.0d0
17345 #endif
17346 #ifdef SPLITELE
17347       energia(3)=ees
17348       energia(16)=evdw1
17349 #else
17350       energia(3)=ees+evdw1
17351       energia(16)=0.0d0
17352 #endif
17353       energia(4)=ecorr
17354       energia(5)=ecorr5
17355       energia(6)=ecorr6
17356       energia(7)=eel_loc
17357       energia(8)=eello_turn3
17358       energia(9)=eello_turn4
17359       energia(10)=eturn6
17360       energia(20)=Uconst+Uconst_back
17361       energia(51)=ehomology_constr
17362       call sum_energy(energia,.true.)
17363 !      write (iout,*) "Exit ETOTAL_LONG"
17364       call flush(iout)
17365       return
17366       end subroutine etotal_long
17367 !-----------------------------------------------------------------------------
17368       subroutine etotal_short(energia)
17369 !
17370 ! Compute the short-range fast-varying contributions to the energy
17371 !
17372 !      implicit real(kind=8) (a-h,o-z)
17373 !      include 'DIMENSIONS'
17374 #ifndef ISNAN
17375       external proc_proc
17376 #ifdef WINPGI
17377 !MS$ATTRIBUTES C ::  proc_proc
17378 #endif
17379 #endif
17380 #ifdef MPI
17381       include "mpif.h"
17382       integer :: ierror,ierr
17383       real(kind=8),dimension(n_ene) :: weights_
17384       real(kind=8) :: time00
17385 #endif
17386 !      include 'COMMON.SETUP'
17387 !      include 'COMMON.IOUNITS'
17388 !      include 'COMMON.FFIELD'
17389 !      include 'COMMON.DERIV'
17390 !      include 'COMMON.INTERACT'
17391 !      include 'COMMON.SBRIDGE'
17392 !      include 'COMMON.CHAIN'
17393 !      include 'COMMON.VAR'
17394 !      include 'COMMON.LOCAL'
17395       real(kind=8),dimension(0:n_ene) :: energia
17396 !el local variables
17397       integer :: i,nres6
17398       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
17399       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr, &
17400                       ehomology_constr
17401       nres6=6*nres
17402
17403 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
17404 !      call flush(iout)
17405       if (modecalc.eq.12.or.modecalc.eq.14) then
17406 #ifdef MPI
17407         if (fg_rank.eq.0) call int_from_cart1(.false.)
17408 #else
17409         call int_from_cart1(.false.)
17410 #endif
17411       endif
17412 #ifdef MPI
17413 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
17414 !     & " absolute rank",myrank," nfgtasks",nfgtasks
17415 !      call flush(iout)
17416       if (nfgtasks.gt.1) then
17417         time00=MPI_Wtime()
17418 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
17419         if (fg_rank.eq.0) then
17420           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
17421 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
17422 !          call flush(iout)
17423 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
17424 ! FG slaves as WEIGHTS array.
17425           weights_(1)=wsc
17426           weights_(2)=wscp
17427           weights_(3)=welec
17428           weights_(4)=wcorr
17429           weights_(5)=wcorr5
17430           weights_(6)=wcorr6
17431           weights_(7)=wel_loc
17432           weights_(8)=wturn3
17433           weights_(9)=wturn4
17434           weights_(10)=wturn6
17435           weights_(11)=wang
17436           weights_(12)=wscloc
17437           weights_(13)=wtor
17438           weights_(14)=wtor_d
17439           weights_(15)=wstrain
17440           weights_(16)=wvdwpp
17441           weights_(17)=wbond
17442           weights_(18)=scal14
17443           weights_(21)=wsccor
17444 ! FG Master broadcasts the WEIGHTS_ array
17445           call MPI_Bcast(weights_(1),n_ene,&
17446               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17447         else
17448 ! FG slaves receive the WEIGHTS array
17449           call MPI_Bcast(weights(1),n_ene,&
17450               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17451           wsc=weights(1)
17452           wscp=weights(2)
17453           welec=weights(3)
17454           wcorr=weights(4)
17455           wcorr5=weights(5)
17456           wcorr6=weights(6)
17457           wel_loc=weights(7)
17458           wturn3=weights(8)
17459           wturn4=weights(9)
17460           wturn6=weights(10)
17461           wang=weights(11)
17462           wscloc=weights(12)
17463           wtor=weights(13)
17464           wtor_d=weights(14)
17465           wstrain=weights(15)
17466           wvdwpp=weights(16)
17467           wbond=weights(17)
17468           scal14=weights(18)
17469           wsccor=weights(21)
17470         endif
17471 !        write (iout,*),"Processor",myrank," BROADCAST weights"
17472         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
17473           king,FG_COMM,IERR)
17474 !        write (iout,*) "Processor",myrank," BROADCAST c"
17475         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
17476           king,FG_COMM,IERR)
17477 !        write (iout,*) "Processor",myrank," BROADCAST dc"
17478         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
17479           king,FG_COMM,IERR)
17480 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
17481         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
17482           king,FG_COMM,IERR)
17483 !        write (iout,*) "Processor",myrank," BROADCAST theta"
17484         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
17485           king,FG_COMM,IERR)
17486 !        write (iout,*) "Processor",myrank," BROADCAST phi"
17487         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
17488           king,FG_COMM,IERR)
17489 !        write (iout,*) "Processor",myrank," BROADCAST alph"
17490         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
17491           king,FG_COMM,IERR)
17492 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
17493         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
17494           king,FG_COMM,IERR)
17495 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
17496         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
17497           king,FG_COMM,IERR)
17498          time_Bcast=time_Bcast+MPI_Wtime()-time00
17499 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
17500       endif
17501 !      write (iout,*) 'Processor',myrank,
17502 !     &  ' calling etotal_short ipot=',ipot
17503 !      call flush(iout)
17504 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
17505 #endif
17506 !      call int_from_cart1(.false.)
17507 !
17508 ! Compute the side-chain and electrostatic interaction energy
17509 !
17510       goto (101,102,103,104,105,106) ipot
17511 ! Lennard-Jones potential.
17512   101 call elj_short(evdw)
17513 !d    print '(a)','Exit ELJ'
17514       goto 107
17515 ! Lennard-Jones-Kihara potential (shifted).
17516   102 call eljk_short(evdw)
17517       goto 107
17518 ! Berne-Pechukas potential (dilated LJ, angular dependence).
17519   103 call ebp_short(evdw)
17520       goto 107
17521 ! Gay-Berne potential (shifted LJ, angular dependence).
17522   104 call egb_short(evdw)
17523       goto 107
17524 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
17525   105 call egbv_short(evdw)
17526       goto 107
17527 ! Soft-sphere potential - already dealt with in the long-range part
17528   106 evdw=0.0d0
17529 !  106 call e_softsphere_short(evdw)
17530 !
17531 ! Calculate electrostatic (H-bonding) energy of the main chain.
17532 !
17533   107 continue
17534 !
17535 ! Calculate the short-range part of Evdwpp
17536 !
17537       call evdwpp_short(evdw1)
17538 !
17539 ! Calculate the short-range part of ESCp
17540 !
17541       if (ipot.lt.6) then
17542        call escp_short(evdw2,evdw2_14)
17543       endif
17544 !
17545 ! Calculate the bond-stretching energy
17546 !
17547       call ebond(estr)
17548 !
17549 ! Calculate the disulfide-bridge and other energy and the contributions
17550 ! from other distance constraints.
17551 !      call edis(ehpb)
17552 !
17553 ! Calculate the virtual-bond-angle energy.
17554 !
17555 ! Calculate the SC local energy.
17556 !
17557       call vec_and_deriv
17558       call esc(escloc)
17559 !
17560       if (wang.gt.0d0) then
17561        if (tor_mode.eq.0) then
17562            call ebend(ebe)
17563        else
17564 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
17565 !C energy function
17566         call ebend_kcc(ebe)
17567        endif
17568       else
17569           ebe=0.0d0
17570       endif
17571       ethetacnstr=0.0d0
17572       if (with_theta_constr) call etheta_constr(ethetacnstr)
17573
17574 !       write(iout,*) "in etotal afer ebe",ipot
17575
17576 !      print *,"Processor",myrank," computed UB"
17577 !
17578 ! Calculate the SC local energy.
17579 !
17580       call esc(escloc)
17581 !elwrite(iout,*) "in etotal afer esc",ipot
17582 !      print *,"Processor",myrank," computed USC"
17583 !
17584 ! Calculate the virtual-bond torsional energy.
17585 !
17586 !d    print *,'nterm=',nterm
17587 !      if (wtor.gt.0) then
17588 !       call etor(etors,edihcnstr)
17589 !      else
17590 !       etors=0
17591 !       edihcnstr=0
17592 !      endif
17593       if (wtor.gt.0.0d0) then
17594          if (tor_mode.eq.0) then
17595            call etor(etors)
17596           else
17597 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
17598 !C energy function
17599         call etor_kcc(etors)
17600          endif
17601       else
17602            etors=0.0d0
17603       endif
17604       edihcnstr=0.0d0
17605       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
17606
17607 ! Calculate the virtual-bond torsional energy.
17608 !
17609 !
17610 ! 6/23/01 Calculate double-torsional energy
17611 !
17612       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
17613       call etor_d(etors_d)
17614       endif
17615 !
17616 ! Homology restraints
17617 !
17618       if (constr_homology.ge.1) then
17619         call e_modeller(ehomology_constr)
17620 !      print *,"tu"
17621       else
17622         ehomology_constr=0.0d0
17623       endif
17624
17625 !
17626 ! 21/5/07 Calculate local sicdechain correlation energy
17627 !
17628       if (wsccor.gt.0.0d0) then
17629        call eback_sc_corr(esccor)
17630       else
17631        esccor=0.0d0
17632       endif
17633 !
17634 ! Put energy components into an array
17635 !
17636       do i=1,n_ene
17637        energia(i)=0.0d0
17638       enddo
17639       energia(1)=evdw
17640 #ifdef SCP14
17641       energia(2)=evdw2-evdw2_14
17642       energia(18)=evdw2_14
17643 #else
17644       energia(2)=evdw2
17645       energia(18)=0.0d0
17646 #endif
17647 #ifdef SPLITELE
17648       energia(16)=evdw1
17649 #else
17650       energia(3)=evdw1
17651 #endif
17652       energia(11)=ebe
17653       energia(12)=escloc
17654       energia(13)=etors
17655       energia(14)=etors_d
17656       energia(15)=ehpb
17657       energia(17)=estr
17658       energia(19)=edihcnstr
17659       energia(21)=esccor
17660       energia(51)=ehomology_constr
17661 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
17662       call flush(iout)
17663       call sum_energy(energia,.true.)
17664 !      write (iout,*) "Exit ETOTAL_SHORT"
17665       call flush(iout)
17666       return
17667       end subroutine etotal_short
17668 !-----------------------------------------------------------------------------
17669 ! gnmr1.f
17670 !-----------------------------------------------------------------------------
17671       real(kind=8) function gnmr1(y,ymin,ymax)
17672 !      implicit none
17673       real(kind=8) :: y,ymin,ymax
17674       real(kind=8) :: wykl=4.0d0
17675       if (y.lt.ymin) then
17676         gnmr1=(ymin-y)**wykl/wykl
17677       else if (y.gt.ymax) then
17678        gnmr1=(y-ymax)**wykl/wykl
17679       else
17680        gnmr1=0.0d0
17681       endif
17682       return
17683       end function gnmr1
17684 !-----------------------------------------------------------------------------
17685       real(kind=8) function gnmr1prim(y,ymin,ymax)
17686 !      implicit none
17687       real(kind=8) :: y,ymin,ymax
17688       real(kind=8) :: wykl=4.0d0
17689       if (y.lt.ymin) then
17690        gnmr1prim=-(ymin-y)**(wykl-1)
17691       else if (y.gt.ymax) then
17692        gnmr1prim=(y-ymax)**(wykl-1)
17693       else
17694        gnmr1prim=0.0d0
17695       endif
17696       return
17697       end function gnmr1prim
17698 !----------------------------------------------------------------------------
17699       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
17700       real(kind=8) y,ymin,ymax,sigma
17701       real(kind=8) wykl /4.0d0/
17702       if (y.lt.ymin) then
17703         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
17704       else if (y.gt.ymax) then
17705        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
17706       else
17707         rlornmr1=0.0d0
17708       endif
17709       return
17710       end function rlornmr1
17711 !------------------------------------------------------------------------------
17712       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
17713       real(kind=8) y,ymin,ymax,sigma
17714       real(kind=8) wykl /4.0d0/
17715       if (y.lt.ymin) then
17716         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
17717         ((ymin-y)**wykl+sigma**wykl)**2
17718       else if (y.gt.ymax) then
17719          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
17720         ((y-ymax)**wykl+sigma**wykl)**2
17721       else
17722        rlornmr1prim=0.0d0
17723       endif
17724       return
17725       end function rlornmr1prim
17726
17727       real(kind=8) function harmonic(y,ymax)
17728 !      implicit none
17729       real(kind=8) :: y,ymax
17730       real(kind=8) :: wykl=2.0d0
17731       harmonic=(y-ymax)**wykl
17732       return
17733       end function harmonic
17734 !-----------------------------------------------------------------------------
17735       real(kind=8) function harmonicprim(y,ymax)
17736       real(kind=8) :: y,ymin,ymax
17737       real(kind=8) :: wykl=2.0d0
17738       harmonicprim=(y-ymax)*wykl
17739       return
17740       end function harmonicprim
17741 !-----------------------------------------------------------------------------
17742 ! gradient_p.F
17743 !-----------------------------------------------------------------------------
17744 #ifndef LBFGS
17745       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
17746
17747       use io_base, only:intout,briefout
17748 !      implicit real(kind=8) (a-h,o-z)
17749 !      include 'DIMENSIONS'
17750 !      include 'COMMON.CHAIN'
17751 !      include 'COMMON.DERIV'
17752 !      include 'COMMON.VAR'
17753 !      include 'COMMON.INTERACT'
17754 !      include 'COMMON.FFIELD'
17755 !      include 'COMMON.MD'
17756 !      include 'COMMON.IOUNITS'
17757       real(kind=8),external :: ufparm
17758       integer :: uiparm(1)
17759       real(kind=8) :: urparm(1)
17760       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
17761       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
17762       integer :: n,nf,ind,ind1,i,k,j
17763 !
17764 ! This subroutine calculates total internal coordinate gradient.
17765 ! Depending on the number of function evaluations, either whole energy
17766 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
17767 ! internal coordinates are reevaluated or only the cartesian-in-internal
17768 ! coordinate derivatives are evaluated. The subroutine was designed to work
17769 ! with SUMSL.
17770 !
17771 !
17772       icg=mod(nf,2)+1
17773
17774 !d      print *,'grad',nf,icg
17775       if (nf-nfl+1) 20,30,40
17776    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
17777 !    write (iout,*) 'grad 20'
17778       if (nf.eq.0) return
17779       goto 40
17780    30 call var_to_geom(n,x)
17781       call chainbuild
17782 !    write (iout,*) 'grad 30'
17783 !
17784 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
17785 !
17786    40 call cartder
17787 !     write (iout,*) 'grad 40'
17788 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
17789 !
17790 ! Convert the Cartesian gradient into internal-coordinate gradient.
17791 !
17792       ind=0
17793       ind1=0
17794       do i=1,nres-2
17795       gthetai=0.0D0
17796       gphii=0.0D0
17797       do j=i+1,nres-1
17798         ind=ind+1
17799 !         ind=indmat(i,j)
17800 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
17801        do k=1,3
17802        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
17803         enddo
17804         do k=1,3
17805         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
17806          enddo
17807        enddo
17808       do j=i+1,nres-1
17809         ind1=ind1+1
17810 !         ind1=indmat(i,j)
17811 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
17812         do k=1,3
17813           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
17814           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
17815           enddo
17816         enddo
17817       if (i.gt.1) g(i-1)=gphii
17818       if (n.gt.nphi) g(nphi+i)=gthetai
17819       enddo
17820       if (n.le.nphi+ntheta) goto 10
17821       do i=2,nres-1
17822       if (itype(i,1).ne.10) then
17823           galphai=0.0D0
17824         gomegai=0.0D0
17825         do k=1,3
17826           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17827           enddo
17828         do k=1,3
17829           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17830           enddo
17831           g(ialph(i,1))=galphai
17832         g(ialph(i,1)+nside)=gomegai
17833         endif
17834       enddo
17835 !
17836 ! Add the components corresponding to local energy terms.
17837 !
17838    10 continue
17839       do i=1,nvar
17840 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17841         g(i)=g(i)+gloc(i,icg)
17842       enddo
17843 ! Uncomment following three lines for diagnostics.
17844 !d    call intout
17845 !elwrite(iout,*) "in gradient after calling intout"
17846 !d    call briefout(0,0.0d0)
17847 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17848       return
17849       end subroutine gradient
17850 #endif
17851 !-----------------------------------------------------------------------------
17852       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17853
17854       use comm_chu
17855 !      implicit real(kind=8) (a-h,o-z)
17856 !      include 'DIMENSIONS'
17857 !      include 'COMMON.DERIV'
17858 !      include 'COMMON.IOUNITS'
17859 !      include 'COMMON.GEO'
17860       integer :: n,nf
17861 !el      integer :: jjj
17862 !el      common /chuju/ jjj
17863       real(kind=8) :: energia(0:n_ene)
17864       integer :: uiparm(1)
17865       real(kind=8) :: urparm(1)
17866       real(kind=8) :: f
17867       real(kind=8),external :: ufparm
17868       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17869 !     if (jjj.gt.0) then
17870 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17871 !     endif
17872       nfl=nf
17873       icg=mod(nf,2)+1
17874 !d      print *,'func',nf,nfl,icg
17875       call var_to_geom(n,x)
17876       call zerograd
17877       call chainbuild
17878 !d    write (iout,*) 'ETOTAL called from FUNC'
17879       call etotal(energia)
17880       call sum_gradient
17881       f=energia(0)
17882 !     if (jjj.gt.0) then
17883 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17884 !       write (iout,*) 'f=',etot
17885 !       jjj=0
17886 !     endif
17887       return
17888       end subroutine func
17889 !-----------------------------------------------------------------------------
17890       subroutine cartgrad
17891 !      implicit real(kind=8) (a-h,o-z)
17892 !      include 'DIMENSIONS'
17893       use energy_data
17894       use MD_data, only: totT,usampl,eq_time
17895 #ifdef MPI
17896       include 'mpif.h'
17897 #endif
17898 !      include 'COMMON.CHAIN'
17899 !      include 'COMMON.DERIV'
17900 !      include 'COMMON.VAR'
17901 !      include 'COMMON.INTERACT'
17902 !      include 'COMMON.FFIELD'
17903 !      include 'COMMON.MD'
17904 !      include 'COMMON.IOUNITS'
17905 !      include 'COMMON.TIME1'
17906 !
17907       integer :: i,j
17908       real(kind=8) :: time00,time01
17909
17910 ! This subrouting calculates total Cartesian coordinate gradient.
17911 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17912 !
17913 !#define DEBUG
17914 #ifdef TIMINGtime01
17915       time00=MPI_Wtime()
17916 #endif
17917       icg=1
17918       call sum_gradient
17919 #ifdef TIMING
17920 #endif
17921 !#define DEBUG
17922 !el      write (iout,*) "After sum_gradient"
17923 #ifdef DEBUG
17924       write (iout,*) "After sum_gradient"
17925       do i=1,nres-1
17926         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17927         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17928       enddo
17929 #endif
17930 !#undef DEBUG
17931 ! If performing constraint dynamics, add the gradients of the constraint energy
17932       if(usampl.and.totT.gt.eq_time) then
17933          do i=1,nct
17934            do j=1,3
17935              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17936              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17937            enddo
17938          enddo
17939          do i=1,nres-3
17940            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17941          enddo
17942          do i=1,nres-2
17943            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17944          enddo
17945       endif
17946 !elwrite (iout,*) "After sum_gradient"
17947 #ifdef TIMING
17948       time01=MPI_Wtime()
17949 #endif
17950       call intcartderiv
17951 !elwrite (iout,*) "After sum_gradient"
17952 #ifdef TIMING
17953       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17954 #endif
17955 !     call checkintcartgrad
17956 !     write(iout,*) 'calling int_to_cart'
17957 !#define DEBUG
17958 #ifdef DEBUG
17959       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17960 #endif
17961       do i=0,nct
17962         do j=1,3
17963           gcart(j,i)=gradc(j,i,icg)
17964           gxcart(j,i)=gradx(j,i,icg)
17965 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17966         enddo
17967 #ifdef DEBUG
17968         write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),&
17969           (gxcart(j,i),j=1,3),gloc(i,icg),(gloc_sc(j,i,icg),j=1,3)
17970 #endif
17971       enddo
17972 #ifdef TIMING
17973       time01=MPI_Wtime()
17974 #endif
17975 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17976       call int_to_cart
17977 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17978
17979 #ifdef TIMING
17980             time_inttocart=time_inttocart+MPI_Wtime()-time01
17981 #endif
17982 #ifdef DEBUG
17983             write (iout,*) "gcart and gxcart after int_to_cart"
17984             do i=0,nres-1
17985             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17986             (gxcart(j,i),j=1,3)
17987             enddo
17988 #endif
17989 !#undef DEBUG
17990 #ifdef CARGRAD
17991 #ifdef DEBUG
17992             write (iout,*) "CARGRAD"
17993 #endif
17994 !            do i=nres,0,-1
17995 !            do j=1,3
17996 !              gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17997       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17998 !            enddo
17999       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
18000       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
18001 !            enddo
18002       ! Correction: dummy residues
18003 !            if (nnt.gt.1) then
18004 !              do j=1,3
18005 !      !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
18006 !            gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
18007 !            enddo
18008 !          endif
18009 !          if (nct.lt.nres) then
18010 !            do j=1,3
18011 !      !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
18012 !            gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
18013 !            enddo
18014 !          endif
18015 !         call grad_transform
18016 #endif
18017 #ifdef TIMING
18018           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
18019 #endif
18020 !#undef DEBUG
18021           return
18022           end subroutine cartgrad
18023
18024 #ifdef FIVEDIAG
18025       subroutine grad_transform
18026       implicit none
18027 #ifdef MPI
18028       include 'mpif.h'
18029 #endif
18030       integer i,j,kk,mnum
18031 #ifdef DEBUG
18032       write (iout,*)"Converting virtual-bond gradient to CA/SC gradient"
18033       write (iout,*) "dC/dX gradient"
18034       do i=0,nres
18035         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
18036      &      (gxcart(j,i),j=1,3)
18037       enddo
18038 #endif
18039       do i=nres,1,-1
18040         do j=1,3
18041           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
18042 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
18043         enddo
18044 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
18045 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
18046       enddo
18047 ! Correction: dummy residues
18048       do i=2,nres
18049         mnum=molnum(i)
18050         if (itype(i-1,mnum).eq.ntyp1_molec(mnum) .and.&
18051         itype(i,mnum).ne.ntyp1_molec(mnum)) then
18052           gcart(:,i)=gcart(:,i)+gcart(:,i-1)
18053         else if (itype(i-1,mnum).ne.ntyp1_molec(mnum).and.&
18054           itype(i,mnum).eq.ntyp1_molec(mnum)) then
18055           gcart(:,i-1)=gcart(:,i-1)+gcart(:,i)
18056         endif
18057       enddo
18058 !      if (nnt.gt.1) then
18059 !        do j=1,3
18060 !          gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
18061 !        enddo
18062 !      endif
18063 !      if (nct.lt.nres) then
18064 !        do j=1,3
18065 !!          gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
18066 !          gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
18067 !        enddo
18068 !      endif
18069 #ifdef DEBUG
18070       write (iout,*) "CA/SC gradient"
18071       do i=1,nres
18072         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
18073      &      (gxcart(j,i),j=1,3)
18074       enddo
18075 #endif
18076       return
18077       end subroutine grad_transform
18078 #endif
18079
18080       !-----------------------------------------------------------------------------
18081           subroutine zerograd
18082       !      implicit real(kind=8) (a-h,o-z)
18083       !      include 'DIMENSIONS'
18084       !      include 'COMMON.DERIV'
18085       !      include 'COMMON.CHAIN'
18086       !      include 'COMMON.VAR'
18087       !      include 'COMMON.MD'
18088       !      include 'COMMON.SCCOR'
18089       !
18090       !el local variables
18091           integer :: i,j,intertyp,k
18092       ! Initialize Cartesian-coordinate gradient
18093       !
18094       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
18095       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
18096
18097       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
18098       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
18099       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
18100       !      allocate(gradcorr_long(3,nres))
18101       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
18102       !      allocate(gcorr6_turn_long(3,nres))
18103       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
18104
18105       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
18106
18107       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
18108       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
18109
18110       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
18111       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
18112
18113       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
18114       !      allocate(gscloc(3,nres)) !(3,maxres)
18115       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
18116
18117
18118
18119       !      common /deriv_scloc/
18120       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
18121       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
18122       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
18123       !      common /mpgrad/
18124       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
18125
18126
18127
18128       !          gradc(j,i,icg)=0.0d0
18129       !          gradx(j,i,icg)=0.0d0
18130
18131       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
18132       !elwrite(iout,*) "icg",icg
18133           do i=-1,nres
18134           do j=1,3
18135             gvdwx(j,i)=0.0D0
18136             gradx_scp(j,i)=0.0D0
18137             gvdwc(j,i)=0.0D0
18138             gvdwc_scp(j,i)=0.0D0
18139             gvdwc_scpp(j,i)=0.0d0
18140             gelc(j,i)=0.0D0
18141             gelc_long(j,i)=0.0D0
18142             gradb(j,i)=0.0d0
18143             gradbx(j,i)=0.0d0
18144             gvdwpp(j,i)=0.0d0
18145             gel_loc(j,i)=0.0d0
18146             gel_loc_long(j,i)=0.0d0
18147             ghpbc(j,i)=0.0D0
18148             ghpbx(j,i)=0.0D0
18149             gcorr3_turn(j,i)=0.0d0
18150             gcorr4_turn(j,i)=0.0d0
18151             gradcorr(j,i)=0.0d0
18152             gradcorr_long(j,i)=0.0d0
18153             gradcorr5_long(j,i)=0.0d0
18154             gradcorr6_long(j,i)=0.0d0
18155             gcorr6_turn_long(j,i)=0.0d0
18156             gradcorr5(j,i)=0.0d0
18157             gradcorr6(j,i)=0.0d0
18158             gcorr6_turn(j,i)=0.0d0
18159             gsccorc(j,i)=0.0d0
18160             gsccorx(j,i)=0.0d0
18161             gradc(j,i,icg)=0.0d0
18162             gradx(j,i,icg)=0.0d0
18163             gscloc(j,i)=0.0d0
18164             gsclocx(j,i)=0.0d0
18165             gliptran(j,i)=0.0d0
18166             gliptranx(j,i)=0.0d0
18167             gliptranc(j,i)=0.0d0
18168             gshieldx(j,i)=0.0d0
18169             gshieldc(j,i)=0.0d0
18170             gshieldc_loc(j,i)=0.0d0
18171             gshieldx_ec(j,i)=0.0d0
18172             gshieldc_ec(j,i)=0.0d0
18173             gshieldc_loc_ec(j,i)=0.0d0
18174             gshieldx_t3(j,i)=0.0d0
18175             gshieldc_t3(j,i)=0.0d0
18176             gshieldc_loc_t3(j,i)=0.0d0
18177             gshieldx_t4(j,i)=0.0d0
18178             gshieldc_t4(j,i)=0.0d0
18179             gshieldc_loc_t4(j,i)=0.0d0
18180             gshieldx_ll(j,i)=0.0d0
18181             gshieldc_ll(j,i)=0.0d0
18182             gshieldc_loc_ll(j,i)=0.0d0
18183             gg_tube(j,i)=0.0d0
18184             gg_tube_sc(j,i)=0.0d0
18185             gradafm(j,i)=0.0d0
18186             gradb_nucl(j,i)=0.0d0
18187             gradbx_nucl(j,i)=0.0d0
18188             gvdwpp_nucl(j,i)=0.0d0
18189             gvdwpp(j,i)=0.0d0
18190             gelpp(j,i)=0.0d0
18191             gvdwpsb(j,i)=0.0d0
18192             gvdwpsb1(j,i)=0.0d0
18193             gvdwsbc(j,i)=0.0d0
18194             gvdwsbx(j,i)=0.0d0
18195             gelsbc(j,i)=0.0d0
18196             gradcorr_nucl(j,i)=0.0d0
18197             gradcorr3_nucl(j,i)=0.0d0
18198             gradxorr_nucl(j,i)=0.0d0
18199             gradxorr3_nucl(j,i)=0.0d0
18200             gelsbx(j,i)=0.0d0
18201             gsbloc(j,i)=0.0d0
18202             gsblocx(j,i)=0.0d0
18203             gradpepcat(j,i)=0.0d0
18204             gradpepcatx(j,i)=0.0d0
18205             gradcatcat(j,i)=0.0d0
18206             gvdwx_scbase(j,i)=0.0d0
18207             gvdwc_scbase(j,i)=0.0d0
18208             gvdwx_pepbase(j,i)=0.0d0
18209             gvdwc_pepbase(j,i)=0.0d0
18210             gvdwx_scpho(j,i)=0.0d0
18211             gvdwc_scpho(j,i)=0.0d0
18212             gvdwc_peppho(j,i)=0.0d0
18213             gradnuclcatx(j,i)=0.0d0
18214             gradnuclcat(j,i)=0.0d0
18215             gradlipbond(j,i)=0.0d0
18216             gradlipang(j,i)=0.0d0
18217             gradliplj(j,i)=0.0d0
18218             gradlipelec(j,i)=0.0d0
18219             gradcattranc(j,i)=0.0d0
18220             gradcattranx(j,i)=0.0d0
18221             gradcatangx(j,i)=0.0d0
18222             gradcatangc(j,i)=0.0d0
18223             duscdiff(j,i)=0.0d0
18224             duscdiffx(j,i)=0.0d0
18225           enddo
18226            enddo
18227           do i=0,nres
18228           do j=1,3
18229             do intertyp=1,3
18230              gloc_sc(intertyp,i,icg)=0.0d0
18231             enddo
18232           enddo
18233           enddo
18234           do i=1,nres
18235            do j=1,maxcontsshi
18236            shield_list(j,i)=0
18237           do k=1,3
18238       !C           print *,i,j,k
18239              grad_shield_side(k,j,i)=0.0d0
18240              grad_shield_loc(k,j,i)=0.0d0
18241            enddo
18242            enddo
18243            ishield_list(i)=0
18244           enddo
18245
18246       !
18247       ! Initialize the gradient of local energy terms.
18248       !
18249       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
18250       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
18251       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
18252       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
18253       !      allocate(gel_loc_turn3(nres))
18254       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
18255       !      allocate(gsccor_loc(nres))      !(maxres)
18256
18257           do i=1,4*nres
18258           gloc(i,icg)=0.0D0
18259           enddo
18260           do i=1,nres
18261           gel_loc_loc(i)=0.0d0
18262           gcorr_loc(i)=0.0d0
18263           g_corr5_loc(i)=0.0d0
18264           g_corr6_loc(i)=0.0d0
18265           gel_loc_turn3(i)=0.0d0
18266           gel_loc_turn4(i)=0.0d0
18267           gel_loc_turn6(i)=0.0d0
18268           gsccor_loc(i)=0.0d0
18269           enddo
18270       ! initialize gcart and gxcart
18271       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
18272           do i=0,nres
18273           do j=1,3
18274             gcart(j,i)=0.0d0
18275             gxcart(j,i)=0.0d0
18276           enddo
18277           enddo
18278           return
18279           end subroutine zerograd
18280       !-----------------------------------------------------------------------------
18281           real(kind=8) function fdum()
18282           fdum=0.0D0
18283           return
18284           end function fdum
18285       !-----------------------------------------------------------------------------
18286       ! intcartderiv.F
18287       !-----------------------------------------------------------------------------
18288           subroutine intcartderiv
18289       !      implicit real(kind=8) (a-h,o-z)
18290       !      include 'DIMENSIONS'
18291 #ifdef MPI
18292           include 'mpif.h'
18293 #endif
18294       !      include 'COMMON.SETUP'
18295       !      include 'COMMON.CHAIN'
18296       !      include 'COMMON.VAR'
18297       !      include 'COMMON.GEO'
18298       !      include 'COMMON.INTERACT'
18299       !      include 'COMMON.DERIV'
18300       !      include 'COMMON.IOUNITS'
18301       !      include 'COMMON.LOCAL'
18302       !      include 'COMMON.SCCOR'
18303           real(kind=8) :: pi4,pi34
18304           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
18305           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
18306                   dcosomega,dsinomega !(3,3,maxres)
18307           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
18308
18309           integer :: i,j,k
18310           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
18311                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
18312                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
18313                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
18314           integer :: nres2
18315           nres2=2*nres
18316
18317       !el from module energy-------------
18318       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
18319       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
18320       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
18321
18322       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
18323       !el      allocate(dsintau(3,3,3,0:nres2))
18324       !el      allocate(dtauangle(3,3,3,0:nres2))
18325       !el      allocate(domicron(3,2,2,0:nres2))
18326       !el      allocate(dcosomicron(3,2,2,0:nres2))
18327
18328
18329
18330 #if defined(MPI) && defined(PARINTDER)
18331           if (nfgtasks.gt.1 .and. me.eq.king) &
18332           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
18333 #endif
18334           pi4 = 0.5d0*pipol
18335           pi34 = 3*pi4
18336
18337       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
18338       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
18339
18340       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
18341           do i=1,nres
18342           do j=1,3
18343             dtheta(j,1,i)=0.0d0
18344             dtheta(j,2,i)=0.0d0
18345             dphi(j,1,i)=0.0d0
18346             dphi(j,2,i)=0.0d0
18347             dphi(j,3,i)=0.0d0
18348             dcosomicron(j,1,1,i)=0.0d0
18349             dcosomicron(j,1,2,i)=0.0d0
18350             dcosomicron(j,2,1,i)=0.0d0
18351             dcosomicron(j,2,2,i)=0.0d0
18352           enddo
18353           enddo
18354       ! Derivatives of theta's
18355 #if defined(MPI) && defined(PARINTDER)
18356       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
18357           do i=max0(ithet_start-1,3),ithet_end
18358 #else
18359           do i=3,nres
18360 #endif
18361           cost=dcos(theta(i))
18362           sint=sqrt(1-cost*cost)
18363           do j=1,3
18364             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
18365             vbld(i-1)
18366             if (((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))) &
18367              dtheta(j,1,i)=-dcostheta(j,1,i)/sint
18368             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
18369             vbld(i)
18370             if ((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))&
18371              dtheta(j,2,i)=-dcostheta(j,2,i)/sint
18372           enddo
18373           enddo
18374 #if defined(MPI) && defined(PARINTDER)
18375       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
18376           do i=max0(ithet_start-1,3),ithet_end
18377 #else
18378           do i=3,nres
18379 #endif
18380           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).lt.4) then
18381           cost1=dcos(omicron(1,i))
18382           sint1=sqrt(1-cost1*cost1)
18383           cost2=dcos(omicron(2,i))
18384           sint2=sqrt(1-cost2*cost2)
18385            do j=1,3
18386       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
18387             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
18388             cost1*dc_norm(j,i-2))/ &
18389             vbld(i-1)
18390             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
18391             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
18392             +cost1*(dc_norm(j,i-1+nres)))/ &
18393             vbld(i-1+nres)
18394             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
18395       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
18396       !C Looks messy but better than if in loop
18397             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
18398             +cost2*dc_norm(j,i-1))/ &
18399             vbld(i)
18400             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
18401             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
18402              +cost2*(-dc_norm(j,i-1+nres)))/ &
18403             vbld(i-1+nres)
18404       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
18405             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
18406           enddo
18407            endif
18408           enddo
18409       !elwrite(iout,*) "after vbld write"
18410       ! Derivatives of phi:
18411       ! If phi is 0 or 180 degrees, then the formulas
18412       ! have to be derived by power series expansion of the
18413       ! conventional formulas around 0 and 180.
18414 #ifdef PARINTDER
18415           do i=iphi1_start,iphi1_end
18416 #else
18417           do i=4,nres
18418 #endif
18419       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
18420       ! the conventional case
18421           sint=dsin(theta(i))
18422           sint1=dsin(theta(i-1))
18423           sing=dsin(phi(i))
18424           cost=dcos(theta(i))
18425           cost1=dcos(theta(i-1))
18426           cosg=dcos(phi(i))
18427           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
18428           if ((sint*sint1).eq.0.0d0) then
18429           fac0=0.0d0
18430           else
18431           fac0=1.0d0/(sint1*sint)
18432           endif
18433           fac1=cost*fac0
18434           fac2=cost1*fac0
18435           if (sint1.ne.0.0d0) then
18436           fac3=cosg*cost1/(sint1*sint1)
18437           else
18438           fac3=0.0d0
18439           endif
18440           if (sint.ne.0.0d0) then
18441           fac4=cosg*cost/(sint*sint)
18442           else
18443           fac4=0.0d0
18444           endif
18445       !    Obtaining the gamma derivatives from sine derivative
18446            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
18447              phi(i).gt.pi34.and.phi(i).le.pi.or. &
18448              phi(i).ge.-pi.and.phi(i).le.-pi34) then
18449            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
18450            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
18451            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
18452            do j=1,3
18453             if (sint.ne.0.0d0) then
18454             ctgt=cost/sint
18455             else
18456             ctgt=0.0d0
18457             endif
18458             if (sint1.ne.0.0d0) then
18459             ctgt1=cost1/sint1
18460             else
18461             ctgt1=0.0d0
18462             endif
18463             cosg_inv=1.0d0/cosg
18464 !            if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
18465             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
18466               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
18467             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
18468             dsinphi(j,2,i)= &
18469               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
18470               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18471             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
18472             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
18473               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
18474       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18475             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
18476 !            endif
18477 !             write(iout,*) "just after,close to pi",dphi(j,3,i),&
18478 !              sing*(ctgt1*dtheta(j,2,i-1)),ctgt*dtheta(j,1,i), &
18479 !              (fac0*vp2(j)+sing*dc_norm(j,i-2)),vbld_inv(i-1)
18480
18481       ! Bug fixed 3/24/05 (AL)
18482            enddo
18483       !   Obtaining the gamma derivatives from cosine derivative
18484           else
18485              do j=1,3
18486 !             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
18487              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
18488              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
18489              dc_norm(j,i-3))/vbld(i-2)
18490              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
18491              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
18492              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
18493              dcostheta(j,1,i)
18494              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
18495              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
18496              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
18497              dc_norm(j,i-1))/vbld(i)
18498              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
18499 !#define DEBUG
18500 #ifdef DEBUG
18501              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
18502 #endif
18503 !#undef DEBUG
18504 !             endif
18505            enddo
18506           endif
18507           enddo
18508       !alculate derivative of Tauangle
18509 #ifdef PARINTDER
18510           do i=itau_start,itau_end
18511 #else
18512           do i=3,nres
18513       !elwrite(iout,*) " vecpr",i,nres
18514 #endif
18515            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
18516       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
18517       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
18518       !c dtauangle(j,intertyp,dervityp,residue number)
18519       !c INTERTYP=1 SC...Ca...Ca..Ca
18520       ! the conventional case
18521           sint=dsin(theta(i))
18522           sint1=dsin(omicron(2,i-1))
18523           sing=dsin(tauangle(1,i))
18524           cost=dcos(theta(i))
18525           cost1=dcos(omicron(2,i-1))
18526           cosg=dcos(tauangle(1,i))
18527       !elwrite(iout,*) " vecpr5",i,nres
18528           do j=1,3
18529       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
18530       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
18531           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
18532       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
18533           enddo
18534           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
18535       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac
18536         if ((sint*sint1).eq.0.0d0) then
18537           fac0=0.0d0
18538           else
18539           fac0=1.0d0/(sint1*sint)
18540           endif
18541           fac1=cost*fac0
18542           fac2=cost1*fac0
18543           if (sint1.ne.0.0d0) then
18544           fac3=cosg*cost1/(sint1*sint1)
18545           else
18546           fac3=0.0d0
18547           endif
18548           if (sint.ne.0.0d0) then
18549           fac4=cosg*cost/(sint*sint)
18550           else
18551           fac4=0.0d0
18552           endif
18553
18554       !    Obtaining the gamma derivatives from sine derivative
18555            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
18556              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
18557              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
18558            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
18559            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
18560            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18561           do j=1,3
18562             ctgt=cost/sint
18563             ctgt1=cost1/sint1
18564             cosg_inv=1.0d0/cosg
18565             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18566            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
18567            *vbld_inv(i-2+nres)
18568             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
18569             dsintau(j,1,2,i)= &
18570               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
18571               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18572       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
18573             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
18574       ! Bug fixed 3/24/05 (AL)
18575             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
18576               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
18577       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18578             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
18579            enddo
18580       !   Obtaining the gamma derivatives from cosine derivative
18581           else
18582              do j=1,3
18583              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18584              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
18585              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
18586              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
18587              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18588              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18589              dcostheta(j,1,i)
18590              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
18591              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
18592              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
18593              dc_norm(j,i-1))/vbld(i)
18594              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
18595       !         write (iout,*) "else",i
18596            enddo
18597           endif
18598       !        do k=1,3
18599       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
18600       !        enddo
18601           enddo
18602       !C Second case Ca...Ca...Ca...SC
18603 #ifdef PARINTDER
18604           do i=itau_start,itau_end
18605 #else
18606           do i=4,nres
18607 #endif
18608            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18609             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
18610       ! the conventional case
18611           sint=dsin(omicron(1,i))
18612           sint1=dsin(theta(i-1))
18613           sing=dsin(tauangle(2,i))
18614           cost=dcos(omicron(1,i))
18615           cost1=dcos(theta(i-1))
18616           cosg=dcos(tauangle(2,i))
18617       !        do j=1,3
18618       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18619       !        enddo
18620           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
18621         if ((sint*sint1).eq.0.0d0) then
18622           fac0=0.0d0
18623           else
18624           fac0=1.0d0/(sint1*sint)
18625           endif
18626           fac1=cost*fac0
18627           fac2=cost1*fac0
18628           if (sint1.ne.0.0d0) then
18629           fac3=cosg*cost1/(sint1*sint1)
18630           else
18631           fac3=0.0d0
18632           endif
18633           if (sint.ne.0.0d0) then
18634           fac4=cosg*cost/(sint*sint)
18635           else
18636           fac4=0.0d0
18637           endif
18638       !    Obtaining the gamma derivatives from sine derivative
18639            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
18640              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
18641              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
18642            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
18643            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
18644            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
18645           do j=1,3
18646             ctgt=cost/sint
18647             ctgt1=cost1/sint1
18648             cosg_inv=1.0d0/cosg
18649             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
18650               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
18651       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
18652       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
18653             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
18654             dsintau(j,2,2,i)= &
18655               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
18656               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18657       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
18658       !     & sing*ctgt*domicron(j,1,2,i),
18659       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18660             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
18661       ! Bug fixed 3/24/05 (AL)
18662             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18663              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
18664       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18665             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
18666            enddo
18667       !   Obtaining the gamma derivatives from cosine derivative
18668           else
18669              do j=1,3
18670              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
18671              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18672              dc_norm(j,i-3))/vbld(i-2)
18673              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
18674              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
18675              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
18676              dcosomicron(j,1,1,i)
18677              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
18678              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18679              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
18680              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18681              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
18682       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
18683            enddo
18684           endif
18685           enddo
18686
18687       !CC third case SC...Ca...Ca...SC
18688 #ifdef PARINTDER
18689
18690           do i=itau_start,itau_end
18691 #else
18692           do i=3,nres
18693 #endif
18694       ! the conventional case
18695           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18696           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
18697           sint=dsin(omicron(1,i))
18698           sint1=dsin(omicron(2,i-1))
18699           sing=dsin(tauangle(3,i))
18700           cost=dcos(omicron(1,i))
18701           cost1=dcos(omicron(2,i-1))
18702           cosg=dcos(tauangle(3,i))
18703           do j=1,3
18704           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
18705       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18706           enddo
18707           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
18708         if ((sint*sint1).eq.0.0d0) then
18709           fac0=0.0d0
18710           else
18711           fac0=1.0d0/(sint1*sint)
18712           endif
18713           fac1=cost*fac0
18714           fac2=cost1*fac0
18715           if (sint1.ne.0.0d0) then
18716           fac3=cosg*cost1/(sint1*sint1)
18717           else
18718           fac3=0.0d0
18719           endif
18720           if (sint.ne.0.0d0) then
18721           fac4=cosg*cost/(sint*sint)
18722           else
18723           fac4=0.0d0
18724           endif
18725       !    Obtaining the gamma derivatives from sine derivative
18726            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
18727              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
18728              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
18729            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
18730            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
18731            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18732           do j=1,3
18733             ctgt=cost/sint
18734             ctgt1=cost1/sint1
18735             cosg_inv=1.0d0/cosg
18736             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18737               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
18738               *vbld_inv(i-2+nres)
18739             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
18740             dsintau(j,3,2,i)= &
18741               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
18742               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18743             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
18744       ! Bug fixed 3/24/05 (AL)
18745             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18746               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
18747               *vbld_inv(i-1+nres)
18748       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18749             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
18750            enddo
18751       !   Obtaining the gamma derivatives from cosine derivative
18752           else
18753              do j=1,3
18754              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18755              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18756              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
18757              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
18758              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18759              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18760              dcosomicron(j,1,1,i)
18761              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
18762              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18763              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
18764              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18765              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
18766       !          write(iout,*) "else",i
18767            enddo
18768           endif
18769           enddo
18770
18771 #ifdef CRYST_SC
18772       !   Derivatives of side-chain angles alpha and omega
18773 #if defined(MPI) && defined(PARINTDER)
18774           do i=ibond_start,ibond_end
18775 #else
18776           do i=2,nres-1
18777 #endif
18778             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
18779              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
18780              fac6=fac5/vbld(i)
18781              fac7=fac5*fac5
18782              fac8=fac5/vbld(i+1)
18783              fac9=fac5/vbld(i+nres)
18784              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
18785              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
18786              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
18787              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
18788              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
18789              sina=sqrt(1-cosa*cosa)
18790              sino=dsin(omeg(i))
18791       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
18792              do j=1,3
18793               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
18794               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
18795               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
18796               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
18797               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
18798               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
18799               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
18800               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
18801               vbld(i+nres))
18802               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
18803             enddo
18804       ! obtaining the derivatives of omega from sines
18805             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
18806                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
18807                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
18808                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
18809                dsin(theta(i+1)))
18810                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
18811                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
18812                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
18813                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
18814                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
18815                coso_inv=1.0d0/dcos(omeg(i))
18816                do j=1,3
18817                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
18818                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
18819                (sino*dc_norm(j,i-1))/vbld(i)
18820                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
18821                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
18822                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
18823                -sino*dc_norm(j,i)/vbld(i+1)
18824                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
18825                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
18826                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
18827                vbld(i+nres)
18828                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
18829               enddo
18830              else
18831       !   obtaining the derivatives of omega from cosines
18832              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
18833              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
18834              fac12=fac10*sina
18835              fac13=fac12*fac12
18836              fac14=sina*sina
18837              do j=1,3
18838               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
18839               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
18840               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
18841               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
18842               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
18843               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
18844               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
18845               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
18846               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
18847               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
18848               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
18849               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
18850               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
18851               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
18852               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
18853             enddo
18854             endif
18855            else
18856              do j=1,3
18857              do k=1,3
18858                dalpha(k,j,i)=0.0d0
18859                domega(k,j,i)=0.0d0
18860              enddo
18861              enddo
18862            endif
18863            enddo
18864 #endif
18865 #if defined(MPI) && defined(PARINTDER)
18866           if (nfgtasks.gt.1) then
18867 #ifdef DEBUG
18868       !d      write (iout,*) "Gather dtheta"
18869       !d      call flush(iout)
18870           write (iout,*) "dtheta before gather"
18871           do i=1,nres
18872           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
18873           enddo
18874 #endif
18875           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
18876           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
18877           king,FG_COMM,IERROR)
18878 !#define DEBUG
18879 #ifdef DEBUG
18880       !d      write (iout,*) "Gather dphi"
18881       !d      call flush(iout)
18882           write (iout,*) "dphi before gather"
18883           do i=1,nres
18884           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
18885           enddo
18886 #endif
18887 !#undef DEBUG
18888           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
18889           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
18890           king,FG_COMM,IERROR)
18891       !d      write (iout,*) "Gather dalpha"
18892       !d      call flush(iout)
18893 #ifdef CRYST_SC
18894           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
18895           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18896           king,FG_COMM,IERROR)
18897       !d      write (iout,*) "Gather domega"
18898       !d      call flush(iout)
18899           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
18900           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18901           king,FG_COMM,IERROR)
18902 #endif
18903           endif
18904 #endif
18905 !#define DEBUG
18906 #ifdef DEBUG
18907           write (iout,*) "dtheta after gather"
18908           do i=1,nres
18909           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
18910           enddo
18911           write (iout,*) "dphi after gather"
18912           do i=1,nres
18913           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
18914           enddo
18915           write (iout,*) "dalpha after gather"
18916           do i=1,nres
18917           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
18918           enddo
18919           write (iout,*) "domega after gather"
18920           do i=1,nres
18921           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
18922           enddo
18923 #endif
18924 !#undef DEBUG
18925           return
18926           end subroutine intcartderiv
18927       !-----------------------------------------------------------------------------
18928           subroutine checkintcartgrad
18929       !      implicit real(kind=8) (a-h,o-z)
18930       !      include 'DIMENSIONS'
18931 #ifdef MPI
18932           include 'mpif.h'
18933 #endif
18934       !      include 'COMMON.CHAIN'
18935       !      include 'COMMON.VAR'
18936       !      include 'COMMON.GEO'
18937       !      include 'COMMON.INTERACT'
18938       !      include 'COMMON.DERIV'
18939       !      include 'COMMON.IOUNITS'
18940       !      include 'COMMON.SETUP'
18941           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
18942           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
18943           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
18944           real(kind=8),dimension(3) :: dc_norm_s
18945           real(kind=8) :: aincr=1.0d-5
18946           integer :: i,j
18947           real(kind=8) :: dcji
18948           do i=1,nres
18949           phi_s(i)=phi(i)
18950           theta_s(i)=theta(i)
18951           alph_s(i)=alph(i)
18952           omeg_s(i)=omeg(i)
18953           enddo
18954       ! Check theta gradient
18955           write (iout,*) &
18956            "Analytical (upper) and numerical (lower) gradient of theta"
18957           write (iout,*)
18958           do i=3,nres
18959           do j=1,3
18960             dcji=dc(j,i-2)
18961             dc(j,i-2)=dcji+aincr
18962             call chainbuild_cart
18963             call int_from_cart1(.false.)
18964         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18965         dc(j,i-2)=dcji
18966         dcji=dc(j,i-1)
18967         dc(j,i-1)=dc(j,i-1)+aincr
18968         call chainbuild_cart
18969         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18970         dc(j,i-1)=dcji
18971       enddo
18972 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18973 !el          (dtheta(j,2,i),j=1,3)
18974 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18975 !el          (dthetanum(j,2,i),j=1,3)
18976 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18977 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18978 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18979 !el        write (iout,*)
18980       enddo
18981 ! Check gamma gradient
18982       write (iout,*) &
18983        "Analytical (upper) and numerical (lower) gradient of gamma"
18984       do i=4,nres
18985       do j=1,3
18986         dcji=dc(j,i-3)
18987         dc(j,i-3)=dcji+aincr
18988         call chainbuild_cart
18989         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18990             dc(j,i-3)=dcji
18991         dcji=dc(j,i-2)
18992         dc(j,i-2)=dcji+aincr
18993         call chainbuild_cart
18994         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18995         dc(j,i-2)=dcji
18996         dcji=dc(j,i-1)
18997         dc(j,i-1)=dc(j,i-1)+aincr
18998         call chainbuild_cart
18999         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
19000         dc(j,i-1)=dcji
19001       enddo
19002 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
19003 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
19004 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
19005 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
19006 !el        write (iout,'(5x,3(3f10.5,5x))') &
19007 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
19008 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
19009 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
19010 !el        write (iout,*)
19011       enddo
19012 ! Check alpha gradient
19013       write (iout,*) &
19014        "Analytical (upper) and numerical (lower) gradient of alpha"
19015       do i=2,nres-1
19016        if(itype(i,1).ne.10) then
19017              do j=1,3
19018               dcji=dc(j,i-1)
19019                dc(j,i-1)=dcji+aincr
19020             call chainbuild_cart
19021             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
19022              /aincr
19023               dc(j,i-1)=dcji
19024             dcji=dc(j,i)
19025             dc(j,i)=dcji+aincr
19026             call chainbuild_cart
19027             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
19028              /aincr
19029             dc(j,i)=dcji
19030             dcji=dc(j,i+nres)
19031             dc(j,i+nres)=dc(j,i+nres)+aincr
19032             call chainbuild_cart
19033             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
19034              /aincr
19035            dc(j,i+nres)=dcji
19036           enddo
19037         endif
19038 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
19039 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
19040 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
19041 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
19042 !el        write (iout,'(5x,3(3f10.5,5x))') &
19043 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
19044 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
19045 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
19046 !el        write (iout,*)
19047       enddo
19048 !     Check omega gradient
19049       write (iout,*) &
19050        "Analytical (upper) and numerical (lower) gradient of omega"
19051       do i=2,nres-1
19052        if(itype(i,1).ne.10) then
19053              do j=1,3
19054               dcji=dc(j,i-1)
19055                dc(j,i-1)=dcji+aincr
19056             call chainbuild_cart
19057             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
19058              /aincr
19059               dc(j,i-1)=dcji
19060             dcji=dc(j,i)
19061             dc(j,i)=dcji+aincr
19062             call chainbuild_cart
19063             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
19064              /aincr
19065             dc(j,i)=dcji
19066             dcji=dc(j,i+nres)
19067             dc(j,i+nres)=dc(j,i+nres)+aincr
19068             call chainbuild_cart
19069             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
19070              /aincr
19071            dc(j,i+nres)=dcji
19072           enddo
19073         endif
19074 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
19075 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
19076 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
19077 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
19078 !el        write (iout,'(5x,3(3f10.5,5x))') &
19079 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
19080 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
19081 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
19082 !el        write (iout,*)
19083       enddo
19084       return
19085       end subroutine checkintcartgrad
19086 !-----------------------------------------------------------------------------
19087 ! q_measure.F
19088 !-----------------------------------------------------------------------------
19089       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
19090 !      implicit real(kind=8) (a-h,o-z)
19091 !      include 'DIMENSIONS'
19092 !      include 'COMMON.IOUNITS'
19093 !      include 'COMMON.CHAIN'
19094 !      include 'COMMON.INTERACT'
19095 !      include 'COMMON.VAR'
19096       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
19097       integer :: kkk,nsep=3
19098       real(kind=8) :: qm      !dist,
19099       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
19100       logical :: lprn=.false.
19101       logical :: flag
19102 !      real(kind=8) :: sigm,x
19103
19104 !el      sigm(x)=0.25d0*x     ! local function
19105       qqmax=1.0d10
19106       do kkk=1,nperm
19107       qq = 0.0d0
19108       nl=0
19109        if(flag) then
19110       do il=seg1+nsep,seg2
19111         do jl=seg1,il-nsep
19112           nl=nl+1
19113           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
19114                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
19115                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19116           dij=dist(il,jl)
19117           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
19118           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19119             nl=nl+1
19120             d0ijCM=dsqrt( &
19121                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19122                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19123                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19124             dijCM=dist(il+nres,jl+nres)
19125             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
19126           endif
19127           qq = qq+qqij+qqijCM
19128         enddo
19129       enddo
19130       qq = qq/nl
19131       else
19132       do il=seg1,seg2
19133       if((seg3-il).lt.3) then
19134            secseg=il+3
19135       else
19136            secseg=seg3
19137       endif
19138         do jl=secseg,seg4
19139           nl=nl+1
19140           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
19141                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
19142                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19143           dij=dist(il,jl)
19144           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
19145           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19146             nl=nl+1
19147             d0ijCM=dsqrt( &
19148                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19149                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19150                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19151             dijCM=dist(il+nres,jl+nres)
19152             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
19153           endif
19154           qq = qq+qqij+qqijCM
19155         enddo
19156       enddo
19157       qq = qq/nl
19158       endif
19159       if (qqmax.le.qq) qqmax=qq
19160       enddo
19161       qwolynes=1.0d0-qqmax
19162       return
19163       end function qwolynes
19164 !-----------------------------------------------------------------------------
19165       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
19166 !      implicit real(kind=8) (a-h,o-z)
19167 !      include 'DIMENSIONS'
19168 !      include 'COMMON.IOUNITS'
19169 !      include 'COMMON.CHAIN'
19170 !      include 'COMMON.INTERACT'
19171 !      include 'COMMON.VAR'
19172 !      include 'COMMON.MD'
19173       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
19174       integer :: nsep=3, kkk
19175 !el      real(kind=8) :: dist
19176       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
19177       logical :: lprn=.false.
19178       logical :: flag
19179       real(kind=8) :: sim,dd0,fac,ddqij
19180 !el      sigm(x)=0.25d0*x           ! local function
19181       do kkk=1,nperm
19182       do i=0,nres
19183       do j=1,3
19184         dqwol(j,i)=0.0d0
19185         dxqwol(j,i)=0.0d0
19186       enddo
19187       enddo
19188       nl=0
19189        if(flag) then
19190       do il=seg1+nsep,seg2
19191         do jl=seg1,il-nsep
19192           nl=nl+1
19193           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
19194                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
19195                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19196           dij=dist(il,jl)
19197           sim = 1.0d0/sigm(d0ij)
19198           sim = sim*sim
19199           dd0 = dij-d0ij
19200           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
19201         do k=1,3
19202             ddqij = (c(k,il)-c(k,jl))*fac
19203             dqwol(k,il)=dqwol(k,il)+ddqij
19204             dqwol(k,jl)=dqwol(k,jl)-ddqij
19205           enddo
19206
19207           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19208             nl=nl+1
19209             d0ijCM=dsqrt( &
19210                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19211                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19212                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19213             dijCM=dist(il+nres,jl+nres)
19214             sim = 1.0d0/sigm(d0ijCM)
19215             sim = sim*sim
19216             dd0=dijCM-d0ijCM
19217             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
19218             do k=1,3
19219             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
19220             dxqwol(k,il)=dxqwol(k,il)+ddqij
19221             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
19222             enddo
19223           endif
19224         enddo
19225       enddo
19226        else
19227       do il=seg1,seg2
19228       if((seg3-il).lt.3) then
19229            secseg=il+3
19230       else
19231            secseg=seg3
19232       endif
19233         do jl=secseg,seg4
19234           nl=nl+1
19235           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
19236                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
19237                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19238           dij=dist(il,jl)
19239           sim = 1.0d0/sigm(d0ij)
19240           sim = sim*sim
19241           dd0 = dij-d0ij
19242           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
19243           do k=1,3
19244             ddqij = (c(k,il)-c(k,jl))*fac
19245             dqwol(k,il)=dqwol(k,il)+ddqij
19246             dqwol(k,jl)=dqwol(k,jl)-ddqij
19247           enddo
19248           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19249             nl=nl+1
19250             d0ijCM=dsqrt( &
19251                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19252                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19253                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19254             dijCM=dist(il+nres,jl+nres)
19255             sim = 1.0d0/sigm(d0ijCM)
19256             sim=sim*sim
19257             dd0 = dijCM-d0ijCM
19258             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
19259             do k=1,3
19260              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
19261              dxqwol(k,il)=dxqwol(k,il)+ddqij
19262              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
19263             enddo
19264           endif
19265         enddo
19266       enddo
19267       endif
19268       enddo
19269        do i=0,nres
19270        do j=1,3
19271          dqwol(j,i)=dqwol(j,i)/nl
19272          dxqwol(j,i)=dxqwol(j,i)/nl
19273        enddo
19274        enddo
19275       return
19276       end subroutine qwolynes_prim
19277 !-----------------------------------------------------------------------------
19278       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
19279 !      implicit real(kind=8) (a-h,o-z)
19280 !      include 'DIMENSIONS'
19281 !      include 'COMMON.IOUNITS'
19282 !      include 'COMMON.CHAIN'
19283 !      include 'COMMON.INTERACT'
19284 !      include 'COMMON.VAR'
19285       integer :: seg1,seg2,seg3,seg4
19286       logical :: flag
19287       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
19288       real(kind=8),dimension(3,0:2*nres) :: cdummy
19289       real(kind=8) :: q1,q2
19290       real(kind=8) :: delta=1.0d-10
19291       integer :: i,j
19292
19293       do i=0,nres
19294       do j=1,3
19295         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
19296         cdummy(j,i)=c(j,i)
19297         c(j,i)=c(j,i)+delta
19298         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
19299         qwolan(j,i)=(q2-q1)/delta
19300         c(j,i)=cdummy(j,i)
19301       enddo
19302       enddo
19303       do i=0,nres
19304       do j=1,3
19305         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
19306         cdummy(j,i+nres)=c(j,i+nres)
19307         c(j,i+nres)=c(j,i+nres)+delta
19308         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
19309         qwolxan(j,i)=(q2-q1)/delta
19310         c(j,i+nres)=cdummy(j,i+nres)
19311       enddo
19312       enddo
19313 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
19314 !      do i=0,nct
19315 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
19316 !      enddo
19317 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
19318 !      do i=0,nct
19319 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
19320 !      enddo
19321       return
19322       end subroutine qwol_num
19323 !-----------------------------------------------------------------------------
19324       subroutine EconstrQ
19325 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
19326 !      implicit real(kind=8) (a-h,o-z)
19327 !      include 'DIMENSIONS'
19328 !      include 'COMMON.CONTROL'
19329 !      include 'COMMON.VAR'
19330 !      include 'COMMON.MD'
19331       use MD_data
19332 !#ifndef LANG0
19333 !      include 'COMMON.LANGEVIN'
19334 !#else
19335 !      include 'COMMON.LANGEVIN.lang0'
19336 !#endif
19337 !      include 'COMMON.CHAIN'
19338 !      include 'COMMON.DERIV'
19339 !      include 'COMMON.GEO'
19340 !      include 'COMMON.LOCAL'
19341 !      include 'COMMON.INTERACT'
19342 !      include 'COMMON.IOUNITS'
19343 !      include 'COMMON.NAMES'
19344 !      include 'COMMON.TIME1'
19345       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
19346       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
19347                duconst,duxconst
19348       integer :: kstart,kend,lstart,lend,idummy
19349       real(kind=8) :: delta=1.0d-7
19350       integer :: i,j,k,ii
19351       do i=0,nres
19352        do j=1,3
19353           duconst(j,i)=0.0d0
19354           dudconst(j,i)=0.0d0
19355           duxconst(j,i)=0.0d0
19356           dudxconst(j,i)=0.0d0
19357        enddo
19358       enddo
19359       Uconst=0.0d0
19360       do i=1,nfrag
19361        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
19362          idummy,idummy)
19363        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
19364 ! Calculating the derivatives of Constraint energy with respect to Q
19365        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
19366          qinfrag(i,iset))
19367 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
19368 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
19369 !         hmnum=(hm2-hm1)/delta
19370 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
19371 !     &   qinfrag(i,iset))
19372 !         write(iout,*) "harmonicnum frag", hmnum
19373 ! Calculating the derivatives of Q with respect to cartesian coordinates
19374        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
19375         idummy,idummy)
19376 !         write(iout,*) "dqwol "
19377 !         do ii=1,nres
19378 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
19379 !         enddo
19380 !         write(iout,*) "dxqwol "
19381 !         do ii=1,nres
19382 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
19383 !         enddo
19384 ! Calculating numerical gradients of dU/dQi and dQi/dxi
19385 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
19386 !     &  ,idummy,idummy)
19387 !  The gradients of Uconst in Cs
19388        do ii=0,nres
19389           do j=1,3
19390              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
19391              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
19392           enddo
19393        enddo
19394       enddo
19395       do i=1,npair
19396        kstart=ifrag(1,ipair(1,i,iset),iset)
19397        kend=ifrag(2,ipair(1,i,iset),iset)
19398        lstart=ifrag(1,ipair(2,i,iset),iset)
19399        lend=ifrag(2,ipair(2,i,iset),iset)
19400        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
19401        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
19402 !  Calculating dU/dQ
19403        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
19404 !         hm1=harmonic(qpair(i),qinpair(i,iset))
19405 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
19406 !         hmnum=(hm2-hm1)/delta
19407 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
19408 !     &   qinpair(i,iset))
19409 !         write(iout,*) "harmonicnum pair ", hmnum
19410 ! Calculating dQ/dXi
19411        call qwolynes_prim(kstart,kend,.false.,&
19412         lstart,lend)
19413 !         write(iout,*) "dqwol "
19414 !         do ii=1,nres
19415 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
19416 !         enddo
19417 !         write(iout,*) "dxqwol "
19418 !         do ii=1,nres
19419 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
19420 !        enddo
19421 ! Calculating numerical gradients
19422 !        call qwol_num(kstart,kend,.false.
19423 !     &  ,lstart,lend)
19424 ! The gradients of Uconst in Cs
19425        do ii=0,nres
19426           do j=1,3
19427              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
19428              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
19429           enddo
19430        enddo
19431       enddo
19432 !      write(iout,*) "Uconst inside subroutine ", Uconst
19433 ! Transforming the gradients from Cs to dCs for the backbone
19434       do i=0,nres
19435        do j=i+1,nres
19436          do k=1,3
19437            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
19438          enddo
19439        enddo
19440       enddo
19441 !  Transforming the gradients from Cs to dCs for the side chains
19442       do i=1,nres
19443        do j=1,3
19444          dudxconst(j,i)=duxconst(j,i)
19445        enddo
19446       enddo
19447 !      write(iout,*) "dU/ddc backbone "
19448 !       do ii=0,nres
19449 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
19450 !      enddo
19451 !      write(iout,*) "dU/ddX side chain "
19452 !      do ii=1,nres
19453 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
19454 !      enddo
19455 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
19456 !      call dEconstrQ_num
19457       return
19458       end subroutine EconstrQ
19459 !-----------------------------------------------------------------------------
19460       subroutine dEconstrQ_num
19461 ! Calculating numerical dUconst/ddc and dUconst/ddx
19462 !      implicit real(kind=8) (a-h,o-z)
19463 !      include 'DIMENSIONS'
19464 !      include 'COMMON.CONTROL'
19465 !      include 'COMMON.VAR'
19466 !      include 'COMMON.MD'
19467       use MD_data
19468 !#ifndef LANG0
19469 !      include 'COMMON.LANGEVIN'
19470 !#else
19471 !      include 'COMMON.LANGEVIN.lang0'
19472 !#endif
19473 !      include 'COMMON.CHAIN'
19474 !      include 'COMMON.DERIV'
19475 !      include 'COMMON.GEO'
19476 !      include 'COMMON.LOCAL'
19477 !      include 'COMMON.INTERACT'
19478 !      include 'COMMON.IOUNITS'
19479 !      include 'COMMON.NAMES'
19480 !      include 'COMMON.TIME1'
19481       real(kind=8) :: uzap1,uzap2
19482       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
19483       integer :: kstart,kend,lstart,lend,idummy
19484       real(kind=8) :: delta=1.0d-7
19485 !el local variables
19486       integer :: i,ii,j
19487 !     real(kind=8) ::
19488 !     For the backbone
19489       do i=0,nres-1
19490        do j=1,3
19491           dUcartan(j,i)=0.0d0
19492           cdummy(j,i)=dc(j,i)
19493           dc(j,i)=dc(j,i)+delta
19494           call chainbuild_cart
19495         uzap2=0.0d0
19496           do ii=1,nfrag
19497            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
19498             idummy,idummy)
19499              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
19500             qinfrag(ii,iset))
19501           enddo
19502           do ii=1,npair
19503              kstart=ifrag(1,ipair(1,ii,iset),iset)
19504              kend=ifrag(2,ipair(1,ii,iset),iset)
19505              lstart=ifrag(1,ipair(2,ii,iset),iset)
19506              lend=ifrag(2,ipair(2,ii,iset),iset)
19507              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19508              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
19509              qinpair(ii,iset))
19510           enddo
19511           dc(j,i)=cdummy(j,i)
19512           call chainbuild_cart
19513           uzap1=0.0d0
19514            do ii=1,nfrag
19515            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
19516             idummy,idummy)
19517              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
19518             qinfrag(ii,iset))
19519           enddo
19520           do ii=1,npair
19521              kstart=ifrag(1,ipair(1,ii,iset),iset)
19522              kend=ifrag(2,ipair(1,ii,iset),iset)
19523              lstart=ifrag(1,ipair(2,ii,iset),iset)
19524              lend=ifrag(2,ipair(2,ii,iset),iset)
19525              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19526              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
19527             qinpair(ii,iset))
19528           enddo
19529           ducartan(j,i)=(uzap2-uzap1)/(delta)
19530        enddo
19531       enddo
19532 ! Calculating numerical gradients for dU/ddx
19533       do i=0,nres-1
19534        duxcartan(j,i)=0.0d0
19535        do j=1,3
19536           cdummy(j,i)=dc(j,i+nres)
19537           dc(j,i+nres)=dc(j,i+nres)+delta
19538           call chainbuild_cart
19539         uzap2=0.0d0
19540           do ii=1,nfrag
19541            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
19542             idummy,idummy)
19543              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
19544             qinfrag(ii,iset))
19545           enddo
19546           do ii=1,npair
19547              kstart=ifrag(1,ipair(1,ii,iset),iset)
19548              kend=ifrag(2,ipair(1,ii,iset),iset)
19549              lstart=ifrag(1,ipair(2,ii,iset),iset)
19550              lend=ifrag(2,ipair(2,ii,iset),iset)
19551              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19552              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
19553             qinpair(ii,iset))
19554           enddo
19555           dc(j,i+nres)=cdummy(j,i)
19556           call chainbuild_cart
19557           uzap1=0.0d0
19558            do ii=1,nfrag
19559              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
19560             ifrag(2,ii,iset),.true.,idummy,idummy)
19561              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
19562             qinfrag(ii,iset))
19563           enddo
19564           do ii=1,npair
19565              kstart=ifrag(1,ipair(1,ii,iset),iset)
19566              kend=ifrag(2,ipair(1,ii,iset),iset)
19567              lstart=ifrag(1,ipair(2,ii,iset),iset)
19568              lend=ifrag(2,ipair(2,ii,iset),iset)
19569              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19570              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
19571             qinpair(ii,iset))
19572           enddo
19573           duxcartan(j,i)=(uzap2-uzap1)/(delta)
19574        enddo
19575       enddo
19576       write(iout,*) "Numerical dUconst/ddc backbone "
19577       do ii=0,nres
19578       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
19579       enddo
19580 !      write(iout,*) "Numerical dUconst/ddx side-chain "
19581 !      do ii=1,nres
19582 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
19583 !      enddo
19584       return
19585       end subroutine dEconstrQ_num
19586 !-----------------------------------------------------------------------------
19587 ! ssMD.F
19588 !-----------------------------------------------------------------------------
19589       subroutine check_energies
19590
19591 !      use random, only: ran_number
19592
19593 !      implicit none
19594 !     Includes
19595 !      include 'DIMENSIONS'
19596 !      include 'COMMON.CHAIN'
19597 !      include 'COMMON.VAR'
19598 !      include 'COMMON.IOUNITS'
19599 !      include 'COMMON.SBRIDGE'
19600 !      include 'COMMON.LOCAL'
19601 !      include 'COMMON.GEO'
19602
19603 !     External functions
19604 !EL      double precision ran_number
19605 !EL      external ran_number
19606
19607 !     Local variables
19608       integer :: i,j,k,l,lmax,p,pmax,countss
19609       real(kind=8) :: rmin,rmax
19610       real(kind=8) :: eij
19611
19612       real(kind=8) :: d
19613       real(kind=8) :: wi,rij,tj,pj
19614 !      return
19615       countss=1
19616       i=5
19617       j=14
19618
19619       d=dsc(1)
19620       rmin=2.0D0
19621       rmax=12.0D0
19622
19623       lmax=10000
19624       pmax=1
19625
19626       do k=1,3
19627       c(k,i)=0.0D0
19628       c(k,j)=0.0D0
19629       c(k,nres+i)=0.0D0
19630       c(k,nres+j)=0.0D0
19631       enddo
19632
19633       do l=1,lmax
19634
19635 !t        wi=ran_number(0.0D0,pi)
19636 !        wi=ran_number(0.0D0,pi/6.0D0)
19637 !        wi=0.0D0
19638 !t        tj=ran_number(0.0D0,pi)
19639 !t        pj=ran_number(0.0D0,pi)
19640 !        pj=ran_number(0.0D0,pi/6.0D0)
19641 !        pj=0.0D0
19642
19643       do p=1,pmax
19644 !t           rij=ran_number(rmin,rmax)
19645
19646          c(1,j)=d*sin(pj)*cos(tj)
19647          c(2,j)=d*sin(pj)*sin(tj)
19648          c(3,j)=d*cos(pj)
19649
19650          c(3,nres+i)=-rij
19651
19652          c(1,i)=d*sin(wi)
19653          c(3,i)=-rij-d*cos(wi)
19654
19655          do k=1,3
19656             dc(k,nres+i)=c(k,nres+i)-c(k,i)
19657             dc_norm(k,nres+i)=dc(k,nres+i)/d
19658             dc(k,nres+j)=c(k,nres+j)-c(k,j)
19659             dc_norm(k,nres+j)=dc(k,nres+j)/d
19660          enddo
19661
19662          call dyn_ssbond_ene(i,j,eij,countss)
19663       enddo
19664       enddo
19665       call exit(1)
19666       return
19667       end subroutine check_energies
19668 !-----------------------------------------------------------------------------
19669       subroutine dyn_ssbond_ene(resi,resj,eij,countss)
19670 !      implicit none
19671 !      Includes
19672       use calc_data
19673       use comm_sschecks
19674 !      include 'DIMENSIONS'
19675 !      include 'COMMON.SBRIDGE'
19676 !      include 'COMMON.CHAIN'
19677 !      include 'COMMON.DERIV'
19678 !      include 'COMMON.LOCAL'
19679 !      include 'COMMON.INTERACT'
19680 !      include 'COMMON.VAR'
19681 !      include 'COMMON.IOUNITS'
19682 !      include 'COMMON.CALC'
19683 #ifndef CLUST
19684 #ifndef WHAM
19685        use MD_data
19686 !      include 'COMMON.MD'
19687 !      use MD, only: totT,t_bath
19688 #endif
19689 #endif
19690 !     External functions
19691 !EL      double precision h_base
19692 !EL      external h_base
19693
19694 !     Input arguments
19695       integer :: resi,resj
19696
19697 !     Output arguments
19698       real(kind=8) :: eij
19699
19700 !     Local variables
19701       logical :: havebond
19702       integer itypi,itypj,countss
19703       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
19704       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
19705       real(kind=8),dimension(3) :: dcosom1,dcosom2
19706       real(kind=8) :: ed
19707       real(kind=8) :: pom1,pom2
19708       real(kind=8) :: ljA,ljB,ljXs
19709       real(kind=8),dimension(1:3) :: d_ljB
19710       real(kind=8) :: ssA,ssB,ssC,ssXs
19711       real(kind=8) :: ssxm,ljxm,ssm,ljm
19712       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
19713       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
19714       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
19715 !-------FIRST METHOD
19716       real(kind=8) :: xm
19717       real(kind=8),dimension(1:3) :: d_xm
19718 !-------END FIRST METHOD
19719 !-------SECOND METHOD
19720 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
19721 !-------END SECOND METHOD
19722
19723 !-------TESTING CODE
19724 !el      logical :: checkstop,transgrad
19725 !el      common /sschecks/ checkstop,transgrad
19726
19727       integer :: icheck,nicheck,jcheck,njcheck
19728       real(kind=8),dimension(-1:1) :: echeck
19729       real(kind=8) :: deps,ssx0,ljx0
19730 !-------END TESTING CODE
19731
19732       eij=0.0d0
19733       i=resi
19734       j=resj
19735
19736 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
19737 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
19738
19739       itypi=itype(i,1)
19740       dxi=dc_norm(1,nres+i)
19741       dyi=dc_norm(2,nres+i)
19742       dzi=dc_norm(3,nres+i)
19743       dsci_inv=vbld_inv(i+nres)
19744
19745       itypj=itype(j,1)
19746       xj=c(1,nres+j)-c(1,nres+i)
19747       yj=c(2,nres+j)-c(2,nres+i)
19748       zj=c(3,nres+j)-c(3,nres+i)
19749       dxj=dc_norm(1,nres+j)
19750       dyj=dc_norm(2,nres+j)
19751       dzj=dc_norm(3,nres+j)
19752       dscj_inv=vbld_inv(j+nres)
19753
19754       chi1=chi(itypi,itypj)
19755       chi2=chi(itypj,itypi)
19756       chi12=chi1*chi2
19757       chip1=chip(itypi)
19758       chip2=chip(itypj)
19759       chip12=chip1*chip2
19760       alf1=alp(itypi)
19761       alf2=alp(itypj)
19762       alf12=0.5D0*(alf1+alf2)
19763
19764       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
19765       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19766 !     The following are set in sc_angular
19767 !      erij(1)=xj*rij
19768 !      erij(2)=yj*rij
19769 !      erij(3)=zj*rij
19770 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
19771 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
19772 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
19773       call sc_angular
19774       rij=1.0D0/rij  ! Reset this so it makes sense
19775
19776       sig0ij=sigma(itypi,itypj)
19777       sig=sig0ij*dsqrt(1.0D0/sigsq)
19778
19779       ljXs=sig-sig0ij
19780       ljA=eps1*eps2rt**2*eps3rt**2
19781       ljB=ljA*bb_aq(itypi,itypj)
19782       ljA=ljA*aa_aq(itypi,itypj)
19783       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
19784
19785       ssXs=d0cm
19786       deltat1=1.0d0-om1
19787       deltat2=1.0d0+om2
19788       deltat12=om2-om1+2.0d0
19789       cosphi=om12-om1*om2
19790       ssA=akcm
19791       ssB=akct*deltat12
19792       ssC=ss_depth &
19793          +akth*(deltat1*deltat1+deltat2*deltat2) &
19794          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
19795       ssxm=ssXs-0.5D0*ssB/ssA
19796
19797 !-------TESTING CODE
19798 !$$$c     Some extra output
19799 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
19800 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
19801 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
19802 !$$$      if (ssx0.gt.0.0d0) then
19803 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
19804 !$$$      else
19805 !$$$        ssx0=ssxm
19806 !$$$      endif
19807 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
19808 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
19809 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
19810 !$$$      return
19811 !-------END TESTING CODE
19812
19813 !-------TESTING CODE
19814 !     Stop and plot energy and derivative as a function of distance
19815       if (checkstop) then
19816       ssm=ssC-0.25D0*ssB*ssB/ssA
19817       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19818       if (ssm.lt.ljm .and. &
19819            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
19820         nicheck=1000
19821         njcheck=1
19822         deps=0.5d-7
19823       else
19824         checkstop=.false.
19825       endif
19826       endif
19827       if (.not.checkstop) then
19828       nicheck=0
19829       njcheck=-1
19830       endif
19831
19832       do icheck=0,nicheck
19833       do jcheck=-1,njcheck
19834       if (checkstop) rij=(ssxm-1.0d0)+ &
19835            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
19836 !-------END TESTING CODE
19837
19838       if (rij.gt.ljxm) then
19839       havebond=.false.
19840       ljd=rij-ljXs
19841       fac=(1.0D0/ljd)**expon
19842       e1=fac*fac*aa_aq(itypi,itypj)
19843       e2=fac*bb_aq(itypi,itypj)
19844       eij=eps1*eps2rt*eps3rt*(e1+e2)
19845       eps2der=eij*eps3rt
19846       eps3der=eij*eps2rt
19847       eij=eij*eps2rt*eps3rt
19848
19849       sigder=-sig/sigsq
19850       e1=e1*eps1*eps2rt**2*eps3rt**2
19851       ed=-expon*(e1+eij)/ljd
19852       sigder=ed*sigder
19853       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
19854       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
19855       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
19856            -2.0D0*alf12*eps3der+sigder*sigsq_om12
19857       else if (rij.lt.ssxm) then
19858       havebond=.true.
19859       ssd=rij-ssXs
19860       eij=ssA*ssd*ssd+ssB*ssd+ssC
19861
19862       ed=2*akcm*ssd+akct*deltat12
19863       pom1=akct*ssd
19864       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
19865       eom1=-2*akth*deltat1-pom1-om2*pom2
19866       eom2= 2*akth*deltat2+pom1-om1*pom2
19867       eom12=pom2
19868       else
19869       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
19870
19871       d_ssxm(1)=0.5D0*akct/ssA
19872       d_ssxm(2)=-d_ssxm(1)
19873       d_ssxm(3)=0.0D0
19874
19875       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
19876       d_ljxm(2)=d_ljxm(1)*sigsq_om2
19877       d_ljxm(3)=d_ljxm(1)*sigsq_om12
19878       d_ljxm(1)=d_ljxm(1)*sigsq_om1
19879
19880 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19881       xm=0.5d0*(ssxm+ljxm)
19882       do k=1,3
19883         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
19884       enddo
19885       if (rij.lt.xm) then
19886         havebond=.true.
19887         ssm=ssC-0.25D0*ssB*ssB/ssA
19888         d_ssm(1)=0.5D0*akct*ssB/ssA
19889         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19890         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19891         d_ssm(3)=omega
19892         f1=(rij-xm)/(ssxm-xm)
19893         f2=(rij-ssxm)/(xm-ssxm)
19894         h1=h_base(f1,hd1)
19895         h2=h_base(f2,hd2)
19896         eij=ssm*h1+Ht*h2
19897         delta_inv=1.0d0/(xm-ssxm)
19898         deltasq_inv=delta_inv*delta_inv
19899         fac=ssm*hd1-Ht*hd2
19900         fac1=deltasq_inv*fac*(xm-rij)
19901         fac2=deltasq_inv*fac*(rij-ssxm)
19902         ed=delta_inv*(Ht*hd2-ssm*hd1)
19903         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
19904         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
19905         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
19906       else
19907         havebond=.false.
19908         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19909         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
19910         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
19911         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
19912              alf12/eps3rt)
19913         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
19914         f1=(rij-ljxm)/(xm-ljxm)
19915         f2=(rij-xm)/(ljxm-xm)
19916         h1=h_base(f1,hd1)
19917         h2=h_base(f2,hd2)
19918         eij=Ht*h1+ljm*h2
19919         delta_inv=1.0d0/(ljxm-xm)
19920         deltasq_inv=delta_inv*delta_inv
19921         fac=Ht*hd1-ljm*hd2
19922         fac1=deltasq_inv*fac*(ljxm-rij)
19923         fac2=deltasq_inv*fac*(rij-xm)
19924         ed=delta_inv*(ljm*hd2-Ht*hd1)
19925         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
19926         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
19927         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
19928       endif
19929 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19930
19931 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19932 !$$$        ssd=rij-ssXs
19933 !$$$        ljd=rij-ljXs
19934 !$$$        fac1=rij-ljxm
19935 !$$$        fac2=rij-ssxm
19936 !$$$
19937 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
19938 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
19939 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
19940 !$$$
19941 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
19942 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
19943 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19944 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19945 !$$$        d_ssm(3)=omega
19946 !$$$
19947 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
19948 !$$$        do k=1,3
19949 !$$$          d_ljm(k)=ljm*d_ljB(k)
19950 !$$$        enddo
19951 !$$$        ljm=ljm*ljB
19952 !$$$
19953 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
19954 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
19955 !$$$        d_ss(2)=akct*ssd
19956 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
19957 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
19958 !$$$        d_ss(3)=omega
19959 !$$$
19960 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19961 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19962 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19963 !$$$        do k=1,3
19964 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19965 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19966 !$$$        enddo
19967 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19968 !$$$
19969 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19970 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19971 !$$$        h1=h_base(f1,hd1)
19972 !$$$        h2=h_base(f2,hd2)
19973 !$$$        eij=ss*h1+ljf*h2
19974 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19975 !$$$        deltasq_inv=delta_inv*delta_inv
19976 !$$$        fac=ljf*hd2-ss*hd1
19977 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19978 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19979 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19980 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19981 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19982 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19983 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19984 !$$$
19985 !$$$        havebond=.false.
19986 !$$$        if (ed.gt.0.0d0) havebond=.true.
19987 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19988
19989       endif
19990
19991       if (havebond) then
19992 !#ifndef CLUST
19993 !#ifndef WHAM
19994 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19995 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19996 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19997 !        endif
19998 !#endif
19999 !#endif
20000       dyn_ssbond_ij(countss)=eij
20001       else if (.not.havebond .and. dyn_ssbond_ij(countss).lt.1.0d300) then
20002       dyn_ssbond_ij(countss)=1.0d300
20003 !#ifndef CLUST
20004 !#ifndef WHAM
20005 !        write(iout,'(a15,f12.2,f8.1,2i5)')
20006 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
20007 !#endif
20008 !#endif
20009       endif
20010
20011 !-------TESTING CODE
20012 !el      if (checkstop) then
20013       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
20014            "CHECKSTOP",rij,eij,ed
20015       echeck(jcheck)=eij
20016 !el      endif
20017       enddo
20018       if (checkstop) then
20019       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
20020       endif
20021       enddo
20022       if (checkstop) then
20023       transgrad=.true.
20024       checkstop=.false.
20025       endif
20026 !-------END TESTING CODE
20027
20028       do k=1,3
20029       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
20030       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
20031       enddo
20032       do k=1,3
20033       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
20034       enddo
20035       do k=1,3
20036       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
20037            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
20038            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
20039       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
20040            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
20041            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
20042       enddo
20043 !grad      do k=i,j-1
20044 !grad        do l=1,3
20045 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
20046 !grad        enddo
20047 !grad      enddo
20048
20049       do l=1,3
20050       gvdwc(l,i)=gvdwc(l,i)-gg(l)
20051       gvdwc(l,j)=gvdwc(l,j)+gg(l)
20052       enddo
20053
20054       return
20055       end subroutine dyn_ssbond_ene
20056 !--------------------------------------------------------------------------
20057        subroutine triple_ssbond_ene(resi,resj,resk,eij)
20058 !      implicit none
20059 !      Includes
20060       use calc_data
20061       use comm_sschecks
20062 !      include 'DIMENSIONS'
20063 !      include 'COMMON.SBRIDGE'
20064 !      include 'COMMON.CHAIN'
20065 !      include 'COMMON.DERIV'
20066 !      include 'COMMON.LOCAL'
20067 !      include 'COMMON.INTERACT'
20068 !      include 'COMMON.VAR'
20069 !      include 'COMMON.IOUNITS'
20070 !      include 'COMMON.CALC'
20071 #ifndef CLUST
20072 #ifndef WHAM
20073        use MD_data
20074 !      include 'COMMON.MD'
20075 !      use MD, only: totT,t_bath
20076 #endif
20077 #endif
20078       double precision h_base
20079       external h_base
20080
20081 !c     Input arguments
20082       integer resi,resj,resk,m,itypi,itypj,itypk
20083
20084 !c     Output arguments
20085       double precision eij,eij1,eij2,eij3
20086
20087 !c     Local variables
20088       logical havebond
20089 !c      integer itypi,itypj,k,l
20090       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
20091       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
20092       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
20093       double precision sig0ij,ljd,sig,fac,e1,e2
20094       double precision dcosom1(3),dcosom2(3),ed
20095       double precision pom1,pom2
20096       double precision ljA,ljB,ljXs
20097       double precision d_ljB(1:3)
20098       double precision ssA,ssB,ssC,ssXs
20099       double precision ssxm,ljxm,ssm,ljm
20100       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
20101       eij=0.0
20102       if (dtriss.eq.0) return
20103       i=resi
20104       j=resj
20105       k=resk
20106 !C      write(iout,*) resi,resj,resk
20107       itypi=itype(i,1)
20108       dxi=dc_norm(1,nres+i)
20109       dyi=dc_norm(2,nres+i)
20110       dzi=dc_norm(3,nres+i)
20111       dsci_inv=vbld_inv(i+nres)
20112       xi=c(1,nres+i)
20113       yi=c(2,nres+i)
20114       zi=c(3,nres+i)
20115       call to_box(xi,yi,zi)
20116       itypj=itype(j,1)
20117       xj=c(1,nres+j)
20118       yj=c(2,nres+j)
20119       zj=c(3,nres+j)
20120       call to_box(xj,yj,zj)
20121       dxj=dc_norm(1,nres+j)
20122       dyj=dc_norm(2,nres+j)
20123       dzj=dc_norm(3,nres+j)
20124       dscj_inv=vbld_inv(j+nres)
20125       itypk=itype(k,1)
20126       xk=c(1,nres+k)
20127       yk=c(2,nres+k)
20128       zk=c(3,nres+k)
20129        call to_box(xk,yk,zk)
20130       dxk=dc_norm(1,nres+k)
20131       dyk=dc_norm(2,nres+k)
20132       dzk=dc_norm(3,nres+k)
20133       dscj_inv=vbld_inv(k+nres)
20134       xij=xj-xi
20135       xik=xk-xi
20136       xjk=xk-xj
20137       yij=yj-yi
20138       yik=yk-yi
20139       yjk=yk-yj
20140       zij=zj-zi
20141       zik=zk-zi
20142       zjk=zk-zj
20143       rrij=(xij*xij+yij*yij+zij*zij)
20144       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
20145       rrik=(xik*xik+yik*yik+zik*zik)
20146       rik=dsqrt(rrik)
20147       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
20148       rjk=dsqrt(rrjk)
20149 !C there are three combination of distances for each trisulfide bonds
20150 !C The first case the ith atom is the center
20151 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
20152 !C distance y is second distance the a,b,c,d are parameters derived for
20153 !C this problem d parameter was set as a penalty currenlty set to 1.
20154       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
20155       eij1=0.0d0
20156       else
20157       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
20158       endif
20159 !C second case jth atom is center
20160       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
20161       eij2=0.0d0
20162       else
20163       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
20164       endif
20165 !C the third case kth atom is the center
20166       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
20167       eij3=0.0d0
20168       else
20169       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
20170       endif
20171 !C      eij2=0.0
20172 !C      eij3=0.0
20173 !C      eij1=0.0
20174       eij=eij1+eij2+eij3
20175 !C      write(iout,*)i,j,k,eij
20176 !C The energy penalty calculated now time for the gradient part
20177 !C derivative over rij
20178       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
20179       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
20180           gg(1)=xij*fac/rij
20181           gg(2)=yij*fac/rij
20182           gg(3)=zij*fac/rij
20183       do m=1,3
20184       gvdwx(m,i)=gvdwx(m,i)-gg(m)
20185       gvdwx(m,j)=gvdwx(m,j)+gg(m)
20186       enddo
20187
20188       do l=1,3
20189       gvdwc(l,i)=gvdwc(l,i)-gg(l)
20190       gvdwc(l,j)=gvdwc(l,j)+gg(l)
20191       enddo
20192 !C now derivative over rik
20193       fac=-eij1**2/dtriss* &
20194       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
20195       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
20196           gg(1)=xik*fac/rik
20197           gg(2)=yik*fac/rik
20198           gg(3)=zik*fac/rik
20199       do m=1,3
20200       gvdwx(m,i)=gvdwx(m,i)-gg(m)
20201       gvdwx(m,k)=gvdwx(m,k)+gg(m)
20202       enddo
20203       do l=1,3
20204       gvdwc(l,i)=gvdwc(l,i)-gg(l)
20205       gvdwc(l,k)=gvdwc(l,k)+gg(l)
20206       enddo
20207 !C now derivative over rjk
20208       fac=-eij2**2/dtriss* &
20209       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
20210       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
20211           gg(1)=xjk*fac/rjk
20212           gg(2)=yjk*fac/rjk
20213           gg(3)=zjk*fac/rjk
20214       do m=1,3
20215       gvdwx(m,j)=gvdwx(m,j)-gg(m)
20216       gvdwx(m,k)=gvdwx(m,k)+gg(m)
20217       enddo
20218       do l=1,3
20219       gvdwc(l,j)=gvdwc(l,j)-gg(l)
20220       gvdwc(l,k)=gvdwc(l,k)+gg(l)
20221       enddo
20222       return
20223       end subroutine triple_ssbond_ene
20224
20225
20226
20227 !-----------------------------------------------------------------------------
20228       real(kind=8) function h_base(x,deriv)
20229 !     A smooth function going 0->1 in range [0,1]
20230 !     It should NOT be called outside range [0,1], it will not work there.
20231       implicit none
20232
20233 !     Input arguments
20234       real(kind=8) :: x
20235
20236 !     Output arguments
20237       real(kind=8) :: deriv
20238
20239 !     Local variables
20240       real(kind=8) :: xsq
20241
20242
20243 !     Two parabolas put together.  First derivative zero at extrema
20244 !$$$      if (x.lt.0.5D0) then
20245 !$$$        h_base=2.0D0*x*x
20246 !$$$        deriv=4.0D0*x
20247 !$$$      else
20248 !$$$        deriv=1.0D0-x
20249 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
20250 !$$$        deriv=4.0D0*deriv
20251 !$$$      endif
20252
20253 !     Third degree polynomial.  First derivative zero at extrema
20254       h_base=x*x*(3.0d0-2.0d0*x)
20255       deriv=6.0d0*x*(1.0d0-x)
20256
20257 !     Fifth degree polynomial.  First and second derivatives zero at extrema
20258 !$$$      xsq=x*x
20259 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
20260 !$$$      deriv=x-1.0d0
20261 !$$$      deriv=deriv*deriv
20262 !$$$      deriv=30.0d0*xsq*deriv
20263
20264       return
20265       end function h_base
20266 !-----------------------------------------------------------------------------
20267       subroutine dyn_set_nss
20268 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
20269 !      implicit none
20270       use MD_data, only: totT,t_bath
20271 !     Includes
20272 !      include 'DIMENSIONS'
20273 #ifdef MPI
20274       include "mpif.h"
20275 #endif
20276 !      include 'COMMON.SBRIDGE'
20277 !      include 'COMMON.CHAIN'
20278 !      include 'COMMON.IOUNITS'
20279 !      include 'COMMON.SETUP'
20280 !      include 'COMMON.MD'
20281 !     Local variables
20282       real(kind=8) :: emin
20283       integer :: i,j,imin,ierr,k
20284       integer :: diff,allnss,newnss
20285       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
20286             newihpb,newjhpb,aliass
20287       logical :: found
20288       integer,dimension(0:nfgtasks) :: i_newnss
20289       integer,dimension(0:nfgtasks) :: displ
20290       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
20291       integer :: g_newnss
20292
20293       allnss=0
20294       k=0
20295       do i=1,nres-1
20296       do j=i+1,nres
20297         if ((itype(i,1).eq.1).and.(itype(j,1).eq.1)) then
20298         k=k+1
20299         if (dyn_ssbond_ij(k).lt.1.0d300) then
20300           allnss=allnss+1
20301           allflag(allnss)=0
20302           allihpb(allnss)=i
20303           alljhpb(allnss)=j
20304           aliass(allnss)=k
20305        endif
20306        endif
20307       enddo
20308       enddo
20309
20310 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
20311
20312  1    emin=1.0d300
20313       do i=1,allnss
20314       if (allflag(i).eq.0 .and. &
20315            dyn_ssbond_ij(aliass(allnss)).lt.emin) then
20316         emin=dyn_ssbond_ij(aliass(allnss))
20317         imin=i
20318       endif
20319       enddo
20320       if (emin.lt.1.0d300) then
20321       allflag(imin)=1
20322       do i=1,allnss
20323         if (allflag(i).eq.0 .and. &
20324              (allihpb(i).eq.allihpb(imin) .or. &
20325              alljhpb(i).eq.allihpb(imin) .or. &
20326              allihpb(i).eq.alljhpb(imin) .or. &
20327              alljhpb(i).eq.alljhpb(imin))) then
20328           allflag(i)=-1
20329         endif
20330       enddo
20331       goto 1
20332       endif
20333
20334 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
20335
20336       newnss=0
20337       do i=1,allnss
20338       if (allflag(i).eq.1) then
20339         newnss=newnss+1
20340         newihpb(newnss)=allihpb(i)
20341         newjhpb(newnss)=alljhpb(i)
20342       endif
20343       enddo
20344
20345 #ifdef MPI
20346       if (nfgtasks.gt.1)then
20347
20348       call MPI_Reduce(newnss,g_newnss,1,&
20349         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
20350       call MPI_Gather(newnss,1,MPI_INTEGER,&
20351                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
20352       displ(0)=0
20353       do i=1,nfgtasks-1,1
20354         displ(i)=i_newnss(i-1)+displ(i-1)
20355       enddo
20356       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
20357                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
20358                    king,FG_COMM,IERR)
20359       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
20360                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
20361                    king,FG_COMM,IERR)
20362       if(fg_rank.eq.0) then
20363 !         print *,'g_newnss',g_newnss
20364 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
20365 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
20366        newnss=g_newnss
20367        do i=1,newnss
20368         newihpb(i)=g_newihpb(i)
20369         newjhpb(i)=g_newjhpb(i)
20370        enddo
20371       endif
20372       endif
20373 #endif
20374
20375       diff=newnss-nss
20376
20377 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
20378 !       print *,newnss,nss,maxdim
20379       do i=1,nss
20380       found=.false.
20381 !        print *,newnss
20382       do j=1,newnss
20383 !!          print *,j
20384         if (idssb(i).eq.newihpb(j) .and. &
20385              jdssb(i).eq.newjhpb(j)) found=.true.
20386       enddo
20387 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
20388 !        write(iout,*) "found",found,i,j
20389       if (.not.found.and.fg_rank.eq.0) &
20390           write(iout,'(a15,f12.2,f8.1,2i5)') &
20391            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
20392 #endif
20393       enddo
20394
20395       do i=1,newnss
20396       found=.false.
20397       do j=1,nss
20398 !          print *,i,j
20399         if (newihpb(i).eq.idssb(j) .and. &
20400              newjhpb(i).eq.jdssb(j)) found=.true.
20401       enddo
20402 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
20403 !        write(iout,*) "found",found,i,j
20404       if (.not.found.and.fg_rank.eq.0) &
20405           write(iout,'(a15,f12.2,f8.1,2i5)') &
20406            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
20407 #endif
20408       enddo
20409 !#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
20410       nss=newnss
20411       do i=1,nss
20412       idssb(i)=newihpb(i)
20413       jdssb(i)=newjhpb(i)
20414       enddo
20415 !#else
20416 !      nss=0
20417 !#endif
20418
20419       return
20420       end subroutine dyn_set_nss
20421 ! Lipid transfer energy function
20422       subroutine Eliptransfer(eliptran)
20423 !C this is done by Adasko
20424 !C      print *,"wchodze"
20425 !C structure of box:
20426 !C      water
20427 !C--bordliptop-- buffore starts
20428 !C--bufliptop--- here true lipid starts
20429 !C      lipid
20430 !C--buflipbot--- lipid ends buffore starts
20431 !C--bordlipbot--buffore ends
20432       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
20433       integer :: i
20434       eliptran=0.0
20435 !      print *, "I am in eliptran"
20436       do i=ilip_start,ilip_end
20437 !C       do i=1,1
20438       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
20439        cycle
20440
20441       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
20442       if (positi.le.0.0) positi=positi+boxzsize
20443 !C        print *,i
20444 !C first for peptide groups
20445 !c for each residue check if it is in lipid or lipid water border area
20446        if ((positi.gt.bordlipbot)  &
20447       .and.(positi.lt.bordliptop)) then
20448 !C the energy transfer exist
20449       if (positi.lt.buflipbot) then
20450 !C what fraction I am in
20451        fracinbuf=1.0d0-      &
20452            ((positi-bordlipbot)/lipbufthick)
20453 !C lipbufthick is thickenes of lipid buffore
20454        sslip=sscalelip(fracinbuf)
20455        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
20456        eliptran=eliptran+sslip*pepliptran
20457        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
20458        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
20459 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
20460
20461 !C        print *,"doing sccale for lower part"
20462 !C         print *,i,sslip,fracinbuf,ssgradlip
20463       elseif (positi.gt.bufliptop) then
20464        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
20465        sslip=sscalelip(fracinbuf)
20466        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
20467        eliptran=eliptran+sslip*pepliptran
20468        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
20469        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
20470 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
20471 !C          print *, "doing sscalefor top part"
20472 !C         print *,i,sslip,fracinbuf,ssgradlip
20473       else
20474        eliptran=eliptran+pepliptran
20475 !C         print *,"I am in true lipid"
20476       endif
20477 !C       else
20478 !C       eliptran=elpitran+0.0 ! I am in water
20479        endif
20480        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
20481        enddo
20482 ! here starts the side chain transfer
20483        do i=ilip_start,ilip_end
20484       if (itype(i,1).eq.ntyp1) cycle
20485       positi=(mod(c(3,i+nres),boxzsize))
20486       if (positi.le.0) positi=positi+boxzsize
20487 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20488 !c for each residue check if it is in lipid or lipid water border area
20489 !C       respos=mod(c(3,i+nres),boxzsize)
20490 !C       print *,positi,bordlipbot,buflipbot
20491        if ((positi.gt.bordlipbot) &
20492        .and.(positi.lt.bordliptop)) then
20493 !C the energy transfer exist
20494       if (positi.lt.buflipbot) then
20495        fracinbuf=1.0d0-   &
20496          ((positi-bordlipbot)/lipbufthick)
20497 !C lipbufthick is thickenes of lipid buffore
20498        sslip=sscalelip(fracinbuf)
20499        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
20500        eliptran=eliptran+sslip*liptranene(itype(i,1))
20501        gliptranx(3,i)=gliptranx(3,i) &
20502       +ssgradlip*liptranene(itype(i,1))
20503        gliptranc(3,i-1)= gliptranc(3,i-1) &
20504       +ssgradlip*liptranene(itype(i,1))
20505 !C         print *,"doing sccale for lower part"
20506       elseif (positi.gt.bufliptop) then
20507        fracinbuf=1.0d0-  &
20508       ((bordliptop-positi)/lipbufthick)
20509        sslip=sscalelip(fracinbuf)
20510        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
20511        eliptran=eliptran+sslip*liptranene(itype(i,1))
20512        gliptranx(3,i)=gliptranx(3,i)  &
20513        +ssgradlip*liptranene(itype(i,1))
20514        gliptranc(3,i-1)= gliptranc(3,i-1) &
20515       +ssgradlip*liptranene(itype(i,1))
20516 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20517       else
20518        eliptran=eliptran+liptranene(itype(i,1))
20519 !C         print *,"I am in true lipid"
20520       endif
20521       endif ! if in lipid or buffor
20522 !C       else
20523 !C       eliptran=elpitran+0.0 ! I am in water
20524       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
20525        enddo
20526        return
20527        end  subroutine Eliptransfer
20528 !----------------------------------NANO FUNCTIONS
20529 !C-----------------------------------------------------------------------
20530 !C-----------------------------------------------------------
20531 !C This subroutine is to mimic the histone like structure but as well can be
20532 !C utilizet to nanostructures (infinit) small modification has to be used to
20533 !C make it finite (z gradient at the ends has to be changes as well as the x,y
20534 !C gradient has to be modified at the ends
20535 !C The energy function is Kihara potential
20536 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
20537 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
20538 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
20539 !C simple Kihara potential
20540       subroutine calctube(Etube)
20541       real(kind=8),dimension(3) :: vectube
20542       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20543        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
20544        sc_aa_tube,sc_bb_tube
20545       integer :: i,j,iti
20546       Etube=0.0d0
20547       do i=itube_start,itube_end
20548       enetube(i)=0.0d0
20549       enetube(i+nres)=0.0d0
20550       enddo
20551 !C first we calculate the distance from tube center
20552 !C for UNRES
20553        do i=itube_start,itube_end
20554 !C lets ommit dummy atoms for now
20555        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20556 !C now calculate distance from center of tube and direction vectors
20557       xmin=boxxsize
20558       ymin=boxysize
20559 ! Find minimum distance in periodic box
20560       do j=-1,1
20561        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20562        vectube(1)=vectube(1)+boxxsize*j
20563        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20564        vectube(2)=vectube(2)+boxysize*j
20565        xminact=abs(vectube(1)-tubecenter(1))
20566        yminact=abs(vectube(2)-tubecenter(2))
20567          if (xmin.gt.xminact) then
20568           xmin=xminact
20569           xtemp=vectube(1)
20570          endif
20571          if (ymin.gt.yminact) then
20572            ymin=yminact
20573            ytemp=vectube(2)
20574           endif
20575        enddo
20576       vectube(1)=xtemp
20577       vectube(2)=ytemp
20578       vectube(1)=vectube(1)-tubecenter(1)
20579       vectube(2)=vectube(2)-tubecenter(2)
20580
20581 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20582 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20583
20584 !C as the tube is infinity we do not calculate the Z-vector use of Z
20585 !C as chosen axis
20586       vectube(3)=0.0d0
20587 !C now calculte the distance
20588        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20589 !C now normalize vector
20590       vectube(1)=vectube(1)/tub_r
20591       vectube(2)=vectube(2)/tub_r
20592 !C calculte rdiffrence between r and r0
20593       rdiff=tub_r-tubeR0
20594 !C and its 6 power
20595       rdiff6=rdiff**6.0d0
20596 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20597        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20598 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20599 !C       print *,rdiff,rdiff6,pep_aa_tube
20600 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20601 !C now we calculate gradient
20602        fac=(-12.0d0*pep_aa_tube/rdiff6- &
20603           6.0d0*pep_bb_tube)/rdiff6/rdiff
20604 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20605 !C     &rdiff,fac
20606 !C now direction of gg_tube vector
20607       do j=1,3
20608       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20609       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20610       enddo
20611       enddo
20612 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20613 !C        print *,gg_tube(1,0),"TU"
20614
20615
20616        do i=itube_start,itube_end
20617 !C Lets not jump over memory as we use many times iti
20618        iti=itype(i,1)
20619 !C lets ommit dummy atoms for now
20620        if ((iti.eq.ntyp1)  &
20621 !C in UNRES uncomment the line below as GLY has no side-chain...
20622 !C      .or.(iti.eq.10)
20623       ) cycle
20624       xmin=boxxsize
20625       ymin=boxysize
20626       do j=-1,1
20627        vectube(1)=mod((c(1,i+nres)),boxxsize)
20628        vectube(1)=vectube(1)+boxxsize*j
20629        vectube(2)=mod((c(2,i+nres)),boxysize)
20630        vectube(2)=vectube(2)+boxysize*j
20631
20632        xminact=abs(vectube(1)-tubecenter(1))
20633        yminact=abs(vectube(2)-tubecenter(2))
20634          if (xmin.gt.xminact) then
20635           xmin=xminact
20636           xtemp=vectube(1)
20637          endif
20638          if (ymin.gt.yminact) then
20639            ymin=yminact
20640            ytemp=vectube(2)
20641           endif
20642        enddo
20643       vectube(1)=xtemp
20644       vectube(2)=ytemp
20645 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20646 !C     &     tubecenter(2)
20647       vectube(1)=vectube(1)-tubecenter(1)
20648       vectube(2)=vectube(2)-tubecenter(2)
20649
20650 !C as the tube is infinity we do not calculate the Z-vector use of Z
20651 !C as chosen axis
20652       vectube(3)=0.0d0
20653 !C now calculte the distance
20654        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20655 !C now normalize vector
20656       vectube(1)=vectube(1)/tub_r
20657       vectube(2)=vectube(2)/tub_r
20658
20659 !C calculte rdiffrence between r and r0
20660       rdiff=tub_r-tubeR0
20661 !C and its 6 power
20662       rdiff6=rdiff**6.0d0
20663 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20664        sc_aa_tube=sc_aa_tube_par(iti)
20665        sc_bb_tube=sc_bb_tube_par(iti)
20666        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20667        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
20668            6.0d0*sc_bb_tube/rdiff6/rdiff
20669 !C now direction of gg_tube vector
20670        do j=1,3
20671         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20672         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20673        enddo
20674       enddo
20675       do i=itube_start,itube_end
20676         Etube=Etube+enetube(i)+enetube(i+nres)
20677       enddo
20678 !C        print *,"ETUBE", etube
20679       return
20680       end subroutine calctube
20681 !C TO DO 1) add to total energy
20682 !C       2) add to gradient summation
20683 !C       3) add reading parameters (AND of course oppening of PARAM file)
20684 !C       4) add reading the center of tube
20685 !C       5) add COMMONs
20686 !C       6) add to zerograd
20687 !C       7) allocate matrices
20688
20689
20690 !C-----------------------------------------------------------------------
20691 !C-----------------------------------------------------------
20692 !C This subroutine is to mimic the histone like structure but as well can be
20693 !C utilizet to nanostructures (infinit) small modification has to be used to
20694 !C make it finite (z gradient at the ends has to be changes as well as the x,y
20695 !C gradient has to be modified at the ends
20696 !C The energy function is Kihara potential
20697 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
20698 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
20699 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
20700 !C simple Kihara potential
20701       subroutine calctube2(Etube)
20702           real(kind=8),dimension(3) :: vectube
20703       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20704        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
20705        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
20706       integer:: i,j,iti
20707       Etube=0.0d0
20708       do i=itube_start,itube_end
20709       enetube(i)=0.0d0
20710       enetube(i+nres)=0.0d0
20711       enddo
20712 !C first we calculate the distance from tube center
20713 !C first sugare-phosphate group for NARES this would be peptide group
20714 !C for UNRES
20715        do i=itube_start,itube_end
20716 !C lets ommit dummy atoms for now
20717
20718        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20719 !C now calculate distance from center of tube and direction vectors
20720 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20721 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20722 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20723 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20724       xmin=boxxsize
20725       ymin=boxysize
20726       do j=-1,1
20727        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20728        vectube(1)=vectube(1)+boxxsize*j
20729        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20730        vectube(2)=vectube(2)+boxysize*j
20731
20732        xminact=abs(vectube(1)-tubecenter(1))
20733        yminact=abs(vectube(2)-tubecenter(2))
20734          if (xmin.gt.xminact) then
20735           xmin=xminact
20736           xtemp=vectube(1)
20737          endif
20738          if (ymin.gt.yminact) then
20739            ymin=yminact
20740            ytemp=vectube(2)
20741           endif
20742        enddo
20743       vectube(1)=xtemp
20744       vectube(2)=ytemp
20745       vectube(1)=vectube(1)-tubecenter(1)
20746       vectube(2)=vectube(2)-tubecenter(2)
20747
20748 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20749 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20750
20751 !C as the tube is infinity we do not calculate the Z-vector use of Z
20752 !C as chosen axis
20753       vectube(3)=0.0d0
20754 !C now calculte the distance
20755        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20756 !C now normalize vector
20757       vectube(1)=vectube(1)/tub_r
20758       vectube(2)=vectube(2)/tub_r
20759 !C calculte rdiffrence between r and r0
20760       rdiff=tub_r-tubeR0
20761 !C and its 6 power
20762       rdiff6=rdiff**6.0d0
20763 !C THIS FRAGMENT MAKES TUBE FINITE
20764       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20765       if (positi.le.0) positi=positi+boxzsize
20766 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20767 !c for each residue check if it is in lipid or lipid water border area
20768 !C       respos=mod(c(3,i+nres),boxzsize)
20769 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20770        if ((positi.gt.bordtubebot)  &
20771       .and.(positi.lt.bordtubetop)) then
20772 !C the energy transfer exist
20773       if (positi.lt.buftubebot) then
20774        fracinbuf=1.0d0-  &
20775          ((positi-bordtubebot)/tubebufthick)
20776 !C lipbufthick is thickenes of lipid buffore
20777        sstube=sscalelip(fracinbuf)
20778        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20779 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20780        enetube(i)=enetube(i)+sstube*tubetranenepep
20781 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20782 !C     &+ssgradtube*tubetranene(itype(i,1))
20783 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20784 !C     &+ssgradtube*tubetranene(itype(i,1))
20785 !C         print *,"doing sccale for lower part"
20786       elseif (positi.gt.buftubetop) then
20787        fracinbuf=1.0d0-  &
20788       ((bordtubetop-positi)/tubebufthick)
20789        sstube=sscalelip(fracinbuf)
20790        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20791        enetube(i)=enetube(i)+sstube*tubetranenepep
20792 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20793 !C     &+ssgradtube*tubetranene(itype(i,1))
20794 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20795 !C     &+ssgradtube*tubetranene(itype(i,1))
20796 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20797       else
20798        sstube=1.0d0
20799        ssgradtube=0.0d0
20800        enetube(i)=enetube(i)+sstube*tubetranenepep
20801 !C         print *,"I am in true lipid"
20802       endif
20803       else
20804 !C          sstube=0.0d0
20805 !C          ssgradtube=0.0d0
20806       cycle
20807       endif ! if in lipid or buffor
20808
20809 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20810        enetube(i)=enetube(i)+sstube* &
20811       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
20812 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20813 !C       print *,rdiff,rdiff6,pep_aa_tube
20814 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20815 !C now we calculate gradient
20816        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
20817            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
20818 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20819 !C     &rdiff,fac
20820
20821 !C now direction of gg_tube vector
20822        do j=1,3
20823       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20824       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20825       enddo
20826        gg_tube(3,i)=gg_tube(3,i)  &
20827        +ssgradtube*enetube(i)/sstube/2.0d0
20828        gg_tube(3,i-1)= gg_tube(3,i-1)  &
20829        +ssgradtube*enetube(i)/sstube/2.0d0
20830
20831       enddo
20832 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20833 !C        print *,gg_tube(1,0),"TU"
20834       do i=itube_start,itube_end
20835 !C Lets not jump over memory as we use many times iti
20836        iti=itype(i,1)
20837 !C lets ommit dummy atoms for now
20838        if ((iti.eq.ntyp1) &
20839 !!C in UNRES uncomment the line below as GLY has no side-chain...
20840          .or.(iti.eq.10) &
20841         ) cycle
20842         vectube(1)=c(1,i+nres)
20843         vectube(1)=mod(vectube(1),boxxsize)
20844         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20845         vectube(2)=c(2,i+nres)
20846         vectube(2)=mod(vectube(2),boxysize)
20847         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20848
20849       vectube(1)=vectube(1)-tubecenter(1)
20850       vectube(2)=vectube(2)-tubecenter(2)
20851 !C THIS FRAGMENT MAKES TUBE FINITE
20852       positi=(mod(c(3,i+nres),boxzsize))
20853       if (positi.le.0) positi=positi+boxzsize
20854 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20855 !c for each residue check if it is in lipid or lipid water border area
20856 !C       respos=mod(c(3,i+nres),boxzsize)
20857 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20858
20859        if ((positi.gt.bordtubebot)  &
20860       .and.(positi.lt.bordtubetop)) then
20861 !C the energy transfer exist
20862       if (positi.lt.buftubebot) then
20863        fracinbuf=1.0d0- &
20864           ((positi-bordtubebot)/tubebufthick)
20865 !C lipbufthick is thickenes of lipid buffore
20866        sstube=sscalelip(fracinbuf)
20867        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20868 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20869        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20870 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20871 !C     &+ssgradtube*tubetranene(itype(i,1))
20872 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20873 !C     &+ssgradtube*tubetranene(itype(i,1))
20874 !C         print *,"doing sccale for lower part"
20875       elseif (positi.gt.buftubetop) then
20876        fracinbuf=1.0d0- &
20877       ((bordtubetop-positi)/tubebufthick)
20878
20879        sstube=sscalelip(fracinbuf)
20880        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20881        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20882 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20883 !C     &+ssgradtube*tubetranene(itype(i,1))
20884 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20885 !C     &+ssgradtube*tubetranene(itype(i,1))
20886 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20887       else
20888        sstube=1.0d0
20889        ssgradtube=0.0d0
20890        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20891 !C         print *,"I am in true lipid"
20892       endif
20893       else
20894 !C          sstube=0.0d0
20895 !C          ssgradtube=0.0d0
20896       cycle
20897       endif ! if in lipid or buffor
20898 !CEND OF FINITE FRAGMENT
20899 !C as the tube is infinity we do not calculate the Z-vector use of Z
20900 !C as chosen axis
20901       vectube(3)=0.0d0
20902 !C now calculte the distance
20903        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20904 !C now normalize vector
20905       vectube(1)=vectube(1)/tub_r
20906       vectube(2)=vectube(2)/tub_r
20907 !C calculte rdiffrence between r and r0
20908       rdiff=tub_r-tubeR0
20909 !C and its 6 power
20910       rdiff6=rdiff**6.0d0
20911 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20912        sc_aa_tube=sc_aa_tube_par(iti)
20913        sc_bb_tube=sc_bb_tube_par(iti)
20914        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
20915                    *sstube+enetube(i+nres)
20916 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20917 !C now we calculate gradient
20918        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
20919           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
20920 !C now direction of gg_tube vector
20921        do j=1,3
20922         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20923         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20924        enddo
20925        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
20926        +ssgradtube*enetube(i+nres)/sstube
20927        gg_tube(3,i-1)= gg_tube(3,i-1) &
20928        +ssgradtube*enetube(i+nres)/sstube
20929
20930       enddo
20931       do i=itube_start,itube_end
20932         Etube=Etube+enetube(i)+enetube(i+nres)
20933       enddo
20934 !C        print *,"ETUBE", etube
20935       return
20936       end subroutine calctube2
20937 !=====================================================================================================================================
20938       subroutine calcnano(Etube)
20939        use MD_data, only:totTafm
20940       real(kind=8),dimension(3) :: vectube,cm
20941
20942       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20943        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
20944        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact,tubezcenter,xi,yi,zi!,&
20945 !       vecsim,vectrue
20946        real(kind=8) :: eps,sig,aa_tub_lip,bb_tub_lip
20947        integer:: i,j,iti,r,ilol,ityp
20948 !      totTafm=2.0
20949       Etube=0.0d0
20950       call to_box(tubecenter(1),tubecenter(2),tubecenter(3))
20951 !      print *,itube_start,itube_end,"poczatek"
20952       do i=itube_start,itube_end
20953       enetube(i)=0.0d0
20954       enetube(i+nres)=0.0d0
20955       enddo
20956 !C first we calculate the distance from tube center
20957 !C first sugare-phosphate group for NARES this would be peptide group
20958 !C for UNRES
20959        do i=itube_start,itube_end
20960 !C lets ommit dummy atoms for now
20961        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20962 !C now calculate distance from center of tube and direction vectors
20963
20964 !      do j=-1,1
20965        xi=(c(1,i)+c(1,i+1))/2.0d0
20966        yi=(c(2,i)+c(2,i+1))/2.0d0
20967        zi=((c(3,i)+c(3,i+1))/2.0d0)
20968        call to_box(xi,yi,zi)
20969 !       tubezcenter=totTafm*velNANOconst+tubecenter(3)
20970
20971       vectube(1)=boxshift(xi-tubecenter(1),boxxsize)
20972       vectube(2)=boxshift(yi-tubecenter(2),boxysize)
20973       vectube(3)=boxshift(zi-tubecenter(3),boxzsize)
20974
20975 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20976 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20977 !C as the tube is infinity we do not calculate the Z-vector use of Z
20978 !C as chosen axis
20979 !C      vectube(3)=0.0d0
20980 !C now calculte the distance
20981        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20982 !C now normalize vector
20983       vectube(1)=vectube(1)/tub_r
20984       vectube(2)=vectube(2)/tub_r
20985       vectube(3)=vectube(3)/tub_r
20986 !C calculte rdiffrence between r and r0
20987       rdiff=tub_r-tubeR0
20988 !C and its 6 power
20989       rdiff6=rdiff**6.0d0
20990 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20991        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20992 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20993 !C       print *,rdiff,rdiff6,pep_aa_tube
20994 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20995 !C now we calculate gradient
20996        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20997           6.0d0*pep_bb_tube)/rdiff6/rdiff
20998 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20999 !C     &rdiff,fac
21000        if (acavtubpep.eq.0.0d0) then
21001 !C go to 667
21002        enecavtube(i)=0.0
21003        faccav=0.0
21004        else
21005        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
21006        enecavtube(i)=  &
21007       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
21008       /denominator
21009        enecavtube(i)=0.0
21010        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
21011       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
21012       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
21013       /denominator**2.0d0
21014 !C         faccav=0.0
21015 !C         fac=fac+faccav
21016 !C 667     continue
21017        endif
21018         if (energy_dec) write(iout,*),"ETUBE_PEP",i,rdiff,enetube(i),enecavtube(i)
21019       do j=1,3
21020       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
21021       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
21022       enddo
21023       enddo
21024
21025        do i=itube_start,itube_end
21026       enecavtube(i)=0.0d0
21027 !C Lets not jump over memory as we use many times iti
21028        iti=itype(i,1)
21029 !C lets ommit dummy atoms for now
21030        if ((iti.eq.ntyp1) &
21031 !C in UNRES uncomment the line below as GLY has no side-chain...
21032 !C      .or.(iti.eq.10)
21033        ) cycle
21034       xi=c(1,i+nres)
21035       yi=c(2,i+nres)
21036       zi=c(3,i+nres)
21037       call to_box(xi,yi,zi)
21038        tubezcenter=totTafm*velNANOconst+tubecenter(3)
21039
21040       vectube(1)=boxshift(xi-tubecenter(1),boxxsize)
21041       vectube(2)=boxshift(yi-tubecenter(2),boxysize)
21042       vectube(3)=boxshift(zi-tubecenter(3),boxzsize)
21043
21044
21045 !C now calculte the distance
21046        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
21047 !C now normalize vector
21048       vectube(1)=vectube(1)/tub_r
21049       vectube(2)=vectube(2)/tub_r
21050       vectube(3)=vectube(3)/tub_r
21051
21052 !C calculte rdiffrence between r and r0
21053       rdiff=tub_r-tubeR0
21054 !C and its 6 power
21055       rdiff6=rdiff**6.0d0
21056        sc_aa_tube=sc_aa_tube_par(iti)
21057        sc_bb_tube=sc_bb_tube_par(iti)
21058        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
21059 !C       enetube(i+nres)=0.0d0
21060 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
21061 !C now we calculate gradient
21062        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
21063           6.0d0*sc_bb_tube/rdiff6/rdiff
21064 !C       fac=0.0
21065 !C now direction of gg_tube vector
21066 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
21067        if (acavtub(iti).eq.0.0d0) then
21068 !C go to 667
21069        enecavtube(i+nres)=0.0d0
21070        faccav=0.0d0
21071        else
21072        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
21073        enecavtube(i+nres)=   &
21074       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
21075       /denominator
21076 !C         enecavtube(i)=0.0
21077        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
21078       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
21079       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
21080       /denominator**2.0d0
21081 !C         faccav=0.0
21082        fac=fac+faccav
21083 !C 667     continue
21084        endif
21085 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
21086 !C     &   enecavtube(i),faccav
21087 !C         print *,"licz=",
21088 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
21089 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
21090        do j=1,3
21091         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
21092         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
21093        enddo
21094         if (energy_dec) write(iout,*),"ETUBE",i,rdiff,enetube(i+nres),enecavtube(i+nres)
21095       enddo
21096
21097
21098
21099       do i=itube_start,itube_end
21100         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
21101        +enecavtube(i+nres)
21102       enddo
21103
21104       do i=ilipbond_start_tub,ilipbond_end_tub
21105        ityp=itype(i,4)
21106 !       print *,"ilipbond_start",ilipbond_start,i,ityp
21107        if (ityp.gt.ntyp_molec(4)) cycle
21108 !C now calculate distance from center of tube and direction vectors
21109        eps=lip_sig(ityp,18)*4.0d0
21110        sig=lip_sig(ityp,18)
21111        aa_tub_lip=eps/(sig**12)
21112        bb_tub_lip=eps/(sig**6)
21113 !      do j=-1,1
21114        xi=c(1,i)
21115        yi=c(2,i)
21116        zi=c(3,i)
21117        call to_box(xi,yi,zi)
21118 !       tubezcenter=totTafm*velNANOconst+tubecenter(3)
21119
21120       vectube(1)=boxshift(xi-tubecenter(1),boxxsize)
21121       vectube(2)=boxshift(yi-tubecenter(2),boxysize)
21122       vectube(3)=boxshift(zi-tubecenter(3),boxzsize)
21123
21124 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
21125 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
21126 !C as the tube is infinity we do not calculate the Z-vector use of Z
21127 !C as chosen axis
21128 !C      vectube(3)=0.0d0
21129 !C now calculte the distance
21130        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
21131 !C now normalize vector
21132       vectube(1)=vectube(1)/tub_r
21133       vectube(2)=vectube(2)/tub_r
21134       vectube(3)=vectube(3)/tub_r
21135 !C calculte rdiffrence between r and r0
21136       rdiff=tub_r-tubeR0
21137 !C and its 6 power
21138       rdiff6=rdiff**6.0d0
21139 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
21140        enetube(i)=aa_tub_lip/rdiff6**2.0d0+bb_tub_lip/rdiff6
21141        Etube=Etube+enetube(i)
21142 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
21143 !C       print *,rdiff,rdiff6,pep_aa_tube
21144 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
21145 !C now we calculate gradient
21146        fac=(-12.0d0*aa_tub_lip/rdiff6-   &
21147           6.0d0*bb_tub_lip)/rdiff6/rdiff
21148        do j=1,3
21149         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
21150        enddo
21151         if (energy_dec) write(iout,*) "ETUBLIP",i,rdiff,enetube(i+nres)
21152       enddo
21153
21154
21155 !-----------------------------------------------------------------------
21156       if (fg_rank.eq.0) then
21157       if (velNANOconst.ne.0) then
21158         do j=1,3
21159          cm(j)=0.0d0
21160         enddo
21161         do i=1,inanomove
21162          ilol=inanotab(i)
21163          do j=1,3
21164           cm(j)=cm(j)+c(j,ilol)
21165          enddo
21166         enddo
21167         do j=1,3
21168          cm(j)=cm(j)/inanomove
21169         enddo
21170         vecsim=velNANOconst*totTafm+distnanoinit
21171         vectrue=cm(3)-tubecenter(3)
21172         etube=etube+0.5d0*forcenanoconst*( vectrue-vecsim)**2
21173         fac=forcenanoconst*(vectrue-vecsim)/inanomove
21174         do  i=1,inanomove
21175           ilol=inanotab(i)
21176           gg_tube(3,ilol-1)=gg_tube(3,ilol-1)+fac
21177         enddo
21178         endif
21179         endif
21180 !        do i=1,20
21181 !         print *,"begin", i,"a"
21182 !         do r=1,10000
21183 !          rdiff=r/100.0d0
21184 !          rdiff6=rdiff**6.0d0
21185 !          sc_aa_tube=sc_aa_tube_par(i)
21186 !          sc_bb_tube=sc_bb_tube_par(i)
21187 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
21188 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
21189 !          enecavtube(i)=   &
21190 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
21191 !         /denominator
21192
21193 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
21194 !         enddo
21195 !         print *,"end",i,"a"
21196 !        enddo
21197 !C        print *,"ETUBE", etube
21198       return
21199       end subroutine calcnano
21200
21201 !===============================================
21202 !--------------------------------------------------------------------------------
21203 !C first for shielding is setting of function of side-chains
21204
21205        subroutine set_shield_fac2
21206        real(kind=8) :: div77_81=0.974996043d0, &
21207       div4_81=0.2222222222d0
21208        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
21209        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
21210        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
21211        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
21212 !C the vector between center of side_chain and peptide group
21213        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
21214        pept_group,costhet_grad,cosphi_grad_long, &
21215        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
21216        sh_frac_dist_grad,pep_side
21217       integer i,j,k
21218 !C      write(2,*) "ivec",ivec_start,ivec_end
21219       do i=1,nres
21220       fac_shield(i)=0.0d0
21221       ishield_list(i)=0
21222       do j=1,3
21223       grad_shield(j,i)=0.0d0
21224       enddo
21225       enddo
21226       do i=ivec_start,ivec_end
21227 !C      do i=1,nres-1
21228 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
21229 !      ishield_list(i)=0
21230       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
21231 !Cif there two consequtive dummy atoms there is no peptide group between them
21232 !C the line below has to be changed for FGPROC>1
21233       VolumeTotal=0.0
21234       do k=1,nres
21235        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
21236        dist_pep_side=0.0
21237        dist_side_calf=0.0
21238        do j=1,3
21239 !C first lets set vector conecting the ithe side-chain with kth side-chain
21240       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
21241 !C      pep_side(j)=2.0d0
21242 !C and vector conecting the side-chain with its proper calfa
21243       side_calf(j)=c(j,k+nres)-c(j,k)
21244 !C      side_calf(j)=2.0d0
21245       pept_group(j)=c(j,i)-c(j,i+1)
21246 !C lets have their lenght
21247       dist_pep_side=pep_side(j)**2+dist_pep_side
21248       dist_side_calf=dist_side_calf+side_calf(j)**2
21249       dist_pept_group=dist_pept_group+pept_group(j)**2
21250       enddo
21251        dist_pep_side=sqrt(dist_pep_side)
21252        dist_pept_group=sqrt(dist_pept_group)
21253        dist_side_calf=sqrt(dist_side_calf)
21254       do j=1,3
21255       pep_side_norm(j)=pep_side(j)/dist_pep_side
21256       side_calf_norm(j)=dist_side_calf
21257       enddo
21258 !C now sscale fraction
21259        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
21260 !       print *,buff_shield,"buff",sh_frac_dist
21261 !C now sscale
21262       if (sh_frac_dist.le.0.0) cycle
21263 !C        print *,ishield_list(i),i
21264 !C If we reach here it means that this side chain reaches the shielding sphere
21265 !C Lets add him to the list for gradient
21266       ishield_list(i)=ishield_list(i)+1
21267 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
21268 !C this list is essential otherwise problem would be O3
21269       shield_list(ishield_list(i),i)=k
21270 !C Lets have the sscale value
21271       if (sh_frac_dist.gt.1.0) then
21272        scale_fac_dist=1.0d0
21273        do j=1,3
21274        sh_frac_dist_grad(j)=0.0d0
21275        enddo
21276       else
21277        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
21278                   *(2.0d0*sh_frac_dist-3.0d0)
21279        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
21280                    /dist_pep_side/buff_shield*0.5d0
21281        do j=1,3
21282        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
21283 !C         sh_frac_dist_grad(j)=0.0d0
21284 !C         scale_fac_dist=1.0d0
21285 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
21286 !C     &                    sh_frac_dist_grad(j)
21287        enddo
21288       endif
21289 !C this is what is now we have the distance scaling now volume...
21290       short=short_r_sidechain(itype(k,1))
21291       long=long_r_sidechain(itype(k,1))
21292       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
21293       sinthet=short/dist_pep_side*costhet
21294 !      print *,"SORT",short,long,sinthet,costhet
21295 !C now costhet_grad
21296 !C       costhet=0.6d0
21297 !C       sinthet=0.8
21298        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
21299 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
21300 !C     &             -short/dist_pep_side**2/costhet)
21301 !C       costhet_fac=0.0d0
21302        do j=1,3
21303        costhet_grad(j)=costhet_fac*pep_side(j)
21304        enddo
21305 !C remember for the final gradient multiply costhet_grad(j)
21306 !C for side_chain by factor -2 !
21307 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
21308 !C pep_side0pept_group is vector multiplication
21309       pep_side0pept_group=0.0d0
21310       do j=1,3
21311       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
21312       enddo
21313       cosalfa=(pep_side0pept_group/ &
21314       (dist_pep_side*dist_side_calf))
21315       fac_alfa_sin=1.0d0-cosalfa**2
21316       fac_alfa_sin=dsqrt(fac_alfa_sin)
21317       rkprim=fac_alfa_sin*(long-short)+short
21318 !C      rkprim=short
21319
21320 !C now costhet_grad
21321        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
21322 !C       cosphi=0.6
21323        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
21324        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
21325          dist_pep_side**2)
21326 !C       sinphi=0.8
21327        do j=1,3
21328        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
21329       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
21330       *(long-short)/fac_alfa_sin*cosalfa/ &
21331       ((dist_pep_side*dist_side_calf))* &
21332       ((side_calf(j))-cosalfa* &
21333       ((pep_side(j)/dist_pep_side)*dist_side_calf))
21334 !C       cosphi_grad_long(j)=0.0d0
21335       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
21336       *(long-short)/fac_alfa_sin*cosalfa &
21337       /((dist_pep_side*dist_side_calf))* &
21338       (pep_side(j)- &
21339       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
21340 !C       cosphi_grad_loc(j)=0.0d0
21341        enddo
21342 !C      print *,sinphi,sinthet
21343       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
21344                    /VSolvSphere_div
21345 !C     &                    *wshield
21346 !C now the gradient...
21347       do j=1,3
21348       grad_shield(j,i)=grad_shield(j,i) &
21349 !C gradient po skalowaniu
21350                  +(sh_frac_dist_grad(j)*VofOverlap &
21351 !C  gradient po costhet
21352           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
21353       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
21354           sinphi/sinthet*costhet*costhet_grad(j) &
21355          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
21356       )*wshield
21357 !C grad_shield_side is Cbeta sidechain gradient
21358       grad_shield_side(j,ishield_list(i),i)=&
21359            (sh_frac_dist_grad(j)*-2.0d0&
21360            *VofOverlap&
21361           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
21362        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
21363           sinphi/sinthet*costhet*costhet_grad(j)&
21364          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
21365           )*wshield
21366 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
21367 !            sinphi/sinthet,&
21368 !           +sinthet/sinphi,"HERE"
21369        grad_shield_loc(j,ishield_list(i),i)=   &
21370           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
21371       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
21372           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
21373            ))&
21374            *wshield
21375 !         print *,grad_shield_loc(j,ishield_list(i),i)
21376       enddo
21377       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
21378       enddo
21379       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
21380
21381 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
21382       enddo
21383       return
21384       end subroutine set_shield_fac2
21385 !----------------------------------------------------------------------------
21386 ! SOUBROUTINE FOR AFM
21387        subroutine AFMvel(Eafmforce)
21388        use MD_data, only:totTafm
21389       real(kind=8),dimension(3) :: diffafm,cbeg,cend
21390       real(kind=8) :: afmdist,Eafmforce
21391        integer :: i,j
21392 !C Only for check grad COMMENT if not used for checkgrad
21393 !C      totT=3.0d0
21394 !C--------------------------------------------------------
21395 !C      print *,"wchodze"
21396       afmdist=0.0d0
21397       Eafmforce=0.0d0
21398       cbeg=0.0d0
21399       cend=0.0d0
21400       if (afmbeg.eq.-1) then
21401         do i=1,nbegafmmat
21402          do j=1,3
21403           cbeg(j)=cbeg(j)+c(j,afmbegcentr(i))/nbegafmmat
21404          enddo
21405         enddo
21406       else
21407       do j=1,3
21408         cbeg(j)=c(j,afmend)
21409       enddo
21410       endif
21411       if (afmend.eq.-1) then
21412         do i=1,nendafmmat
21413          do j=1,3
21414           cend(j)=cend(j)+c(j,afmendcentr(i))/nendafmmat
21415          enddo
21416         enddo
21417       else
21418         cend(j)=c(j,afmend)
21419       endif
21420
21421       do i=1,3
21422       diffafm(i)=cend(i)-cbeg(i)
21423       afmdist=afmdist+diffafm(i)**2
21424       enddo
21425       afmdist=dsqrt(afmdist)
21426 !      totTafm=3.0
21427       Eafmforce=0.5d0*forceAFMconst &
21428       *(distafminit+totTafm*velAFMconst-afmdist)**2
21429 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
21430       if (afmend.eq.-1) then
21431       do i=1,nendafmmat
21432          do j=1,3
21433           gradafm(j,afmendcentr(i)-1)=-forceAFMconst* &
21434           (distafminit+totTafm*velAFMconst-afmdist) &
21435           *diffafm(j)/afmdist/nendafmmat
21436          enddo
21437       enddo
21438       else
21439       do i=1,3
21440       gradafm(i,afmend-1)=-forceAFMconst* &
21441        (distafminit+totTafm*velAFMconst-afmdist) &
21442        *diffafm(i)/afmdist
21443       enddo
21444       endif
21445        if (afmbeg.eq.-1) then
21446         do i=1,nbegafmmat
21447          do j=1,3
21448            gradafm(i,afmbegcentr(i)-1)=forceAFMconst* &
21449           (distafminit+totTafm*velAFMconst-afmdist) &
21450            *diffafm(i)/afmdist
21451          enddo
21452         enddo
21453        else
21454        do i=1,3
21455       gradafm(i,afmbeg-1)=forceAFMconst* &
21456       (distafminit+totTafm*velAFMconst-afmdist) &
21457       *diffafm(i)/afmdist
21458       enddo
21459        endif
21460 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
21461       return
21462       end subroutine AFMvel
21463 !---------------------------------------------------------
21464        subroutine AFMforce(Eafmforce)
21465
21466       real(kind=8),dimension(3) :: diffafm
21467 !      real(kind=8) ::afmdist
21468       real(kind=8) :: afmdist,Eafmforce
21469       integer :: i
21470       afmdist=0.0d0
21471       Eafmforce=0.0d0
21472       do i=1,3
21473       diffafm(i)=c(i,afmend)-c(i,afmbeg)
21474       afmdist=afmdist+diffafm(i)**2
21475       enddo
21476       afmdist=dsqrt(afmdist)
21477 !      print *,afmdist,distafminit
21478       Eafmforce=-forceAFMconst*(afmdist-distafminit)
21479       do i=1,3
21480       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
21481       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
21482       enddo
21483 !C      print *,'AFM',Eafmforce
21484       return
21485       end subroutine AFMforce
21486
21487 !-----------------------------------------------------------------------------
21488 #ifdef WHAM
21489       subroutine read_ssHist
21490 !      implicit none
21491 !      Includes
21492 !      include 'DIMENSIONS'
21493 !      include "DIMENSIONS.FREE"
21494 !      include 'COMMON.FREE'
21495 !     Local variables
21496       integer :: i,j
21497       character(len=80) :: controlcard
21498
21499       do i=1,dyn_nssHist
21500       call card_concat(controlcard,.true.)
21501       read(controlcard,*) &
21502            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
21503       enddo
21504
21505       return
21506       end subroutine read_ssHist
21507 #endif
21508 !-----------------------------------------------------------------------------
21509       integer function indmat(i,j)
21510 !el
21511 ! get the position of the jth ijth fragment of the chain coordinate system
21512 ! in the fromto array.
21513       integer :: i,j
21514
21515       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
21516       return
21517       end function indmat
21518 !-----------------------------------------------------------------------------
21519       real(kind=8) function sigm(x)
21520 !el
21521        real(kind=8) :: x
21522       sigm=0.25d0*x
21523       return
21524       end function sigm
21525 !-----------------------------------------------------------------------------
21526 !-----------------------------------------------------------------------------
21527       subroutine alloc_ener_arrays
21528 !EL Allocation of arrays used by module energy
21529       use MD_data, only: mset
21530 !el local variables
21531       integer :: i,j
21532
21533       if(nres.lt.100) then
21534       maxconts=10*nres
21535       elseif(nres.lt.200) then
21536       maxconts=10*nres      ! Max. number of contacts per residue
21537       else
21538       maxconts=10*nres ! (maxconts=maxres/4)
21539       endif
21540       maxcont=100*nres      ! Max. number of SC contacts
21541       maxvar=6*nres      ! Max. number of variables
21542 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
21543       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
21544 !----------------------
21545 ! arrays in subroutine init_int_table
21546 !el#ifdef MPI
21547 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
21548 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
21549 !el#endif
21550       allocate(nint_gr(nres))
21551       allocate(nscp_gr(nres))
21552       allocate(ielstart(nres))
21553       allocate(ielend(nres))
21554 !(maxres)
21555       allocate(istart(nres,maxint_gr))
21556       allocate(iend(nres,maxint_gr))
21557 !(maxres,maxint_gr)
21558       allocate(iscpstart(nres,maxint_gr))
21559       allocate(iscpend(nres,maxint_gr))
21560 !(maxres,maxint_gr)
21561       allocate(ielstart_vdw(nres))
21562       allocate(ielend_vdw(nres))
21563 !(maxres)
21564       allocate(nint_gr_nucl(nres))
21565       allocate(nscp_gr_nucl(nres))
21566       allocate(ielstart_nucl(nres))
21567       allocate(ielend_nucl(nres))
21568 !(maxres)
21569       allocate(istart_nucl(nres,maxint_gr))
21570       allocate(iend_nucl(nres,maxint_gr))
21571 !(maxres,maxint_gr)
21572       allocate(iscpstart_nucl(nres,maxint_gr))
21573       allocate(iscpend_nucl(nres,maxint_gr))
21574 !(maxres,maxint_gr)
21575       allocate(ielstart_vdw_nucl(nres))
21576       allocate(ielend_vdw_nucl(nres))
21577
21578       allocate(lentyp(0:nfgtasks-1))
21579 !(0:maxprocs-1)
21580 !----------------------
21581 ! commom.contacts
21582 !      common /contacts/
21583       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
21584       allocate(icont(2,maxcont))
21585 !(2,maxcont)
21586 !      common /contacts1/
21587       allocate(num_cont(0:nres+4))
21588 !(maxres)
21589 #ifndef NEWCORR
21590       allocate(jcont(maxconts,nres))
21591 !(maxconts,maxres)
21592       allocate(facont(maxconts,nres))
21593 !(maxconts,maxres)
21594       allocate(gacont(3,maxconts,nres))
21595 !(3,maxconts,maxres)
21596 !      common /contacts_hb/
21597       allocate(gacontp_hb1(3,maxconts,nres))
21598       allocate(gacontp_hb2(3,maxconts,nres))
21599       allocate(gacontp_hb3(3,maxconts,nres))
21600       allocate(gacontm_hb1(3,maxconts,nres))
21601       allocate(gacontm_hb2(3,maxconts,nres))
21602       allocate(gacontm_hb3(3,maxconts,nres))
21603       allocate(gacont_hbr(3,maxconts,nres))
21604       allocate(grij_hb_cont(3,maxconts,nres))
21605         !(3,maxconts,maxres)
21606       allocate(facont_hb(maxconts,nres))
21607
21608       allocate(ees0p(maxconts,nres))
21609       allocate(ees0m(maxconts,nres))
21610       allocate(d_cont(maxconts,nres))
21611       allocate(ees0plist(maxconts,nres))
21612
21613 !(maxconts,maxres)
21614 !(maxres)
21615       allocate(jcont_hb(maxconts,nres))
21616 #endif
21617       allocate(num_cont_hb(nres))
21618 !(maxconts,maxres)
21619 !      common /rotat/
21620       allocate(Ug(2,2,nres))
21621       allocate(Ugder(2,2,nres))
21622       allocate(Ug2(2,2,nres))
21623       allocate(Ug2der(2,2,nres))
21624 !(2,2,maxres)
21625       allocate(obrot(2,nres))
21626       allocate(obrot2(2,nres))
21627       allocate(obrot_der(2,nres))
21628       allocate(obrot2_der(2,nres))
21629 !(2,maxres)
21630 !      common /precomp1/
21631       allocate(mu(2,nres))
21632       allocate(muder(2,nres))
21633       allocate(Ub2(2,nres))
21634       Ub2(1,:)=0.0d0
21635       Ub2(2,:)=0.0d0
21636       allocate(Ub2der(2,nres))
21637       allocate(Ctobr(2,nres))
21638       allocate(Ctobrder(2,nres))
21639       allocate(Dtobr2(2,nres))
21640       allocate(Dtobr2der(2,nres))
21641 !(2,maxres)
21642       allocate(EUg(2,2,nres))
21643       allocate(EUgder(2,2,nres))
21644       allocate(CUg(2,2,nres))
21645       allocate(CUgder(2,2,nres))
21646       allocate(DUg(2,2,nres))
21647       allocate(Dugder(2,2,nres))
21648       allocate(DtUg2(2,2,nres))
21649       allocate(DtUg2der(2,2,nres))
21650 !(2,2,maxres)
21651 !      common /precomp2/
21652       allocate(Ug2Db1t(2,nres))
21653       allocate(Ug2Db1tder(2,nres))
21654       allocate(CUgb2(2,nres))
21655       allocate(CUgb2der(2,nres))
21656 !(2,maxres)
21657       allocate(EUgC(2,2,nres))
21658       allocate(EUgCder(2,2,nres))
21659       allocate(EUgD(2,2,nres))
21660       allocate(EUgDder(2,2,nres))
21661       allocate(DtUg2EUg(2,2,nres))
21662       allocate(Ug2DtEUg(2,2,nres))
21663 !(2,2,maxres)
21664       allocate(Ug2DtEUgder(2,2,2,nres))
21665       allocate(DtUg2EUgder(2,2,2,nres))
21666 !(2,2,2,maxres)
21667       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
21668       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
21669       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
21670       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
21671
21672       allocate(ctilde(2,2,nres))
21673       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
21674       allocate(gtb1(2,nres))
21675       allocate(gtb2(2,nres))
21676       allocate(cc(2,2,nres))
21677       allocate(dd(2,2,nres))
21678       allocate(ee(2,2,nres))
21679       allocate(gtcc(2,2,nres))
21680       allocate(gtdd(2,2,nres))
21681       allocate(gtee(2,2,nres))
21682       allocate(gUb2(2,nres))
21683       allocate(gteUg(2,2,nres))
21684
21685 !      common /rotat_old/
21686       allocate(costab(nres))
21687       allocate(sintab(nres))
21688       allocate(costab2(nres))
21689       allocate(sintab2(nres))
21690 !(maxres)
21691 !      common /dipmat/
21692 !      allocate(a_chuj(2,2,maxconts,nres))
21693 !(2,2,maxconts,maxres)(maxconts=maxres/4)
21694 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))
21695 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
21696 !      common /contdistrib/
21697       allocate(ncont_sent(nres))
21698       allocate(ncont_recv(nres))
21699
21700       allocate(iat_sent(nres))
21701 !(maxres)
21702 #ifndef NEWCORR
21703       print *,"before iint_sent allocate"
21704       allocate(iint_sent(4,nres,nres))
21705       allocate(iint_sent_local(4,nres,nres))
21706       print *,"after iint_sent allocate"
21707 #endif
21708 !(4,maxres,maxres)
21709       allocate(iturn3_sent(4,0:nres+4))
21710       allocate(iturn4_sent(4,0:nres+4))
21711       allocate(iturn3_sent_local(4,nres))
21712       allocate(iturn4_sent_local(4,nres))
21713 !(4,maxres)
21714       allocate(itask_cont_from(0:nfgtasks-1))
21715       allocate(itask_cont_to(0:nfgtasks-1))
21716 !(0:max_fg_procs-1)
21717
21718
21719
21720 !----------------------
21721 ! commom.deriv;
21722 !      common /derivat/
21723 #ifdef NEWCORR
21724       print *,"before dcdv allocate"
21725       allocate(dcdv(6,nres+2))
21726       allocate(dxdv(6,nres+2))
21727 #else
21728       print *,"before dcdv allocate"
21729       allocate(dcdv(6,maxdim))
21730       allocate(dxdv(6,maxdim))
21731 #endif
21732 !(6,maxdim)
21733       allocate(dxds(6,nres))
21734 !(6,maxres)
21735       allocate(gradx(3,-1:nres,0:2))
21736       allocate(gradc(3,-1:nres,0:2))
21737 !(3,maxres,2)
21738       allocate(gvdwx(3,-1:nres))
21739       allocate(gvdwc(3,-1:nres))
21740       allocate(gelc(3,-1:nres))
21741       allocate(gelc_long(3,-1:nres))
21742       allocate(gvdwpp(3,-1:nres))
21743       allocate(gvdwc_scpp(3,-1:nres))
21744       allocate(gradx_scp(3,-1:nres))
21745       allocate(gvdwc_scp(3,-1:nres))
21746       allocate(ghpbx(3,-1:nres))
21747       allocate(ghpbc(3,-1:nres))
21748       allocate(gradcorr(3,-1:nres))
21749       allocate(gradcorr_long(3,-1:nres))
21750       allocate(gradcorr5_long(3,-1:nres))
21751       allocate(gradcorr6_long(3,-1:nres))
21752       allocate(gcorr6_turn_long(3,-1:nres))
21753       allocate(gradxorr(3,-1:nres))
21754       allocate(gradcorr5(3,-1:nres))
21755       allocate(gradcorr6(3,-1:nres))
21756       allocate(gliptran(3,-1:nres))
21757       allocate(gliptranc(3,-1:nres))
21758       allocate(gliptranx(3,-1:nres))
21759       allocate(gshieldx(3,-1:nres))
21760       allocate(gshieldc(3,-1:nres))
21761       allocate(gshieldc_loc(3,-1:nres))
21762       allocate(gshieldx_ec(3,-1:nres))
21763       allocate(gshieldc_ec(3,-1:nres))
21764       allocate(gshieldc_loc_ec(3,-1:nres))
21765       allocate(gshieldx_t3(3,-1:nres))
21766       allocate(gshieldc_t3(3,-1:nres))
21767       allocate(gshieldc_loc_t3(3,-1:nres))
21768       allocate(gshieldx_t4(3,-1:nres))
21769       allocate(gshieldc_t4(3,-1:nres))
21770       allocate(gshieldc_loc_t4(3,-1:nres))
21771       allocate(gshieldx_ll(3,-1:nres))
21772       allocate(gshieldc_ll(3,-1:nres))
21773       allocate(gshieldc_loc_ll(3,-1:nres))
21774       allocate(grad_shield(3,-1:nres))
21775       allocate(gg_tube_sc(3,-1:nres))
21776       allocate(gg_tube(3,-1:nres))
21777       allocate(gradafm(3,-1:nres))
21778       allocate(gradb_nucl(3,-1:nres))
21779       allocate(gradbx_nucl(3,-1:nres))
21780       allocate(gvdwpsb1(3,-1:nres))
21781       allocate(gelpp(3,-1:nres))
21782       allocate(gvdwpsb(3,-1:nres))
21783       allocate(gelsbc(3,-1:nres))
21784       allocate(gelsbx(3,-1:nres))
21785       allocate(gvdwsbx(3,-1:nres))
21786       allocate(gvdwsbc(3,-1:nres))
21787       allocate(gsbloc(3,-1:nres))
21788       allocate(gsblocx(3,-1:nres))
21789       allocate(gradcorr_nucl(3,-1:nres))
21790       allocate(gradxorr_nucl(3,-1:nres))
21791       allocate(gradcorr3_nucl(3,-1:nres))
21792       allocate(gradxorr3_nucl(3,-1:nres))
21793       allocate(gvdwpp_nucl(3,-1:nres))
21794       allocate(gradpepcat(3,-1:nres))
21795       allocate(gradpepcatx(3,-1:nres))
21796       allocate(gradcatcat(3,-1:nres))
21797       allocate(gradnuclcat(3,-1:nres))
21798       allocate(gradnuclcatx(3,-1:nres))
21799       allocate(gradlipbond(3,-1:nres))
21800       allocate(gradlipang(3,-1:nres))
21801       allocate(gradliplj(3,-1:nres))
21802       allocate(gradlipelec(3,-1:nres))
21803       allocate(gradcattranc(3,-1:nres))
21804       allocate(gradcattranx(3,-1:nres))
21805       allocate(gradcatangx(3,-1:nres))
21806       allocate(gradcatangc(3,-1:nres))
21807 !(3,maxres)
21808       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
21809       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
21810 ! grad for shielding surroing
21811       allocate(gloc(0:maxvar,0:2))
21812       allocate(gloc_x(0:maxvar,2))
21813 !(maxvar,2)
21814       allocate(gel_loc(3,-1:nres))
21815       allocate(gel_loc_long(3,-1:nres))
21816       allocate(gcorr3_turn(3,-1:nres))
21817       allocate(gcorr4_turn(3,-1:nres))
21818       allocate(gcorr6_turn(3,-1:nres))
21819       allocate(gradb(3,-1:nres))
21820       allocate(gradbx(3,-1:nres))
21821 !(3,maxres)
21822       allocate(gel_loc_loc(maxvar))
21823       allocate(gel_loc_turn3(maxvar))
21824       allocate(gel_loc_turn4(maxvar))
21825       allocate(gel_loc_turn6(maxvar))
21826       allocate(gcorr_loc(maxvar))
21827       allocate(g_corr5_loc(maxvar))
21828       allocate(g_corr6_loc(maxvar))
21829 !(maxvar)
21830       allocate(gsccorc(3,-1:nres))
21831       allocate(gsccorx(3,-1:nres))
21832 !(3,maxres)
21833       allocate(gsccor_loc(-1:nres))
21834 !(maxres)
21835       allocate(gvdwx_scbase(3,-1:nres))
21836       allocate(gvdwc_scbase(3,-1:nres))
21837       allocate(gvdwx_pepbase(3,-1:nres))
21838       allocate(gvdwc_pepbase(3,-1:nres))
21839       allocate(gvdwx_scpho(3,-1:nres))
21840       allocate(gvdwc_scpho(3,-1:nres))
21841       allocate(gvdwc_peppho(3,-1:nres))
21842
21843       allocate(dtheta(3,2,-1:nres))
21844 !(3,2,maxres)
21845       allocate(gscloc(3,-1:nres))
21846       allocate(gsclocx(3,-1:nres))
21847 !(3,maxres)
21848       allocate(dphi(3,3,-1:nres))
21849       allocate(dalpha(3,3,-1:nres))
21850       allocate(domega(3,3,-1:nres))
21851 !(3,3,maxres)
21852 !      common /deriv_scloc/
21853       allocate(dXX_C1tab(3,nres))
21854       allocate(dYY_C1tab(3,nres))
21855       allocate(dZZ_C1tab(3,nres))
21856       allocate(dXX_Ctab(3,nres))
21857       allocate(dYY_Ctab(3,nres))
21858       allocate(dZZ_Ctab(3,nres))
21859       allocate(dXX_XYZtab(3,nres))
21860       allocate(dYY_XYZtab(3,nres))
21861       allocate(dZZ_XYZtab(3,nres))
21862 !(3,maxres)
21863 !      common /mpgrad/
21864       allocate(jgrad_start(nres))
21865       allocate(jgrad_end(nres))
21866 !(maxres)
21867 !----------------------
21868
21869 !      common /indices/
21870       allocate(ibond_displ(0:nfgtasks-1))
21871       allocate(ibond_count(0:nfgtasks-1))
21872       allocate(ithet_displ(0:nfgtasks-1))
21873       allocate(ithet_count(0:nfgtasks-1))
21874       allocate(iphi_displ(0:nfgtasks-1))
21875       allocate(iphi_count(0:nfgtasks-1))
21876       allocate(iphi1_displ(0:nfgtasks-1))
21877       allocate(iphi1_count(0:nfgtasks-1))
21878       allocate(ivec_displ(0:nfgtasks-1))
21879       allocate(ivec_count(0:nfgtasks-1))
21880       allocate(iset_displ(0:nfgtasks-1))
21881       allocate(iset_count(0:nfgtasks-1))
21882       allocate(iint_count(0:nfgtasks-1))
21883       allocate(iint_displ(0:nfgtasks-1))
21884 !(0:max_fg_procs-1)
21885 !----------------------
21886 ! common.MD
21887 !      common /mdgrad/
21888       allocate(gcart(3,-1:nres))
21889       allocate(gxcart(3,-1:nres))
21890 !(3,0:MAXRES)
21891       allocate(gradcag(3,-1:nres))
21892       allocate(gradxag(3,-1:nres))
21893 !(3,MAXRES)
21894 !      common /back_constr/
21895 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
21896       allocate(dutheta(nres))
21897       allocate(dugamma(nres))
21898 !(maxres)
21899       allocate(duscdiff(3,-1:nres))
21900       allocate(duscdiffx(3,-1:nres))
21901 !(3,maxres)
21902 !el i io:read_fragments
21903 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
21904 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
21905 !      common /qmeas/
21906 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
21907 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
21908       allocate(mset(0:nprocs))  !(maxprocs/20)
21909       mset(:)=0
21910 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
21911 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
21912       allocate(dUdconst(3,0:nres))
21913       allocate(dUdxconst(3,0:nres))
21914       allocate(dqwol(3,0:nres))
21915       allocate(dxqwol(3,0:nres))
21916 !(3,0:MAXRES)
21917 !----------------------
21918 ! common.sbridge
21919 !      common /sbridge/ in io_common: read_bridge
21920 !el    allocate((:),allocatable :: iss      !(maxss)
21921 !      common /links/  in io_common: read_bridge
21922 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
21923 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
21924 !      common /dyn_ssbond/
21925 ! and side-chain vectors in theta or phi.
21926       allocate(dyn_ssbond_ij(10000))
21927 !(maxres,maxres)
21928 !      do i=1,nres
21929 !        do j=i+1,nres
21930       dyn_ssbond_ij(:)=1.0d300
21931 !        enddo
21932 !      enddo
21933
21934 !      if (nss.gt.0) then
21935       allocate(idssb(maxdim),jdssb(maxdim))
21936 !        allocate(newihpb(nss),newjhpb(nss))
21937 !(maxdim)
21938 !      endif
21939       allocate(ishield_list(-1:nres))
21940       allocate(shield_list(maxcontsshi,-1:nres))
21941       allocate(dyn_ss_mask(nres))
21942       allocate(fac_shield(-1:nres))
21943       allocate(enetube(nres*2))
21944       allocate(enecavtube(nres*2))
21945
21946 !(maxres)
21947       dyn_ss_mask(:)=.false.
21948 !----------------------
21949 ! common.sccor
21950 ! Parameters of the SCCOR term
21951 !      common/sccor/
21952 !el in io_conf: parmread
21953 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
21954 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
21955 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
21956 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
21957 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
21958 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
21959 !      allocate(vlor1sccor(maxterm_sccor,20,20))
21960 !      allocate(vlor2sccor(maxterm_sccor,20,20))
21961 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
21962 !----------------
21963       allocate(gloc_sc(3,0:2*nres,0:10))
21964 !(3,0:maxres2,10)maxres2=2*maxres
21965       allocate(dcostau(3,3,3,2*nres))
21966       allocate(dsintau(3,3,3,2*nres))
21967       allocate(dtauangle(3,3,3,2*nres))
21968       allocate(dcosomicron(3,3,3,2*nres))
21969       allocate(domicron(3,3,3,2*nres))
21970 !(3,3,3,maxres2)maxres2=2*maxres
21971 !----------------------
21972 ! common.var
21973 !      common /restr/
21974       allocate(varall(maxvar))
21975 !(maxvar)(maxvar=6*maxres)
21976       allocate(mask_theta(nres))
21977       allocate(mask_phi(nres))
21978       allocate(mask_side(nres))
21979 !(maxres)
21980 !----------------------
21981 ! common.vectors
21982 !      common /vectors/
21983       allocate(uy(3,nres))
21984       allocate(uz(3,nres))
21985 !(3,maxres)
21986       allocate(uygrad(3,3,2,nres))
21987       allocate(uzgrad(3,3,2,nres))
21988 !(3,3,2,maxres)
21989       print *,"before all 300"
21990 ! allocateion of lists JPRDLA
21991       allocate(newcontlistppi(300*nres))
21992       allocate(newcontlistscpi(350*nres))
21993       allocate(newcontlisti(300*nres))
21994       allocate(newcontlistppj(300*nres))
21995       allocate(newcontlistscpj(350*nres))
21996       allocate(newcontlistj(300*nres))
21997       allocate(newcontlistcatsctrani(300*nres))
21998       allocate(newcontlistcatsctranj(300*nres))
21999       allocate(newcontlistcatptrani(300*nres))
22000       allocate(newcontlistcatptranj(300*nres))
22001       allocate(newcontlistcatscnormi(300*nres))
22002       allocate(newcontlistcatscnormj(300*nres))
22003       allocate(newcontlistcatpnormi(300*nres))
22004       allocate(newcontlistcatpnormj(300*nres))
22005       allocate(newcontlistcatcatnormi(900*nres))
22006       allocate(newcontlistcatcatnormj(900*nres))
22007
22008       allocate(newcontlistcatscangi(300*nres))
22009       allocate(newcontlistcatscangj(300*nres))
22010       allocate(newcontlistcatscangfi(300*nres))
22011       allocate(newcontlistcatscangfj(300*nres))
22012       allocate(newcontlistcatscangfk(300*nres))
22013       allocate(newcontlistcatscangti(300*nres))
22014       allocate(newcontlistcatscangtj(300*nres))
22015       allocate(newcontlistcatscangtk(300*nres))
22016       allocate(newcontlistcatscangtl(300*nres))
22017
22018
22019       return
22020       end subroutine alloc_ener_arrays
22021 !-----------------------------------------------------------------
22022       subroutine ebond_nucl(estr_nucl)
22023 !c
22024 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
22025 !c
22026
22027       real(kind=8),dimension(3) :: u,ud
22028       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
22029       real(kind=8) :: estr_nucl,diff
22030       integer :: iti,i,j,k,nbi
22031       estr_nucl=0.0d0
22032 !C      print *,"I enter ebond"
22033       if (energy_dec) &
22034       write (iout,*) "ibondp_start,ibondp_end",&
22035        ibondp_nucl_start,ibondp_nucl_end
22036       do i=ibondp_nucl_start,ibondp_nucl_end
22037
22038         if (itype(i-1,2).eq.ntyp1_molec(2)&
22039             .and.itype(i,2).eq.ntyp1_molec(2)) cycle
22040         if (itype(i-1,2).eq.ntyp1_molec(2)&
22041             .or. itype(i,2).eq.ntyp1_molec(2)) then
22042 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
22043 !C          do j=1,3
22044 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
22045 !C            *dc(j,i-1)/vbld(i)
22046 !C          enddo
22047 !C          if (energy_dec) write(iout,*) &
22048 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
22049         diff = vbld(i)-vbldpDUM
22050         else
22051         diff = vbld(i)-vbldp0_nucl
22052         endif
22053 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
22054 !          do j=1,3
22055 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
22056 !     &      *dc(j,i-1)/vbld(i)
22057 !          enddo
22058 !          if (energy_dec) write(iout,*)
22059 !     &       "estr1",i,vbld(i),distchainmax,
22060 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
22061
22062         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
22063         vbldp0_nucl,diff,AKP_nucl*diff*diff
22064         estr_nucl=estr_nucl+diff*diff
22065 !          print *,estr_nucl
22066         do j=1,3
22067           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
22068         enddo
22069 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
22070       enddo
22071       estr_nucl=0.5d0*AKP_nucl*estr_nucl
22072 !      print *,"partial sum", estr_nucl,AKP_nucl
22073
22074       if (energy_dec) &
22075       write (iout,*) "ibondp_start,ibondp_end",&
22076        ibond_nucl_start,ibond_nucl_end
22077
22078       do i=ibond_nucl_start,ibond_nucl_end
22079 !C        print *, "I am stuck",i
22080       iti=itype(i,2)
22081       if (iti.eq.ntyp1_molec(2)) cycle
22082         nbi=nbondterm_nucl(iti)
22083 !C        print *,iti,nbi
22084         if (nbi.eq.1) then
22085           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
22086
22087           if (energy_dec) &
22088          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
22089          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
22090           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
22091 !            print *,estr_nucl
22092           do j=1,3
22093             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
22094           enddo
22095         else
22096           do j=1,nbi
22097             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
22098             ud(j)=aksc_nucl(j,iti)*diff
22099             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
22100           enddo
22101           uprod=u(1)
22102           do j=2,nbi
22103             uprod=uprod*u(j)
22104           enddo
22105           usum=0.0d0
22106           usumsqder=0.0d0
22107           do j=1,nbi
22108             uprod1=1.0d0
22109             uprod2=1.0d0
22110             do k=1,nbi
22111             if (k.ne.j) then
22112               uprod1=uprod1*u(k)
22113               uprod2=uprod2*u(k)*u(k)
22114             endif
22115             enddo
22116             usum=usum+uprod1
22117             usumsqder=usumsqder+ud(j)*uprod2
22118           enddo
22119           estr_nucl=estr_nucl+uprod/usum
22120           do j=1,3
22121            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
22122           enddo
22123       endif
22124       enddo
22125 !C      print *,"I am about to leave ebond"
22126       return
22127       end subroutine ebond_nucl
22128
22129 !-----------------------------------------------------------------------------
22130       subroutine ebend_nucl(etheta_nucl)
22131       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
22132       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
22133       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
22134       logical :: lprn=.false., lprn1=.false.
22135 !el local variables
22136       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
22137       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
22138       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
22139 ! local variables for constrains
22140       real(kind=8) :: difi,thetiii
22141        integer itheta
22142       etheta_nucl=0.0D0
22143 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
22144       do i=ithet_nucl_start,ithet_nucl_end
22145       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
22146       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
22147       (itype(i,2).eq.ntyp1_molec(2))) cycle
22148       dethetai=0.0d0
22149       dephii=0.0d0
22150       dephii1=0.0d0
22151       theti2=0.5d0*theta(i)
22152       ityp2=ithetyp_nucl(itype(i-1,2))
22153       do k=1,nntheterm_nucl
22154         coskt(k)=dcos(k*theti2)
22155         sinkt(k)=dsin(k*theti2)
22156       enddo
22157       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
22158 #ifdef OSF
22159         phii=phi(i)
22160         if (phii.ne.phii) phii=150.0
22161 #else
22162         phii=phi(i)
22163 #endif
22164         ityp1=ithetyp_nucl(itype(i-2,2))
22165         do k=1,nsingle_nucl
22166           cosph1(k)=dcos(k*phii)
22167           sinph1(k)=dsin(k*phii)
22168         enddo
22169       else
22170         phii=0.0d0
22171         ityp1=nthetyp_nucl+1
22172         do k=1,nsingle_nucl
22173           cosph1(k)=0.0d0
22174           sinph1(k)=0.0d0
22175         enddo
22176       endif
22177
22178       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
22179 #ifdef OSF
22180         phii1=phi(i+1)
22181         if (phii1.ne.phii1) phii1=150.0
22182         phii1=pinorm(phii1)
22183 #else
22184         phii1=phi(i+1)
22185 #endif
22186         ityp3=ithetyp_nucl(itype(i,2))
22187         do k=1,nsingle_nucl
22188           cosph2(k)=dcos(k*phii1)
22189           sinph2(k)=dsin(k*phii1)
22190         enddo
22191       else
22192         phii1=0.0d0
22193         ityp3=nthetyp_nucl+1
22194         do k=1,nsingle_nucl
22195           cosph2(k)=0.0d0
22196           sinph2(k)=0.0d0
22197         enddo
22198       endif
22199       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
22200       do k=1,ndouble_nucl
22201         do l=1,k-1
22202           ccl=cosph1(l)*cosph2(k-l)
22203           ssl=sinph1(l)*sinph2(k-l)
22204           scl=sinph1(l)*cosph2(k-l)
22205           csl=cosph1(l)*sinph2(k-l)
22206           cosph1ph2(l,k)=ccl-ssl
22207           cosph1ph2(k,l)=ccl+ssl
22208           sinph1ph2(l,k)=scl+csl
22209           sinph1ph2(k,l)=scl-csl
22210         enddo
22211       enddo
22212       if (lprn) then
22213       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
22214        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
22215       write (iout,*) "coskt and sinkt",nntheterm_nucl
22216       do k=1,nntheterm_nucl
22217         write (iout,*) k,coskt(k),sinkt(k)
22218       enddo
22219       endif
22220       do k=1,ntheterm_nucl
22221         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
22222         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
22223          *coskt(k)
22224         if (lprn)&
22225        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
22226         " ethetai",ethetai
22227       enddo
22228       if (lprn) then
22229       write (iout,*) "cosph and sinph"
22230       do k=1,nsingle_nucl
22231         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
22232       enddo
22233       write (iout,*) "cosph1ph2 and sinph2ph2"
22234       do k=2,ndouble_nucl
22235         do l=1,k-1
22236           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
22237             sinph1ph2(l,k),sinph1ph2(k,l)
22238         enddo
22239       enddo
22240       write(iout,*) "ethetai",ethetai
22241       endif
22242       do m=1,ntheterm2_nucl
22243         do k=1,nsingle_nucl
22244           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
22245             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
22246             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
22247             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
22248           ethetai=ethetai+sinkt(m)*aux
22249           dethetai=dethetai+0.5d0*m*aux*coskt(m)
22250           dephii=dephii+k*sinkt(m)*(&
22251              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
22252              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
22253           dephii1=dephii1+k*sinkt(m)*(&
22254              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
22255              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
22256           if (lprn) &
22257          write (iout,*) "m",m," k",k," bbthet",&
22258             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
22259             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
22260             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
22261             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
22262         enddo
22263       enddo
22264       if (lprn) &
22265       write(iout,*) "ethetai",ethetai
22266       do m=1,ntheterm3_nucl
22267         do k=2,ndouble_nucl
22268           do l=1,k-1
22269             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
22270              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
22271              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
22272              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
22273             ethetai=ethetai+sinkt(m)*aux
22274             dethetai=dethetai+0.5d0*m*coskt(m)*aux
22275             dephii=dephii+l*sinkt(m)*(&
22276             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
22277              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
22278              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
22279              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
22280             dephii1=dephii1+(k-l)*sinkt(m)*( &
22281             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
22282              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
22283              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
22284              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
22285             if (lprn) then
22286             write (iout,*) "m",m," k",k," l",l," ffthet", &
22287              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
22288              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
22289              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
22290              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
22291             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
22292              cosph1ph2(k,l)*sinkt(m),&
22293              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
22294             endif
22295           enddo
22296         enddo
22297       enddo
22298 10      continue
22299       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
22300       i,theta(i)*rad2deg,phii*rad2deg, &
22301       phii1*rad2deg,ethetai
22302       etheta_nucl=etheta_nucl+ethetai
22303 !        print *,i,"partial sum",etheta_nucl
22304       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
22305       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
22306       gloc(nphi+i-2,icg)=wang_nucl*dethetai
22307       enddo
22308       return
22309       end subroutine ebend_nucl
22310 !----------------------------------------------------
22311       subroutine etor_nucl(etors_nucl)
22312 !      implicit real(kind=8) (a-h,o-z)
22313 !      include 'DIMENSIONS'
22314 !      include 'COMMON.VAR'
22315 !      include 'COMMON.GEO'
22316 !      include 'COMMON.LOCAL'
22317 !      include 'COMMON.TORSION'
22318 !      include 'COMMON.INTERACT'
22319 !      include 'COMMON.DERIV'
22320 !      include 'COMMON.CHAIN'
22321 !      include 'COMMON.NAMES'
22322 !      include 'COMMON.IOUNITS'
22323 !      include 'COMMON.FFIELD'
22324 !      include 'COMMON.TORCNSTR'
22325 !      include 'COMMON.CONTROL'
22326       real(kind=8) :: etors_nucl,edihcnstr
22327       logical :: lprn
22328 !el local variables
22329       integer :: i,j,iblock,itori,itori1
22330       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
22331                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
22332 ! Set lprn=.true. for debugging
22333       lprn=.false.
22334 !     lprn=.true.
22335       etors_nucl=0.0D0
22336 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
22337       do i=iphi_nucl_start,iphi_nucl_end
22338       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
22339            .or. itype(i-3,2).eq.ntyp1_molec(2) &
22340            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
22341       etors_ii=0.0D0
22342       itori=itortyp_nucl(itype(i-2,2))
22343       itori1=itortyp_nucl(itype(i-1,2))
22344       phii=phi(i)
22345 !         print *,i,itori,itori1
22346       gloci=0.0D0
22347 !C Regular cosine and sine terms
22348       do j=1,nterm_nucl(itori,itori1)
22349         v1ij=v1_nucl(j,itori,itori1)
22350         v2ij=v2_nucl(j,itori,itori1)
22351         cosphi=dcos(j*phii)
22352         sinphi=dsin(j*phii)
22353         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
22354         if (energy_dec) etors_ii=etors_ii+&
22355                  v1ij*cosphi+v2ij*sinphi
22356         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
22357       enddo
22358 !C Lorentz terms
22359 !C                         v1
22360 !C  E = SUM ----------------------------------- - v1
22361 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
22362 !C
22363       cosphi=dcos(0.5d0*phii)
22364       sinphi=dsin(0.5d0*phii)
22365       do j=1,nlor_nucl(itori,itori1)
22366         vl1ij=vlor1_nucl(j,itori,itori1)
22367         vl2ij=vlor2_nucl(j,itori,itori1)
22368         vl3ij=vlor3_nucl(j,itori,itori1)
22369         pom=vl2ij*cosphi+vl3ij*sinphi
22370         pom1=1.0d0/(pom*pom+1.0d0)
22371         etors_nucl=etors_nucl+vl1ij*pom1
22372         if (energy_dec) etors_ii=etors_ii+ &
22373                  vl1ij*pom1
22374         pom=-pom*pom1*pom1
22375         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
22376       enddo
22377 !C Subtract the constant term
22378       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
22379         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
22380             'etor',i,etors_ii-v0_nucl(itori,itori1)
22381       if (lprn) &
22382        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
22383        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
22384        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
22385       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
22386 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
22387       enddo
22388       return
22389       end subroutine etor_nucl
22390 !------------------------------------------------------------
22391       subroutine epp_nucl_sub(evdw1,ees)
22392 !C
22393 !C This subroutine calculates the average interaction energy and its gradient
22394 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
22395 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
22396 !C The potential depends both on the distance of peptide-group centers and on
22397 !C the orientation of the CA-CA virtual bonds.
22398 !C
22399       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
22400       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
22401                       sslipj,ssgradlipj,faclipij2
22402       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
22403              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
22404              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
22405       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22406                 dist_temp, dist_init,sss_grad,fac,evdw1ij
22407       integer xshift,yshift,zshift
22408       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
22409       real(kind=8) :: ees,eesij
22410 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
22411       real(kind=8) scal_el /0.5d0/
22412       t_eelecij=0.0d0
22413       ees=0.0D0
22414       evdw1=0.0D0
22415       ind=0
22416 !c
22417 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
22418 !c
22419 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
22420       do i=iatel_s_nucl,iatel_e_nucl
22421       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
22422       dxi=dc(1,i)
22423       dyi=dc(2,i)
22424       dzi=dc(3,i)
22425       dx_normi=dc_norm(1,i)
22426       dy_normi=dc_norm(2,i)
22427       dz_normi=dc_norm(3,i)
22428       xmedi=c(1,i)+0.5d0*dxi
22429       ymedi=c(2,i)+0.5d0*dyi
22430       zmedi=c(3,i)+0.5d0*dzi
22431         call to_box(xmedi,ymedi,zmedi)
22432         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
22433
22434       do j=ielstart_nucl(i),ielend_nucl(i)
22435         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
22436         ind=ind+1
22437         dxj=dc(1,j)
22438         dyj=dc(2,j)
22439         dzj=dc(3,j)
22440 !          xj=c(1,j)+0.5D0*dxj-xmedi
22441 !          yj=c(2,j)+0.5D0*dyj-ymedi
22442 !          zj=c(3,j)+0.5D0*dzj-zmedi
22443         xj=c(1,j)+0.5D0*dxj
22444         yj=c(2,j)+0.5D0*dyj
22445         zj=c(3,j)+0.5D0*dzj
22446      call to_box(xj,yj,zj)
22447      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22448       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
22449       xj=boxshift(xj-xmedi,boxxsize)
22450       yj=boxshift(yj-ymedi,boxysize)
22451       zj=boxshift(zj-zmedi,boxzsize)
22452         rij=xj*xj+yj*yj+zj*zj
22453 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
22454         fac=(r0pp**2/rij)**3
22455         ev1=epspp*fac*fac
22456         ev2=epspp*fac
22457         evdw1ij=ev1-2*ev2
22458         fac=(-ev1-evdw1ij)/rij
22459 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
22460         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
22461         evdw1=evdw1+evdw1ij
22462 !C
22463 !C Calculate contributions to the Cartesian gradient.
22464 !C
22465         ggg(1)=fac*xj
22466         ggg(2)=fac*yj
22467         ggg(3)=fac*zj
22468         do k=1,3
22469           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
22470           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
22471         enddo
22472 !c phoshate-phosphate electrostatic interactions
22473         rij=dsqrt(rij)
22474         fac=1.0d0/rij
22475         eesij=dexp(-BEES*rij)*fac
22476 !          write (2,*)"fac",fac," eesijpp",eesij
22477         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
22478         ees=ees+eesij
22479 !c          fac=-eesij*fac
22480         fac=-(fac+BEES)*eesij*fac
22481         ggg(1)=fac*xj
22482         ggg(2)=fac*yj
22483         ggg(3)=fac*zj
22484 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
22485 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
22486 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
22487         do k=1,3
22488           gelpp(k,i)=gelpp(k,i)-ggg(k)
22489           gelpp(k,j)=gelpp(k,j)+ggg(k)
22490         enddo
22491       enddo ! j
22492       enddo   ! i
22493 !c      ees=332.0d0*ees
22494       ees=AEES*ees
22495       do i=nnt,nct
22496 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
22497       do k=1,3
22498         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
22499 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
22500         gelpp(k,i)=AEES*gelpp(k,i)
22501       enddo
22502 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
22503       enddo
22504 !c      write (2,*) "total EES",ees
22505       return
22506       end subroutine epp_nucl_sub
22507 !---------------------------------------------------------------------
22508       subroutine epsb(evdwpsb,eelpsb)
22509 !      use comm_locel
22510 !C
22511 !C This subroutine calculates the excluded-volume interaction energy between
22512 !C peptide-group centers and side chains and its gradient in virtual-bond and
22513 !C side-chain vectors.
22514 !C
22515       real(kind=8),dimension(3):: ggg
22516       integer :: i,iint,j,k,iteli,itypj,subchap
22517       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
22518                e1,e2,evdwij,rij,evdwpsb,eelpsb
22519       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22520                 dist_temp, dist_init
22521       integer xshift,yshift,zshift
22522
22523 !cd    print '(a)','Enter ESCP'
22524 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
22525       eelpsb=0.0d0
22526       evdwpsb=0.0d0
22527 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
22528       do i=iatscp_s_nucl,iatscp_e_nucl
22529       if (itype(i,2).eq.ntyp1_molec(2) &
22530        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
22531       xi=0.5D0*(c(1,i)+c(1,i+1))
22532       yi=0.5D0*(c(2,i)+c(2,i+1))
22533       zi=0.5D0*(c(3,i)+c(3,i+1))
22534         call to_box(xi,yi,zi)
22535
22536       do iint=1,nscp_gr_nucl(i)
22537
22538       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
22539         itypj=itype(j,2)
22540         if (itypj.eq.ntyp1_molec(2)) cycle
22541 !C Uncomment following three lines for SC-p interactions
22542 !c         xj=c(1,nres+j)-xi
22543 !c         yj=c(2,nres+j)-yi
22544 !c         zj=c(3,nres+j)-zi
22545 !C Uncomment following three lines for Ca-p interactions
22546 !          xj=c(1,j)-xi
22547 !          yj=c(2,j)-yi
22548 !          zj=c(3,j)-zi
22549         xj=c(1,j)
22550         yj=c(2,j)
22551         zj=c(3,j)
22552         call to_box(xj,yj,zj)
22553       xj=boxshift(xj-xi,boxxsize)
22554       yj=boxshift(yj-yi,boxysize)
22555       zj=boxshift(zj-zi,boxzsize)
22556
22557       dist_init=xj**2+yj**2+zj**2
22558
22559         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
22560         fac=rrij**expon2
22561         e1=fac*fac*aad_nucl(itypj)
22562         e2=fac*bad_nucl(itypj)
22563         if (iabs(j-i) .le. 2) then
22564           e1=scal14*e1
22565           e2=scal14*e2
22566         endif
22567         evdwij=e1+e2
22568         evdwpsb=evdwpsb+evdwij
22569         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
22570            'evdw2',i,j,evdwij,"tu4"
22571 !C
22572 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
22573 !C
22574         fac=-(evdwij+e1)*rrij
22575         ggg(1)=xj*fac
22576         ggg(2)=yj*fac
22577         ggg(3)=zj*fac
22578         do k=1,3
22579           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
22580           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
22581         enddo
22582       enddo
22583
22584       enddo ! iint
22585       enddo ! i
22586       do i=1,nct
22587       do j=1,3
22588         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
22589         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
22590       enddo
22591       enddo
22592       return
22593       end subroutine epsb
22594
22595 !------------------------------------------------------
22596       subroutine esb_gb(evdwsb,eelsb)
22597       use comm_locel
22598       use calc_data_nucl
22599       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
22600       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22601       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
22602       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22603                 dist_temp, dist_init,aa,bb,faclip,sig0ij
22604       integer :: ii
22605       logical lprn
22606       evdw=0.0D0
22607       eelsb=0.0d0
22608       ecorr=0.0d0
22609       evdwsb=0.0D0
22610       lprn=.false.
22611       ind=0
22612 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
22613       do i=iatsc_s_nucl,iatsc_e_nucl
22614       num_conti=0
22615       num_conti2=0
22616       itypi=itype(i,2)
22617 !        PRINT *,"I=",i,itypi
22618       if (itypi.eq.ntyp1_molec(2)) cycle
22619       itypi1=itype(i+1,2)
22620       xi=c(1,nres+i)
22621       yi=c(2,nres+i)
22622       zi=c(3,nres+i)
22623       call to_box(xi,yi,zi)
22624       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22625       dxi=dc_norm(1,nres+i)
22626       dyi=dc_norm(2,nres+i)
22627       dzi=dc_norm(3,nres+i)
22628       dsci_inv=vbld_inv(i+nres)
22629 !C
22630 !C Calculate SC interaction energy.
22631 !C
22632       do iint=1,nint_gr_nucl(i)
22633 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
22634         do j=istart_nucl(i,iint),iend_nucl(i,iint)
22635           ind=ind+1
22636 !            print *,"JESTEM"
22637           itypj=itype(j,2)
22638           if (itypj.eq.ntyp1_molec(2)) cycle
22639           dscj_inv=vbld_inv(j+nres)
22640           sig0ij=sigma_nucl(itypi,itypj)
22641           chi1=chi_nucl(itypi,itypj)
22642           chi2=chi_nucl(itypj,itypi)
22643           chi12=chi1*chi2
22644           chip1=chip_nucl(itypi,itypj)
22645           chip2=chip_nucl(itypj,itypi)
22646           chip12=chip1*chip2
22647 !            xj=c(1,nres+j)-xi
22648 !            yj=c(2,nres+j)-yi
22649 !            zj=c(3,nres+j)-zi
22650          xj=c(1,nres+j)
22651          yj=c(2,nres+j)
22652          zj=c(3,nres+j)
22653      call to_box(xj,yj,zj)
22654 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22655 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22656 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22657 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22658 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22659       xj=boxshift(xj-xi,boxxsize)
22660       yj=boxshift(yj-yi,boxysize)
22661       zj=boxshift(zj-zi,boxzsize)
22662
22663           dxj=dc_norm(1,nres+j)
22664           dyj=dc_norm(2,nres+j)
22665           dzj=dc_norm(3,nres+j)
22666           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
22667           rij=dsqrt(rrij)
22668 !C Calculate angle-dependent terms of energy and contributions to their
22669 !C derivatives.
22670           erij(1)=xj*rij
22671           erij(2)=yj*rij
22672           erij(3)=zj*rij
22673           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
22674           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
22675           om12=dxi*dxj+dyi*dyj+dzi*dzj
22676           call sc_angular_nucl
22677           sigsq=1.0D0/sigsq
22678           sig=sig0ij*dsqrt(sigsq)
22679           rij_shift=1.0D0/rij-sig+sig0ij
22680 !            print *,rij_shift,"rij_shift"
22681 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
22682 !c     &       " rij_shift",rij_shift
22683           if (rij_shift.le.0.0D0) then
22684             evdw=1.0D20
22685             return
22686           endif
22687           sigder=-sig*sigsq
22688 !c---------------------------------------------------------------
22689           rij_shift=1.0D0/rij_shift
22690           fac=rij_shift**expon
22691           e1=fac*fac*aa_nucl(itypi,itypj)
22692           e2=fac*bb_nucl(itypi,itypj)
22693           evdwij=eps1*eps2rt*(e1+e2)
22694 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
22695 !c     &       " e1",e1," e2",e2," evdwij",evdwij
22696           eps2der=evdwij
22697           evdwij=evdwij*eps2rt
22698           evdwsb=evdwsb+evdwij
22699           if (lprn) then
22700           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
22701           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
22702           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
22703            restyp(itypi,2),i,restyp(itypj,2),j, &
22704            epsi,sigm,chi1,chi2,chip1,chip2, &
22705            eps1,eps2rt**2,sig,sig0ij, &
22706            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
22707           evdwij
22708           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
22709           endif
22710
22711           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
22712                        'evdw',i,j,evdwij,"tu3"
22713
22714
22715 !C Calculate gradient components.
22716           e1=e1*eps1*eps2rt**2
22717           fac=-expon*(e1+evdwij)*rij_shift
22718           sigder=fac*sigder
22719           fac=rij*fac
22720 !c            fac=0.0d0
22721 !C Calculate the radial part of the gradient
22722           gg(1)=xj*fac
22723           gg(2)=yj*fac
22724           gg(3)=zj*fac
22725 !C Calculate angular part of the gradient.
22726           call sc_grad_nucl
22727           call eelsbij(eelij,num_conti2)
22728           if (energy_dec .and. &
22729          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
22730         write (istat,'(e14.5)') evdwij
22731           eelsb=eelsb+eelij
22732         enddo      ! j
22733       enddo        ! iint
22734       num_cont_hb(i)=num_conti2
22735       enddo          ! i
22736 !c      write (iout,*) "Number of loop steps in EGB:",ind
22737 !cccc      energy_dec=.false.
22738       return
22739       end subroutine esb_gb
22740 !-------------------------------------------------------------------------------
22741       subroutine eelsbij(eesij,num_conti2)
22742       use comm_locel
22743       use calc_data_nucl
22744       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
22745       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
22746       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22747                 dist_temp, dist_init,rlocshield,fracinbuf
22748       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
22749
22750 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
22751       real(kind=8) scal_el /0.5d0/
22752       integer :: iteli,itelj,kkk,kkll,m,isubchap
22753       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
22754       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
22755       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
22756               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
22757               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
22758               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
22759               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
22760               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
22761               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
22762               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
22763       ind=ind+1
22764       itypi=itype(i,2)
22765       itypj=itype(j,2)
22766 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
22767       ael6i=ael6_nucl(itypi,itypj)
22768       ael3i=ael3_nucl(itypi,itypj)
22769       ael63i=ael63_nucl(itypi,itypj)
22770       ael32i=ael32_nucl(itypi,itypj)
22771 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
22772 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
22773       dxj=dc(1,j+nres)
22774       dyj=dc(2,j+nres)
22775       dzj=dc(3,j+nres)
22776       dx_normi=dc_norm(1,i+nres)
22777       dy_normi=dc_norm(2,i+nres)
22778       dz_normi=dc_norm(3,i+nres)
22779       dx_normj=dc_norm(1,j+nres)
22780       dy_normj=dc_norm(2,j+nres)
22781       dz_normj=dc_norm(3,j+nres)
22782 !c      xj=c(1,j)+0.5D0*dxj-xmedi
22783 !c      yj=c(2,j)+0.5D0*dyj-ymedi
22784 !c      zj=c(3,j)+0.5D0*dzj-zmedi
22785       if (ipot_nucl.ne.2) then
22786       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
22787       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
22788       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
22789       else
22790       cosa=om12
22791       cosb=om1
22792       cosg=om2
22793       endif
22794       r3ij=rij*rrij
22795       r6ij=r3ij*r3ij
22796       fac=cosa-3.0D0*cosb*cosg
22797       facfac=fac*fac
22798       fac1=3.0d0*(cosb*cosb+cosg*cosg)
22799       fac3=ael6i*r6ij
22800       fac4=ael3i*r3ij
22801       fac5=ael63i*r6ij
22802       fac6=ael32i*r6ij
22803 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
22804 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
22805       el1=fac3*(4.0D0+facfac-fac1)
22806       el2=fac4*fac
22807       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
22808       el4=fac6*facfac
22809       eesij=el1+el2+el3+el4
22810 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
22811       ees0ij=4.0D0+facfac-fac1
22812
22813       if (energy_dec) then
22814         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
22815         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
22816          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
22817          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
22818          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
22819         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
22820       endif
22821
22822 !C
22823 !C Calculate contributions to the Cartesian gradient.
22824 !C
22825       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
22826       fac1=fac
22827 !c      erij(1)=xj*rmij
22828 !c      erij(2)=yj*rmij
22829 !c      erij(3)=zj*rmij
22830 !*
22831 !* Radial derivatives. First process both termini of the fragment (i,j)
22832 !*
22833       ggg(1)=facel*xj
22834       ggg(2)=facel*yj
22835       ggg(3)=facel*zj
22836       do k=1,3
22837       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22838       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22839       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
22840       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
22841       enddo
22842 !*
22843 !* Angular part
22844 !*
22845       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
22846       fac4=-3.0D0*fac4
22847       fac3=-6.0D0*fac3
22848       fac5= 6.0d0*fac5
22849       fac6=-6.0d0*fac6
22850       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
22851        fac6*fac1*cosg
22852       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
22853        fac6*fac1*cosb
22854       do k=1,3
22855       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
22856       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
22857       enddo
22858       do k=1,3
22859       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
22860       enddo
22861       do k=1,3
22862       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
22863            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
22864            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22865       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
22866            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22867            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22868       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22869       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22870       enddo
22871 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
22872        IF ( j.gt.i+1 .and.&
22873         num_conti.le.maxcont) THEN
22874 !C
22875 !C Calculate the contact function. The ith column of the array JCONT will
22876 !C contain the numbers of atoms that make contacts with the atom I (of numbers
22877 !C greater than I). The arrays FACONT and GACONT will contain the values of
22878 !C the contact function and its derivative.
22879       r0ij=2.20D0*sigma_nucl(itypi,itypj)
22880 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
22881       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
22882 !c        write (2,*) "fcont",fcont
22883       if (fcont.gt.0.0D0) then
22884         num_conti=num_conti+1
22885         num_conti2=num_conti2+1
22886
22887         if (num_conti.gt.maxconts) then
22888           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
22889                     ' will skip next contacts for this conf.',maxconts
22890         else
22891           jcont_hb(num_conti,i)=j
22892 !c            write (iout,*) "num_conti",num_conti,
22893 !c     &        " jcont_hb",jcont_hb(num_conti,i)
22894 !C Calculate contact energies
22895           cosa4=4.0D0*cosa
22896           wij=cosa-3.0D0*cosb*cosg
22897           cosbg1=cosb+cosg
22898           cosbg2=cosb-cosg
22899           fac3=dsqrt(-ael6i)*r3ij
22900 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
22901           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
22902           if (ees0tmp.gt.0) then
22903             ees0pij=dsqrt(ees0tmp)
22904           else
22905             ees0pij=0
22906           endif
22907           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
22908           if (ees0tmp.gt.0) then
22909             ees0mij=dsqrt(ees0tmp)
22910           else
22911             ees0mij=0
22912           endif
22913           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
22914           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
22915 !c            write (iout,*) "i",i," j",j,
22916 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
22917           ees0pij1=fac3/ees0pij
22918           ees0mij1=fac3/ees0mij
22919           fac3p=-3.0D0*fac3*rrij
22920           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
22921           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
22922           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
22923           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
22924           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
22925           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
22926           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
22927           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
22928           ecosap=ecosa1+ecosa2
22929           ecosbp=ecosb1+ecosb2
22930           ecosgp=ecosg1+ecosg2
22931           ecosam=ecosa1-ecosa2
22932           ecosbm=ecosb1-ecosb2
22933           ecosgm=ecosg1-ecosg2
22934 !C End diagnostics
22935           facont_hb(num_conti,i)=fcont
22936           fprimcont=fprimcont/rij
22937           do k=1,3
22938             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
22939             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
22940           enddo
22941           gggp(1)=gggp(1)+ees0pijp*xj
22942           gggp(2)=gggp(2)+ees0pijp*yj
22943           gggp(3)=gggp(3)+ees0pijp*zj
22944           gggm(1)=gggm(1)+ees0mijp*xj
22945           gggm(2)=gggm(2)+ees0mijp*yj
22946           gggm(3)=gggm(3)+ees0mijp*zj
22947 !C Derivatives due to the contact function
22948           gacont_hbr(1,num_conti,i)=fprimcont*xj
22949           gacont_hbr(2,num_conti,i)=fprimcont*yj
22950           gacont_hbr(3,num_conti,i)=fprimcont*zj
22951           do k=1,3
22952 !c
22953 !c Gradient of the correlation terms
22954 !c
22955             gacontp_hb1(k,num_conti,i)= &
22956            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22957           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22958             gacontp_hb2(k,num_conti,i)= &
22959            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
22960           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22961             gacontp_hb3(k,num_conti,i)=gggp(k)
22962             gacontm_hb1(k,num_conti,i)= &
22963            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22964           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22965             gacontm_hb2(k,num_conti,i)= &
22966            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22967           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22968             gacontm_hb3(k,num_conti,i)=gggm(k)
22969           enddo
22970         endif
22971       endif
22972       ENDIF
22973       return
22974       end subroutine eelsbij
22975 !------------------------------------------------------------------
22976       subroutine sc_grad_nucl
22977       use comm_locel
22978       use calc_data_nucl
22979       real(kind=8),dimension(3) :: dcosom1,dcosom2
22980       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
22981       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
22982       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
22983       do k=1,3
22984       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
22985       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
22986       enddo
22987       do k=1,3
22988       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
22989       enddo
22990       do k=1,3
22991       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
22992              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
22993              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22994       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
22995              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22996              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22997       enddo
22998 !C
22999 !C Calculate the components of the gradient in DC and X
23000 !C
23001       do l=1,3
23002       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
23003       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
23004       enddo
23005       return
23006       end subroutine sc_grad_nucl
23007 !-----------------------------------------------------------------------
23008       subroutine esb(esbloc)
23009 !C Calculate the local energy of a side chain and its derivatives in the
23010 !C corresponding virtual-bond valence angles THETA and the spherical angles
23011 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
23012 !C added by Urszula Kozlowska. 07/11/2007
23013 !C
23014       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
23015       real(kind=8),dimension(9):: x
23016      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
23017       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
23018       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
23019       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
23020        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
23021        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
23022        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
23023        integer::it,nlobit,i,j,k
23024 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
23025       delta=0.02d0*pi
23026       esbloc=0.0D0
23027       do i=loc_start_nucl,loc_end_nucl
23028       if (itype(i,2).eq.ntyp1_molec(2)) cycle
23029       costtab(i+1) =dcos(theta(i+1))
23030       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
23031       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
23032       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
23033       cosfac2=0.5d0/(1.0d0+costtab(i+1))
23034       cosfac=dsqrt(cosfac2)
23035       sinfac2=0.5d0/(1.0d0-costtab(i+1))
23036       sinfac=dsqrt(sinfac2)
23037       it=itype(i,2)
23038       if (it.eq.10) goto 1
23039
23040 !c
23041 !C  Compute the axes of tghe local cartesian coordinates system; store in
23042 !c   x_prime, y_prime and z_prime
23043 !c
23044       do j=1,3
23045         x_prime(j) = 0.00
23046         y_prime(j) = 0.00
23047         z_prime(j) = 0.00
23048       enddo
23049 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
23050 !C     &   dc_norm(3,i+nres)
23051       do j = 1,3
23052         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
23053         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
23054       enddo
23055       do j = 1,3
23056         z_prime(j) = -uz(j,i-1)
23057 !           z_prime(j)=0.0
23058       enddo
23059
23060       xx=0.0d0
23061       yy=0.0d0
23062       zz=0.0d0
23063       do j = 1,3
23064         xx = xx + x_prime(j)*dc_norm(j,i+nres)
23065         yy = yy + y_prime(j)*dc_norm(j,i+nres)
23066         zz = zz + z_prime(j)*dc_norm(j,i+nres)
23067       enddo
23068
23069       xxtab(i)=xx
23070       yytab(i)=yy
23071       zztab(i)=zz
23072        it=itype(i,2)
23073       do j = 1,9
23074         x(j) = sc_parmin_nucl(j,it)
23075       enddo
23076 #ifdef CHECK_COORD
23077 !Cc diagnostics - remove later
23078       xx1 = dcos(alph(2))
23079       yy1 = dsin(alph(2))*dcos(omeg(2))
23080       zz1 = -dsin(alph(2))*dsin(omeg(2))
23081       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
23082        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
23083        xx1,yy1,zz1
23084 !C,"  --- ", xx_w,yy_w,zz_w
23085 !c end diagnostics
23086 #endif
23087       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23088       esbloc = esbloc + sumene
23089       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
23090 !        print *,"enecomp",sumene,sumene2
23091         if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
23092 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
23093 #ifdef DEBUG
23094       write (2,*) "x",(x(k),k=1,9)
23095 !C
23096 !C This section to check the numerical derivatives of the energy of ith side
23097 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
23098 !C #define DEBUG in the code to turn it on.
23099 !C
23100       write (2,*) "sumene               =",sumene
23101       aincr=1.0d-7
23102       xxsave=xx
23103       xx=xx+aincr
23104       write (2,*) xx,yy,zz
23105       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23106       de_dxx_num=(sumenep-sumene)/aincr
23107       xx=xxsave
23108       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
23109       yysave=yy
23110       yy=yy+aincr
23111       write (2,*) xx,yy,zz
23112       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23113       de_dyy_num=(sumenep-sumene)/aincr
23114       yy=yysave
23115       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
23116       zzsave=zz
23117       zz=zz+aincr
23118       write (2,*) xx,yy,zz
23119       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23120       de_dzz_num=(sumenep-sumene)/aincr
23121       zz=zzsave
23122       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
23123       costsave=cost2tab(i+1)
23124       sintsave=sint2tab(i+1)
23125       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
23126       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
23127       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23128       de_dt_num=(sumenep-sumene)/aincr
23129       write (2,*) " t+ sumene from enesc=",sumenep,sumene
23130       cost2tab(i+1)=costsave
23131       sint2tab(i+1)=sintsave
23132 !C End of diagnostics section.
23133 #endif
23134 !C
23135 !C Compute the gradient of esc
23136 !C
23137       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
23138       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
23139       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
23140       de_dtt=0.0d0
23141 #ifdef DEBUG
23142       write (2,*) "x",(x(k),k=1,9)
23143       write (2,*) "xx",xx," yy",yy," zz",zz
23144       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
23145         " de_zz   ",de_zz," de_tt   ",de_tt
23146       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
23147         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
23148 #endif
23149 !C
23150        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
23151        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
23152        cosfac2xx=cosfac2*xx
23153        sinfac2yy=sinfac2*yy
23154        do k = 1,3
23155        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
23156          vbld_inv(i+1)
23157        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
23158          vbld_inv(i)
23159        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
23160        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
23161 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
23162 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
23163 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
23164 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
23165        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
23166        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
23167        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
23168        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
23169        dZZ_Ci1(k)=0.0d0
23170        dZZ_Ci(k)=0.0d0
23171        do j=1,3
23172          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
23173          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
23174        enddo
23175
23176        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
23177        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
23178        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
23179 !c
23180        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
23181        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
23182        enddo
23183
23184        do k=1,3
23185        dXX_Ctab(k,i)=dXX_Ci(k)
23186        dXX_C1tab(k,i)=dXX_Ci1(k)
23187        dYY_Ctab(k,i)=dYY_Ci(k)
23188        dYY_C1tab(k,i)=dYY_Ci1(k)
23189        dZZ_Ctab(k,i)=dZZ_Ci(k)
23190        dZZ_C1tab(k,i)=dZZ_Ci1(k)
23191        dXX_XYZtab(k,i)=dXX_XYZ(k)
23192        dYY_XYZtab(k,i)=dYY_XYZ(k)
23193        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
23194        enddo
23195        do k = 1,3
23196 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
23197 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
23198 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
23199 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
23200 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
23201 !c     &    dt_dci(k)
23202 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
23203 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
23204        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
23205        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
23206        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
23207        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
23208        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
23209        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
23210 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
23211        enddo
23212 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
23213 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
23214
23215 !C to check gradient call subroutine check_grad
23216
23217     1 continue
23218       enddo
23219       return
23220       end subroutine esb
23221 !=-------------------------------------------------------
23222       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
23223 !      implicit none
23224       real(kind=8),dimension(9):: x(9)
23225        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
23226       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
23227       integer i
23228 !c      write (2,*) "enesc"
23229 !c      write (2,*) "x",(x(i),i=1,9)
23230 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
23231       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
23232       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
23233       + x(9)*yy*zz
23234       enesc_nucl=sumene
23235       return
23236       end function enesc_nucl
23237 !-----------------------------------------------------------------------------
23238       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
23239 #ifdef MPI
23240       include 'mpif.h'
23241       integer,parameter :: max_cont=2000
23242       integer,parameter:: max_dim=2*(8*3+6)
23243       integer, parameter :: msglen1=max_cont*max_dim
23244       integer,parameter :: msglen2=2*msglen1
23245       integer source,CorrelType,CorrelID,Error
23246       real(kind=8) :: buffer(max_cont,max_dim)
23247       integer status(MPI_STATUS_SIZE)
23248       integer :: ierror,nbytes
23249 #endif
23250       real(kind=8),dimension(3):: gx(3),gx1(3)
23251       real(kind=8) :: time00
23252       logical lprn,ldone
23253       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
23254       real(kind=8) ecorr,ecorr3
23255       integer :: n_corr,n_corr1,mm,msglen
23256 !C Set lprn=.true. for debugging
23257       lprn=.false.
23258       n_corr=0
23259       n_corr1=0
23260 #ifdef MPI
23261       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
23262
23263       if (nfgtasks.le.1) goto 30
23264       if (lprn) then
23265       write (iout,'(a)') 'Contact function values:'
23266       do i=nnt,nct-1
23267         write (iout,'(2i3,50(1x,i2,f5.2))')  &
23268        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
23269        j=1,num_cont_hb(i))
23270       enddo
23271       endif
23272 !C Caution! Following code assumes that electrostatic interactions concerning
23273 !C a given atom are split among at most two processors!
23274       CorrelType=477
23275       CorrelID=fg_rank+1
23276       ldone=.false.
23277       do i=1,max_cont
23278       do j=1,max_dim
23279         buffer(i,j)=0.0D0
23280       enddo
23281       enddo
23282       mm=mod(fg_rank,2)
23283 !c      write (*,*) 'MyRank',MyRank,' mm',mm
23284       if (mm) 20,20,10
23285    10 continue
23286 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
23287       if (fg_rank.gt.0) then
23288 !C Send correlation contributions to the preceding processor
23289       msglen=msglen1
23290       nn=num_cont_hb(iatel_s_nucl)
23291       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
23292 !c        write (*,*) 'The BUFFER array:'
23293 !c        do i=1,nn
23294 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
23295 !c        enddo
23296       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
23297         msglen=msglen2
23298         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
23299 !C Clear the contacts of the atom passed to the neighboring processor
23300       nn=num_cont_hb(iatel_s_nucl+1)
23301 !c        do i=1,nn
23302 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
23303 !c        enddo
23304           num_cont_hb(iatel_s_nucl)=0
23305       endif
23306 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
23307 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
23308 !cd   & ' msglen=',msglen
23309 !c        write (*,*) 'Processor ',fg_rank,MyRank,
23310 !c     & ' is sending correlation contribution to processor',fg_rank-1,
23311 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
23312       time00=MPI_Wtime()
23313       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
23314        CorrelType,FG_COMM,IERROR)
23315       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
23316 !cd      write (iout,*) 'Processor ',fg_rank,
23317 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
23318 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
23319 !c        write (*,*) 'Processor ',fg_rank,
23320 !c     & ' has sent correlation contribution to processor',fg_rank-1,
23321 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
23322 !c        msglen=msglen1
23323       endif ! (fg_rank.gt.0)
23324       if (ldone) goto 30
23325       ldone=.true.
23326    20 continue
23327 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
23328       if (fg_rank.lt.nfgtasks-1) then
23329 !C Receive correlation contributions from the next processor
23330       msglen=msglen1
23331       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
23332 !cd      write (iout,*) 'Processor',fg_rank,
23333 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
23334 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
23335 !c        write (*,*) 'Processor',fg_rank,
23336 !c     &' is receiving correlation contribution from processor',fg_rank+1,
23337 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
23338       time00=MPI_Wtime()
23339       nbytes=-1
23340       do while (nbytes.le.0)
23341         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
23342         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
23343       enddo
23344 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
23345       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
23346        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
23347       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
23348 !c        write (*,*) 'Processor',fg_rank,
23349 !c     &' has received correlation contribution from processor',fg_rank+1,
23350 !c     & ' msglen=',msglen,' nbytes=',nbytes
23351 !c        write (*,*) 'The received BUFFER array:'
23352 !c        do i=1,max_cont
23353 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
23354 !c        enddo
23355       if (msglen.eq.msglen1) then
23356         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
23357       else if (msglen.eq.msglen2)  then
23358         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
23359         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
23360       else
23361         write (iout,*) &
23362       'ERROR!!!! message length changed while processing correlations.'
23363         write (*,*) &
23364       'ERROR!!!! message length changed while processing correlations.'
23365         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
23366       endif ! msglen.eq.msglen1
23367       endif ! fg_rank.lt.nfgtasks-1
23368       if (ldone) goto 30
23369       ldone=.true.
23370       goto 10
23371    30 continue
23372 #endif
23373       if (lprn) then
23374       write (iout,'(a)') 'Contact function values:'
23375       do i=nnt_molec(2),nct_molec(2)-1
23376         write (iout,'(2i3,50(1x,i2,f5.2))') &
23377        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
23378        j=1,num_cont_hb(i))
23379       enddo
23380       endif
23381       ecorr=0.0D0
23382       ecorr3=0.0d0
23383 !C Remove the loop below after debugging !!!
23384 !      do i=nnt_molec(2),nct_molec(2)
23385 !        do j=1,3
23386 !          gradcorr_nucl(j,i)=0.0D0
23387 !          gradxorr_nucl(j,i)=0.0D0
23388 !          gradcorr3_nucl(j,i)=0.0D0
23389 !          gradxorr3_nucl(j,i)=0.0D0
23390 !        enddo
23391 !      enddo
23392 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
23393 !C Calculate the local-electrostatic correlation terms
23394       do i=iatsc_s_nucl,iatsc_e_nucl
23395       i1=i+1
23396       num_conti=num_cont_hb(i)
23397       num_conti1=num_cont_hb(i+1)
23398 !        print *,i,num_conti,num_conti1
23399       do jj=1,num_conti
23400         j=jcont_hb(jj,i)
23401         do kk=1,num_conti1
23402           j1=jcont_hb(kk,i1)
23403 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
23404 !c     &         ' jj=',jj,' kk=',kk
23405           if (j1.eq.j+1 .or. j1.eq.j-1) then
23406 !C
23407 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
23408 !C The system gains extra energy.
23409 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
23410 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
23411 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
23412 !C
23413             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
23414             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
23415              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
23416             n_corr=n_corr+1
23417           else if (j1.eq.j) then
23418 !C
23419 !C Contacts I-J and I-(J+1) occur simultaneously.
23420 !C The system loses extra energy.
23421 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
23422 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
23423 !C Need to implement full formulas 32 from Liwo et al., 1998.
23424 !C
23425 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
23426 !c     &         ' jj=',jj,' kk=',kk
23427             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
23428           endif
23429         enddo ! kk
23430         do kk=1,num_conti
23431           j1=jcont_hb(kk,i)
23432 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
23433 !c     &         ' jj=',jj,' kk=',kk
23434           if (j1.eq.j+1) then
23435 !C Contacts I-J and (I+1)-J occur simultaneously.
23436 !C The system loses extra energy.
23437             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
23438           endif ! j1==j+1
23439         enddo ! kk
23440       enddo ! jj
23441       enddo ! i
23442       return
23443       end subroutine multibody_hb_nucl
23444 !-----------------------------------------------------------
23445       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
23446 !      implicit real(kind=8) (a-h,o-z)
23447 !      include 'DIMENSIONS'
23448 !      include 'COMMON.IOUNITS'
23449 !      include 'COMMON.DERIV'
23450 !      include 'COMMON.INTERACT'
23451 !      include 'COMMON.CONTACTS'
23452       real(kind=8),dimension(3) :: gx,gx1
23453       logical :: lprn
23454 !el local variables
23455       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
23456       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
23457                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
23458                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
23459                rlocshield
23460
23461       lprn=.false.
23462       eij=facont_hb(jj,i)
23463       ekl=facont_hb(kk,k)
23464       ees0pij=ees0p(jj,i)
23465       ees0pkl=ees0p(kk,k)
23466       ees0mij=ees0m(jj,i)
23467       ees0mkl=ees0m(kk,k)
23468       ekont=eij*ekl
23469       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
23470 !      print *,"ehbcorr_nucl",ekont,ees
23471 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
23472 !C Following 4 lines for diagnostics.
23473 !cd    ees0pkl=0.0D0
23474 !cd    ees0pij=1.0D0
23475 !cd    ees0mkl=0.0D0
23476 !cd    ees0mij=1.0D0
23477 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
23478 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
23479 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
23480 !C Calculate the multi-body contribution to energy.
23481 !      ecorr_nucl=ecorr_nucl+ekont*ees
23482 !C Calculate multi-body contributions to the gradient.
23483       coeffpees0pij=coeffp*ees0pij
23484       coeffmees0mij=coeffm*ees0mij
23485       coeffpees0pkl=coeffp*ees0pkl
23486       coeffmees0mkl=coeffm*ees0mkl
23487       do ll=1,3
23488       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
23489        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
23490        coeffmees0mkl*gacontm_hb1(ll,jj,i))
23491       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
23492       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
23493       coeffmees0mkl*gacontm_hb2(ll,jj,i))
23494       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
23495       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
23496       coeffmees0mij*gacontm_hb1(ll,kk,k))
23497       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
23498       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
23499       coeffmees0mij*gacontm_hb2(ll,kk,k))
23500       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
23501         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
23502         coeffmees0mkl*gacontm_hb3(ll,jj,i))
23503       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
23504       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
23505       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
23506         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
23507         coeffmees0mij*gacontm_hb3(ll,kk,k))
23508       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
23509       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
23510       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
23511       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
23512       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
23513       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
23514       enddo
23515       ehbcorr_nucl=ekont*ees
23516       return
23517       end function ehbcorr_nucl
23518 !-------------------------------------------------------------------------
23519
23520      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
23521 !      implicit real(kind=8) (a-h,o-z)
23522 !      include 'DIMENSIONS'
23523 !      include 'COMMON.IOUNITS'
23524 !      include 'COMMON.DERIV'
23525 !      include 'COMMON.INTERACT'
23526 !      include 'COMMON.CONTACTS'
23527       real(kind=8),dimension(3) :: gx,gx1
23528       logical :: lprn
23529 !el local variables
23530       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
23531       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
23532                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
23533                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
23534                rlocshield
23535
23536       lprn=.false.
23537       eij=facont_hb(jj,i)
23538       ekl=facont_hb(kk,k)
23539       ees0pij=ees0p(jj,i)
23540       ees0pkl=ees0p(kk,k)
23541       ees0mij=ees0m(jj,i)
23542       ees0mkl=ees0m(kk,k)
23543       ekont=eij*ekl
23544       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
23545 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
23546 !C Following 4 lines for diagnostics.
23547 !cd    ees0pkl=0.0D0
23548 !cd    ees0pij=1.0D0
23549 !cd    ees0mkl=0.0D0
23550 !cd    ees0mij=1.0D0
23551 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
23552 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
23553 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
23554 !C Calculate the multi-body contribution to energy.
23555 !      ecorr=ecorr+ekont*ees
23556 !C Calculate multi-body contributions to the gradient.
23557       coeffpees0pij=coeffp*ees0pij
23558       coeffmees0mij=coeffm*ees0mij
23559       coeffpees0pkl=coeffp*ees0pkl
23560       coeffmees0mkl=coeffm*ees0mkl
23561       do ll=1,3
23562       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
23563        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
23564        coeffmees0mkl*gacontm_hb1(ll,jj,i))
23565       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
23566       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
23567       coeffmees0mkl*gacontm_hb2(ll,jj,i))
23568       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
23569       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
23570       coeffmees0mij*gacontm_hb1(ll,kk,k))
23571       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
23572       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
23573       coeffmees0mij*gacontm_hb2(ll,kk,k))
23574       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
23575         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
23576         coeffmees0mkl*gacontm_hb3(ll,jj,i))
23577       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
23578       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
23579       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
23580         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
23581         coeffmees0mij*gacontm_hb3(ll,kk,k))
23582       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
23583       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
23584       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
23585       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
23586       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
23587       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
23588       enddo
23589       ehbcorr3_nucl=ekont*ees
23590       return
23591       end function ehbcorr3_nucl
23592 #ifdef MPI
23593       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
23594       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
23595       real(kind=8):: buffer(dimen1,dimen2)
23596       num_kont=num_cont_hb(atom)
23597       do i=1,num_kont
23598       do k=1,8
23599         do j=1,3
23600           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
23601         enddo ! j
23602       enddo ! k
23603       buffer(i,indx+25)=facont_hb(i,atom)
23604       buffer(i,indx+26)=ees0p(i,atom)
23605       buffer(i,indx+27)=ees0m(i,atom)
23606       buffer(i,indx+28)=d_cont(i,atom)
23607       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
23608       enddo ! i
23609       buffer(1,indx+30)=dfloat(num_kont)
23610       return
23611       end subroutine pack_buffer
23612 !c------------------------------------------------------------------------------
23613       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
23614       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
23615       real(kind=8):: buffer(dimen1,dimen2)
23616 !      double precision zapas
23617 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
23618 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
23619 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
23620 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
23621       num_kont=buffer(1,indx+30)
23622       num_kont_old=num_cont_hb(atom)
23623       num_cont_hb(atom)=num_kont+num_kont_old
23624       do i=1,num_kont
23625       ii=i+num_kont_old
23626       do k=1,8
23627         do j=1,3
23628           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
23629         enddo ! j
23630       enddo ! k
23631       facont_hb(ii,atom)=buffer(i,indx+25)
23632       ees0p(ii,atom)=buffer(i,indx+26)
23633       ees0m(ii,atom)=buffer(i,indx+27)
23634       d_cont(i,atom)=buffer(i,indx+28)
23635       jcont_hb(ii,atom)=buffer(i,indx+29)
23636       enddo ! i
23637       return
23638       end subroutine unpack_buffer
23639 !c------------------------------------------------------------------------------
23640 #endif
23641       subroutine ecatcat(ecationcation)
23642       use MD_data, only: t_bath
23643       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj,irdiff,&
23644       ii
23645       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23646       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
23647       real(kind=8) :: xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23648       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
23649       real(kind=8) :: awat,bwat,cwat,dwat,sss2min2,sss2mingrad2,rdiff,ewater
23650       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23651       gg,r
23652
23653       ecationcation=0.0d0
23654       if (nres_molec(5).le.1) return
23655       rcat0=3.472
23656       epscalc=0.05
23657       r06 = rcat0**6
23658       r012 = r06**2
23659 !        k0 = 332.0*(2.0*2.0)/80.0
23660       itmp=0
23661
23662 !      do i=1,4
23663 !      itmp=itmp+nres_molec(i)
23664 !      enddo
23665 !        write(iout,*) "itmp",g_listcatcatnorm_start, g_listcatcatnorm_end
23666 !      do i=itmp+1,itmp+nres_molec(5)-1
23667        do ii=g_listcatcatnorm_start, g_listcatcatnorm_end
23668         i=newcontlistcatcatnormi(ii)
23669         j=newcontlistcatcatnormj(ii)
23670
23671       xi=c(1,i)
23672       yi=c(2,i)
23673       zi=c(3,i)
23674 !        write (iout,*) i,"TUTUT",c(1,i)
23675         itypi=itype(i,5)
23676       call to_box(xi,yi,zi)
23677       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23678 !        do j=i+1,itmp+nres_molec(5)
23679         itypj=itype(j,5)
23680 !          print *,i,j,itypi,itypj
23681         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
23682 !           print *,i,j,'catcat'
23683          xj=c(1,j)
23684          yj=c(2,j)
23685          zj=c(3,j)
23686       call to_box(xj,yj,zj)
23687 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23688 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23689 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23690 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23691 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23692       xj=boxshift(xj-xi,boxxsize)
23693       yj=boxshift(yj-yi,boxysize)
23694       zj=boxshift(zj-zi,boxzsize)
23695        rcal =xj**2+yj**2+zj**2
23696       ract=sqrt(rcal)
23697         if ((itypi.gt.1).or.(itypj.gt.1)) then
23698        if (sss2min2.eq.0.0d0) cycle
23699        sss2min2=sscale2(ract,12.0d0,1.0d0)
23700        sss2mingrad2=sscagrad2(ract,12.0d0,1.0d0)
23701 !        rcat0=3.472
23702 !        epscalc=0.05
23703 !        r06 = rcat0**6
23704 !        r012 = r06**2
23705 !        k0 = 332*(2*2)/80
23706       Evan1cat=epscalc*(r012/(rcal**6))
23707       Evan2cat=epscalc*2*(r06/(rcal**3))
23708       Eeleccat=k0/ract
23709       r7 = rcal**7
23710       r4 = rcal**4
23711       r(1)=xj
23712       r(2)=yj
23713       r(3)=zj
23714       do k=1,3
23715         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
23716         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
23717         dEeleccat(k)=-k0*r(k)/ract**3
23718       enddo
23719       do k=1,3
23720         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
23721         gradcatcat(k,i)=gradcatcat(k,i)-(gg(k)*sss2min2+(Evan1cat+Evan2cat+Eeleccat)*sss2mingrad2)
23722         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)*sss2min2+(Evan1cat+Evan2cat+Eeleccat)*sss2mingrad2
23723       enddo
23724       if (energy_dec) write (iout,*) "ecatcat",i,j,Evan1cat,Evan2cat,Eeleccat,&
23725        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
23726 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
23727       ecationcation=ecationcation+(Evan1cat+Evan2cat+Eeleccat)*sss2min2
23728        else !this is water part and other non standard molecules
23729
23730        sss2min2=sscale2(ract,10.0d0,1.0d0)! cutoff for water interaction is 15A
23731        if (sss2min2.eq.0.0d0) cycle
23732        sss2mingrad2=sscagrad2(ract,10.0d0,1.0d0)
23733        irdiff=int((ract-2.06d0)*50.0d0)+1
23734
23735        rdiff=ract-((irdiff-1)*0.02d0+2.06d0)
23736        if (irdiff.le.0) then
23737         irdiff=0
23738         rdiff=ract
23739        endif
23740 !       print *,rdiff,ract,irdiff,sss2mingrad2
23741        awat=awaterenta(irdiff)-awaterentro(irdiff)*t_bath/1000.0d0
23742        bwat=bwaterenta(irdiff)-bwaterentro(irdiff)*t_bath/1000.0d0
23743        cwat=cwaterenta(irdiff)-cwaterentro(irdiff)*t_bath/1000.0d0
23744        dwat=dwaterenta(irdiff)-dwaterentro(irdiff)*t_bath/1000.0d0
23745        r(1)=xj
23746        r(2)=yj
23747        r(3)=zj
23748
23749        ewater=awat+bwat*rdiff+cwat*rdiff*rdiff+dwat*rdiff*rdiff*rdiff
23750        ecationcation=ecationcation+ewater*sss2min2
23751        do k=1,3
23752         gg(k)=(bwat+2.0d0*cwat*rdiff+dwat*3.0d0*rdiff*rdiff)*r(k)/ract
23753         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)*sss2min2-sss2mingrad2*ewater*r(k)/ract
23754         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)*sss2min2+sss2mingrad2*ewater*r(k)/ract
23755       enddo
23756        if (energy_dec) write(iout,'(2f8.2,f10.2,2i5)') rdiff,ract,ecationcation,i,j
23757        endif ! end water
23758        enddo
23759 !      enddo
23760        return
23761        end subroutine ecatcat
23762 !---------------------------------------------------------------------------
23763 ! new for K+
23764       subroutine ecats_prot_amber(evdw)
23765 !      subroutine ecat_prot2(ecation_prot)
23766       use calc_data
23767       use comm_momo
23768
23769       logical :: lprn
23770 !el local variables
23771       integer :: iint,itypi1,subchap,isel,itmp
23772       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
23773       real(kind=8) :: evdw,aa,bb
23774       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23775                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
23776                 sslipi,sslipj,faclip,alpha_sco
23777       integer :: ii
23778       real(kind=8) :: fracinbuf
23779       real (kind=8) :: escpho
23780       real (kind=8),dimension(4):: ener
23781       real(kind=8) :: b1,b2,egb
23782       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
23783        Lambf,&
23784        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
23785        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
23786        federmaus,&
23787        d1i,d1j
23788 !       real(kind=8),dimension(3,2)::erhead_tail
23789 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
23790       real(kind=8) ::  facd4, adler, Fgb, facd3
23791       integer troll,jj,istate
23792       real (kind=8) :: dcosom1(3),dcosom2(3)
23793       real(kind=8) ::locbox(3)
23794       locbox(1)=boxxsize
23795           locbox(2)=boxysize
23796       locbox(3)=boxzsize
23797
23798       evdw=0.0D0
23799       if (nres_molec(5).eq.0) return
23800       eps_out=80.0d0
23801 !      sss_ele_cut=1.0d0
23802
23803       itmp=0
23804       do i=1,4
23805       itmp=itmp+nres_molec(i)
23806       enddo
23807 !        go to 17
23808 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23809       do i=ibond_start,ibond_end
23810
23811 !        print *,"I am in EVDW",i
23812       itypi=iabs(itype(i,1))
23813
23814 !        if (i.ne.47) cycle
23815       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
23816       itypi1=iabs(itype(i+1,1))
23817       xi=c(1,nres+i)
23818       yi=c(2,nres+i)
23819       zi=c(3,nres+i)
23820       call to_box(xi,yi,zi)
23821       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23822       dxi=dc_norm(1,nres+i)
23823       dyi=dc_norm(2,nres+i)
23824       dzi=dc_norm(3,nres+i)
23825       dsci_inv=vbld_inv(i+nres)
23826        do j=itmp+1,itmp+nres_molec(5)
23827
23828 ! Calculate SC interaction energy.
23829           itypj=iabs(itype(j,5))
23830           if ((itypj.eq.ntyp1)) cycle
23831            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23832
23833           dscj_inv=0.0
23834          xj=c(1,j)
23835          yj=c(2,j)
23836          zj=c(3,j)
23837
23838       call to_box(xj,yj,zj)
23839 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
23840
23841 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23842 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23843 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23844 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23845 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23846       xj=boxshift(xj-xi,boxxsize)
23847       yj=boxshift(yj-yi,boxysize)
23848       zj=boxshift(zj-zi,boxzsize)
23849 !      write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize
23850
23851 !          dxj = dc_norm( 1, nres+j )
23852 !          dyj = dc_norm( 2, nres+j )
23853 !          dzj = dc_norm( 3, nres+j )
23854
23855         itypi = itype(i,1)
23856         itypj = itype(j,5)
23857 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23858 ! sampling performed with amber package
23859 !          alf1   = 0.0d0
23860 !          alf2   = 0.0d0
23861 !          alf12  = 0.0d0
23862 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23863         chi1 = chi1cat(itypi,itypj)
23864         chis1 = chis1cat(itypi,itypj)
23865         chip1 = chipp1cat(itypi,itypj)
23866 !          chi1=0.0d0
23867 !          chis1=0.0d0
23868 !          chip1=0.0d0
23869         chi2=0.0
23870         chip2=0.0
23871         chis2=0.0
23872 !          chis2 = chis(itypj,itypi)
23873         chis12 = chis1 * chis2
23874         sig1 = sigmap1cat(itypi,itypj)
23875         sig2=0.0d0
23876 !          sig2 = sigmap2(itypi,itypj)
23877 ! alpha factors from Fcav/Gcav
23878         b1cav = alphasurcat(1,itypi,itypj)
23879         b2cav = alphasurcat(2,itypi,itypj)
23880         b3cav = alphasurcat(3,itypi,itypj)
23881         b4cav = alphasurcat(4,itypi,itypj)
23882
23883 !        b1cav=0.0d0
23884 !        b2cav=0.0d0
23885 !        b3cav=0.0d0
23886 !        b4cav=0.0d0
23887
23888 ! used to determine whether we want to do quadrupole calculations
23889        eps_in = epsintabcat(itypi,itypj)
23890        if (eps_in.eq.0.0) eps_in=1.0
23891
23892        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23893 !       Rtail = 0.0d0
23894
23895        DO k = 1, 3
23896       ctail(k,1)=c(k,i+nres)
23897       ctail(k,2)=c(k,j)
23898        END DO
23899       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
23900       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
23901 !c! tail distances will be themselves usefull elswhere
23902 !c1 (in Gcav, for example)
23903        do k=1,3
23904        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
23905        enddo
23906        Rtail = dsqrt( &
23907         (Rtail_distance(1)*Rtail_distance(1)) &
23908       + (Rtail_distance(2)*Rtail_distance(2)) &
23909       + (Rtail_distance(3)*Rtail_distance(3)))
23910 ! tail location and distance calculations
23911 ! dhead1
23912        d1 = dheadcat(1, 1, itypi, itypj)
23913 !       d2 = dhead(2, 1, itypi, itypj)
23914        DO k = 1,3
23915 ! location of polar head is computed by taking hydrophobic centre
23916 ! and moving by a d1 * dc_norm vector
23917 ! see unres publications for very informative images
23918       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
23919       chead(k,2) = c(k, j)
23920       enddo
23921       call to_box(chead(1,1),chead(2,1),chead(3,1))
23922       call to_box(chead(1,2),chead(2,2),chead(3,2))
23923 !      write(iout,*) "TEST",chead(1,1),chead(2,1),chead(3,1),dc_norm(k, i+nres),d1
23924 ! distance
23925 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23926 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23927       do k=1,3
23928       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
23929        END DO
23930 ! pitagoras (root of sum of squares)
23931        Rhead = dsqrt( &
23932         (Rhead_distance(1)*Rhead_distance(1)) &
23933       + (Rhead_distance(2)*Rhead_distance(2)) &
23934       + (Rhead_distance(3)*Rhead_distance(3)))
23935 !-------------------------------------------------------------------
23936 ! zero everything that should be zero'ed
23937        evdwij = 0.0d0
23938        ECL = 0.0d0
23939        Elj = 0.0d0
23940        Equad = 0.0d0
23941        Epol = 0.0d0
23942        Fcav=0.0d0
23943        eheadtail = 0.0d0
23944        dGCLdOM1 = 0.0d0
23945        dGCLdOM2 = 0.0d0
23946        dGCLdOM12 = 0.0d0
23947        dPOLdOM1 = 0.0d0
23948        dPOLdOM2 = 0.0d0
23949         Fcav = 0.0d0
23950         Fisocav=0.0d0
23951         dFdR = 0.0d0
23952         dCAVdOM1  = 0.0d0
23953         dCAVdOM2  = 0.0d0
23954         dCAVdOM12 = 0.0d0
23955         dscj_inv = vbld_inv(j+nres)
23956 !          print *,i,j,dscj_inv,dsci_inv
23957 ! rij holds 1/(distance of Calpha atoms)
23958         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23959         rij  = dsqrt(rrij)
23960         CALL sc_angular
23961 ! this should be in elgrad_init but om's are calculated by sc_angular
23962 ! which in turn is used by older potentials
23963 ! om = omega, sqom = om^2
23964         sqom1  = om1 * om1
23965         sqom2  = om2 * om2
23966         sqom12 = om12 * om12
23967
23968 ! now we calculate EGB - Gey-Berne
23969 ! It will be summed up in evdwij and saved in evdw
23970         sigsq     = 1.0D0  / sigsq
23971         sig       = sig0ij * dsqrt(sigsq)
23972 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23973         rij_shift = Rtail - sig + sig0ij
23974         IF (rij_shift.le.0.0D0) THEN
23975          evdw = 1.0D20
23976       if (evdw.gt.1.0d6) then
23977       write (*,'(2(1x,a3,i3),7f7.2)') &
23978       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23979       1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij,sigsq
23980       write(*,*) facsig,faceps1_inv,om1,chiom1,chi1
23981      write(*,*) "ANISO?!",chi1
23982 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23983 !      Equad,evdwij+Fcav+eheadtail,evdw
23984       endif
23985
23986          RETURN
23987         END IF
23988         sigder = -sig * sigsq
23989         rij_shift = 1.0D0 / rij_shift
23990         fac       = rij_shift**expon
23991         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23992 !          print *,"ADAM",aa_aq(itypi,itypj)
23993
23994 !          c1        = 0.0d0
23995         c2        = fac  * bb_aq_cat(itypi,itypj)
23996 !          c2        = 0.0d0
23997         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23998         eps2der   = eps3rt * evdwij
23999         eps3der   = eps2rt * evdwij
24000 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24001         evdwij    = eps2rt * eps3rt * evdwij
24002 !#ifdef TSCSC
24003 !          IF (bb_aq(itypi,itypj).gt.0) THEN
24004 !           evdw_p = evdw_p + evdwij
24005 !          ELSE
24006 !           evdw_m = evdw_m + evdwij
24007 !          END IF
24008 !#else
24009         evdw = evdw  &
24010             + evdwij
24011 !#endif
24012         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24013         fac    = -expon * (c1 + evdwij) * rij_shift
24014         sigder = fac * sigder
24015 ! Calculate distance derivative
24016         gg(1) =  fac
24017         gg(2) =  fac
24018         gg(3) =  fac
24019 !       print *,"GG(1),distance grad",gg(1)
24020         fac = chis1 * sqom1 + chis2 * sqom2 &
24021         - 2.0d0 * chis12 * om1 * om2 * om12
24022         pom = 1.0d0 - chis1 * chis2 * sqom12
24023         Lambf = (1.0d0 - (fac / pom))
24024         Lambf = dsqrt(Lambf)
24025         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24026         Chif = Rtail * sparrow
24027         ChiLambf = Chif * Lambf
24028         eagle = dsqrt(ChiLambf)
24029         bat = ChiLambf ** 11.0d0
24030         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
24031         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
24032         botsq = bot * bot
24033         Fcav = top / bot
24034
24035        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
24036        dbot = 12.0d0 * b4cav * bat * Lambf
24037        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24038
24039         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
24040         dbot = 12.0d0 * b4cav * bat * Chif
24041         eagle = Lambf * pom
24042         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24043         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24044         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24045             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24046
24047         dFdL = ((dtop * bot - top * dbot) / botsq)
24048         dCAVdOM1  = dFdL * ( dFdOM1 )
24049         dCAVdOM2  = dFdL * ( dFdOM2 )
24050         dCAVdOM12 = dFdL * ( dFdOM12 )
24051
24052        DO k= 1, 3
24053       ertail(k) = Rtail_distance(k)/Rtail
24054        END DO
24055        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24056        erdxj = scalar( ertail(1), dC_norm(1,j) )
24057        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
24058        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j)
24059        DO k = 1, 3
24060       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24061       gradpepcatx(k,i) = gradpepcatx(k,i) &
24062               - (( dFdR + gg(k) ) * pom)
24063       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j))
24064 !        gvdwx(k,j) = gvdwx(k,j)   &
24065 !                  + (( dFdR + gg(k) ) * pom)
24066       gradpepcat(k,i) = gradpepcat(k,i)  &
24067               - (( dFdR + gg(k) ) * ertail(k))
24068       gradpepcat(k,j) = gradpepcat(k,j) &
24069               + (( dFdR + gg(k) ) * ertail(k))
24070       gg(k) = 0.0d0
24071        ENDDO
24072 !c! Compute head-head and head-tail energies for each state
24073 !!        if (.false.) then ! turn off electrostatic
24074         if (itype(j,5).gt.0) then ! the normal cation case
24075         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
24076 !        print *,i,itype(i,1),isel
24077         IF (isel.eq.0) THEN
24078 !c! No charges - do nothing
24079          eheadtail = 0.0d0
24080
24081         ELSE IF (isel.eq.1) THEN
24082 !c! Nonpolar-charge interactions
24083         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24084           Qi=Qi*2
24085           Qij=Qij*2
24086          endif
24087
24088          CALL enq_cat(epol)
24089          eheadtail = epol
24090 !           eheadtail = 0.0d0
24091
24092         ELSE IF (isel.eq.3) THEN
24093 !c! Dipole-charge interactions
24094         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24095           Qi=Qi*2
24096           Qij=Qij*2
24097          endif
24098 !         write(iout,*) "KURWA0",d1
24099
24100          CALL edq_cat(ecl, elj, epol)
24101         eheadtail = ECL + elj + epol
24102 !           eheadtail = 0.0d0
24103
24104         ELSE IF ((isel.eq.2)) THEN
24105
24106 !c! Same charge-charge interaction ( +/+ or -/- )
24107         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24108           Qi=Qi*2
24109           Qij=Qij*2
24110          endif
24111
24112          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
24113          eheadtail = ECL + Egb + Epol + Fisocav + Elj
24114 !           eheadtail = 0.0d0
24115
24116 !          ELSE IF ((isel.eq.2.and.  &
24117 !               iabs(Qi).eq.1).and. &
24118 !               nstate(itypi,itypj).ne.1) THEN
24119 !c! Different charge-charge interaction ( +/- or -/+ )
24120 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24121 !            Qi=Qi*2
24122 !            Qij=Qij*2
24123 !           endif
24124 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
24125 !            Qj=Qj*2
24126 !            Qij=Qij*2
24127 !           endif
24128 !
24129 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
24130        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
24131        else
24132        write(iout,*) "not yet implemented",j,itype(j,5)
24133        endif
24134 !!       endif ! turn off electrostatic
24135       evdw = evdw  + Fcav + eheadtail
24136 !      if (evdw.gt.1.0d6) then
24137 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24138 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24139 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24140 !      Equad,evdwij+Fcav+eheadtail,evdw
24141 !      endif
24142
24143        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24144       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24145       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24146       Equad,evdwij+Fcav+eheadtail,evdw
24147 !       evdw = evdw  + Fcav  + eheadtail
24148        if (energy_dec) write(iout,*) "FCAV", &
24149          sig1,sig2,b1cav,b2cav,b3cav,b4cav
24150 !       print *,"before sc_grad_cat", i,j, gradpepcat(1,j)
24151 !        iF (nstate(itypi,itypj).eq.1) THEN
24152       CALL sc_grad_cat
24153 !       print *,"after sc_grad_cat", i,j, gradpepcat(1,j)
24154
24155 !       END IF
24156 !c!-------------------------------------------------------------------
24157 !c! NAPISY KONCOWE
24158        END DO   ! j
24159        END DO     ! i
24160 !c      write (iout,*) "Number of loop steps in EGB:",ind
24161 !c      energy_dec=.false.
24162 !              print *,"EVDW KURW",evdw,nres
24163 !!!        return
24164    17   continue
24165 !      go to 23
24166       do i=ibond_start,ibond_end
24167
24168 !        print *,"I am in EVDW",i
24169       itypi=10 ! the peptide group parameters are for glicine
24170
24171 !        if (i.ne.47) cycle
24172       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
24173       itypi1=iabs(itype(i+1,1))
24174       xi=(c(1,i)+c(1,i+1))/2.0
24175       yi=(c(2,i)+c(2,i+1))/2.0
24176       zi=(c(3,i)+c(3,i+1))/2.0
24177         call to_box(xi,yi,zi)
24178       dxi=dc_norm(1,i)
24179       dyi=dc_norm(2,i)
24180       dzi=dc_norm(3,i)
24181       dsci_inv=vbld_inv(i+1)/2.0
24182        do j=itmp+1,itmp+nres_molec(5)
24183
24184 ! Calculate SC interaction energy.
24185           itypj=iabs(itype(j,5))
24186           if ((itypj.eq.ntyp1)) cycle
24187            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
24188
24189           dscj_inv=0.0
24190          xj=c(1,j)
24191          yj=c(2,j)
24192          zj=c(3,j)
24193         call to_box(xj,yj,zj)
24194       xj=boxshift(xj-xi,boxxsize)
24195       yj=boxshift(yj-yi,boxysize)
24196       zj=boxshift(zj-zi,boxzsize)
24197
24198         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24199
24200         dxj = 0.0d0! dc_norm( 1, nres+j )
24201         dyj = 0.0d0!dc_norm( 2, nres+j )
24202         dzj = 0.0d0! dc_norm( 3, nres+j )
24203
24204         itypi = 10
24205         itypj = itype(j,5)
24206 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
24207 ! sampling performed with amber package
24208 !          alf1   = 0.0d0
24209 !          alf2   = 0.0d0
24210 !          alf12  = 0.0d0
24211 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
24212         chi1 = chi1cat(itypi,itypj)
24213         chis1 = chis1cat(itypi,itypj)
24214         chip1 = chipp1cat(itypi,itypj)
24215 !          chi1=0.0d0
24216 !          chis1=0.0d0
24217 !          chip1=0.0d0
24218         chi2=0.0
24219         chip2=0.0
24220         chis2=0.0
24221 !          chis2 = chis(itypj,itypi)
24222         chis12 = chis1 * chis2
24223         sig1 = sigmap1cat(itypi,itypj)
24224         sig2=0.0
24225 !          sig2 = sigmap2(itypi,itypj)
24226 ! alpha factors from Fcav/Gcav
24227         b1cav = alphasurcat(1,itypi,itypj)
24228         b2cav = alphasurcat(2,itypi,itypj)
24229         b3cav = alphasurcat(3,itypi,itypj)
24230         b4cav = alphasurcat(4,itypi,itypj)
24231
24232 ! used to determine whether we want to do quadrupole calculations
24233        eps_in = epsintabcat(itypi,itypj)
24234        if (eps_in.eq.0.0) eps_in=1.0
24235
24236        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24237 !       Rtail = 0.0d0
24238
24239        DO k = 1, 3
24240       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
24241       ctail(k,2)=c(k,j)
24242        END DO
24243       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
24244       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
24245 !c! tail distances will be themselves usefull elswhere
24246 !c1 (in Gcav, for example)
24247        do k=1,3
24248        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
24249        enddo
24250
24251 !c! tail distances will be themselves usefull elswhere
24252 !c1 (in Gcav, for example)
24253        Rtail = dsqrt( &
24254         (Rtail_distance(1)*Rtail_distance(1)) &
24255       + (Rtail_distance(2)*Rtail_distance(2)) &
24256       + (Rtail_distance(3)*Rtail_distance(3)))
24257 ! tail location and distance calculations
24258 ! dhead1
24259        d1 = dheadcat(1, 1, itypi, itypj)
24260 !       print *,"d1",d1
24261 !       d1=0.0d0
24262 !       d2 = dhead(2, 1, itypi, itypj)
24263        DO k = 1,3
24264 ! location of polar head is computed by taking hydrophobic centre
24265 ! and moving by a d1 * dc_norm vector
24266 ! see unres publications for very informative images
24267       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
24268       chead(k,2) = c(k, j)
24269        ENDDO
24270 ! distance
24271 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24272 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24273       call to_box(chead(1,1),chead(2,1),chead(3,1))
24274       call to_box(chead(1,2),chead(2,2),chead(3,2))
24275
24276 ! distance
24277 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24278 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24279       do k=1,3
24280       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
24281        END DO
24282
24283 ! pitagoras (root of sum of squares)
24284        Rhead = dsqrt( &
24285         (Rhead_distance(1)*Rhead_distance(1)) &
24286       + (Rhead_distance(2)*Rhead_distance(2)) &
24287       + (Rhead_distance(3)*Rhead_distance(3)))
24288 !-------------------------------------------------------------------
24289 ! zero everything that should be zero'ed
24290        evdwij = 0.0d0
24291        ECL = 0.0d0
24292        Elj = 0.0d0
24293        Equad = 0.0d0
24294        Epol = 0.0d0
24295        Fcav=0.0d0
24296        eheadtail = 0.0d0
24297        dGCLdOM1 = 0.0d0
24298        dGCLdOM2 = 0.0d0
24299        dGCLdOM12 = 0.0d0
24300        dPOLdOM1 = 0.0d0
24301        dPOLdOM2 = 0.0d0
24302         Fcav = 0.0d0
24303         dFdR = 0.0d0
24304         dCAVdOM1  = 0.0d0
24305         dCAVdOM2  = 0.0d0
24306         dCAVdOM12 = 0.0d0
24307         dscj_inv = vbld_inv(j+nres)
24308 !          print *,i,j,dscj_inv,dsci_inv
24309 ! rij holds 1/(distance of Calpha atoms)
24310         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24311         rij  = dsqrt(rrij)
24312         CALL sc_angular
24313 ! this should be in elgrad_init but om's are calculated by sc_angular
24314 ! which in turn is used by older potentials
24315 ! om = omega, sqom = om^2
24316         sqom1  = om1 * om1
24317         sqom2  = om2 * om2
24318         sqom12 = om12 * om12
24319
24320 ! now we calculate EGB - Gey-Berne
24321 ! It will be summed up in evdwij and saved in evdw
24322         sigsq     = 1.0D0  / sigsq
24323         sig       = sig0ij * dsqrt(sigsq)
24324 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24325         rij_shift = Rtail - sig + sig0ij
24326         IF (rij_shift.le.0.0D0) THEN
24327          evdw = 1.0D20
24328 !      if (evdw.gt.1.0d6) then
24329 !      write (*,'(2(1x,a3,i3),6f6.2)') &
24330 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24331 !      1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij
24332 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24333 !      Equad,evdwij+Fcav+eheadtail,evdw
24334 !      endif
24335          RETURN
24336         END IF
24337         sigder = -sig * sigsq
24338         rij_shift = 1.0D0 / rij_shift
24339         fac       = rij_shift**expon
24340         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
24341 !          print *,"ADAM",aa_aq(itypi,itypj)
24342
24343 !          c1        = 0.0d0
24344         c2        = fac  * bb_aq_cat(itypi,itypj)
24345 !          c2        = 0.0d0
24346         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24347         eps2der   = eps3rt * evdwij
24348         eps3der   = eps2rt * evdwij
24349 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24350         evdwij    = eps2rt * eps3rt * evdwij
24351 !#ifdef TSCSC
24352 !          IF (bb_aq(itypi,itypj).gt.0) THEN
24353 !           evdw_p = evdw_p + evdwij
24354 !          ELSE
24355 !           evdw_m = evdw_m + evdwij
24356 !          END IF
24357 !#else
24358         evdw = evdw  &
24359             + evdwij
24360 !#endif
24361         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24362         fac    = -expon * (c1 + evdwij) * rij_shift
24363         sigder = fac * sigder
24364 ! Calculate distance derivative
24365         gg(1) =  fac
24366         gg(2) =  fac
24367         gg(3) =  fac
24368
24369         fac = chis1 * sqom1 + chis2 * sqom2 &
24370         - 2.0d0 * chis12 * om1 * om2 * om12
24371
24372         pom = 1.0d0 - chis1 * chis2 * sqom12
24373 !          print *,"TUT2",fac,chis1,sqom1,pom
24374         Lambf = (1.0d0 - (fac / pom))
24375         Lambf = dsqrt(Lambf)
24376         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24377         Chif = Rtail * sparrow
24378         ChiLambf = Chif * Lambf
24379         eagle = dsqrt(ChiLambf)
24380         bat = ChiLambf ** 11.0d0
24381         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
24382         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
24383         botsq = bot * bot
24384         Fcav = top / bot
24385
24386        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
24387        dbot = 12.0d0 * b4cav * bat * Lambf
24388        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24389
24390         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
24391         dbot = 12.0d0 * b4cav * bat * Chif
24392         eagle = Lambf * pom
24393         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24394         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24395         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24396             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24397
24398         dFdL = ((dtop * bot - top * dbot) / botsq)
24399         dCAVdOM1  = dFdL * ( dFdOM1 )
24400         dCAVdOM2  = dFdL * ( dFdOM2 )
24401         dCAVdOM12 = dFdL * ( dFdOM12 )
24402
24403        DO k= 1, 3
24404       ertail(k) = Rtail_distance(k)/Rtail
24405        END DO
24406        erdxi = scalar( ertail(1), dC_norm(1,i) )
24407        erdxj = scalar( ertail(1), dC_norm(1,j) )
24408        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
24409        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
24410        DO k = 1, 3
24411       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
24412 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
24413 !                  - (( dFdR + gg(k) ) * pom)
24414       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24415 !        gvdwx(k,j) = gvdwx(k,j)   &
24416 !                  + (( dFdR + gg(k) ) * pom)
24417       gradpepcat(k,i) = gradpepcat(k,i)  &
24418               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
24419       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
24420               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
24421
24422       gradpepcat(k,j) = gradpepcat(k,j) &
24423               + (( dFdR + gg(k) ) * ertail(k))
24424       gg(k) = 0.0d0
24425        ENDDO
24426       if (itype(j,5).gt.0) then
24427 !c! Compute head-head and head-tail energies for each state
24428         isel = 3
24429 !c! Dipole-charge interactions
24430          CALL edq_cat_pep(ecl, elj, epol)
24431          eheadtail = ECL + elj + epol
24432 !          print *,"i,",i,eheadtail
24433 !           eheadtail = 0.0d0
24434       else
24435 !HERE WATER and other types of molecules solvents will be added
24436       write(iout,*) "not yet implemented"
24437 !      CALL edd_cat_pep
24438       endif
24439       evdw = evdw  + Fcav + eheadtail
24440 !      if (evdw.gt.1.0d6) then
24441 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24442 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24443 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24444 !      Equad,evdwij+Fcav+eheadtail,evdw
24445 !      endif
24446        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24447       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24448       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24449       Equad,evdwij+Fcav+eheadtail,evdw
24450 !       evdw = evdw  + Fcav  + eheadtail
24451
24452 !        iF (nstate(itypi,itypj).eq.1) THEN
24453       CALL sc_grad_cat_pep
24454 !       END IF
24455 !c!-------------------------------------------------------------------
24456 !c! NAPISY KONCOWE
24457        END DO   ! j
24458        END DO     ! i
24459 !c      write (iout,*) "Number of loop steps in EGB:",ind
24460 !c      energy_dec=.false.
24461 !              print *,"EVDW KURW",evdw,nres
24462  23   continue
24463 !       print *,"before leave sc_grad_cat", i,j, gradpepcat(1,nres-1)
24464
24465       return
24466       end subroutine ecats_prot_amber
24467
24468 !---------------------------------------------------------------------------
24469 ! old for Ca2+
24470        subroutine ecat_prot(ecation_prot)
24471 !      use calc_data
24472 !      use comm_momo
24473        integer i,j,k,subchap,itmp,inum
24474       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
24475       r7,r4
24476       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
24477       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
24478       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
24479       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
24480       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
24481       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
24482       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
24483       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
24484       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
24485       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
24486       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
24487       ndiv,ndivi
24488       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
24489       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
24490       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
24491       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
24492       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
24493       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
24494       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
24495       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
24496       dEvan1Cat
24497       real(kind=8),dimension(6) :: vcatprm
24498       ecation_prot=0.0d0
24499 ! first lets calculate interaction with peptide groups
24500       if (nres_molec(5).eq.0) return
24501       itmp=0
24502       do i=1,4
24503       itmp=itmp+nres_molec(i)
24504       enddo
24505 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
24506       do i=ibond_start,ibond_end
24507 !         cycle
24508        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
24509       xi=0.5d0*(c(1,i)+c(1,i+1))
24510       yi=0.5d0*(c(2,i)+c(2,i+1))
24511       zi=0.5d0*(c(3,i)+c(3,i+1))
24512         call to_box(xi,yi,zi)
24513
24514        do j=itmp+1,itmp+nres_molec(5)
24515 !           print *,"WTF",itmp,j,i
24516 ! all parameters were for Ca2+ to approximate single charge divide by two
24517        ndiv=1.0
24518        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24519        wconst=78*ndiv
24520       wdip =1.092777950857032D2
24521       wdip=wdip/wconst
24522       wmodquad=-2.174122713004870D4
24523       wmodquad=wmodquad/wconst
24524       wquad1 = 3.901232068562804D1
24525       wquad1=wquad1/wconst
24526       wquad2 = 3
24527       wquad2=wquad2/wconst
24528       wvan1 = 0.1
24529       wvan2 = 6
24530 !        itmp=0
24531
24532          xj=c(1,j)
24533          yj=c(2,j)
24534          zj=c(3,j)
24535         call to_box(xj,yj,zj)
24536       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24537 !       enddo
24538 !       enddo
24539        rcpm = sqrt(xj**2+yj**2+zj**2)
24540        drcp_norm(1)=xj/rcpm
24541        drcp_norm(2)=yj/rcpm
24542        drcp_norm(3)=zj/rcpm
24543        dcmag=0.0
24544        do k=1,3
24545        dcmag=dcmag+dc(k,i)**2
24546        enddo
24547        dcmag=dsqrt(dcmag)
24548        do k=1,3
24549        myd_norm(k)=dc(k,i)/dcmag
24550        enddo
24551       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
24552       drcp_norm(3)*myd_norm(3)
24553       rsecp = rcpm**2
24554       Ir = 1.0d0/rcpm
24555       Irsecp = 1.0d0/rsecp
24556       Irthrp = Irsecp/rcpm
24557       Irfourp = Irthrp/rcpm
24558       Irfiftp = Irfourp/rcpm
24559       Irsistp=Irfiftp/rcpm
24560       Irseven=Irsistp/rcpm
24561       Irtwelv=Irsistp*Irsistp
24562       Irthir=Irtwelv/rcpm
24563       sin2thet = (1-costhet*costhet)
24564       sinthet=sqrt(sin2thet)
24565       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
24566            *sin2thet
24567       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
24568            2*wvan2**6*Irsistp)
24569       ecation_prot = ecation_prot+E1+E2
24570 !        print *,"ecatprot",i,j,ecation_prot,rcpm
24571       dE1dr = -2*costhet*wdip*Irthrp-&
24572        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
24573       dE2dr = 3*wquad1*wquad2*Irfourp-     &
24574         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
24575       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
24576       do k=1,3
24577         drdpep(k) = -drcp_norm(k)
24578         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
24579         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
24580         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
24581         dEddci(k) = dEdcos*dcosddci(k)
24582       enddo
24583       do k=1,3
24584       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
24585       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
24586       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
24587       enddo
24588        enddo ! j
24589        enddo ! i
24590 !------------------------------------------sidechains
24591 !        do i=1,nres_molec(1)
24592       do i=ibond_start,ibond_end
24593        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
24594 !         cycle
24595 !        print *,i,ecation_prot
24596       xi=(c(1,i+nres))
24597       yi=(c(2,i+nres))
24598       zi=(c(3,i+nres))
24599                 call to_box(xi,yi,zi)
24600         do k=1,3
24601           cm1(k)=dc(k,i+nres)
24602         enddo
24603          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
24604        do j=itmp+1,itmp+nres_molec(5)
24605        ndiv=1.0
24606        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24607
24608          xj=c(1,j)
24609          yj=c(2,j)
24610          zj=c(3,j)
24611         call to_box(xj,yj,zj)
24612       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24613 !       enddo
24614 !       enddo
24615 ! 15- Glu 16-Asp
24616        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
24617        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
24618        (itype(i,1).eq.25))) then
24619           if(itype(i,1).eq.16) then
24620           inum=1
24621           else
24622           inum=2
24623           endif
24624           do k=1,6
24625           vcatprm(k)=catprm(k,inum)
24626           enddo
24627           dASGL=catprm(7,inum)
24628 !             do k=1,3
24629 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
24630             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
24631             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
24632             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
24633
24634 !                valpha(k)=c(k,i)
24635 !                vcat(k)=c(k,j)
24636             if (subchap.eq.1) then
24637              vcat(1)=xj_temp
24638              vcat(2)=yj_temp
24639              vcat(3)=zj_temp
24640              else
24641             vcat(1)=xj_safe
24642             vcat(2)=yj_safe
24643             vcat(3)=zj_safe
24644              endif
24645             valpha(1)=xi-c(1,i+nres)+c(1,i)
24646             valpha(2)=yi-c(2,i+nres)+c(2,i)
24647             valpha(3)=zi-c(3,i+nres)+c(3,i)
24648
24649 !              enddo
24650       do k=1,3
24651         dx(k) = vcat(k)-vcm(k)
24652       enddo
24653       do k=1,3
24654         v1(k)=(vcm(k)-valpha(k))
24655         v2(k)=(vcat(k)-valpha(k))
24656       enddo
24657       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24658       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
24659       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
24660
24661 !  The weights of the energy function calculated from
24662 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
24663         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24664           ndivi=0.5
24665         else
24666           ndivi=1.0
24667         endif
24668        ndiv=1.0
24669        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24670
24671       wh2o=78*ndivi*ndiv
24672       wc = vcatprm(1)
24673       wc=wc/wh2o
24674       wdip =vcatprm(2)
24675       wdip=wdip/wh2o
24676       wquad1 =vcatprm(3)
24677       wquad1=wquad1/wh2o
24678       wquad2 = vcatprm(4)
24679       wquad2=wquad2/wh2o
24680       wquad2p = 1.0d0-wquad2
24681       wvan1 = vcatprm(5)
24682       wvan2 =vcatprm(6)
24683       opt = dx(1)**2+dx(2)**2
24684       rsecp = opt+dx(3)**2
24685       rs = sqrt(rsecp)
24686       rthrp = rsecp*rs
24687       rfourp = rthrp*rs
24688       rsixp = rfourp*rsecp
24689       reight=rsixp*rsecp
24690       Ir = 1.0d0/rs
24691       Irsecp = 1.0d0/rsecp
24692       Irthrp = Irsecp/rs
24693       Irfourp = Irthrp/rs
24694       Irsixp = 1.0d0/rsixp
24695       Ireight=1.0d0/reight
24696       Irtw=Irsixp*Irsixp
24697       Irthir=Irtw/rs
24698       Irfourt=Irthir/rs
24699       opt1 = (4*rs*dx(3)*wdip)
24700       opt2 = 6*rsecp*wquad1*opt
24701       opt3 = wquad1*wquad2p*Irsixp
24702       opt4 = (wvan1*wvan2**12)
24703       opt5 = opt4*12*Irfourt
24704       opt6 = 2*wvan1*wvan2**6
24705       opt7 = 6*opt6*Ireight
24706       opt8 = wdip/v1m
24707       opt10 = wdip/v2m
24708       opt11 = (rsecp*v2m)**2
24709       opt12 = (rsecp*v1m)**2
24710       opt14 = (v1m*v2m*rsecp)**2
24711       opt15 = -wquad1/v2m**2
24712       opt16 = (rthrp*(v1m*v2m)**2)**2
24713       opt17 = (v1m**2*rthrp)**2
24714       opt18 = -wquad1/rthrp
24715       opt19 = (v1m**2*v2m**2)**2
24716       Ec = wc*Ir
24717       do k=1,3
24718         dEcCat(k) = -(dx(k)*wc)*Irthrp
24719         dEcCm(k)=(dx(k)*wc)*Irthrp
24720         dEcCalp(k)=0.0d0
24721       enddo
24722       Edip=opt8*(v1dpv2)/(rsecp*v2m)
24723       do k=1,3
24724         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
24725                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24726         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
24727                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24728         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
24729                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
24730                   *v1dpv2)/opt14
24731       enddo
24732       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24733       do k=1,3
24734         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
24735                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
24736                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24737         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
24738                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
24739                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24740         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24741                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
24742                   v1dpv2**2)/opt19
24743       enddo
24744       Equad2=wquad1*wquad2p*Irthrp
24745       do k=1,3
24746         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24747         dEquad2Cm(k)=3*dx(k)*rs*opt3
24748         dEquad2Calp(k)=0.0d0
24749       enddo
24750       Evan1=opt4*Irtw
24751       do k=1,3
24752         dEvan1Cat(k)=-dx(k)*opt5
24753         dEvan1Cm(k)=dx(k)*opt5
24754         dEvan1Calp(k)=0.0d0
24755       enddo
24756       Evan2=-opt6*Irsixp
24757       do k=1,3
24758         dEvan2Cat(k)=dx(k)*opt7
24759         dEvan2Cm(k)=-dx(k)*opt7
24760         dEvan2Calp(k)=0.0d0
24761       enddo
24762       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
24763 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
24764
24765       do k=1,3
24766         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
24767                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24768 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
24769         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
24770                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24771         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
24772                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24773       enddo
24774           dscmag = 0.0d0
24775           do k=1,3
24776             dscvec(k) = dc(k,i+nres)
24777             dscmag = dscmag+dscvec(k)*dscvec(k)
24778           enddo
24779           dscmag3 = dscmag
24780           dscmag = sqrt(dscmag)
24781           dscmag3 = dscmag3*dscmag
24782           constA = 1.0d0+dASGL/dscmag
24783           constB = 0.0d0
24784           do k=1,3
24785             constB = constB+dscvec(k)*dEtotalCm(k)
24786           enddo
24787           constB = constB*dASGL/dscmag3
24788           do k=1,3
24789             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24790             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24791              constA*dEtotalCm(k)-constB*dscvec(k)
24792 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
24793             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24794             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24795            enddo
24796       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
24797          if(itype(i,1).eq.14) then
24798           inum=3
24799           else
24800           inum=4
24801           endif
24802           do k=1,6
24803           vcatprm(k)=catprm(k,inum)
24804           enddo
24805           dASGL=catprm(7,inum)
24806 !             do k=1,3
24807 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
24808 !                valpha(k)=c(k,i)
24809 !                vcat(k)=c(k,j)
24810 !              enddo
24811             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
24812             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
24813             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
24814             if (subchap.eq.1) then
24815              vcat(1)=xj_temp
24816              vcat(2)=yj_temp
24817              vcat(3)=zj_temp
24818              else
24819             vcat(1)=xj_safe
24820             vcat(2)=yj_safe
24821             vcat(3)=zj_safe
24822             endif
24823             valpha(1)=xi-c(1,i+nres)+c(1,i)
24824             valpha(2)=yi-c(2,i+nres)+c(2,i)
24825             valpha(3)=zi-c(3,i+nres)+c(3,i)
24826
24827
24828       do k=1,3
24829         dx(k) = vcat(k)-vcm(k)
24830       enddo
24831       do k=1,3
24832         v1(k)=(vcm(k)-valpha(k))
24833         v2(k)=(vcat(k)-valpha(k))
24834       enddo
24835       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24836       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
24837       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
24838 !  The weights of the energy function calculated from
24839 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
24840        ndiv=1.0
24841        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24842
24843       wh2o=78*ndiv
24844       wdip =vcatprm(2)
24845       wdip=wdip/wh2o
24846       wquad1 =vcatprm(3)
24847       wquad1=wquad1/wh2o
24848       wquad2 = vcatprm(4)
24849       wquad2=wquad2/wh2o
24850       wquad2p = 1-wquad2
24851       wvan1 = vcatprm(5)
24852       wvan2 =vcatprm(6)
24853       opt = dx(1)**2+dx(2)**2
24854       rsecp = opt+dx(3)**2
24855       rs = sqrt(rsecp)
24856       rthrp = rsecp*rs
24857       rfourp = rthrp*rs
24858       rsixp = rfourp*rsecp
24859       reight=rsixp*rsecp
24860       Ir = 1.0d0/rs
24861       Irsecp = 1/rsecp
24862       Irthrp = Irsecp/rs
24863       Irfourp = Irthrp/rs
24864       Irsixp = 1/rsixp
24865       Ireight=1/reight
24866       Irtw=Irsixp*Irsixp
24867       Irthir=Irtw/rs
24868       Irfourt=Irthir/rs
24869       opt1 = (4*rs*dx(3)*wdip)
24870       opt2 = 6*rsecp*wquad1*opt
24871       opt3 = wquad1*wquad2p*Irsixp
24872       opt4 = (wvan1*wvan2**12)
24873       opt5 = opt4*12*Irfourt
24874       opt6 = 2*wvan1*wvan2**6
24875       opt7 = 6*opt6*Ireight
24876       opt8 = wdip/v1m
24877       opt10 = wdip/v2m
24878       opt11 = (rsecp*v2m)**2
24879       opt12 = (rsecp*v1m)**2
24880       opt14 = (v1m*v2m*rsecp)**2
24881       opt15 = -wquad1/v2m**2
24882       opt16 = (rthrp*(v1m*v2m)**2)**2
24883       opt17 = (v1m**2*rthrp)**2
24884       opt18 = -wquad1/rthrp
24885       opt19 = (v1m**2*v2m**2)**2
24886       Edip=opt8*(v1dpv2)/(rsecp*v2m)
24887       do k=1,3
24888         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
24889                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24890        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
24891                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24892         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
24893                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
24894                   *v1dpv2)/opt14
24895       enddo
24896       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24897       do k=1,3
24898         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
24899                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
24900                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24901         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
24902                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
24903                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24904         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24905                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
24906                   v1dpv2**2)/opt19
24907       enddo
24908       Equad2=wquad1*wquad2p*Irthrp
24909       do k=1,3
24910         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24911         dEquad2Cm(k)=3*dx(k)*rs*opt3
24912         dEquad2Calp(k)=0.0d0
24913       enddo
24914       Evan1=opt4*Irtw
24915       do k=1,3
24916         dEvan1Cat(k)=-dx(k)*opt5
24917         dEvan1Cm(k)=dx(k)*opt5
24918         dEvan1Calp(k)=0.0d0
24919       enddo
24920       Evan2=-opt6*Irsixp
24921       do k=1,3
24922         dEvan2Cat(k)=dx(k)*opt7
24923         dEvan2Cm(k)=-dx(k)*opt7
24924         dEvan2Calp(k)=0.0d0
24925       enddo
24926        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
24927       do k=1,3
24928         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
24929                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24930         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
24931                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24932         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
24933                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24934       enddo
24935           dscmag = 0.0d0
24936           do k=1,3
24937             dscvec(k) = c(k,i+nres)-c(k,i)
24938 ! TU SPRAWDZ???
24939 !              dscvec(1) = xj
24940 !              dscvec(2) = yj
24941 !              dscvec(3) = zj
24942
24943             dscmag = dscmag+dscvec(k)*dscvec(k)
24944           enddo
24945           dscmag3 = dscmag
24946           dscmag = sqrt(dscmag)
24947           dscmag3 = dscmag3*dscmag
24948           constA = 1+dASGL/dscmag
24949           constB = 0.0d0
24950           do k=1,3
24951             constB = constB+dscvec(k)*dEtotalCm(k)
24952           enddo
24953           constB = constB*dASGL/dscmag3
24954           do k=1,3
24955             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24956             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24957              constA*dEtotalCm(k)-constB*dscvec(k)
24958             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24959             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24960            enddo
24961          else
24962           rcal = 0.0d0
24963           do k=1,3
24964 !              r(k) = c(k,j)-c(k,i+nres)
24965             r(1) = xj
24966             r(2) = yj
24967             r(3) = zj
24968             rcal = rcal+r(k)*r(k)
24969           enddo
24970           ract=sqrt(rcal)
24971           rocal=1.5
24972           epscalc=0.2
24973           r0p=0.5*(rocal+sig0(itype(i,1)))
24974           r06 = r0p**6
24975           r012 = r06*r06
24976           Evan1=epscalc*(r012/rcal**6)
24977           Evan2=epscalc*2*(r06/rcal**3)
24978           r4 = rcal**4
24979           r7 = rcal**7
24980           do k=1,3
24981             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
24982             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
24983           enddo
24984           do k=1,3
24985             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
24986           enddo
24987              ecation_prot = ecation_prot+ Evan1+Evan2
24988           do  k=1,3
24989              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24990              dEtotalCm(k)
24991             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
24992             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
24993            enddo
24994        endif ! 13-16 residues
24995        enddo !j
24996        enddo !i
24997        return
24998        end subroutine ecat_prot
24999
25000 !----------------------------------------------------------------------------
25001 !---------------------------------------------------------------------------
25002        subroutine ecat_nucl(ecation_nucl)
25003        integer i,j,k,subchap,itmp,inum,itypi,itypj
25004        real(kind=8) :: xi,yi,zi,xj,yj,zj
25005        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
25006        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
25007        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
25008        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
25009        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
25010        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
25011        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
25012        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
25013        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
25014        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
25015        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
25016        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
25017        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
25018        dEcavdCm,boxik
25019        real(kind=8),dimension(14) :: vcatnuclprm
25020        ecation_nucl=0.0d0
25021        boxik(1)=boxxsize
25022        boxik(2)=boxysize
25023        boxik(3)=boxzsize
25024
25025        if (nres_molec(5).eq.0) return
25026        itmp=0
25027        do i=1,4
25028           itmp=itmp+nres_molec(i)
25029        enddo
25030 !       print *,nres_molec(2),"nres2"
25031       do i=ibond_nucl_start,ibond_nucl_end
25032 !       do i=iatsc_s_nucl,iatsc_e_nucl
25033           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
25034           xi=(c(1,i+nres))
25035           yi=(c(2,i+nres))
25036           zi=(c(3,i+nres))
25037       call to_box(xi,yi,zi)
25038       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25039           do k=1,3
25040              cm1(k)=dc(k,i+nres)
25041           enddo
25042           do j=itmp+1,itmp+nres_molec(5)
25043              xj=c(1,j)
25044              yj=c(2,j)
25045              zj=c(3,j)
25046       call to_box(xj,yj,zj)
25047 !      print *,i,j,itmp
25048 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
25049 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25050 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25051 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25052 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25053 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25054       xj=boxshift(xj-xi,boxxsize)
25055       yj=boxshift(yj-yi,boxysize)
25056       zj=boxshift(zj-zi,boxzsize)
25057 !       write(iout,*) 'after shift', xj,yj,zj
25058              dist_init=xj**2+yj**2+zj**2
25059
25060              itypi=itype(i,2)
25061              itypj=itype(j,5)
25062              do k=1,13
25063                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
25064              enddo
25065              do k=1,3
25066                 vcm(k)=c(k,i+nres)
25067                 vsug(k)=c(k,i)
25068                 vcat(k)=c(k,j)
25069              enddo
25070              call to_box(vcm(1),vcm(2),vcm(3))
25071              call to_box(vsug(1),vsug(2),vsug(3))
25072              call to_box(vcat(1),vcat(2),vcat(3))
25073              do k=1,3
25074 !                dx(k) = vcat(k)-vcm(k)
25075 !             enddo
25076                 dx(k)=boxshift(vcat(k)-vcm(k),boxik(k))
25077 !             do k=1,3
25078                 v1(k)=dc(k,i+nres)
25079                 v2(k)=boxshift(vcat(k)-vsug(k),boxik(k))
25080              enddo
25081              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
25082              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
25083 !  The weights of the energy function calculated from
25084 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
25085              wh2o=78
25086              wdip1 = vcatnuclprm(1)
25087              wdip1 = wdip1/wh2o                     !w1
25088              wdip2 = vcatnuclprm(2)
25089              wdip2 = wdip2/wh2o                     !w2
25090              wvan1 = vcatnuclprm(3)
25091              wvan2 = vcatnuclprm(4)                 !pis1
25092              wgbsig = vcatnuclprm(5)                !sigma0
25093              wgbeps = vcatnuclprm(6)                !epsi0
25094              wgbchi = vcatnuclprm(7)                !chi1
25095              wgbchip = vcatnuclprm(8)               !chip1
25096              wcavsig = vcatnuclprm(9)               !sig
25097              wcav1 = vcatnuclprm(10)                !b1
25098              wcav2 = vcatnuclprm(11)                !b2
25099              wcav3 = vcatnuclprm(12)                !b3
25100              wcav4 = vcatnuclprm(13)                !b4
25101              wcavchi = vcatnuclprm(14)              !chis1
25102              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
25103              invrcs6 = 1/rcs2**3
25104              invrcs8 = invrcs6/rcs2
25105              invrcs12 = invrcs6**2
25106              invrcs14 = invrcs12/rcs2
25107              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
25108              rcb = sqrt(rcb2)
25109              invrcb = 1/rcb
25110              invrcb2 = invrcb**2
25111              invrcb4 = invrcb2**2
25112              invrcb6 = invrcb4*invrcb2
25113              cosinus = v1dpdx/(v1m*rcb)
25114              cos2 = cosinus**2
25115              dcosdcatconst = invrcb2/v1m
25116              dcosdcalpconst = invrcb/v1m**2
25117              dcosdcmconst = invrcb2/v1m**2
25118              do k=1,3
25119                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
25120                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
25121                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
25122                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
25123              enddo
25124              rcav = rcb/wcavsig
25125              rcav11 = rcav**11
25126              rcav12 = rcav11*rcav
25127              constcav1 = 1-wcavchi*cos2
25128              constcav2 = sqrt(constcav1)
25129              constgb1 = 1/sqrt(1-wgbchi*cos2)
25130              constgb2 = wgbeps*(1-wgbchip*cos2)**2
25131              constdvan1 = 12*wvan1*wvan2**12*invrcs14
25132              constdvan2 = 6*wvan1*wvan2**6*invrcs8
25133 !----------------------------------------------------------------------------
25134 !Gay-Berne term
25135 !---------------------------------------------------------------------------
25136              sgb = 1/(1-constgb1+(rcb/wgbsig))
25137              sgb6 = sgb**6
25138              sgb7 = sgb6*sgb
25139              sgb12 = sgb6**2
25140              sgb13 = sgb12*sgb
25141              Egb = constgb2*(sgb12-sgb6)
25142              do k=1,3
25143                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
25144                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
25145      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
25146                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
25147                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
25148      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
25149                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
25150                                *(12*sgb13-6*sgb7) &
25151      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
25152              enddo
25153 !----------------------------------------------------------------------------
25154 !cavity term
25155 !---------------------------------------------------------------------------
25156              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
25157              cavdenom = 1+wcav4*rcav12*constcav1**6
25158              Ecav = wcav1*cavnum/cavdenom
25159              invcavdenom2 = 1/cavdenom**2
25160              dcavnumdcos = -wcavchi*cosinus/constcav2 &
25161                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
25162              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
25163              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
25164              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
25165              do k=1,3
25166                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
25167      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
25168                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
25169      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
25170                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
25171                              *dcosdcalp(k)*wcav1*invcavdenom2
25172              enddo
25173 !----------------------------------------------------------------------------
25174 !van der Waals and dipole-charge interaction energy
25175 !---------------------------------------------------------------------------
25176              Evan1 = wvan1*wvan2**12*invrcs12
25177              do k=1,3
25178                 dEvan1Cat(k) = -v2(k)*constdvan1
25179                 dEvan1Cm(k) = 0.0d0
25180                 dEvan1Calp(k) = v2(k)*constdvan1
25181              enddo
25182              Evan2 = -wvan1*wvan2**6*invrcs6
25183              do k=1,3
25184                 dEvan2Cat(k) = v2(k)*constdvan2
25185                 dEvan2Cm(k) = 0.0d0
25186                 dEvan2Calp(k) = -v2(k)*constdvan2
25187              enddo
25188              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
25189              do k=1,3
25190                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
25191                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
25192                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
25193                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
25194                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
25195                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
25196                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
25197                                   +2*wdip2*cosinus*invrcb4)
25198              enddo
25199              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
25200          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
25201              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
25202              do k=1,3
25203                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
25204                                              +dEgbdCat(k)+dEdipCat(k)
25205                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
25206                                            +dEgbdCm(k)+dEdipCm(k)
25207                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
25208                                              +dEdipCalp(k)+dEvan2Calp(k)
25209              enddo
25210              do k=1,3
25211                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
25212                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
25213                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
25214                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
25215              enddo
25216           enddo !j
25217        enddo !i
25218        return
25219        end subroutine ecat_nucl
25220
25221 !-----------------------------------------------------------------------------
25222 !-----------------------------------------------------------------------------
25223       subroutine eprot_sc_base(escbase)
25224       use calc_data
25225 !      implicit real(kind=8) (a-h,o-z)
25226 !      include 'DIMENSIONS'
25227 !      include 'COMMON.GEO'
25228 !      include 'COMMON.VAR'
25229 !      include 'COMMON.LOCAL'
25230 !      include 'COMMON.CHAIN'
25231 !      include 'COMMON.DERIV'
25232 !      include 'COMMON.NAMES'
25233 !      include 'COMMON.INTERACT'
25234 !      include 'COMMON.IOUNITS'
25235 !      include 'COMMON.CALC'
25236 !      include 'COMMON.CONTROL'
25237 !      include 'COMMON.SBRIDGE'
25238       logical :: lprn
25239 !el local variables
25240       integer :: iint,itypi,itypi1,itypj,subchap
25241       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25242       real(kind=8) :: evdw,sig0ij
25243       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25244                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25245                 sslipi,sslipj,faclip
25246       integer :: ii
25247       real(kind=8) :: fracinbuf
25248        real (kind=8) :: escbase
25249        real (kind=8),dimension(4):: ener
25250        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25251        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25252       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
25253       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25254       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
25255       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25256       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25257       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
25258        real(kind=8),dimension(3,2)::chead,erhead_tail
25259        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25260        integer troll
25261        eps_out=80.0d0
25262        escbase=0.0d0
25263 !       do i=1,nres_molec(1)
25264       do i=ibond_start,ibond_end
25265       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25266       itypi  = itype(i,1)
25267       dxi    = dc_norm(1,nres+i)
25268       dyi    = dc_norm(2,nres+i)
25269       dzi    = dc_norm(3,nres+i)
25270       dsci_inv = vbld_inv(i+nres)
25271       xi=c(1,nres+i)
25272       yi=c(2,nres+i)
25273       zi=c(3,nres+i)
25274       call to_box(xi,yi,zi)
25275       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25276        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
25277          itypj= itype(j,2)
25278          if (itype(j,2).eq.ntyp1_molec(2))cycle
25279          xj=c(1,j+nres)
25280          yj=c(2,j+nres)
25281          zj=c(3,j+nres)
25282       call to_box(xj,yj,zj)
25283 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25284 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25285 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25286 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25287 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25288       xj=boxshift(xj-xi,boxxsize)
25289       yj=boxshift(yj-yi,boxysize)
25290       zj=boxshift(zj-zi,boxzsize)
25291
25292         dxj = dc_norm( 1, nres+j )
25293         dyj = dc_norm( 2, nres+j )
25294         dzj = dc_norm( 3, nres+j )
25295 !          print *,i,j,itypi,itypj
25296         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
25297         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
25298 !          d1i=0.0d0
25299 !          d1j=0.0d0
25300 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25301 ! Gay-berne var's
25302         sig0ij = sigma_scbase( itypi,itypj )
25303         if (sig0ij.lt.0.2) print *,"KURWA",sig0ij,itypi,itypj
25304         chi1   = chi_scbase( itypi, itypj,1 )
25305         chi2   = chi_scbase( itypi, itypj,2 )
25306 !          chi1=0.0d0
25307 !          chi2=0.0d0
25308         chi12  = chi1 * chi2
25309         chip1  = chipp_scbase( itypi, itypj,1 )
25310         chip2  = chipp_scbase( itypi, itypj,2 )
25311 !          chip1=0.0d0
25312 !          chip2=0.0d0
25313         chip12 = chip1 * chip2
25314 ! not used by momo potential, but needed by sc_angular which is shared
25315 ! by all energy_potential subroutines
25316         alf1   = 0.0d0
25317         alf2   = 0.0d0
25318         alf12  = 0.0d0
25319         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
25320 !       a12sq = a12sq * a12sq
25321 ! charge of amino acid itypi is...
25322         chis1 = chis_scbase(itypi,itypj,1)
25323         chis2 = chis_scbase(itypi,itypj,2)
25324         chis12 = chis1 * chis2
25325         sig1 = sigmap1_scbase(itypi,itypj)
25326         sig2 = sigmap2_scbase(itypi,itypj)
25327 !       write (*,*) "sig1 = ", sig1
25328 !       write (*,*) "sig2 = ", sig2
25329 ! alpha factors from Fcav/Gcav
25330         b1 = alphasur_scbase(1,itypi,itypj)
25331 !          b1=0.0d0
25332         b2 = alphasur_scbase(2,itypi,itypj)
25333         b3 = alphasur_scbase(3,itypi,itypj)
25334         b4 = alphasur_scbase(4,itypi,itypj)
25335 ! used to determine whether we want to do quadrupole calculations
25336 ! used by Fgb
25337        eps_in = epsintab_scbase(itypi,itypj)
25338        if (eps_in.eq.0.0) eps_in=1.0
25339        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25340 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25341 !-------------------------------------------------------------------
25342 ! tail location and distance calculations
25343        DO k = 1,3
25344 ! location of polar head is computed by taking hydrophobic centre
25345 ! and moving by a d1 * dc_norm vector
25346 ! see unres publications for very informative images
25347       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
25348       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
25349 ! distance
25350 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25351 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25352       Rhead_distance(k) = chead(k,2) - chead(k,1)
25353        END DO
25354 ! pitagoras (root of sum of squares)
25355        Rhead = dsqrt( &
25356         (Rhead_distance(1)*Rhead_distance(1)) &
25357       + (Rhead_distance(2)*Rhead_distance(2)) &
25358       + (Rhead_distance(3)*Rhead_distance(3)))
25359 !-------------------------------------------------------------------
25360 ! zero everything that should be zero'ed
25361        evdwij = 0.0d0
25362        ECL = 0.0d0
25363        Elj = 0.0d0
25364        Equad = 0.0d0
25365        Epol = 0.0d0
25366        Fcav=0.0d0
25367        eheadtail = 0.0d0
25368        dGCLdOM1 = 0.0d0
25369        dGCLdOM2 = 0.0d0
25370        dGCLdOM12 = 0.0d0
25371        dPOLdOM1 = 0.0d0
25372        dPOLdOM2 = 0.0d0
25373         Fcav = 0.0d0
25374         dFdR = 0.0d0
25375         dCAVdOM1  = 0.0d0
25376         dCAVdOM2  = 0.0d0
25377         dCAVdOM12 = 0.0d0
25378         dscj_inv = vbld_inv(j+nres)
25379 !          print *,i,j,dscj_inv,dsci_inv
25380 ! rij holds 1/(distance of Calpha atoms)
25381         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25382         rij  = dsqrt(rrij)
25383 !----------------------------
25384         CALL sc_angular
25385 ! this should be in elgrad_init but om's are calculated by sc_angular
25386 ! which in turn is used by older potentials
25387 ! om = omega, sqom = om^2
25388         sqom1  = om1 * om1
25389         sqom2  = om2 * om2
25390         sqom12 = om12 * om12
25391
25392 ! now we calculate EGB - Gey-Berne
25393 ! It will be summed up in evdwij and saved in evdw
25394         sigsq     = 1.0D0  / sigsq
25395         sig       = sig0ij * dsqrt(sigsq)
25396 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25397         rij_shift = 1.0/rij - sig + sig0ij
25398         IF (rij_shift.le.0.0D0) THEN
25399          evdw = 1.0D20
25400          RETURN
25401         END IF
25402         sigder = -sig * sigsq
25403         rij_shift = 1.0D0 / rij_shift
25404         fac       = rij_shift**expon
25405         c1        = fac  * fac * aa_scbase(itypi,itypj)
25406 !          c1        = 0.0d0
25407         c2        = fac  * bb_scbase(itypi,itypj)
25408 !          c2        = 0.0d0
25409         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25410         eps2der   = eps3rt * evdwij
25411         eps3der   = eps2rt * evdwij
25412 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25413         evdwij    = eps2rt * eps3rt * evdwij
25414         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25415         fac    = -expon * (c1 + evdwij) * rij_shift
25416         sigder = fac * sigder
25417 !          fac    = rij * fac
25418 ! Calculate distance derivative
25419         gg(1) =  fac
25420         gg(2) =  fac
25421         gg(3) =  fac
25422 !          if (b2.gt.0.0) then
25423         fac = chis1 * sqom1 + chis2 * sqom2 &
25424         - 2.0d0 * chis12 * om1 * om2 * om12
25425 ! we will use pom later in Gcav, so dont mess with it!
25426         pom = 1.0d0 - chis1 * chis2 * sqom12
25427         Lambf = (1.0d0 - (fac / pom))
25428         Lambf = dsqrt(Lambf)
25429         sparrow=dsqrt(sig1**2.0d0 + sig2**2.0d0)
25430         if (b1.eq.0.0d0) sparrow=1.0d0
25431         sparrow = 1.0d0 / sparrow
25432 !        write (*,*) "sparrow = ", sparrow,sig1,sig2,b1
25433         Chif = 1.0d0/rij * sparrow
25434         ChiLambf = Chif * Lambf
25435         eagle = dsqrt(ChiLambf)
25436         bat = ChiLambf ** 11.0d0
25437         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25438         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25439         botsq = bot * bot
25440         Fcav = top / bot
25441 !          print *,i,j,Fcav
25442         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25443         dbot = 12.0d0 * b4 * bat * Lambf
25444         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25445 !       dFdR = 0.0d0
25446 !      write (*,*) "dFcav/dR = ", dFdR
25447         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25448         dbot = 12.0d0 * b4 * bat * Chif
25449         eagle = Lambf * pom
25450         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25451         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25452         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25453             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25454
25455         dFdL = ((dtop * bot - top * dbot) / botsq)
25456 !       dFdL = 0.0d0
25457         dCAVdOM1  = dFdL * ( dFdOM1 )
25458         dCAVdOM2  = dFdL * ( dFdOM2 )
25459         dCAVdOM12 = dFdL * ( dFdOM12 )
25460
25461         ertail(1) = xj*rij
25462         ertail(2) = yj*rij
25463         ertail(3) = zj*rij
25464 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
25465 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
25466 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
25467 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
25468 !           print *,"EOMY",eom1,eom2,eom12
25469 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25470 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25471 ! here dtail=0.0
25472 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25473 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25474        DO k = 1, 3
25475 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25476 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25477       pom = ertail(k)
25478 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25479       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
25480               - (( dFdR + gg(k) ) * pom)
25481 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25482 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25483 !     &             - ( dFdR * pom )
25484       pom = ertail(k)
25485 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25486       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
25487               + (( dFdR + gg(k) ) * pom)
25488 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25489 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25490 !c!     &             + ( dFdR * pom )
25491
25492       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
25493               - (( dFdR + gg(k) ) * ertail(k))
25494 !c!     &             - ( dFdR * ertail(k))
25495
25496       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
25497               + (( dFdR + gg(k) ) * ertail(k))
25498 !c!     &             + ( dFdR * ertail(k))
25499
25500       gg(k) = 0.0d0
25501 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25502 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25503       END DO
25504
25505 !          else
25506
25507 !          endif
25508 !Now dipole-dipole
25509        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
25510        w1 = wdipdip_scbase(1,itypi,itypj)
25511        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
25512        w3 = wdipdip_scbase(2,itypi,itypj)
25513 !c!-------------------------------------------------------------------
25514 !c! ECL
25515        fac = (om12 - 3.0d0 * om1 * om2)
25516        c1 = (w1 / (Rhead**3.0d0)) * fac
25517        c2 = (w2 / Rhead ** 6.0d0)  &
25518        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25519        c3= (w3/ Rhead ** 6.0d0)  &
25520        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25521        ECL = c1 - c2 + c3
25522 !c!       write (*,*) "w1 = ", w1
25523 !c!       write (*,*) "w2 = ", w2
25524 !c!       write (*,*) "om1 = ", om1
25525 !c!       write (*,*) "om2 = ", om2
25526 !c!       write (*,*) "om12 = ", om12
25527 !c!       write (*,*) "fac = ", fac
25528 !c!       write (*,*) "c1 = ", c1
25529 !c!       write (*,*) "c2 = ", c2
25530 !c!       write (*,*) "Ecl = ", Ecl
25531 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
25532 !c!       write (*,*) "c2_2 = ",
25533 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25534 !c!-------------------------------------------------------------------
25535 !c! dervative of ECL is GCL...
25536 !c! dECL/dr
25537        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25538        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25539        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25540        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
25541        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25542        dGCLdR = c1 - c2 + c3
25543 !c! dECL/dom1
25544        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25545        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25546        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25547        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
25548        dGCLdOM1 = c1 - c2 + c3
25549 !c! dECL/dom2
25550        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25551        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25552        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25553        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
25554        dGCLdOM2 = c1 - c2 + c3
25555 !c! dECL/dom12
25556        c1 = w1 / (Rhead ** 3.0d0)
25557        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25558        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
25559        dGCLdOM12 = c1 - c2 + c3
25560        DO k= 1, 3
25561       erhead(k) = Rhead_distance(k)/Rhead
25562        END DO
25563        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25564        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25565        facd1 = d1i * vbld_inv(i+nres)
25566        facd2 = d1j * vbld_inv(j+nres)
25567        DO k = 1, 3
25568
25569       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25570       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
25571               - dGCLdR * pom
25572       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25573       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
25574               + dGCLdR * pom
25575
25576       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
25577               - dGCLdR * erhead(k)
25578       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
25579               + dGCLdR * erhead(k)
25580        END DO
25581        endif
25582 !now charge with dipole eg. ARG-dG
25583        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
25584       alphapol1 = alphapol_scbase(itypi,itypj)
25585        w1        = wqdip_scbase(1,itypi,itypj)
25586        w2        = wqdip_scbase(2,itypi,itypj)
25587 !       w1=0.0d0
25588 !       w2=0.0d0
25589 !       pis       = sig0head_scbase(itypi,itypj)
25590 !       eps_head   = epshead_scbase(itypi,itypj)
25591 !c!-------------------------------------------------------------------
25592 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25593        R1 = 0.0d0
25594        DO k = 1, 3
25595 !c! Calculate head-to-tail distances tail is center of side-chain
25596       R1=R1+(c(k,j+nres)-chead(k,1))**2
25597        END DO
25598 !c! Pitagoras
25599        R1 = dsqrt(R1)
25600
25601 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25602 !c!     &        +dhead(1,1,itypi,itypj))**2))
25603 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25604 !c!     &        +dhead(2,1,itypi,itypj))**2))
25605
25606 !c!-------------------------------------------------------------------
25607 !c! ecl
25608        sparrow  = w1  *  om1
25609        hawk     = w2 *  (1.0d0 - sqom2)
25610        Ecl = sparrow / Rhead**2.0d0 &
25611          - hawk    / Rhead**4.0d0
25612 !c!-------------------------------------------------------------------
25613 !c! derivative of ecl is Gcl
25614 !c! dF/dr part
25615        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25616             + 4.0d0 * hawk    / Rhead**5.0d0
25617 !c! dF/dom1
25618        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25619 !c! dF/dom2
25620        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25621 !c--------------------------------------------------------------------
25622 !c Polarization energy
25623 !c Epol
25624        MomoFac1 = (1.0d0 - chi1 * sqom2)
25625        RR1  = R1 * R1 / MomoFac1
25626        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25627        fgb1 = sqrt( RR1 + a12sq * ee1)
25628 !       eps_inout_fac=0.0d0
25629        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25630 ! derivative of Epol is Gpol...
25631        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25632             / (fgb1 ** 5.0d0)
25633        dFGBdR1 = ( (R1 / MomoFac1) &
25634            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25635            / ( 2.0d0 * fgb1 )
25636        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25637              * (2.0d0 - 0.5d0 * ee1) ) &
25638              / (2.0d0 * fgb1)
25639        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25640 !       dPOLdR1 = 0.0d0
25641        dPOLdOM1 = 0.0d0
25642        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25643        DO k = 1, 3
25644       erhead(k) = Rhead_distance(k)/Rhead
25645       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
25646        END DO
25647
25648        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25649        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25650        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25651 !       bat=0.0d0
25652        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25653        facd1 = d1i * vbld_inv(i+nres)
25654        facd2 = d1j * vbld_inv(j+nres)
25655 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25656
25657        DO k = 1, 3
25658       hawk = (erhead_tail(k,1) + &
25659       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25660 !        facd1=0.0d0
25661 !        facd2=0.0d0
25662       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25663       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
25664                - dGCLdR * pom &
25665                - dPOLdR1 *  (erhead_tail(k,1))
25666 !     &             - dGLJdR * pom
25667
25668       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25669       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
25670                + dGCLdR * pom  &
25671                + dPOLdR1 * (erhead_tail(k,1))
25672 !     &             + dGLJdR * pom
25673
25674
25675       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
25676               - dGCLdR * erhead(k) &
25677               - dPOLdR1 * erhead_tail(k,1)
25678 !     &             - dGLJdR * erhead(k)
25679
25680       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
25681               + dGCLdR * erhead(k)  &
25682               + dPOLdR1 * erhead_tail(k,1)
25683 !     &             + dGLJdR * erhead(k)
25684
25685        END DO
25686        endif
25687 !       print *,i,j,evdwij,epol,Fcav,ECL
25688        escbase=escbase+evdwij+epol+Fcav+ECL
25689        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25690       "escbase:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escbase
25691        if (energy_dec) write (iout,*) "evdwij,", evdwij, 1.0/rij, sig, sig0ij
25692        call sc_grad_scbase
25693        enddo
25694       enddo
25695
25696       return
25697       end subroutine eprot_sc_base
25698       SUBROUTINE sc_grad_scbase
25699       use calc_data
25700
25701        real (kind=8) :: dcosom1(3),dcosom2(3)
25702        eom1  =    &
25703             eps2der * eps2rt_om1   &
25704           - 2.0D0 * alf1 * eps3der &
25705           + sigder * sigsq_om1     &
25706           + dCAVdOM1               &
25707           + dGCLdOM1               &
25708           + dPOLdOM1
25709
25710        eom2  =  &
25711             eps2der * eps2rt_om2   &
25712           + 2.0D0 * alf2 * eps3der &
25713           + sigder * sigsq_om2     &
25714           + dCAVdOM2               &
25715           + dGCLdOM2               &
25716           + dPOLdOM2
25717
25718        eom12 =    &
25719             evdwij  * eps1_om12     &
25720           + eps2der * eps2rt_om12   &
25721           - 2.0D0 * alf12 * eps3der &
25722           + sigder *sigsq_om12      &
25723           + dCAVdOM12               &
25724           + dGCLdOM12
25725
25726 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25727 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25728 !               gg(1),gg(2),"rozne"
25729        DO k = 1, 3
25730       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25731       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25732       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25733       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
25734              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25735              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25736       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
25737              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25738              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25739       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
25740       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
25741        END DO
25742
25743        RETURN
25744       END SUBROUTINE sc_grad_scbase
25745
25746
25747       subroutine epep_sc_base(epepbase)
25748       use calc_data
25749       logical :: lprn
25750 !el local variables
25751       integer :: iint,itypi,itypi1,itypj,subchap
25752       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25753       real(kind=8) :: evdw,sig0ij
25754       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25755                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25756                 sslipi,sslipj,faclip
25757       integer :: ii
25758       real(kind=8) :: fracinbuf
25759        real (kind=8) :: epepbase
25760        real (kind=8),dimension(4):: ener
25761        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25762        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25763       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
25764       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25765       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
25766       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25767       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25768       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
25769        real(kind=8),dimension(3,2)::chead,erhead_tail
25770        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25771        integer troll
25772        eps_out=80.0d0
25773        epepbase=0.0d0
25774 !       do i=1,nres_molec(1)-1
25775       do i=ibond_start,ibond_end
25776       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
25777 !C        itypi  = itype(i,1)
25778       dxi    = dc_norm(1,i)
25779       dyi    = dc_norm(2,i)
25780       dzi    = dc_norm(3,i)
25781 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
25782       dsci_inv = vbld_inv(i+1)/2.0
25783       xi=(c(1,i)+c(1,i+1))/2.0
25784       yi=(c(2,i)+c(2,i+1))/2.0
25785       zi=(c(3,i)+c(3,i+1))/2.0
25786         call to_box(xi,yi,zi)
25787        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
25788          itypj= itype(j,2)
25789          if (itype(j,2).eq.ntyp1_molec(2))cycle
25790          xj=c(1,j+nres)
25791          yj=c(2,j+nres)
25792          zj=c(3,j+nres)
25793                 call to_box(xj,yj,zj)
25794       xj=boxshift(xj-xi,boxxsize)
25795       yj=boxshift(yj-yi,boxysize)
25796       zj=boxshift(zj-zi,boxzsize)
25797         dist_init=xj**2+yj**2+zj**2
25798         dxj = dc_norm( 1, nres+j )
25799         dyj = dc_norm( 2, nres+j )
25800         dzj = dc_norm( 3, nres+j )
25801 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
25802 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
25803
25804 ! Gay-berne var's
25805         sig0ij = sigma_pepbase(itypj )
25806         chi1   = chi_pepbase(itypj,1 )
25807         chi2   = chi_pepbase(itypj,2 )
25808 !          chi1=0.0d0
25809 !          chi2=0.0d0
25810         chi12  = chi1 * chi2
25811         chip1  = chipp_pepbase(itypj,1 )
25812         chip2  = chipp_pepbase(itypj,2 )
25813 !          chip1=0.0d0
25814 !          chip2=0.0d0
25815         chip12 = chip1 * chip2
25816         chis1 = chis_pepbase(itypj,1)
25817         chis2 = chis_pepbase(itypj,2)
25818         chis12 = chis1 * chis2
25819         sig1 = sigmap1_pepbase(itypj)
25820         sig2 = sigmap2_pepbase(itypj)
25821 !       write (*,*) "sig1 = ", sig1
25822 !       write (*,*) "sig2 = ", sig2
25823        DO k = 1,3
25824 ! location of polar head is computed by taking hydrophobic centre
25825 ! and moving by a d1 * dc_norm vector
25826 ! see unres publications for very informative images
25827       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
25828 ! + d1i * dc_norm(k, i+nres)
25829       chead(k,2) = c(k, j+nres)
25830 ! + d1j * dc_norm(k, j+nres)
25831 ! distance
25832 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25833 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25834       Rhead_distance(k) = chead(k,2) - chead(k,1)
25835 !        print *,gvdwc_pepbase(k,i)
25836
25837        END DO
25838        Rhead = dsqrt( &
25839         (Rhead_distance(1)*Rhead_distance(1)) &
25840       + (Rhead_distance(2)*Rhead_distance(2)) &
25841       + (Rhead_distance(3)*Rhead_distance(3)))
25842
25843 ! alpha factors from Fcav/Gcav
25844         b1 = alphasur_pepbase(1,itypj)
25845 !          b1=0.0d0
25846         b2 = alphasur_pepbase(2,itypj)
25847         b3 = alphasur_pepbase(3,itypj)
25848         b4 = alphasur_pepbase(4,itypj)
25849         alf1   = 0.0d0
25850         alf2   = 0.0d0
25851         alf12  = 0.0d0
25852         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25853 !          print *,i,j,rrij
25854         rij  = dsqrt(rrij)
25855 !----------------------------
25856        evdwij = 0.0d0
25857        ECL = 0.0d0
25858        Elj = 0.0d0
25859        Equad = 0.0d0
25860        Epol = 0.0d0
25861        Fcav=0.0d0
25862        eheadtail = 0.0d0
25863        dGCLdOM1 = 0.0d0
25864        dGCLdOM2 = 0.0d0
25865        dGCLdOM12 = 0.0d0
25866        dPOLdOM1 = 0.0d0
25867        dPOLdOM2 = 0.0d0
25868         Fcav = 0.0d0
25869         dFdR = 0.0d0
25870         dCAVdOM1  = 0.0d0
25871         dCAVdOM2  = 0.0d0
25872         dCAVdOM12 = 0.0d0
25873         dscj_inv = vbld_inv(j+nres)
25874         CALL sc_angular
25875 ! this should be in elgrad_init but om's are calculated by sc_angular
25876 ! which in turn is used by older potentials
25877 ! om = omega, sqom = om^2
25878         sqom1  = om1 * om1
25879         sqom2  = om2 * om2
25880         sqom12 = om12 * om12
25881
25882 ! now we calculate EGB - Gey-Berne
25883 ! It will be summed up in evdwij and saved in evdw
25884         sigsq     = 1.0D0  / sigsq
25885         sig       = sig0ij * dsqrt(sigsq)
25886         rij_shift = 1.0/rij - sig + sig0ij
25887         IF (rij_shift.le.0.0D0) THEN
25888          evdw = 1.0D20
25889          RETURN
25890         END IF
25891         sigder = -sig * sigsq
25892         rij_shift = 1.0D0 / rij_shift
25893         fac       = rij_shift**expon
25894         c1        = fac  * fac * aa_pepbase(itypj)
25895 !          c1        = 0.0d0
25896         c2        = fac  * bb_pepbase(itypj)
25897 !          c2        = 0.0d0
25898         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25899         eps2der   = eps3rt * evdwij
25900         eps3der   = eps2rt * evdwij
25901 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25902         evdwij    = eps2rt * eps3rt * evdwij
25903         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25904         fac    = -expon * (c1 + evdwij) * rij_shift
25905         sigder = fac * sigder
25906 !          fac    = rij * fac
25907 ! Calculate distance derivative
25908         gg(1) =  fac
25909         gg(2) =  fac
25910         gg(3) =  fac
25911         fac = chis1 * sqom1 + chis2 * sqom2 &
25912         - 2.0d0 * chis12 * om1 * om2 * om12
25913 ! we will use pom later in Gcav, so dont mess with it!
25914         pom = 1.0d0 - chis1 * chis2 * sqom12
25915         Lambf = (1.0d0 - (fac / pom))
25916         Lambf = dsqrt(Lambf)
25917         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25918 !       write (*,*) "sparrow = ", sparrow
25919         Chif = 1.0d0/rij * sparrow
25920         ChiLambf = Chif * Lambf
25921         eagle = dsqrt(ChiLambf)
25922         bat = ChiLambf ** 11.0d0
25923         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25924         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25925         botsq = bot * bot
25926         Fcav = top / bot
25927 !          print *,i,j,Fcav
25928         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25929         dbot = 12.0d0 * b4 * bat * Lambf
25930         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25931 !       dFdR = 0.0d0
25932 !      write (*,*) "dFcav/dR = ", dFdR
25933         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25934         dbot = 12.0d0 * b4 * bat * Chif
25935         eagle = Lambf * pom
25936         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25937         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25938         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25939             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25940
25941         dFdL = ((dtop * bot - top * dbot) / botsq)
25942 !       dFdL = 0.0d0
25943         dCAVdOM1  = dFdL * ( dFdOM1 )
25944         dCAVdOM2  = dFdL * ( dFdOM2 )
25945         dCAVdOM12 = dFdL * ( dFdOM12 )
25946
25947         ertail(1) = xj*rij
25948         ertail(2) = yj*rij
25949         ertail(3) = zj*rij
25950        DO k = 1, 3
25951 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25952 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25953       pom = ertail(k)
25954 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25955       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25956               - (( dFdR + gg(k) ) * pom)/2.0
25957 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
25958 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25959 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25960 !     &             - ( dFdR * pom )
25961       pom = ertail(k)
25962 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25963       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25964               + (( dFdR + gg(k) ) * pom)
25965 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25966 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25967 !c!     &             + ( dFdR * pom )
25968
25969       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25970               - (( dFdR + gg(k) ) * ertail(k))/2.0
25971 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
25972
25973 !c!     &             - ( dFdR * ertail(k))
25974
25975       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25976               + (( dFdR + gg(k) ) * ertail(k))
25977 !c!     &             + ( dFdR * ertail(k))
25978
25979       gg(k) = 0.0d0
25980 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25981 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25982       END DO
25983
25984
25985        w1 = wdipdip_pepbase(1,itypj)
25986        w2 = -wdipdip_pepbase(3,itypj)/2.0
25987        w3 = wdipdip_pepbase(2,itypj)
25988 !       w1=0.0d0
25989 !       w2=0.0d0
25990 !c!-------------------------------------------------------------------
25991 !c! ECL
25992 !       w3=0.0d0
25993        fac = (om12 - 3.0d0 * om1 * om2)
25994        c1 = (w1 / (Rhead**3.0d0)) * fac
25995        c2 = (w2 / Rhead ** 6.0d0)  &
25996        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25997        c3= (w3/ Rhead ** 6.0d0)  &
25998        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25999
26000        ECL = c1 - c2 + c3
26001
26002        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
26003        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
26004        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
26005        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
26006        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
26007
26008        dGCLdR = c1 - c2 + c3
26009 !c! dECL/dom1
26010        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
26011        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26012        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
26013        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
26014        dGCLdOM1 = c1 - c2 + c3
26015 !c! dECL/dom2
26016        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
26017        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26018        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
26019        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
26020
26021        dGCLdOM2 = c1 - c2 + c3
26022 !c! dECL/dom12
26023        c1 = w1 / (Rhead ** 3.0d0)
26024        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
26025        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
26026        dGCLdOM12 = c1 - c2 + c3
26027        DO k= 1, 3
26028       erhead(k) = Rhead_distance(k)/Rhead
26029        END DO
26030        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26031        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26032 !       facd1 = d1 * vbld_inv(i+nres)
26033 !       facd2 = d2 * vbld_inv(j+nres)
26034        DO k = 1, 3
26035
26036 !        pom = erhead(k)
26037 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26038 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
26039 !                  - dGCLdR * pom
26040       pom = erhead(k)
26041 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26042       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
26043               + dGCLdR * pom
26044
26045       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
26046               - dGCLdR * erhead(k)/2.0d0
26047 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
26048       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
26049               - dGCLdR * erhead(k)/2.0d0
26050 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
26051       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
26052               + dGCLdR * erhead(k)
26053        END DO
26054 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
26055        epepbase=epepbase+evdwij+Fcav+ECL
26056        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
26057       "epepbase:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,epepbase
26058        call sc_grad_pepbase
26059        enddo
26060        enddo
26061       END SUBROUTINE epep_sc_base
26062       SUBROUTINE sc_grad_pepbase
26063       use calc_data
26064
26065        real (kind=8) :: dcosom1(3),dcosom2(3)
26066        eom1  =    &
26067             eps2der * eps2rt_om1   &
26068           - 2.0D0 * alf1 * eps3der &
26069           + sigder * sigsq_om1     &
26070           + dCAVdOM1               &
26071           + dGCLdOM1               &
26072           + dPOLdOM1
26073
26074        eom2  =  &
26075             eps2der * eps2rt_om2   &
26076           + 2.0D0 * alf2 * eps3der &
26077           + sigder * sigsq_om2     &
26078           + dCAVdOM2               &
26079           + dGCLdOM2               &
26080           + dPOLdOM2
26081
26082        eom12 =    &
26083             evdwij  * eps1_om12     &
26084           + eps2der * eps2rt_om12   &
26085           - 2.0D0 * alf12 * eps3der &
26086           + sigder *sigsq_om12      &
26087           + dCAVdOM12               &
26088           + dGCLdOM12
26089 !        om12=0.0
26090 !        eom12=0.0
26091 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
26092 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
26093 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
26094 !                 *dsci_inv*2.0
26095 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
26096 !               gg(1),gg(2),"rozne"
26097        DO k = 1, 3
26098       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
26099       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26100       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26101       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
26102              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
26103              *dsci_inv*2.0 &
26104              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26105       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
26106              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
26107              *dsci_inv*2.0 &
26108              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26109 !         print *,eom12,eom2,om12,om2
26110 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
26111 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
26112       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
26113              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
26114              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26115       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
26116        END DO
26117        RETURN
26118       END SUBROUTINE sc_grad_pepbase
26119       subroutine eprot_sc_phosphate(escpho)
26120       use calc_data
26121 !      implicit real(kind=8) (a-h,o-z)
26122 !      include 'DIMENSIONS'
26123 !      include 'COMMON.GEO'
26124 !      include 'COMMON.VAR'
26125 !      include 'COMMON.LOCAL'
26126 !      include 'COMMON.CHAIN'
26127 !      include 'COMMON.DERIV'
26128 !      include 'COMMON.NAMES'
26129 !      include 'COMMON.INTERACT'
26130 !      include 'COMMON.IOUNITS'
26131 !      include 'COMMON.CALC'
26132 !      include 'COMMON.CONTROL'
26133 !      include 'COMMON.SBRIDGE'
26134       logical :: lprn
26135 !el local variables
26136       integer :: iint,itypi,itypi1,itypj,subchap
26137       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
26138       real(kind=8) :: evdw,sig0ij,aa,bb
26139       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26140                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
26141                 sslipi,sslipj,faclip,alpha_sco
26142       integer :: ii
26143       real(kind=8) :: fracinbuf
26144        real (kind=8) :: escpho
26145        real (kind=8),dimension(4):: ener
26146        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
26147        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
26148       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
26149       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
26150       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
26151       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
26152       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
26153       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
26154        real(kind=8),dimension(3,2)::chead,erhead_tail
26155        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
26156        integer troll
26157        eps_out=80.0d0
26158        escpho=0.0d0
26159 !       do i=1,nres_molec(1)
26160       do i=ibond_start,ibond_end
26161       if (itype(i,1).eq.ntyp1_molec(1)) cycle
26162       itypi  = itype(i,1)
26163       dxi    = dc_norm(1,nres+i)
26164       dyi    = dc_norm(2,nres+i)
26165       dzi    = dc_norm(3,nres+i)
26166       dsci_inv = vbld_inv(i+nres)
26167       xi=c(1,nres+i)
26168       yi=c(2,nres+i)
26169       zi=c(3,nres+i)
26170        call to_box(xi,yi,zi)
26171       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
26172        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
26173          itypj= itype(j,2)
26174          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
26175           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
26176          xj=(c(1,j)+c(1,j+1))/2.0
26177          yj=(c(2,j)+c(2,j+1))/2.0
26178          zj=(c(3,j)+c(3,j+1))/2.0
26179      call to_box(xj,yj,zj)
26180 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
26181 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26182 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26183 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26184 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26185       xj=boxshift(xj-xi,boxxsize)
26186       yj=boxshift(yj-yi,boxysize)
26187       zj=boxshift(zj-zi,boxzsize)
26188           dxj = dc_norm( 1,j )
26189         dyj = dc_norm( 2,j )
26190         dzj = dc_norm( 3,j )
26191         dscj_inv = vbld_inv(j+1)
26192
26193 ! Gay-berne var's
26194         sig0ij = sigma_scpho(itypi )
26195         chi1   = chi_scpho(itypi,1 )
26196         chi2   = chi_scpho(itypi,2 )
26197 !          chi1=0.0d0
26198 !          chi2=0.0d0
26199         chi12  = chi1 * chi2
26200         chip1  = chipp_scpho(itypi,1 )
26201         chip2  = chipp_scpho(itypi,2 )
26202 !          chip1=0.0d0
26203 !          chip2=0.0d0
26204         chip12 = chip1 * chip2
26205         chis1 = chis_scpho(itypi,1)
26206         chis2 = chis_scpho(itypi,2)
26207         chis12 = chis1 * chis2
26208         sig1 = sigmap1_scpho(itypi)
26209         sig2 = sigmap2_scpho(itypi)
26210 !       write (*,*) "sig1 = ", sig1
26211 !       write (*,*) "sig1 = ", sig1
26212 !       write (*,*) "sig2 = ", sig2
26213 ! alpha factors from Fcav/Gcav
26214         alf1   = 0.0d0
26215         alf2   = 0.0d0
26216         alf12  = 0.0d0
26217         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
26218
26219         b1 = alphasur_scpho(1,itypi)
26220 !          b1=0.0d0
26221         b2 = alphasur_scpho(2,itypi)
26222         b3 = alphasur_scpho(3,itypi)
26223         b4 = alphasur_scpho(4,itypi)
26224 ! used to determine whether we want to do quadrupole calculations
26225 ! used by Fgb
26226        eps_in = epsintab_scpho(itypi)
26227        if (eps_in.eq.0.0) eps_in=1.0
26228        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26229 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26230 !-------------------------------------------------------------------
26231 ! tail location and distance calculations
26232         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
26233         d1j = 0.0
26234        DO k = 1,3
26235 ! location of polar head is computed by taking hydrophobic centre
26236 ! and moving by a d1 * dc_norm vector
26237 ! see unres publications for very informative images
26238       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
26239       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
26240 ! distance
26241 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26242 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26243       Rhead_distance(k) = chead(k,2) - chead(k,1)
26244        END DO
26245 ! pitagoras (root of sum of squares)
26246        Rhead = dsqrt( &
26247         (Rhead_distance(1)*Rhead_distance(1)) &
26248       + (Rhead_distance(2)*Rhead_distance(2)) &
26249       + (Rhead_distance(3)*Rhead_distance(3)))
26250        Rhead_sq=Rhead**2.0
26251 !-------------------------------------------------------------------
26252 ! zero everything that should be zero'ed
26253        evdwij = 0.0d0
26254        ECL = 0.0d0
26255        Elj = 0.0d0
26256        Equad = 0.0d0
26257        Epol = 0.0d0
26258        Fcav=0.0d0
26259        eheadtail = 0.0d0
26260        dGCLdR=0.0d0
26261        dGCLdOM1 = 0.0d0
26262        dGCLdOM2 = 0.0d0
26263        dGCLdOM12 = 0.0d0
26264        dPOLdOM1 = 0.0d0
26265        dPOLdOM2 = 0.0d0
26266         Fcav = 0.0d0
26267         dFdR = 0.0d0
26268         dCAVdOM1  = 0.0d0
26269         dCAVdOM2  = 0.0d0
26270         dCAVdOM12 = 0.0d0
26271         dscj_inv = vbld_inv(j+1)/2.0
26272 !dhead_scbasej(itypi,itypj)
26273 !          print *,i,j,dscj_inv,dsci_inv
26274 ! rij holds 1/(distance of Calpha atoms)
26275         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26276         rij  = dsqrt(rrij)
26277 !----------------------------
26278         CALL sc_angular
26279 ! this should be in elgrad_init but om's are calculated by sc_angular
26280 ! which in turn is used by older potentials
26281 ! om = omega, sqom = om^2
26282         sqom1  = om1 * om1
26283         sqom2  = om2 * om2
26284         sqom12 = om12 * om12
26285
26286 ! now we calculate EGB - Gey-Berne
26287 ! It will be summed up in evdwij and saved in evdw
26288         sigsq     = 1.0D0  / sigsq
26289         sig       = sig0ij * dsqrt(sigsq)
26290 !          rij_shift = 1.0D0  / rij - sig + sig0ij
26291         rij_shift = 1.0/rij - sig + sig0ij
26292         IF (rij_shift.le.0.0D0) THEN
26293          evdw = 1.0D20
26294          RETURN
26295         END IF
26296         sigder = -sig * sigsq
26297         rij_shift = 1.0D0 / rij_shift
26298         fac       = rij_shift**expon
26299         c1        = fac  * fac * aa_scpho(itypi)
26300 !          c1        = 0.0d0
26301         c2        = fac  * bb_scpho(itypi)
26302 !          c2        = 0.0d0
26303         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
26304         eps2der   = eps3rt * evdwij
26305         eps3der   = eps2rt * evdwij
26306 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
26307         evdwij    = eps2rt * eps3rt * evdwij
26308         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
26309         fac    = -expon * (c1 + evdwij) * rij_shift
26310         sigder = fac * sigder
26311 !          fac    = rij * fac
26312 ! Calculate distance derivative
26313         gg(1) =  fac
26314         gg(2) =  fac
26315         gg(3) =  fac
26316         fac = chis1 * sqom1 + chis2 * sqom2 &
26317         - 2.0d0 * chis12 * om1 * om2 * om12
26318 ! we will use pom later in Gcav, so dont mess with it!
26319         pom = 1.0d0 - chis1 * chis2 * sqom12
26320         Lambf = (1.0d0 - (fac / pom))
26321         Lambf = dsqrt(Lambf)
26322         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
26323 !       write (*,*) "sparrow = ", sparrow
26324         Chif = 1.0d0/rij * sparrow
26325         ChiLambf = Chif * Lambf
26326         eagle = dsqrt(ChiLambf)
26327         bat = ChiLambf ** 11.0d0
26328         top = b1 * ( eagle + b2 * ChiLambf - b3 )
26329         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
26330         botsq = bot * bot
26331         Fcav = top / bot
26332         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
26333         dbot = 12.0d0 * b4 * bat * Lambf
26334         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
26335 !       dFdR = 0.0d0
26336 !      write (*,*) "dFcav/dR = ", dFdR
26337         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
26338         dbot = 12.0d0 * b4 * bat * Chif
26339         eagle = Lambf * pom
26340         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
26341         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
26342         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
26343             * (chis2 * om2 * om12 - om1) / (eagle * pom)
26344
26345         dFdL = ((dtop * bot - top * dbot) / botsq)
26346 !       dFdL = 0.0d0
26347         dCAVdOM1  = dFdL * ( dFdOM1 )
26348         dCAVdOM2  = dFdL * ( dFdOM2 )
26349         dCAVdOM12 = dFdL * ( dFdOM12 )
26350
26351         ertail(1) = xj*rij
26352         ertail(2) = yj*rij
26353         ertail(3) = zj*rij
26354        DO k = 1, 3
26355 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26356 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26357 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
26358
26359       pom = ertail(k)
26360 !        print *,pom,gg(k),dFdR
26361 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
26362       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
26363               - (( dFdR + gg(k) ) * pom)
26364 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
26365 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26366 !     &             - ( dFdR * pom )
26367 !        pom = ertail(k)
26368 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
26369 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
26370 !                  + (( dFdR + gg(k) ) * pom)
26371 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26372 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26373 !c!     &             + ( dFdR * pom )
26374
26375       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
26376               - (( dFdR + gg(k) ) * ertail(k))
26377 !c!     &             - ( dFdR * ertail(k))
26378
26379       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
26380               + (( dFdR + gg(k) ) * ertail(k))/2.0
26381
26382       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
26383               + (( dFdR + gg(k) ) * ertail(k))/2.0
26384
26385 !c!     &             + ( dFdR * ertail(k))
26386
26387       gg(k) = 0.0d0
26388       ENDDO
26389 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26390 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26391 !      alphapol1 = alphapol_scpho(itypi)
26392        if (wqq_scpho(itypi).ne.0.0) then
26393        Qij=wqq_scpho(itypi)/eps_in
26394        alpha_sco=1.d0/alphi_scpho(itypi)
26395 !       Qij=0.0
26396        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
26397 !c! derivative of Ecl is Gcl...
26398        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
26399             (Rhead*alpha_sco+1) ) / Rhead_sq
26400        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
26401        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
26402        w1        = wqdip_scpho(1,itypi)
26403        w2        = wqdip_scpho(2,itypi)
26404 !       w1=0.0d0
26405 !       w2=0.0d0
26406 !       pis       = sig0head_scbase(itypi,itypj)
26407 !       eps_head   = epshead_scbase(itypi,itypj)
26408 !c!-------------------------------------------------------------------
26409
26410 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26411 !c!     &        +dhead(1,1,itypi,itypj))**2))
26412 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26413 !c!     &        +dhead(2,1,itypi,itypj))**2))
26414
26415 !c!-------------------------------------------------------------------
26416 !c! ecl
26417        sparrow  = w1  *  om1
26418        hawk     = w2 *  (1.0d0 - sqom2)
26419        Ecl = sparrow / Rhead**2.0d0 &
26420          - hawk    / Rhead**4.0d0
26421 !c!-------------------------------------------------------------------
26422        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
26423          1.0/rij,sparrow
26424
26425 !c! derivative of ecl is Gcl
26426 !c! dF/dr part
26427        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26428             + 4.0d0 * hawk    / Rhead**5.0d0
26429 !c! dF/dom1
26430        dGCLdOM1 = (w1) / (Rhead**2.0d0)
26431 !c! dF/dom2
26432        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
26433        endif
26434
26435 !c--------------------------------------------------------------------
26436 !c Polarization energy
26437 !c Epol
26438        R1 = 0.0d0
26439        DO k = 1, 3
26440 !c! Calculate head-to-tail distances tail is center of side-chain
26441       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
26442        END DO
26443 !c! Pitagoras
26444        R1 = dsqrt(R1)
26445
26446       alphapol1 = alphapol_scpho(itypi)
26447 !      alphapol1=0.0
26448        MomoFac1 = (1.0d0 - chi2 * sqom1)
26449        RR1  = R1 * R1 / MomoFac1
26450        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26451 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
26452        fgb1 = sqrt( RR1 + a12sq * ee1)
26453 !       eps_inout_fac=0.0d0
26454        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26455 ! derivative of Epol is Gpol...
26456        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26457             / (fgb1 ** 5.0d0)
26458        dFGBdR1 = ( (R1 / MomoFac1) &
26459            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26460            / ( 2.0d0 * fgb1 )
26461        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26462              * (2.0d0 - 0.5d0 * ee1) ) &
26463              / (2.0d0 * fgb1)
26464        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26465 !       dPOLdR1 = 0.0d0
26466 !       dPOLdOM1 = 0.0d0
26467        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
26468              * (2.0d0 - 0.5d0 * ee1) ) &
26469              / (2.0d0 * fgb1)
26470
26471        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
26472        dPOLdOM2 = 0.0
26473        DO k = 1, 3
26474       erhead(k) = Rhead_distance(k)/Rhead
26475       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
26476        END DO
26477
26478        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26479        erdxj = scalar( erhead(1), dC_norm(1,j) )
26480        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26481 !       bat=0.0d0
26482        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26483        facd1 = d1i * vbld_inv(i+nres)
26484        facd2 = d1j * vbld_inv(j)
26485 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26486
26487        DO k = 1, 3
26488       hawk = (erhead_tail(k,1) + &
26489       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26490 !        facd1=0.0d0
26491 !        facd2=0.0d0
26492 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
26493 !                pom,(erhead_tail(k,1))
26494
26495 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
26496       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26497       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
26498                - dGCLdR * pom &
26499                - dPOLdR1 *  (erhead_tail(k,1))
26500 !     &             - dGLJdR * pom
26501
26502       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26503 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
26504 !                   + dGCLdR * pom  &
26505 !                   + dPOLdR1 * (erhead_tail(k,1))
26506 !     &             + dGLJdR * pom
26507
26508
26509       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
26510               - dGCLdR * erhead(k) &
26511               - dPOLdR1 * erhead_tail(k,1)
26512 !     &             - dGLJdR * erhead(k)
26513
26514       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
26515               + (dGCLdR * erhead(k)  &
26516               + dPOLdR1 * erhead_tail(k,1))/2.0
26517       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
26518               + (dGCLdR * erhead(k)  &
26519               + dPOLdR1 * erhead_tail(k,1))/2.0
26520
26521 !     &             + dGLJdR * erhead(k)
26522 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
26523
26524        END DO
26525 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
26526        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
26527       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
26528        escpho=escpho+evdwij+epol+Fcav+ECL
26529        call sc_grad_scpho
26530        enddo
26531
26532       enddo
26533
26534       return
26535       end subroutine eprot_sc_phosphate
26536       SUBROUTINE sc_grad_scpho
26537       use calc_data
26538
26539        real (kind=8) :: dcosom1(3),dcosom2(3)
26540        eom1  =    &
26541             eps2der * eps2rt_om1   &
26542           - 2.0D0 * alf1 * eps3der &
26543           + sigder * sigsq_om1     &
26544           + dCAVdOM1               &
26545           + dGCLdOM1               &
26546           + dPOLdOM1
26547
26548        eom2  =  &
26549             eps2der * eps2rt_om2   &
26550           + 2.0D0 * alf2 * eps3der &
26551           + sigder * sigsq_om2     &
26552           + dCAVdOM2               &
26553           + dGCLdOM2               &
26554           + dPOLdOM2
26555
26556        eom12 =    &
26557             evdwij  * eps1_om12     &
26558           + eps2der * eps2rt_om12   &
26559           - 2.0D0 * alf12 * eps3der &
26560           + sigder *sigsq_om12      &
26561           + dCAVdOM12               &
26562           + dGCLdOM12
26563 !        om12=0.0
26564 !        eom12=0.0
26565 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
26566 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
26567 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
26568 !                 *dsci_inv*2.0
26569 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
26570 !               gg(1),gg(2),"rozne"
26571        DO k = 1, 3
26572       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26573       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
26574       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26575       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
26576              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
26577              *dscj_inv*2.0 &
26578              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26579       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
26580              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
26581              *dscj_inv*2.0 &
26582              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26583       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
26584              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
26585              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26586
26587 !         print *,eom12,eom2,om12,om2
26588 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
26589 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
26590 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
26591 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
26592 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26593       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
26594        END DO
26595        RETURN
26596       END SUBROUTINE sc_grad_scpho
26597       subroutine eprot_pep_phosphate(epeppho)
26598       use calc_data
26599 !      implicit real(kind=8) (a-h,o-z)
26600 !      include 'DIMENSIONS'
26601 !      include 'COMMON.GEO'
26602 !      include 'COMMON.VAR'
26603 !      include 'COMMON.LOCAL'
26604 !      include 'COMMON.CHAIN'
26605 !      include 'COMMON.DERIV'
26606 !      include 'COMMON.NAMES'
26607 !      include 'COMMON.INTERACT'
26608 !      include 'COMMON.IOUNITS'
26609 !      include 'COMMON.CALC'
26610 !      include 'COMMON.CONTROL'
26611 !      include 'COMMON.SBRIDGE'
26612       logical :: lprn
26613 !el local variables
26614       integer :: iint,itypi,itypi1,itypj,subchap
26615       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
26616       real(kind=8) :: evdw,sig0ij
26617       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26618                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
26619                 sslipi,sslipj,faclip
26620       integer :: ii
26621       real(kind=8) :: fracinbuf
26622        real (kind=8) :: epeppho
26623        real (kind=8),dimension(4):: ener
26624        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
26625        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
26626       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
26627       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
26628       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
26629       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
26630       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
26631       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
26632        real(kind=8),dimension(3,2)::chead,erhead_tail
26633        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
26634        integer troll
26635        real (kind=8) :: dcosom1(3),dcosom2(3)
26636        epeppho=0.0d0
26637 !       do i=1,nres_molec(1)
26638       do i=ibond_start,ibond_end
26639       if (itype(i,1).eq.ntyp1_molec(1)) cycle
26640       itypi  = itype(i,1)
26641       dsci_inv = vbld_inv(i+1)/2.0
26642       dxi    = dc_norm(1,i)
26643       dyi    = dc_norm(2,i)
26644       dzi    = dc_norm(3,i)
26645       xi=(c(1,i)+c(1,i+1))/2.0
26646       yi=(c(2,i)+c(2,i+1))/2.0
26647       zi=(c(3,i)+c(3,i+1))/2.0
26648                call to_box(xi,yi,zi)
26649
26650         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
26651          itypj= itype(j,2)
26652          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
26653           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
26654          xj=(c(1,j)+c(1,j+1))/2.0
26655          yj=(c(2,j)+c(2,j+1))/2.0
26656          zj=(c(3,j)+c(3,j+1))/2.0
26657                 call to_box(xj,yj,zj)
26658       xj=boxshift(xj-xi,boxxsize)
26659       yj=boxshift(yj-yi,boxysize)
26660       zj=boxshift(zj-zi,boxzsize)
26661
26662         dist_init=xj**2+yj**2+zj**2
26663         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26664         rij  = dsqrt(rrij)
26665         dxj = dc_norm( 1,j )
26666         dyj = dc_norm( 2,j )
26667         dzj = dc_norm( 3,j )
26668         dscj_inv = vbld_inv(j+1)/2.0
26669 ! Gay-berne var's
26670         sig0ij = sigma_peppho
26671 !          chi1=0.0d0
26672 !          chi2=0.0d0
26673         chi12  = chi1 * chi2
26674 !          chip1=0.0d0
26675 !          chip2=0.0d0
26676         chip12 = chip1 * chip2
26677 !          chis1 = 0.0d0
26678 !          chis2 = 0.0d0
26679         chis12 = chis1 * chis2
26680         sig1 = sigmap1_peppho
26681         sig2 = sigmap2_peppho
26682 !       write (*,*) "sig1 = ", sig1
26683 !       write (*,*) "sig1 = ", sig1
26684 !       write (*,*) "sig2 = ", sig2
26685 ! alpha factors from Fcav/Gcav
26686         alf1   = 0.0d0
26687         alf2   = 0.0d0
26688         alf12  = 0.0d0
26689         b1 = alphasur_peppho(1)
26690 !          b1=0.0d0
26691         b2 = alphasur_peppho(2)
26692         b3 = alphasur_peppho(3)
26693         b4 = alphasur_peppho(4)
26694         CALL sc_angular
26695        sqom1=om1*om1
26696        evdwij = 0.0d0
26697        ECL = 0.0d0
26698        Elj = 0.0d0
26699        Equad = 0.0d0
26700        Epol = 0.0d0
26701        Fcav=0.0d0
26702        eheadtail = 0.0d0
26703        dGCLdR=0.0d0
26704        dGCLdOM1 = 0.0d0
26705        dGCLdOM2 = 0.0d0
26706        dGCLdOM12 = 0.0d0
26707        dPOLdOM1 = 0.0d0
26708        dPOLdOM2 = 0.0d0
26709         Fcav = 0.0d0
26710         dFdR = 0.0d0
26711         dCAVdOM1  = 0.0d0
26712         dCAVdOM2  = 0.0d0
26713         dCAVdOM12 = 0.0d0
26714         rij_shift = rij
26715         fac       = rij_shift**expon
26716         c1        = fac  * fac * aa_peppho
26717 !          c1        = 0.0d0
26718         c2        = fac  * bb_peppho
26719 !          c2        = 0.0d0
26720         evdwij    =  c1 + c2
26721 ! Now cavity....................
26722        eagle = dsqrt(1.0/rij_shift)
26723        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
26724         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
26725         botsq = bot * bot
26726         Fcav = top / bot
26727         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
26728         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
26729         dFdR = ((dtop * bot - top * dbot) / botsq)
26730        w1        = wqdip_peppho(1)
26731        w2        = wqdip_peppho(2)
26732 !       w1=0.0d0
26733 !       w2=0.0d0
26734 !       pis       = sig0head_scbase(itypi,itypj)
26735 !       eps_head   = epshead_scbase(itypi,itypj)
26736 !c!-------------------------------------------------------------------
26737
26738 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26739 !c!     &        +dhead(1,1,itypi,itypj))**2))
26740 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26741 !c!     &        +dhead(2,1,itypi,itypj))**2))
26742
26743 !c!-------------------------------------------------------------------
26744 !c! ecl
26745        sparrow  = w1  *  om1
26746        hawk     = w2 *  (1.0d0 - sqom1)
26747        Ecl = sparrow * rij_shift**2.0d0 &
26748          - hawk    * rij_shift**4.0d0
26749 !c!-------------------------------------------------------------------
26750 !c! derivative of ecl is Gcl
26751 !c! dF/dr part
26752 !       rij_shift=5.0
26753        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
26754             + 4.0d0 * hawk    * rij_shift**5.0d0
26755 !c! dF/dom1
26756        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
26757 !c! dF/dom2
26758        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
26759        eom1  =    dGCLdOM1+dGCLdOM2
26760        eom2  =    0.0
26761
26762         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
26763 !          fac=0.0
26764         gg(1) =  fac*xj*rij
26765         gg(2) =  fac*yj*rij
26766         gg(3) =  fac*zj*rij
26767        do k=1,3
26768        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
26769        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
26770        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
26771        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
26772        gg(k)=0.0
26773        enddo
26774
26775       DO k = 1, 3
26776       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
26777       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
26778       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
26779       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
26780 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26781       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
26782 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26783       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
26784              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26785       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
26786              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26787       enddo
26788        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
26789       "epeppho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,epeppho
26790
26791        epeppho=epeppho+evdwij+Fcav+ECL
26792 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
26793        enddo
26794        enddo
26795       end subroutine eprot_pep_phosphate
26796 !!!!!!!!!!!!!!!!-------------------------------------------------------------
26797       subroutine emomo(evdw)
26798       use calc_data
26799       use comm_momo
26800 !      implicit real(kind=8) (a-h,o-z)
26801 !      include 'DIMENSIONS'
26802 !      include 'COMMON.GEO'
26803 !      include 'COMMON.VAR'
26804 !      include 'COMMON.LOCAL'
26805 !      include 'COMMON.CHAIN'
26806 !      include 'COMMON.DERIV'
26807 !      include 'COMMON.NAMES'
26808 !      include 'COMMON.INTERACT'
26809 !      include 'COMMON.IOUNITS'
26810 !      include 'COMMON.CALC'
26811 !      include 'COMMON.CONTROL'
26812 !      include 'COMMON.SBRIDGE'
26813       logical :: lprn
26814 !el local variables
26815       integer :: iint,itypi1,subchap,isel,countss
26816       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
26817       real(kind=8) :: evdw,aa,bb
26818       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26819                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
26820                 sslipi,sslipj,faclip,alpha_sco
26821       integer :: ii
26822       real(kind=8) :: fracinbuf
26823        real (kind=8) :: escpho
26824        real (kind=8),dimension(4):: ener
26825        real(kind=8) :: b1,b2,egb
26826        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
26827       Lambf,&
26828       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
26829       dFdOM2,dFdL,dFdOM12,&
26830       federmaus,&
26831       d1i,d1j
26832 !       real(kind=8),dimension(3,2)::erhead_tail
26833 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
26834        real(kind=8) ::  facd4, adler, Fgb, facd3
26835        integer troll,jj,istate
26836        real (kind=8) :: dcosom1(3),dcosom2(3)
26837        evdw=0.0d0
26838        eps_out=80.0d0
26839        sss_ele_cut=1.0d0
26840        countss=0
26841 !       print *,"EVDW KURW",evdw,nres
26842       do i=iatsc_s,iatsc_e
26843 !        print *,"I am in EVDW",i
26844       itypi=iabs(itype(i,1))
26845 !        if (i.ne.47) cycle
26846       if (itypi.eq.ntyp1) cycle
26847       itypi1=iabs(itype(i+1,1))
26848       xi=c(1,nres+i)
26849       yi=c(2,nres+i)
26850       zi=c(3,nres+i)
26851         call to_box(xi,yi,zi)
26852         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
26853 !       endif
26854 !       print *, sslipi,ssgradlipi
26855       dxi=dc_norm(1,nres+i)
26856       dyi=dc_norm(2,nres+i)
26857       dzi=dc_norm(3,nres+i)
26858 !        dsci_inv=dsc_inv(itypi)
26859       dsci_inv=vbld_inv(i+nres)
26860 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
26861 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
26862 !
26863 ! Calculate SC interaction energy.
26864 !
26865       do iint=1,nint_gr(i)
26866         do j=istart(i,iint),iend(i,iint)
26867 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
26868           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
26869             call dyn_ssbond_ene(i,j,evdwij,countss)
26870             evdw=evdw+evdwij
26871             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26872                         'evdw',i,j,evdwij,' ss'
26873 !              if (energy_dec) write (iout,*) &
26874 !                              'evdw',i,j,evdwij,' ss'
26875            do k=j+1,iend(i,iint)
26876 !C search over all next residues
26877             if (dyn_ss_mask(k)) then
26878 !C check if they are cysteins
26879 !C              write(iout,*) 'k=',k
26880
26881 !c              write(iout,*) "PRZED TRI", evdwij
26882 !               evdwij_przed_tri=evdwij
26883             call triple_ssbond_ene(i,j,k,evdwij)
26884 !c               if(evdwij_przed_tri.ne.evdwij) then
26885 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
26886 !c               endif
26887
26888 !c              write(iout,*) "PO TRI", evdwij
26889 !C call the energy function that removes the artifical triple disulfide
26890 !C bond the soubroutine is located in ssMD.F
26891             evdw=evdw+evdwij
26892             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26893                       'evdw',i,j,evdwij,'tss'
26894             endif!dyn_ss_mask(k)
26895            enddo! k
26896           ELSE
26897 !el            ind=ind+1
26898           itypj=iabs(itype(j,1))
26899           if (itypj.eq.ntyp1) cycle
26900            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26901
26902 !             if (j.ne.78) cycle
26903 !            dscj_inv=dsc_inv(itypj)
26904           dscj_inv=vbld_inv(j+nres)
26905          xj=c(1,j+nres)
26906          yj=c(2,j+nres)
26907          zj=c(3,j+nres)
26908      call to_box(xj,yj,zj)
26909      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
26910 !      write(iout,*) "KRUWA", i,j
26911       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26912       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26913       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26914       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26915       xj=boxshift(xj-xi,boxxsize)
26916       yj=boxshift(yj-yi,boxysize)
26917       zj=boxshift(zj-zi,boxzsize)
26918         dxj = dc_norm( 1, nres+j )
26919         dyj = dc_norm( 2, nres+j )
26920         dzj = dc_norm( 3, nres+j )
26921 !          print *,i,j,itypi,itypj
26922 !          d1i=0.0d0
26923 !          d1j=0.0d0
26924 !          BetaT = 1.0d0 / (298.0d0 * Rb)
26925 ! Gay-berne var's
26926 !1!          sig0ij = sigma_scsc( itypi,itypj )
26927 !          chi1=0.0d0
26928 !          chi2=0.0d0
26929 !          chip1=0.0d0
26930 !          chip2=0.0d0
26931 ! not used by momo potential, but needed by sc_angular which is shared
26932 ! by all energy_potential subroutines
26933         alf1   = 0.0d0
26934         alf2   = 0.0d0
26935         alf12  = 0.0d0
26936         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26937 !       a12sq = a12sq * a12sq
26938 ! charge of amino acid itypi is...
26939         chis1 = chis(itypi,itypj)
26940         chis2 = chis(itypj,itypi)
26941         chis12 = chis1 * chis2
26942         sig1 = sigmap1(itypi,itypj)
26943         sig2 = sigmap2(itypi,itypj)
26944 !       write (*,*) "sig1 = ", sig1
26945 !          chis1=0.0
26946 !          chis2=0.0
26947 !                    chis12 = chis1 * chis2
26948 !          sig1=0.0
26949 !          sig2=0.0
26950 !       write (*,*) "sig2 = ", sig2
26951 ! alpha factors from Fcav/Gcav
26952         b1cav = alphasur(1,itypi,itypj)
26953 !          b1cav=0.0d0
26954         b2cav = alphasur(2,itypi,itypj)
26955         b3cav = alphasur(3,itypi,itypj)
26956         b4cav = alphasur(4,itypi,itypj)
26957 ! used to determine whether we want to do quadrupole calculations
26958        eps_in = epsintab(itypi,itypj)
26959        if (eps_in.eq.0.0) eps_in=1.0
26960
26961        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26962        Rtail = 0.0d0
26963 !       dtail(1,itypi,itypj)=0.0
26964 !       dtail(2,itypi,itypj)=0.0
26965
26966        DO k = 1, 3
26967       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26968       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26969        END DO
26970        call to_box (ctail(1,1),ctail(2,1),ctail(3,1))
26971        call to_box (ctail(1,2),ctail(2,2),ctail(3,2))
26972
26973 !c! tail distances will be themselves usefull elswhere
26974 !c1 (in Gcav, for example)
26975        Rtail_distance(1)=boxshift(ctail( 1, 2 ) - ctail( 1,1 ),boxxsize)
26976        Rtail_distance(2)=boxshift(ctail( 2, 2 ) - ctail( 2,1 ),boxysize)
26977        Rtail_distance(3)=boxshift(ctail( 3, 2 ) - ctail( 3,1 ),boxzsize)
26978        Rtail = dsqrt( &
26979         (Rtail_distance(1)*Rtail_distance(1)) &
26980       + (Rtail_distance(2)*Rtail_distance(2)) &
26981       + (Rtail_distance(3)*Rtail_distance(3)))
26982
26983 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26984 !-------------------------------------------------------------------
26985 ! tail location and distance calculations
26986        d1 = dhead(1, 1, itypi, itypj)
26987        d2 = dhead(2, 1, itypi, itypj)
26988
26989        DO k = 1,3
26990 ! location of polar head is computed by taking hydrophobic centre
26991 ! and moving by a d1 * dc_norm vector
26992 ! see unres publications for very informative images
26993       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26994       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26995 ! distance
26996       enddo
26997        if (energy_dec) write(iout,*) "before",chead(1,1),chead(2,1),chead(3,1)
26998        if (energy_dec) write(iout,*) "before",chead(1,2),chead(2,2),chead(3,2)
26999        call to_box (chead(1,1),chead(2,1),chead(3,1))
27000        call to_box (chead(1,2),chead(2,2),chead(3,2))
27001
27002 !c! head distances will be themselves usefull elswhere
27003 !c1 (in Gcav, for example)
27004        if (energy_dec) write(iout,*) "after",chead(1,1),chead(2,1),chead(3,1)
27005        if (energy_dec) write(iout,*) "after",chead(1,2),chead(2,2),chead(3,2)
27006
27007        Rhead_distance(1)=boxshift(chead( 1, 2 ) - chead( 1,1 ),boxxsize)
27008        Rhead_distance(2)=boxshift(chead( 2, 2 ) - chead( 2,1 ),boxysize)
27009        Rhead_distance(3)=boxshift(chead( 3, 2 ) - chead( 3,1 ),boxzsize)
27010        if (energy_dec) write(iout,*) "after,rdi",(Rhead_distance(k),k=1,3)
27011 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27012 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27013 !      Rhead_distance(k) = chead(k,2) - chead(k,1)
27014 !       END DO
27015 ! pitagoras (root of sum of squares)
27016        Rhead = dsqrt( &
27017         (Rhead_distance(1)*Rhead_distance(1)) &
27018       + (Rhead_distance(2)*Rhead_distance(2)) &
27019       + (Rhead_distance(3)*Rhead_distance(3)))
27020 !-------------------------------------------------------------------
27021 ! zero everything that should be zero'ed
27022        evdwij = 0.0d0
27023        ECL = 0.0d0
27024        Elj = 0.0d0
27025        Equad = 0.0d0
27026        Epol = 0.0d0
27027        Fcav=0.0d0
27028        eheadtail = 0.0d0
27029        dGCLdOM1 = 0.0d0
27030        dGCLdOM2 = 0.0d0
27031        dGCLdOM12 = 0.0d0
27032        dPOLdOM1 = 0.0d0
27033        dPOLdOM2 = 0.0d0
27034         Fcav = 0.0d0
27035         dFdR = 0.0d0
27036         dCAVdOM1  = 0.0d0
27037         dCAVdOM2  = 0.0d0
27038         dCAVdOM12 = 0.0d0
27039         dscj_inv = vbld_inv(j+nres)
27040 !          print *,i,j,dscj_inv,dsci_inv
27041 ! rij holds 1/(distance of Calpha atoms)
27042         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
27043         rij  = dsqrt(rrij)
27044 !----------------------------
27045         CALL sc_angular
27046 ! this should be in elgrad_init but om's are calculated by sc_angular
27047 ! which in turn is used by older potentials
27048 ! om = omega, sqom = om^2
27049         sqom1  = om1 * om1
27050         sqom2  = om2 * om2
27051         sqom12 = om12 * om12
27052
27053 ! now we calculate EGB - Gey-Berne
27054 ! It will be summed up in evdwij and saved in evdw
27055         sigsq     = 1.0D0  / sigsq
27056         sig       = sig0ij * dsqrt(sigsq)
27057 !          rij_shift = 1.0D0  / rij - sig + sig0ij
27058         rij_shift = Rtail - sig + sig0ij
27059         IF (rij_shift.le.0.0D0) THEN
27060          evdw = 1.0D20
27061          RETURN
27062         END IF
27063         sigder = -sig * sigsq
27064         rij_shift = 1.0D0 / rij_shift
27065         fac       = rij_shift**expon
27066         c1        = fac  * fac * aa_aq(itypi,itypj)
27067 !          print *,"ADAM",aa_aq(itypi,itypj)
27068
27069 !          c1        = 0.0d0
27070         c2        = fac  * bb_aq(itypi,itypj)
27071 !          c2        = 0.0d0
27072         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
27073         eps2der   = eps3rt * evdwij
27074         eps3der   = eps2rt * evdwij
27075 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
27076         evdwij    = eps2rt * eps3rt * evdwij
27077 !#ifdef TSCSC
27078 !          IF (bb_aq(itypi,itypj).gt.0) THEN
27079 !           evdw_p = evdw_p + evdwij
27080 !          ELSE
27081 !           evdw_m = evdw_m + evdwij
27082 !          END IF
27083 !#else
27084         evdw = evdw  &
27085             + evdwij
27086 !#endif
27087
27088         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
27089         fac    = -expon * (c1 + evdwij) * rij_shift
27090         sigder = fac * sigder
27091 !          fac    = rij * fac
27092 ! Calculate distance derivative
27093         gg(1) =  fac
27094         gg(2) =  fac
27095         gg(3) =  fac
27096 !          if (b2.gt.0.0) then
27097         fac = chis1 * sqom1 + chis2 * sqom2 &
27098         - 2.0d0 * chis12 * om1 * om2 * om12
27099 ! we will use pom later in Gcav, so dont mess with it!
27100         pom = 1.0d0 - chis1 * chis2 * sqom12
27101         Lambf = (1.0d0 - (fac / pom))
27102 !          print *,"fac,pom",fac,pom,Lambf
27103         Lambf = dsqrt(Lambf)
27104         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
27105 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
27106 !       write (*,*) "sparrow = ", sparrow
27107         Chif = Rtail * sparrow
27108 !           print *,"rij,sparrow",rij , sparrow
27109         ChiLambf = Chif * Lambf
27110         eagle = dsqrt(ChiLambf)
27111         bat = ChiLambf ** 11.0d0
27112         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
27113         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
27114         botsq = bot * bot
27115 !          print *,top,bot,"bot,top",ChiLambf,Chif
27116         Fcav = top / bot
27117
27118        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
27119        dbot = 12.0d0 * b4cav * bat * Lambf
27120        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
27121
27122         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
27123         dbot = 12.0d0 * b4cav * bat * Chif
27124         eagle = Lambf * pom
27125         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
27126         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
27127         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
27128             * (chis2 * om2 * om12 - om1) / (eagle * pom)
27129
27130         dFdL = ((dtop * bot - top * dbot) / botsq)
27131 !       dFdL = 0.0d0
27132         dCAVdOM1  = dFdL * ( dFdOM1 )
27133         dCAVdOM2  = dFdL * ( dFdOM2 )
27134         dCAVdOM12 = dFdL * ( dFdOM12 )
27135
27136        DO k= 1, 3
27137       ertail(k) = Rtail_distance(k)/Rtail
27138        END DO
27139        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
27140        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
27141        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27142        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27143        DO k = 1, 3
27144 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
27145 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
27146       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
27147       gvdwx(k,i) = gvdwx(k,i) &
27148               - (( dFdR + gg(k) ) * pom)
27149 !c!     &             - ( dFdR * pom )
27150       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
27151       gvdwx(k,j) = gvdwx(k,j)   &
27152               + (( dFdR + gg(k) ) * pom)
27153 !c!     &             + ( dFdR * pom )
27154
27155       gvdwc(k,i) = gvdwc(k,i)  &
27156               - (( dFdR + gg(k) ) * ertail(k))
27157 !c!     &             - ( dFdR * ertail(k))
27158
27159       gvdwc(k,j) = gvdwc(k,j) &
27160               + (( dFdR + gg(k) ) * ertail(k))
27161 !c!     &             + ( dFdR * ertail(k))
27162
27163       gg(k) = 0.0d0
27164 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
27165 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
27166       END DO
27167
27168
27169 !c! Compute head-head and head-tail energies for each state
27170
27171         isel = iabs(Qi) + iabs(Qj)
27172 ! double charge for Phophorylated! itype - 25,27,27
27173 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
27174 !            Qi=Qi*2
27175 !            Qij=Qij*2
27176 !           endif
27177 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
27178 !            Qj=Qj*2
27179 !            Qij=Qij*2
27180 !           endif
27181
27182 !          isel=0
27183         IF (isel.eq.0) THEN
27184 !c! No charges - do nothing
27185          eheadtail = 0.0d0
27186
27187         ELSE IF (isel.eq.4) THEN
27188 !c! Calculate dipole-dipole interactions
27189          CALL edd(ecl)
27190          eheadtail = ECL
27191 !           eheadtail = 0.0d0
27192
27193         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
27194 !c! Charge-nonpolar interactions
27195         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27196           Qi=Qi*2
27197           Qij=Qij*2
27198          endif
27199         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27200           Qj=Qj*2
27201           Qij=Qij*2
27202          endif
27203
27204          CALL eqn(epol)
27205          eheadtail = epol
27206 !           eheadtail = 0.0d0
27207
27208         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
27209 !c! Nonpolar-charge interactions
27210         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27211           Qi=Qi*2
27212           Qij=Qij*2
27213          endif
27214         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27215           Qj=Qj*2
27216           Qij=Qij*2
27217          endif
27218
27219          CALL enq(epol)
27220          eheadtail = epol
27221 !           eheadtail = 0.0d0
27222
27223         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
27224 !c! Charge-dipole interactions
27225         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27226           Qi=Qi*2
27227           Qij=Qij*2
27228          endif
27229         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27230           Qj=Qj*2
27231           Qij=Qij*2
27232          endif
27233
27234          CALL eqd(ecl, elj, epol)
27235          eheadtail = ECL + elj + epol
27236 !           eheadtail = 0.0d0
27237
27238         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
27239 !c! Dipole-charge interactions
27240         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27241           Qi=Qi*2
27242           Qij=Qij*2
27243          endif
27244         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27245           Qj=Qj*2
27246           Qij=Qij*2
27247          endif
27248          CALL edq(ecl, elj, epol)
27249         eheadtail = ECL + elj + epol
27250 !           eheadtail = 0.0d0
27251
27252         ELSE IF ((isel.eq.2.and.   &
27253              iabs(Qi).eq.1).and.  &
27254              nstate(itypi,itypj).eq.1) THEN
27255 !c! Same charge-charge interaction ( +/+ or -/- )
27256         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27257           Qi=Qi*2
27258           Qij=Qij*2
27259          endif
27260         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27261           Qj=Qj*2
27262           Qij=Qij*2
27263          endif
27264
27265          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
27266          eheadtail = ECL + Egb + Epol + Fisocav + Elj
27267 !           eheadtail = 0.0d0
27268
27269         ELSE IF ((isel.eq.2.and.  &
27270              iabs(Qi).eq.1).and. &
27271              nstate(itypi,itypj).ne.1) THEN
27272 !c! Different charge-charge interaction ( +/- or -/+ )
27273         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27274           Qi=Qi*2
27275           Qij=Qij*2
27276          endif
27277         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27278           Qj=Qj*2
27279           Qij=Qij*2
27280          endif
27281
27282          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
27283         END IF
27284        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
27285       evdw = evdw  + Fcav + eheadtail
27286
27287        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
27288       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
27289       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
27290       Equad,evdwij+Fcav+eheadtail,evdw
27291 !       evdw = evdw  + Fcav  + eheadtail
27292
27293       iF (nstate(itypi,itypj).eq.1) THEN
27294       CALL sc_grad
27295        END IF
27296 !c!-------------------------------------------------------------------
27297 !c! NAPISY KONCOWE
27298        END DO   ! j
27299       END DO    ! iint
27300        END DO     ! i
27301 !c      write (iout,*) "Number of loop steps in EGB:",ind
27302 !c      energy_dec=.false.
27303 !              print *,"EVDW KURW",evdw,nres
27304
27305        RETURN
27306       END SUBROUTINE emomo
27307 !C------------------------------------------------------------------------------------
27308       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
27309       use calc_data
27310       use comm_momo
27311        real (kind=8) ::  facd3, facd4, federmaus, adler,&
27312        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
27313 !       integer :: k
27314 !c! Epol and Gpol analytical parameters
27315        alphapol1 = alphapol(itypi,itypj)
27316        alphapol2 = alphapol(itypj,itypi)
27317 !c! Fisocav and Gisocav analytical parameters
27318        al1  = alphiso(1,itypi,itypj)
27319        al2  = alphiso(2,itypi,itypj)
27320        al3  = alphiso(3,itypi,itypj)
27321        al4  = alphiso(4,itypi,itypj)
27322        csig = (1.0d0  &
27323          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
27324          + sigiso2(itypi,itypj)**2.0d0))
27325 !c!
27326        pis  = sig0head(itypi,itypj)
27327        eps_head = epshead(itypi,itypj)
27328        Rhead_sq = Rhead * Rhead
27329 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27330 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27331        R1 = 0.0d0
27332        R2 = 0.0d0
27333        DO k = 1, 3
27334 !c! Calculate head-to-tail distances needed by Epol
27335       R1=R1+(ctail(k,2)-chead(k,1))**2
27336       R2=R2+(chead(k,2)-ctail(k,1))**2
27337        END DO
27338 !c! Pitagoras
27339        R1 = dsqrt(R1)
27340        R2 = dsqrt(R2)
27341
27342 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27343 !c!     &        +dhead(1,1,itypi,itypj))**2))
27344 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27345 !c!     &        +dhead(2,1,itypi,itypj))**2))
27346
27347 !c!-------------------------------------------------------------------
27348 !c! Coulomb electrostatic interaction
27349        Ecl = (332.0d0 * Qij) / Rhead
27350 !c! derivative of Ecl is Gcl...
27351        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
27352        dGCLdOM1 = 0.0d0
27353        dGCLdOM2 = 0.0d0
27354        dGCLdOM12 = 0.0d0
27355        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27356        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27357        debkap=debaykap(itypi,itypj)
27358        Egb = -(332.0d0 * Qij *&
27359       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
27360 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
27361 !c! Derivative of Egb is Ggb...
27362        dGGBdFGB = -(-332.0d0 * Qij * &
27363        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
27364        -(332.0d0 * Qij *&
27365       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
27366        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
27367        dGGBdR = dGGBdFGB * dFGBdR
27368 !c!-------------------------------------------------------------------
27369 !c! Fisocav - isotropic cavity creation term
27370 !c! or "how much energy it costs to put charged head in water"
27371        pom = Rhead * csig
27372        top = al1 * (dsqrt(pom) + al2 * pom - al3)
27373        bot = (1.0d0 + al4 * pom**12.0d0)
27374        botsq = bot * bot
27375        FisoCav = top / bot
27376 !      write (*,*) "Rhead = ",Rhead
27377 !      write (*,*) "csig = ",csig
27378 !      write (*,*) "pom = ",pom
27379 !      write (*,*) "al1 = ",al1
27380 !      write (*,*) "al2 = ",al2
27381 !      write (*,*) "al3 = ",al3
27382 !      write (*,*) "al4 = ",al4
27383 !        write (*,*) "top = ",top
27384 !        write (*,*) "bot = ",bot
27385 !c! Derivative of Fisocav is GCV...
27386        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27387        dbot = 12.0d0 * al4 * pom ** 11.0d0
27388        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
27389 !c!-------------------------------------------------------------------
27390 !c! Epol
27391 !c! Polarization energy - charged heads polarize hydrophobic "neck"
27392        MomoFac1 = (1.0d0 - chi1 * sqom2)
27393        MomoFac2 = (1.0d0 - chi2 * sqom1)
27394        RR1  = ( R1 * R1 ) / MomoFac1
27395        RR2  = ( R2 * R2 ) / MomoFac2
27396        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27397        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27398        fgb1 = sqrt( RR1 + a12sq * ee1 )
27399        fgb2 = sqrt( RR2 + a12sq * ee2 )
27400        epol = 332.0d0 * eps_inout_fac * ( &
27401       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27402 !c!       epol = 0.0d0
27403        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27404              / (fgb1 ** 5.0d0)
27405        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27406              / (fgb2 ** 5.0d0)
27407        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
27408            / ( 2.0d0 * fgb1 )
27409        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
27410            / ( 2.0d0 * fgb2 )
27411        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
27412             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
27413        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
27414             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
27415        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27416 !c!       dPOLdR1 = 0.0d0
27417        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27418 !c!       dPOLdR2 = 0.0d0
27419        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27420 !c!       dPOLdOM1 = 0.0d0
27421        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27422 !c!       dPOLdOM2 = 0.0d0
27423 !c!-------------------------------------------------------------------
27424 !c! Elj
27425 !c! Lennard-Jones 6-12 interaction between heads
27426        pom = (pis / Rhead)**6.0d0
27427        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27428 !c! derivative of Elj is Glj
27429        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
27430            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27431 !c!-------------------------------------------------------------------
27432 !c! Return the results
27433 !c! These things do the dRdX derivatives, that is
27434 !c! allow us to change what we see from function that changes with
27435 !c! distance to function that changes with LOCATION (of the interaction
27436 !c! site)
27437        DO k = 1, 3
27438       erhead(k) = Rhead_distance(k)/Rhead
27439       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27440       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27441        END DO
27442
27443        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27444        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27445        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27446        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27447        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27448        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27449        facd1 = d1 * vbld_inv(i+nres)
27450        facd2 = d2 * vbld_inv(j+nres)
27451        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27452        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27453
27454 !c! Now we add appropriate partial derivatives (one in each dimension)
27455        DO k = 1, 3
27456       hawk   = (erhead_tail(k,1) + &
27457       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
27458       condor = (erhead_tail(k,2) + &
27459       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27460
27461       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27462       gvdwx(k,i) = gvdwx(k,i) &
27463               - dGCLdR * pom&
27464               - dGGBdR * pom&
27465               - dGCVdR * pom&
27466               - dPOLdR1 * hawk&
27467               - dPOLdR2 * (erhead_tail(k,2)&
27468       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27469               - dGLJdR * pom
27470
27471       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27472       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
27473                + dGGBdR * pom+ dGCVdR * pom&
27474               + dPOLdR1 * (erhead_tail(k,1)&
27475       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
27476               + dPOLdR2 * condor + dGLJdR * pom
27477
27478       gvdwc(k,i) = gvdwc(k,i)  &
27479               - dGCLdR * erhead(k)&
27480               - dGGBdR * erhead(k)&
27481               - dGCVdR * erhead(k)&
27482               - dPOLdR1 * erhead_tail(k,1)&
27483               - dPOLdR2 * erhead_tail(k,2)&
27484               - dGLJdR * erhead(k)
27485
27486       gvdwc(k,j) = gvdwc(k,j)         &
27487               + dGCLdR * erhead(k) &
27488               + dGGBdR * erhead(k) &
27489               + dGCVdR * erhead(k) &
27490               + dPOLdR1 * erhead_tail(k,1) &
27491               + dPOLdR2 * erhead_tail(k,2)&
27492               + dGLJdR * erhead(k)
27493
27494        END DO
27495        RETURN
27496       END SUBROUTINE eqq
27497
27498       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
27499       use calc_data
27500       use comm_momo
27501        real (kind=8) ::  facd3, facd4, federmaus, adler,&
27502        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
27503 !       integer :: k
27504 !c! Epol and Gpol analytical parameters
27505        alphapol1 = alphapolcat(itypi,itypj)
27506        alphapol2 = alphapolcat2(itypj,itypi)
27507 !c! Fisocav and Gisocav analytical parameters
27508        al1  = alphisocat(1,itypi,itypj)
27509        al2  = alphisocat(2,itypi,itypj)
27510        al3  = alphisocat(3,itypi,itypj)
27511        al4  = alphisocat(4,itypi,itypj)
27512        csig = (1.0d0  &
27513          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
27514          + sigiso2cat(itypi,itypj)**2.0d0))
27515 !c!
27516        pis  = sig0headcat(itypi,itypj)
27517        eps_head = epsheadcat(itypi,itypj)
27518        Rhead_sq = Rhead * Rhead
27519 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27520 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27521        R1 = 0.0d0
27522        R2 = 0.0d0
27523        DO k = 1, 3
27524 !c! Calculate head-to-tail distances needed by Epol
27525       R1=R1+(ctail(k,2)-chead(k,1))**2
27526       R2=R2+(chead(k,2)-ctail(k,1))**2
27527        END DO
27528 !c! Pitagoras
27529        R1 = dsqrt(R1)
27530        R2 = dsqrt(R2)
27531
27532 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27533 !c!     &        +dhead(1,1,itypi,itypj))**2))
27534 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27535 !c!     &        +dhead(2,1,itypi,itypj))**2))
27536
27537 !c!-------------------------------------------------------------------
27538 !c! Coulomb electrostatic interaction
27539        Ecl = (332.0d0 * Qij) / Rhead
27540 !c! derivative of Ecl is Gcl...
27541        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
27542        dGCLdOM1 = 0.0d0
27543        dGCLdOM2 = 0.0d0
27544        dGCLdOM12 = 0.0d0
27545
27546        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27547        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27548        debkap=debaykapcat(itypi,itypj)
27549        if (energy_dec) write(iout,*) "egb",Qij,debkap,Fgb,a12sq,ee0
27550        Egb = -(332.0d0 * Qij *&
27551       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
27552 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
27553 !c! Derivative of Egb is Ggb...
27554        dGGBdFGB = -(-332.0d0 * Qij * &
27555        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
27556        -(332.0d0 * Qij *&
27557       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
27558        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
27559        dGGBdR = dGGBdFGB * dFGBdR
27560 !c!-------------------------------------------------------------------
27561 !c! Fisocav - isotropic cavity creation term
27562 !c! or "how much energy it costs to put charged head in water"
27563        pom = Rhead * csig
27564        top = al1 * (dsqrt(pom) + al2 * pom - al3)
27565        bot = (1.0d0 + al4 * pom**12.0d0)
27566        botsq = bot * bot
27567        FisoCav = top / bot
27568 !      write (*,*) "Rhead = ",Rhead
27569 !      write (*,*) "csig = ",csig
27570 !      write (*,*) "pom = ",pom
27571 !      write (*,*) "al1 = ",al1
27572 !      write (*,*) "al2 = ",al2
27573 !      write (*,*) "al3 = ",al3
27574 !      write (*,*) "al4 = ",al4
27575 !        write (*,*) "top = ",top
27576 !        write (*,*) "bot = ",bot
27577 !c! Derivative of Fisocav is GCV...
27578        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27579        dbot = 12.0d0 * al4 * pom ** 11.0d0
27580        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
27581 !c!-------------------------------------------------------------------
27582 !c! Epol
27583 !c! Polarization energy - charged heads polarize hydrophobic "neck"
27584        MomoFac1 = (1.0d0 - chi1 * sqom2)
27585        MomoFac2 = (1.0d0 - chi2 * sqom1)
27586        RR1  = ( R1 * R1 ) / MomoFac1
27587        RR2  = ( R2 * R2 ) / MomoFac2
27588        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27589        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27590        fgb1 = sqrt( RR1 + a12sq * ee1 )
27591        fgb2 = sqrt( RR2 + a12sq * ee2 )
27592        epol = 332.0d0 * eps_inout_fac * ( &
27593       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27594 !c!       epol = 0.0d0
27595        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27596              / (fgb1 ** 5.0d0)
27597        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27598              / (fgb2 ** 5.0d0)
27599        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
27600            / ( 2.0d0 * fgb1 )
27601        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
27602            / ( 2.0d0 * fgb2 )
27603        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
27604             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
27605        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
27606             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
27607        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27608 !c!       dPOLdR1 = 0.0d0
27609        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27610 !c!       dPOLdR2 = 0.0d0
27611        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27612 !c!       dPOLdOM1 = 0.0d0
27613        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27614 !c!       dPOLdOM2 = 0.0d0
27615 !c!-------------------------------------------------------------------
27616 !c! Elj
27617 !c! Lennard-Jones 6-12 interaction between heads
27618        pom = (pis / Rhead)**6.0d0
27619        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27620 !c! derivative of Elj is Glj
27621        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
27622            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27623 !c!-------------------------------------------------------------------
27624 !c! Return the results
27625 !c! These things do the dRdX derivatives, that is
27626 !c! allow us to change what we see from function that changes with
27627 !c! distance to function that changes with LOCATION (of the interaction
27628 !c! site)
27629        DO k = 1, 3
27630       erhead(k) = Rhead_distance(k)/Rhead
27631       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27632       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27633        END DO
27634
27635        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27636        erdxj = scalar( erhead(1), dC_norm(1,j) )
27637        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27638        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
27639        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27640        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27641        facd1 = d1 * vbld_inv(i+nres)
27642        facd2 = d2 * vbld_inv(j)
27643        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27644        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
27645
27646 !c! Now we add appropriate partial derivatives (one in each dimension)
27647        DO k = 1, 3
27648       hawk   = (erhead_tail(k,1) + &
27649       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
27650       condor = (erhead_tail(k,2) + &
27651       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27652
27653       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27654       gradpepcatx(k,i) = gradpepcatx(k,i) &
27655               - dGCLdR * pom&
27656               - dGGBdR * pom&
27657               - dGCVdR * pom&
27658               - dPOLdR1 * hawk&
27659               - dPOLdR2 * (erhead_tail(k,2)&
27660       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27661               - dGLJdR * pom
27662
27663       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27664 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
27665 !                   + dGGBdR * pom+ dGCVdR * pom&
27666 !                  + dPOLdR1 * (erhead_tail(k,1)&
27667 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
27668 !                  + dPOLdR2 * condor + dGLJdR * pom
27669
27670       gradpepcat(k,i) = gradpepcat(k,i)  &
27671               - dGCLdR * erhead(k)&
27672               - dGGBdR * erhead(k)&
27673               - dGCVdR * erhead(k)&
27674               - dPOLdR1 * erhead_tail(k,1)&
27675               - dPOLdR2 * erhead_tail(k,2)&
27676               - dGLJdR * erhead(k)
27677
27678       gradpepcat(k,j) = gradpepcat(k,j)         &
27679               + dGCLdR * erhead(k) &
27680               + dGGBdR * erhead(k) &
27681               + dGCVdR * erhead(k) &
27682               + dPOLdR1 * erhead_tail(k,1) &
27683               + dPOLdR2 * erhead_tail(k,2)&
27684               + dGLJdR * erhead(k)
27685
27686        END DO
27687        RETURN
27688       END SUBROUTINE eqq_cat
27689 !c!-------------------------------------------------------------------
27690       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
27691       use comm_momo
27692       use calc_data
27693
27694        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
27695        double precision ener(4)
27696        double precision dcosom1(3),dcosom2(3)
27697 !c! used in Epol derivatives
27698        double precision facd3, facd4
27699        double precision federmaus, adler
27700        integer istate,ii,jj
27701        real (kind=8) :: Fgb
27702 !       print *,"CALLING EQUAD"
27703 !c! Epol and Gpol analytical parameters
27704        alphapol1 = alphapol(itypi,itypj)
27705        alphapol2 = alphapol(itypj,itypi)
27706 !c! Fisocav and Gisocav analytical parameters
27707        al1  = alphiso(1,itypi,itypj)
27708        al2  = alphiso(2,itypi,itypj)
27709        al3  = alphiso(3,itypi,itypj)
27710        al4  = alphiso(4,itypi,itypj)
27711        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
27712           + sigiso2(itypi,itypj)**2.0d0))
27713 !c!
27714        w1   = wqdip(1,itypi,itypj)
27715        w2   = wqdip(2,itypi,itypj)
27716        pis  = sig0head(itypi,itypj)
27717        eps_head = epshead(itypi,itypj)
27718 !c! First things first:
27719 !c! We need to do sc_grad's job with GB and Fcav
27720        eom1  = eps2der * eps2rt_om1 &
27721            - 2.0D0 * alf1 * eps3der&
27722            + sigder * sigsq_om1&
27723            + dCAVdOM1
27724        eom2  = eps2der * eps2rt_om2 &
27725            + 2.0D0 * alf2 * eps3der&
27726            + sigder * sigsq_om2&
27727            + dCAVdOM2
27728        eom12 =  evdwij  * eps1_om12 &
27729            + eps2der * eps2rt_om12 &
27730            - 2.0D0 * alf12 * eps3der&
27731            + sigder *sigsq_om12&
27732            + dCAVdOM12
27733 !c! now some magical transformations to project gradient into
27734 !c! three cartesian vectors
27735        DO k = 1, 3
27736       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
27737       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27738       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
27739 !c! this acts on hydrophobic center of interaction
27740       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
27741               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
27742               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
27743       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
27744               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
27745               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
27746 !c! this acts on Calpha
27747       gvdwc(k,i)=gvdwc(k,i)-gg(k)
27748       gvdwc(k,j)=gvdwc(k,j)+gg(k)
27749        END DO
27750 !c! sc_grad is done, now we will compute
27751        eheadtail = 0.0d0
27752        eom1 = 0.0d0
27753        eom2 = 0.0d0
27754        eom12 = 0.0d0
27755        DO istate = 1, nstate(itypi,itypj)
27756 !c*************************************************************
27757       IF (istate.ne.1) THEN
27758        IF (istate.lt.3) THEN
27759         ii = 1
27760        ELSE
27761         ii = 2
27762        END IF
27763       jj = istate/ii
27764       d1 = dhead(1,ii,itypi,itypj)
27765       d2 = dhead(2,jj,itypi,itypj)
27766       do k=1,3
27767       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27768       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27769 ! distance
27770       enddo
27771        call to_box (chead(1,1),chead(2,1),chead(3,1))
27772        call to_box (chead(1,2),chead(2,2),chead(3,2))
27773
27774 !c! head distances will be themselves usefull elswhere
27775 !c1 (in Gcav, for example)
27776
27777        Rhead_distance(1)=boxshift(chead( 1, 2 ) - chead( 1,1 ),boxxsize)
27778        Rhead_distance(2)=boxshift(chead( 2, 2 ) - chead( 2,1 ),boxysize)
27779        Rhead_distance(3)=boxshift(chead( 3, 2 ) - chead( 3,1 ),boxzsize)
27780 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27781 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27782 !      Rhead_distance(k) = chead(k,2) - chead(k,1)
27783 !       END DO
27784 ! pitagoras (root of sum of squares)
27785        Rhead = dsqrt( &
27786         (Rhead_distance(1)*Rhead_distance(1)) &
27787       + (Rhead_distance(2)*Rhead_distance(2)) &
27788       + (Rhead_distance(3)*Rhead_distance(3)))
27789
27790 !      DO k = 1,3
27791 !       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27792 !       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27793 !       Rhead_distance(k) = chead(k,2) - chead(k,1)
27794 !      END DO
27795 !c! pitagoras (root of sum of squares)
27796 !      Rhead = dsqrt( &
27797 !             (Rhead_distance(1)*Rhead_distance(1))  &
27798 !           + (Rhead_distance(2)*Rhead_distance(2))  &
27799 !           + (Rhead_distance(3)*Rhead_distance(3)))
27800       END IF
27801       Rhead_sq = Rhead * Rhead
27802
27803 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27804 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27805       R1 = 0.0d0
27806       R2 = 0.0d0
27807       DO k = 1, 3
27808 !c! Calculate head-to-tail distances
27809        R1=R1+(ctail(k,2)-chead(k,1))**2
27810        R2=R2+(chead(k,2)-ctail(k,1))**2
27811       END DO
27812 !c! Pitagoras
27813       R1 = dsqrt(R1)
27814       R2 = dsqrt(R2)
27815       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
27816 !c!        Ecl = 0.0d0
27817 !c!        write (*,*) "Ecl = ", Ecl
27818 !c! derivative of Ecl is Gcl...
27819       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
27820 !c!        dGCLdR = 0.0d0
27821       dGCLdOM1 = 0.0d0
27822       dGCLdOM2 = 0.0d0
27823       dGCLdOM12 = 0.0d0
27824 !c!-------------------------------------------------------------------
27825 !c! Generalised Born Solvent Polarization
27826       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27827       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27828       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
27829 !c!        Egb = 0.0d0
27830 !c!      write (*,*) "a1*a2 = ", a12sq
27831 !c!      write (*,*) "Rhead = ", Rhead
27832 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
27833 !c!      write (*,*) "ee = ", ee
27834 !c!      write (*,*) "Fgb = ", Fgb
27835 !c!      write (*,*) "fac = ", eps_inout_fac
27836 !c!      write (*,*) "Qij = ", Qij
27837 !c!      write (*,*) "Egb = ", Egb
27838 !c! Derivative of Egb is Ggb...
27839 !c! dFGBdR is used by Quad's later...
27840       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
27841       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
27842              / ( 2.0d0 * Fgb )
27843       dGGBdR = dGGBdFGB * dFGBdR
27844 !c!        dGGBdR = 0.0d0
27845 !c!-------------------------------------------------------------------
27846 !c! Fisocav - isotropic cavity creation term
27847       pom = Rhead * csig
27848       top = al1 * (dsqrt(pom) + al2 * pom - al3)
27849       bot = (1.0d0 + al4 * pom**12.0d0)
27850       botsq = bot * bot
27851       FisoCav = top / bot
27852       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27853       dbot = 12.0d0 * al4 * pom ** 11.0d0
27854       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
27855 !c!        dGCVdR = 0.0d0
27856 !c!-------------------------------------------------------------------
27857 !c! Polarization energy
27858 !c! Epol
27859       MomoFac1 = (1.0d0 - chi1 * sqom2)
27860       MomoFac2 = (1.0d0 - chi2 * sqom1)
27861       RR1  = ( R1 * R1 ) / MomoFac1
27862       RR2  = ( R2 * R2 ) / MomoFac2
27863       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27864       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27865       fgb1 = sqrt( RR1 + a12sq * ee1 )
27866       fgb2 = sqrt( RR2 + a12sq * ee2 )
27867       epol = 332.0d0 * eps_inout_fac * (&
27868       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27869 !c!        epol = 0.0d0
27870 !c! derivative of Epol is Gpol...
27871       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27872               / (fgb1 ** 5.0d0)
27873       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27874               / (fgb2 ** 5.0d0)
27875       dFGBdR1 = ( (R1 / MomoFac1) &
27876             * ( 2.0d0 - (0.5d0 * ee1) ) )&
27877             / ( 2.0d0 * fgb1 )
27878       dFGBdR2 = ( (R2 / MomoFac2) &
27879             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27880             / ( 2.0d0 * fgb2 )
27881       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27882              * ( 2.0d0 - 0.5d0 * ee1) ) &
27883              / ( 2.0d0 * fgb1 )
27884       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27885              * ( 2.0d0 - 0.5d0 * ee2) ) &
27886              / ( 2.0d0 * fgb2 )
27887       dPOLdR1 = dPOLdFGB1 * dFGBdR1
27888 !c!        dPOLdR1 = 0.0d0
27889       dPOLdR2 = dPOLdFGB2 * dFGBdR2
27890 !c!        dPOLdR2 = 0.0d0
27891       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27892 !c!        dPOLdOM1 = 0.0d0
27893       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27894       pom = (pis / Rhead)**6.0d0
27895       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27896 !c!        Elj = 0.0d0
27897 !c! derivative of Elj is Glj
27898       dGLJdR = 4.0d0 * eps_head &
27899           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27900           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27901 !c!        dGLJdR = 0.0d0
27902 !c!-------------------------------------------------------------------
27903 !c! Equad
27904        IF (Wqd.ne.0.0d0) THEN
27905       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
27906            - 37.5d0  * ( sqom1 + sqom2 ) &
27907            + 157.5d0 * ( sqom1 * sqom2 ) &
27908            - 45.0d0  * om1*om2*om12
27909       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
27910       Equad = fac * Beta1
27911 !c!        Equad = 0.0d0
27912 !c! derivative of Equad...
27913       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
27914 !c!        dQUADdR = 0.0d0
27915       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
27916 !c!        dQUADdOM1 = 0.0d0
27917       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
27918 !c!        dQUADdOM2 = 0.0d0
27919       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
27920        ELSE
27921        Beta1 = 0.0d0
27922        Equad = 0.0d0
27923       END IF
27924 !c!-------------------------------------------------------------------
27925 !c! Return the results
27926 !c! Angular stuff
27927       eom1 = dPOLdOM1 + dQUADdOM1
27928       eom2 = dPOLdOM2 + dQUADdOM2
27929       eom12 = dQUADdOM12
27930 !c! now some magical transformations to project gradient into
27931 !c! three cartesian vectors
27932       DO k = 1, 3
27933        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
27934        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27935        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
27936       END DO
27937 !c! Radial stuff
27938       DO k = 1, 3
27939        erhead(k) = Rhead_distance(k)/Rhead
27940        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27941        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27942       END DO
27943       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27944       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27945       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27946       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27947       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27948       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27949       facd1 = d1 * vbld_inv(i+nres)
27950       facd2 = d2 * vbld_inv(j+nres)
27951       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27952       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27953       DO k = 1, 3
27954        hawk   = erhead_tail(k,1) + &
27955        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
27956        condor = erhead_tail(k,2) + &
27957        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
27958
27959        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27960 !c! this acts on hydrophobic center of interaction
27961        gheadtail(k,1,1) = gheadtail(k,1,1) &
27962                    - dGCLdR * pom &
27963                    - dGGBdR * pom &
27964                    - dGCVdR * pom &
27965                    - dPOLdR1 * hawk &
27966                    - dPOLdR2 * (erhead_tail(k,2) &
27967       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27968                    - dGLJdR * pom &
27969                    - dQUADdR * pom&
27970                    - tuna(k) &
27971              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
27972              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
27973
27974        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27975 !c! this acts on hydrophobic center of interaction
27976        gheadtail(k,2,1) = gheadtail(k,2,1)  &
27977                    + dGCLdR * pom      &
27978                    + dGGBdR * pom      &
27979                    + dGCVdR * pom      &
27980                    + dPOLdR1 * (erhead_tail(k,1) &
27981       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27982                    + dPOLdR2 * condor &
27983                    + dGLJdR * pom &
27984                    + dQUADdR * pom &
27985                    + tuna(k) &
27986              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
27987              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
27988
27989 !c! this acts on Calpha
27990        gheadtail(k,3,1) = gheadtail(k,3,1)  &
27991                    - dGCLdR * erhead(k)&
27992                    - dGGBdR * erhead(k)&
27993                    - dGCVdR * erhead(k)&
27994                    - dPOLdR1 * erhead_tail(k,1)&
27995                    - dPOLdR2 * erhead_tail(k,2)&
27996                    - dGLJdR * erhead(k) &
27997                    - dQUADdR * erhead(k)&
27998                    - tuna(k)
27999 !c! this acts on Calpha
28000        gheadtail(k,4,1) = gheadtail(k,4,1)   &
28001                     + dGCLdR * erhead(k) &
28002                     + dGGBdR * erhead(k) &
28003                     + dGCVdR * erhead(k) &
28004                     + dPOLdR1 * erhead_tail(k,1) &
28005                     + dPOLdR2 * erhead_tail(k,2) &
28006                     + dGLJdR * erhead(k) &
28007                     + dQUADdR * erhead(k)&
28008                     + tuna(k)
28009       END DO
28010       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
28011       eheadtail = eheadtail &
28012               + wstate(istate, itypi, itypj) &
28013               * dexp(-betaT * ener(istate))
28014 !c! foreach cartesian dimension
28015       DO k = 1, 3
28016 !c! foreach of two gvdwx and gvdwc
28017        DO l = 1, 4
28018         gheadtail(k,l,2) = gheadtail(k,l,2)  &
28019                      + wstate( istate, itypi, itypj ) &
28020                      * dexp(-betaT * ener(istate)) &
28021                      * gheadtail(k,l,1)
28022         gheadtail(k,l,1) = 0.0d0
28023        END DO
28024       END DO
28025        END DO
28026 !c! Here ended the gigantic DO istate = 1, 4, which starts
28027 !c! at the beggining of the subroutine
28028
28029        DO k = 1, 3
28030       DO l = 1, 4
28031        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
28032       END DO
28033       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
28034       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
28035       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
28036       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
28037       DO l = 1, 4
28038        gheadtail(k,l,1) = 0.0d0
28039        gheadtail(k,l,2) = 0.0d0
28040       END DO
28041        END DO
28042        eheadtail = (-dlog(eheadtail)) / betaT
28043        dPOLdOM1 = 0.0d0
28044        dPOLdOM2 = 0.0d0
28045        dQUADdOM1 = 0.0d0
28046        dQUADdOM2 = 0.0d0
28047        dQUADdOM12 = 0.0d0
28048        RETURN
28049       END SUBROUTINE energy_quad
28050 !!-----------------------------------------------------------
28051       SUBROUTINE eqn(Epol)
28052       use comm_momo
28053       use calc_data
28054
28055       double precision  facd4, federmaus,epol
28056       alphapol1 = alphapol(itypi,itypj)
28057 !c! R1 - distance between head of ith side chain and tail of jth sidechain
28058        R1 = 0.0d0
28059        DO k = 1, 3
28060 !c! Calculate head-to-tail distances
28061       R1=R1+(ctail(k,2)-chead(k,1))**2
28062        END DO
28063 !c! Pitagoras
28064        R1 = dsqrt(R1)
28065
28066 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28067 !c!     &        +dhead(1,1,itypi,itypj))**2))
28068 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28069 !c!     &        +dhead(2,1,itypi,itypj))**2))
28070 !c--------------------------------------------------------------------
28071 !c Polarization energy
28072 !c Epol
28073        MomoFac1 = (1.0d0 - chi1 * sqom2)
28074        RR1  = R1 * R1 / MomoFac1
28075        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
28076        fgb1 = sqrt( RR1 + a12sq * ee1)
28077        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
28078        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
28079              / (fgb1 ** 5.0d0)
28080        dFGBdR1 = ( (R1 / MomoFac1) &
28081             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
28082             / ( 2.0d0 * fgb1 )
28083        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
28084             * (2.0d0 - 0.5d0 * ee1) ) &
28085             / (2.0d0 * fgb1)
28086        dPOLdR1 = dPOLdFGB1 * dFGBdR1
28087 !c!       dPOLdR1 = 0.0d0
28088        dPOLdOM1 = 0.0d0
28089        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
28090        DO k = 1, 3
28091       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
28092        END DO
28093        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
28094        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
28095        facd1 = d1 * vbld_inv(i+nres)
28096        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
28097
28098        DO k = 1, 3
28099       hawk = (erhead_tail(k,1) + &
28100       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
28101
28102       gvdwx(k,i) = gvdwx(k,i) &
28103                - dPOLdR1 * hawk
28104       gvdwx(k,j) = gvdwx(k,j) &
28105                + dPOLdR1 * (erhead_tail(k,1) &
28106        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
28107
28108       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
28109       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
28110
28111        END DO
28112        RETURN
28113       END SUBROUTINE eqn
28114       SUBROUTINE enq(Epol)
28115       use calc_data
28116       use comm_momo
28117        double precision facd3, adler,epol
28118        alphapol2 = alphapol(itypj,itypi)
28119 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28120        R2 = 0.0d0
28121        DO k = 1, 3
28122 !c! Calculate head-to-tail distances
28123       R2=R2+(chead(k,2)-ctail(k,1))**2
28124        END DO
28125 !c! Pitagoras
28126        R2 = dsqrt(R2)
28127
28128 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28129 !c!     &        +dhead(1,1,itypi,itypj))**2))
28130 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28131 !c!     &        +dhead(2,1,itypi,itypj))**2))
28132 !c------------------------------------------------------------------------
28133 !c Polarization energy
28134        MomoFac2 = (1.0d0 - chi2 * sqom1)
28135        RR2  = R2 * R2 / MomoFac2
28136        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28137        fgb2 = sqrt(RR2  + a12sq * ee2)
28138        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28139        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28140             / (fgb2 ** 5.0d0)
28141        dFGBdR2 = ( (R2 / MomoFac2)  &
28142             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28143             / (2.0d0 * fgb2)
28144        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28145             * (2.0d0 - 0.5d0 * ee2) ) &
28146             / (2.0d0 * fgb2)
28147        dPOLdR2 = dPOLdFGB2 * dFGBdR2
28148 !c!       dPOLdR2 = 0.0d0
28149        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28150 !c!       dPOLdOM1 = 0.0d0
28151        dPOLdOM2 = 0.0d0
28152 !c!-------------------------------------------------------------------
28153 !c! Return the results
28154 !c! (See comments in Eqq)
28155        DO k = 1, 3
28156       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28157        END DO
28158        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
28159        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28160        facd2 = d2 * vbld_inv(j+nres)
28161        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
28162        DO k = 1, 3
28163       condor = (erhead_tail(k,2) &
28164        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
28165
28166       gvdwx(k,i) = gvdwx(k,i) &
28167                - dPOLdR2 * (erhead_tail(k,2) &
28168        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
28169       gvdwx(k,j) = gvdwx(k,j)   &
28170                + dPOLdR2 * condor
28171
28172       gvdwc(k,i) = gvdwc(k,i) &
28173                - dPOLdR2 * erhead_tail(k,2)
28174       gvdwc(k,j) = gvdwc(k,j) &
28175                + dPOLdR2 * erhead_tail(k,2)
28176
28177        END DO
28178       RETURN
28179       END SUBROUTINE enq
28180
28181       SUBROUTINE enq_cat(Epol)
28182       use calc_data
28183       use comm_momo
28184        double precision facd3, adler,epol
28185        alphapol2 = alphapolcat(itypi,itypj)
28186 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28187        R2 = 0.0d0
28188        DO k = 1, 3
28189 !c! Calculate head-to-tail distances
28190       R2=R2+(chead(k,2)-ctail(k,1))**2
28191        END DO
28192 !c! Pitagoras
28193        R2 = dsqrt(R2)
28194
28195 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28196 !c!     &        +dhead(1,1,itypi,itypj))**2))
28197 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28198 !c!     &        +dhead(2,1,itypi,itypj))**2))
28199 !c------------------------------------------------------------------------
28200 !c Polarization energy
28201        MomoFac2 = (1.0d0 - chi2 * sqom1)
28202        RR2  = R2 * R2 / MomoFac2
28203        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28204        fgb2 = sqrt(RR2  + a12sq * ee2)
28205        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28206        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28207             / (fgb2 ** 5.0d0)
28208        dFGBdR2 = ( (R2 / MomoFac2)  &
28209             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28210             / (2.0d0 * fgb2)
28211        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28212             * (2.0d0 - 0.5d0 * ee2) ) &
28213             / (2.0d0 * fgb2)
28214        dPOLdR2 = dPOLdFGB2 * dFGBdR2
28215 !c!       dPOLdR2 = 0.0d0
28216        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28217 !c!       dPOLdOM1 = 0.0d0
28218        dPOLdOM2 = 0.0d0
28219
28220 !c!-------------------------------------------------------------------
28221 !c! Return the results
28222 !c! (See comments in Eqq)
28223        DO k = 1, 3
28224       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28225        END DO
28226        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
28227        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28228        facd2 = d2 * vbld_inv(j+nres)
28229        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
28230        DO k = 1, 3
28231       condor = (erhead_tail(k,2) &
28232        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
28233
28234       gradpepcatx(k,i) = gradpepcatx(k,i) &
28235                - dPOLdR2 * (erhead_tail(k,2) &
28236        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
28237 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
28238 !                   + dPOLdR2 * condor
28239
28240       gradpepcat(k,i) = gradpepcat(k,i) &
28241                - dPOLdR2 * erhead_tail(k,2)
28242       gradpepcat(k,j) = gradpepcat(k,j) &
28243                + dPOLdR2 * erhead_tail(k,2)
28244
28245        END DO
28246       RETURN
28247       END SUBROUTINE enq_cat
28248
28249       SUBROUTINE eqd(Ecl,Elj,Epol)
28250       use calc_data
28251       use comm_momo
28252        double precision  facd4, federmaus,ecl,elj,epol
28253        alphapol1 = alphapol(itypi,itypj)
28254        w1        = wqdip(1,itypi,itypj)
28255        w2        = wqdip(2,itypi,itypj)
28256        pis       = sig0head(itypi,itypj)
28257        eps_head   = epshead(itypi,itypj)
28258 !c!-------------------------------------------------------------------
28259 !c! R1 - distance between head of ith side chain and tail of jth sidechain
28260        R1 = 0.0d0
28261        DO k = 1, 3
28262 !c! Calculate head-to-tail distances
28263       R1=R1+(ctail(k,2)-chead(k,1))**2
28264        END DO
28265 !c! Pitagoras
28266        R1 = dsqrt(R1)
28267
28268 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28269 !c!     &        +dhead(1,1,itypi,itypj))**2))
28270 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28271 !c!     &        +dhead(2,1,itypi,itypj))**2))
28272
28273 !c!-------------------------------------------------------------------
28274 !c! ecl
28275        sparrow  = w1 * Qi * om1
28276        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
28277        Ecl = sparrow / Rhead**2.0d0 &
28278          - hawk    / Rhead**4.0d0
28279        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
28280              + 4.0d0 * hawk    / Rhead**5.0d0
28281 !c! dF/dom1
28282        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
28283 !c! dF/dom2
28284        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
28285 !c--------------------------------------------------------------------
28286 !c Polarization energy
28287 !c Epol
28288        MomoFac1 = (1.0d0 - chi1 * sqom2)
28289        RR1  = R1 * R1 / MomoFac1
28290        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
28291        fgb1 = sqrt( RR1 + a12sq * ee1)
28292        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
28293 !c!       epol = 0.0d0
28294 !c!------------------------------------------------------------------
28295 !c! derivative of Epol is Gpol...
28296        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
28297              / (fgb1 ** 5.0d0)
28298        dFGBdR1 = ( (R1 / MomoFac1)  &
28299            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
28300            / ( 2.0d0 * fgb1 )
28301        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
28302              * (2.0d0 - 0.5d0 * ee1) ) &
28303              / (2.0d0 * fgb1)
28304        dPOLdR1 = dPOLdFGB1 * dFGBdR1
28305 !c!       dPOLdR1 = 0.0d0
28306        dPOLdOM1 = 0.0d0
28307        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
28308 !c!       dPOLdOM2 = 0.0d0
28309 !c!-------------------------------------------------------------------
28310 !c! Elj
28311        pom = (pis / Rhead)**6.0d0
28312        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28313 !c! derivative of Elj is Glj
28314        dGLJdR = 4.0d0 * eps_head &
28315         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28316         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
28317        DO k = 1, 3
28318       erhead(k) = Rhead_distance(k)/Rhead
28319       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
28320        END DO
28321
28322        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28323        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
28324        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
28325        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
28326        facd1 = d1 * vbld_inv(i+nres)
28327        facd2 = d2 * vbld_inv(j+nres)
28328        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
28329
28330        DO k = 1, 3
28331       hawk = (erhead_tail(k,1) +  &
28332       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
28333
28334       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28335       gvdwx(k,i) = gvdwx(k,i)  &
28336                - dGCLdR * pom&
28337                - dPOLdR1 * hawk &
28338                - dGLJdR * pom
28339
28340       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28341       gvdwx(k,j) = gvdwx(k,j)    &
28342                + dGCLdR * pom  &
28343                + dPOLdR1 * (erhead_tail(k,1) &
28344        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
28345                + dGLJdR * pom
28346
28347
28348       gvdwc(k,i) = gvdwc(k,i)          &
28349                - dGCLdR * erhead(k)  &
28350                - dPOLdR1 * erhead_tail(k,1) &
28351                - dGLJdR * erhead(k)
28352
28353       gvdwc(k,j) = gvdwc(k,j)          &
28354                + dGCLdR * erhead(k)  &
28355                + dPOLdR1 * erhead_tail(k,1) &
28356                + dGLJdR * erhead(k)
28357
28358        END DO
28359        RETURN
28360       END SUBROUTINE eqd
28361       SUBROUTINE edq(Ecl,Elj,Epol)
28362 !       IMPLICIT NONE
28363        use comm_momo
28364       use calc_data
28365
28366       double precision  facd3, adler,ecl,elj,epol
28367        alphapol2 = alphapol(itypj,itypi)
28368        w1        = wqdip(1,itypi,itypj)
28369        w2        = wqdip(2,itypi,itypj)
28370        pis       = sig0head(itypi,itypj)
28371        eps_head  = epshead(itypi,itypj)
28372 !c!-------------------------------------------------------------------
28373 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28374        R2 = 0.0d0
28375        DO k = 1, 3
28376 !c! Calculate head-to-tail distances
28377       R2=R2+(chead(k,2)-ctail(k,1))**2
28378        END DO
28379 !c! Pitagoras
28380        R2 = dsqrt(R2)
28381
28382 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28383 !c!     &        +dhead(1,1,itypi,itypj))**2))
28384 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28385 !c!     &        +dhead(2,1,itypi,itypj))**2))
28386
28387
28388 !c!-------------------------------------------------------------------
28389 !c! ecl
28390        sparrow  = w1 * Qj * om1
28391        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
28392        ECL = sparrow / Rhead**2.0d0 &
28393          - hawk    / Rhead**4.0d0
28394 !c!-------------------------------------------------------------------
28395 !c! derivative of ecl is Gcl
28396 !c! dF/dr part
28397        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
28398              + 4.0d0 * hawk    / Rhead**5.0d0
28399 !c! dF/dom1
28400        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
28401 !c! dF/dom2
28402        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
28403 !c--------------------------------------------------------------------
28404 !c Polarization energy
28405 !c Epol
28406        MomoFac2 = (1.0d0 - chi2 * sqom1)
28407        RR2  = R2 * R2 / MomoFac2
28408        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28409        fgb2 = sqrt(RR2  + a12sq * ee2)
28410        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28411        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28412              / (fgb2 ** 5.0d0)
28413        dFGBdR2 = ( (R2 / MomoFac2)  &
28414              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28415              / (2.0d0 * fgb2)
28416        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28417             * (2.0d0 - 0.5d0 * ee2) ) &
28418             / (2.0d0 * fgb2)
28419        dPOLdR2 = dPOLdFGB2 * dFGBdR2
28420 !c!       dPOLdR2 = 0.0d0
28421        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28422 !c!       dPOLdOM1 = 0.0d0
28423        dPOLdOM2 = 0.0d0
28424 !c!-------------------------------------------------------------------
28425 !c! Elj
28426        pom = (pis / Rhead)**6.0d0
28427        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28428 !c! derivative of Elj is Glj
28429        dGLJdR = 4.0d0 * eps_head &
28430          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28431          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
28432 !c!-------------------------------------------------------------------
28433 !c! Return the results
28434 !c! (see comments in Eqq)
28435        DO k = 1, 3
28436       erhead(k) = Rhead_distance(k)/Rhead
28437       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28438        END DO
28439        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28440        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
28441        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
28442        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28443        facd1 = d1 * vbld_inv(i+nres)
28444        facd2 = d2 * vbld_inv(j+nres)
28445        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
28446        DO k = 1, 3
28447       condor = (erhead_tail(k,2) &
28448        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
28449
28450       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28451       gvdwx(k,i) = gvdwx(k,i) &
28452               - dGCLdR * pom &
28453               - dPOLdR2 * (erhead_tail(k,2) &
28454        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
28455               - dGLJdR * pom
28456
28457       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28458       gvdwx(k,j) = gvdwx(k,j) &
28459               + dGCLdR * pom &
28460               + dPOLdR2 * condor &
28461               + dGLJdR * pom
28462
28463
28464       gvdwc(k,i) = gvdwc(k,i) &
28465               - dGCLdR * erhead(k) &
28466               - dPOLdR2 * erhead_tail(k,2) &
28467               - dGLJdR * erhead(k)
28468
28469       gvdwc(k,j) = gvdwc(k,j) &
28470               + dGCLdR * erhead(k) &
28471               + dPOLdR2 * erhead_tail(k,2) &
28472               + dGLJdR * erhead(k)
28473
28474        END DO
28475        RETURN
28476       END SUBROUTINE edq
28477
28478       SUBROUTINE edq_cat(Ecl,Elj,Epol)
28479       use comm_momo
28480       use calc_data
28481
28482       double precision  facd3, adler,ecl,elj,epol
28483        alphapol2 = alphapolcat(itypi,itypj)
28484        w1        = wqdipcat(1,itypi,itypj)
28485        w2        = wqdipcat(2,itypi,itypj)
28486        pis       = sig0headcat(itypi,itypj)
28487        eps_head  = epsheadcat(itypi,itypj)
28488 !c!-------------------------------------------------------------------
28489 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28490        R2 = 0.0d0
28491        DO k = 1, 3
28492 !c! Calculate head-to-tail distances
28493       R2=R2+(chead(k,2)-ctail(k,1))**2
28494        END DO
28495 !c! Pitagoras
28496        R2 = dsqrt(R2)
28497
28498 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28499 !c!     &        +dhead(1,1,itypi,itypj))**2))
28500 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28501 !c!     &        +dhead(2,1,itypi,itypj))**2))
28502
28503
28504 !c!-------------------------------------------------------------------
28505 !c! ecl
28506 !       write(iout,*) "KURWA2",Rhead
28507        sparrow  = w1 * Qj * om1
28508        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
28509        ECL = sparrow / Rhead**2.0d0 &
28510          - hawk    / Rhead**4.0d0
28511 !c!-------------------------------------------------------------------
28512 !c! derivative of ecl is Gcl
28513 !c! dF/dr part
28514        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
28515              + 4.0d0 * hawk    / Rhead**5.0d0
28516 !c! dF/dom1
28517        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
28518 !c! dF/dom2
28519        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
28520 !c--------------------------------------------------------------------
28521 !c--------------------------------------------------------------------
28522 !c Polarization energy
28523 !c Epol
28524        MomoFac2 = (1.0d0 - chi2 * sqom1)
28525        RR2  = R2 * R2 / MomoFac2
28526        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28527        fgb2 = sqrt(RR2  + a12sq * ee2)
28528        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28529        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28530              / (fgb2 ** 5.0d0)
28531        dFGBdR2 = ( (R2 / MomoFac2)  &
28532              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28533              / (2.0d0 * fgb2)
28534        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28535             * (2.0d0 - 0.5d0 * ee2) ) &
28536             / (2.0d0 * fgb2)
28537        dPOLdR2 = dPOLdFGB2 * dFGBdR2
28538 !c!       dPOLdR2 = 0.0d0
28539        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28540 !c!       dPOLdOM1 = 0.0d0
28541        dPOLdOM2 = 0.0d0
28542 !c!-------------------------------------------------------------------
28543 !c! Elj
28544        pom = (pis / Rhead)**6.0d0
28545        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28546 !c! derivative of Elj is Glj
28547        dGLJdR = 4.0d0 * eps_head &
28548          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28549          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
28550 !c!-------------------------------------------------------------------
28551
28552 !c! Return the results
28553 !c! (see comments in Eqq)
28554        DO k = 1, 3
28555       erhead(k) = Rhead_distance(k)/Rhead
28556       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28557        END DO
28558        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28559        erdxj = scalar( erhead(1), dC_norm(1,j) )
28560        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
28561        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28562        facd1 = d1 * vbld_inv(i+nres)
28563        facd2 = d2 * vbld_inv(j)
28564        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
28565        DO k = 1, 3
28566       condor = (erhead_tail(k,2) &
28567        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
28568
28569       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28570       gradpepcatx(k,i) = gradpepcatx(k,i) &
28571               - dGCLdR * pom &
28572               - dPOLdR2 * (erhead_tail(k,2) &
28573        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
28574               - dGLJdR * pom
28575
28576       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
28577 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
28578 !                  + dGCLdR * pom &
28579 !                  + dPOLdR2 * condor &
28580 !                  + dGLJdR * pom
28581
28582
28583       gradpepcat(k,i) = gradpepcat(k,i) &
28584               - dGCLdR * erhead(k) &
28585               - dPOLdR2 * erhead_tail(k,2) &
28586               - dGLJdR * erhead(k)
28587
28588       gradpepcat(k,j) = gradpepcat(k,j) &
28589               + dGCLdR * erhead(k) &
28590               + dPOLdR2 * erhead_tail(k,2) &
28591               + dGLJdR * erhead(k)
28592
28593        END DO
28594        RETURN
28595       END SUBROUTINE edq_cat
28596
28597       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
28598       use comm_momo
28599       use calc_data
28600
28601       double precision  facd3, adler,ecl,elj,epol
28602        alphapol2 = alphapolcat(itypi,itypj)
28603        w1        = wqdipcat(1,itypi,itypj)
28604        w2        = wqdipcat(2,itypi,itypj)
28605        pis       = sig0headcat(itypi,itypj)
28606        eps_head  = epsheadcat(itypi,itypj)
28607 !c!-------------------------------------------------------------------
28608 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28609        R2 = 0.0d0
28610        DO k = 1, 3
28611 !c! Calculate head-to-tail distances
28612       R2=R2+(chead(k,2)-ctail(k,1))**2
28613        END DO
28614 !c! Pitagoras
28615        R2 = dsqrt(R2)
28616
28617 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28618 !c!     &        +dhead(1,1,itypi,itypj))**2))
28619 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28620 !c!     &        +dhead(2,1,itypi,itypj))**2))
28621
28622
28623 !c!-------------------------------------------------------------------
28624 !c! ecl
28625        sparrow  = w1 * Qj * om1
28626        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
28627 !       print *,"CO2", itypi,itypj
28628 !       print *,"CO?!.", w1,w2,Qj,om1
28629        ECL = sparrow / Rhead**2.0d0 &
28630          - hawk    / Rhead**4.0d0
28631 !c!-------------------------------------------------------------------
28632 !c! derivative of ecl is Gcl
28633 !c! dF/dr part
28634        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
28635              + 4.0d0 * hawk    / Rhead**5.0d0
28636 !c! dF/dom1
28637        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
28638 !c! dF/dom2
28639        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
28640 !c--------------------------------------------------------------------
28641 !c--------------------------------------------------------------------
28642 !c Polarization energy
28643 !c Epol
28644        MomoFac2 = (1.0d0 - chi2 * sqom1)
28645        RR2  = R2 * R2 / MomoFac2
28646        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28647        fgb2 = sqrt(RR2  + a12sq * ee2)
28648        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28649        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28650              / (fgb2 ** 5.0d0)
28651        dFGBdR2 = ( (R2 / MomoFac2)  &
28652              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28653              / (2.0d0 * fgb2)
28654        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28655             * (2.0d0 - 0.5d0 * ee2) ) &
28656             / (2.0d0 * fgb2)
28657        dPOLdR2 = dPOLdFGB2 * dFGBdR2
28658 !c!       dPOLdR2 = 0.0d0
28659        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28660 !c!       dPOLdOM1 = 0.0d0
28661        dPOLdOM2 = 0.0d0
28662 !c!-------------------------------------------------------------------
28663 !c! Elj
28664        pom = (pis / Rhead)**6.0d0
28665        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28666 !c! derivative of Elj is Glj
28667        dGLJdR = 4.0d0 * eps_head &
28668          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28669          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
28670 !c!-------------------------------------------------------------------
28671
28672 !c! Return the results
28673 !c! (see comments in Eqq)
28674        DO k = 1, 3
28675       erhead(k) = Rhead_distance(k)/Rhead
28676       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28677        END DO
28678        erdxi = scalar( erhead(1), dC_norm(1,i) )
28679        erdxj = scalar( erhead(1), dC_norm(1,j) )
28680        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
28681        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
28682        facd1 = d1 * vbld_inv(i+1)/2.0
28683        facd2 = d2 * vbld_inv(j)
28684        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
28685        DO k = 1, 3
28686       condor = (erhead_tail(k,2) &
28687        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
28688
28689       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
28690 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
28691 !                  - dGCLdR * pom &
28692 !                  - dPOLdR2 * (erhead_tail(k,2) &
28693 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
28694 !                  - dGLJdR * pom
28695
28696       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
28697 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
28698 !                  + dGCLdR * pom &
28699 !                  + dPOLdR2 * condor &
28700 !                  + dGLJdR * pom
28701
28702
28703       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
28704               - dGCLdR * erhead(k) &
28705               - dPOLdR2 * erhead_tail(k,2) &
28706               - dGLJdR * erhead(k))
28707       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
28708               - dGCLdR * erhead(k) &
28709               - dPOLdR2 * erhead_tail(k,2) &
28710               - dGLJdR * erhead(k))
28711
28712
28713       gradpepcat(k,j) = gradpepcat(k,j) &
28714               + dGCLdR * erhead(k) &
28715               + dPOLdR2 * erhead_tail(k,2) &
28716               + dGLJdR * erhead(k)
28717
28718        END DO
28719        RETURN
28720       END SUBROUTINE edq_cat_pep
28721
28722       SUBROUTINE edd(ECL)
28723 !       IMPLICIT NONE
28724        use comm_momo
28725       use calc_data
28726
28727        double precision ecl
28728 !c!       csig = sigiso(itypi,itypj)
28729        w1 = wqdip(1,itypi,itypj)
28730        w2 = wqdip(2,itypi,itypj)
28731 !c!-------------------------------------------------------------------
28732 !c! ECL
28733        fac = (om12 - 3.0d0 * om1 * om2)
28734        c1 = (w1 / (Rhead**3.0d0)) * fac
28735        c2 = (w2 / Rhead ** 6.0d0) &
28736         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
28737        ECL = c1 - c2
28738 !c!       write (*,*) "w1 = ", w1
28739 !c!       write (*,*) "w2 = ", w2
28740 !c!       write (*,*) "om1 = ", om1
28741 !c!       write (*,*) "om2 = ", om2
28742 !c!       write (*,*) "om12 = ", om12
28743 !c!       write (*,*) "fac = ", fac
28744 !c!       write (*,*) "c1 = ", c1
28745 !c!       write (*,*) "c2 = ", c2
28746 !c!       write (*,*) "Ecl = ", Ecl
28747 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
28748 !c!       write (*,*) "c2_2 = ",
28749 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
28750 !c!-------------------------------------------------------------------
28751 !c! dervative of ECL is GCL...
28752 !c! dECL/dr
28753        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
28754        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
28755         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
28756        dGCLdR = c1 - c2
28757 !c! dECL/dom1
28758        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
28759        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
28760         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
28761        dGCLdOM1 = c1 - c2
28762 !c! dECL/dom2
28763        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
28764        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
28765         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
28766        dGCLdOM2 = c1 - c2
28767 !c! dECL/dom12
28768        c1 = w1 / (Rhead ** 3.0d0)
28769        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
28770        dGCLdOM12 = c1 - c2
28771 !c!-------------------------------------------------------------------
28772 !c! Return the results
28773 !c! (see comments in Eqq)
28774        DO k= 1, 3
28775       erhead(k) = Rhead_distance(k)/Rhead
28776        END DO
28777        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28778        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
28779        facd1 = d1 * vbld_inv(i+nres)
28780        facd2 = d2 * vbld_inv(j+nres)
28781        DO k = 1, 3
28782
28783       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28784       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
28785       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28786       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
28787
28788       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
28789       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
28790        END DO
28791        RETURN
28792       END SUBROUTINE edd
28793       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28794 !       IMPLICIT NONE
28795        use comm_momo
28796       use calc_data
28797
28798        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28799        eps_out=80.0d0
28800        itypi = itype(i,1)
28801        itypj = itype(j,1)
28802 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28803 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28804 !c!       t_bath = 300
28805 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28806        Rb=0.001986d0
28807        BetaT = 1.0d0 / (298.0d0 * Rb)
28808 !c! Gay-berne var's
28809        sig0ij = sigma( itypi,itypj )
28810        chi1   = chi( itypi, itypj )
28811        chi2   = chi( itypj, itypi )
28812        chi12  = chi1 * chi2
28813        chip1  = chipp( itypi, itypj )
28814        chip2  = chipp( itypj, itypi )
28815        chip12 = chip1 * chip2
28816 !       chi1=0.0
28817 !       chi2=0.0
28818 !       chi12=0.0
28819 !       chip1=0.0
28820 !       chip2=0.0
28821 !       chip12=0.0
28822 !c! not used by momo potential, but needed by sc_angular which is shared
28823 !c! by all energy_potential subroutines
28824        alf1   = 0.0d0
28825        alf2   = 0.0d0
28826        alf12  = 0.0d0
28827 !c! location, location, location
28828 !       xj  = c( 1, nres+j ) - xi
28829 !       yj  = c( 2, nres+j ) - yi
28830 !       zj  = c( 3, nres+j ) - zi
28831        dxj = dc_norm( 1, nres+j )
28832        dyj = dc_norm( 2, nres+j )
28833        dzj = dc_norm( 3, nres+j )
28834 !c! distance from center of chain(?) to polar/charged head
28835 !c!       write (*,*) "istate = ", 1
28836 !c!       write (*,*) "ii = ", 1
28837 !c!       write (*,*) "jj = ", 1
28838        d1 = dhead(1, 1, itypi, itypj)
28839        d2 = dhead(2, 1, itypi, itypj)
28840 !c! ai*aj from Fgb
28841        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
28842 !c!       a12sq = a12sq * a12sq
28843 !c! charge of amino acid itypi is...
28844        Qi  = icharge(itypi)
28845        Qj  = icharge(itypj)
28846        Qij = Qi * Qj
28847 !c! chis1,2,12
28848        chis1 = chis(itypi,itypj)
28849        chis2 = chis(itypj,itypi)
28850        chis12 = chis1 * chis2
28851        sig1 = sigmap1(itypi,itypj)
28852        sig2 = sigmap2(itypi,itypj)
28853 !c!       write (*,*) "sig1 = ", sig1
28854 !c!       write (*,*) "sig2 = ", sig2
28855 !c! alpha factors from Fcav/Gcav
28856        b1cav = alphasur(1,itypi,itypj)
28857 !       b1cav=0.0
28858        b2cav = alphasur(2,itypi,itypj)
28859        b3cav = alphasur(3,itypi,itypj)
28860        b4cav = alphasur(4,itypi,itypj)
28861        wqd = wquad(itypi, itypj)
28862 !c! used by Fgb
28863        eps_in = epsintab(itypi,itypj)
28864        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28865 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
28866 !c!-------------------------------------------------------------------
28867 !c! tail location and distance calculations
28868        Rtail = 0.0d0
28869        DO k = 1, 3
28870       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
28871       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
28872        END DO
28873 !c! tail distances will be themselves usefull elswhere
28874 !c1 (in Gcav, for example)
28875        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28876        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28877        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28878        Rtail = dsqrt(  &
28879         (Rtail_distance(1)*Rtail_distance(1))  &
28880       + (Rtail_distance(2)*Rtail_distance(2))  &
28881       + (Rtail_distance(3)*Rtail_distance(3)))
28882 !c!-------------------------------------------------------------------
28883 !c! Calculate location and distance between polar heads
28884 !c! distance between heads
28885 !c! for each one of our three dimensional space...
28886        d1 = dhead(1, 1, itypi, itypj)
28887        d2 = dhead(2, 1, itypi, itypj)
28888
28889        DO k = 1,3
28890 !c! location of polar head is computed by taking hydrophobic centre
28891 !c! and moving by a d1 * dc_norm vector
28892 !c! see unres publications for very informative images
28893       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28894       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
28895 !c! distance
28896 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28897 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28898       Rhead_distance(k) = chead(k,2) - chead(k,1)
28899        END DO
28900 !c! pitagoras (root of sum of squares)
28901        Rhead = dsqrt(   &
28902         (Rhead_distance(1)*Rhead_distance(1)) &
28903       + (Rhead_distance(2)*Rhead_distance(2)) &
28904       + (Rhead_distance(3)*Rhead_distance(3)))
28905 !c!-------------------------------------------------------------------
28906 !c! zero everything that should be zero'ed
28907        Egb = 0.0d0
28908        ECL = 0.0d0
28909        Elj = 0.0d0
28910        Equad = 0.0d0
28911        Epol = 0.0d0
28912        eheadtail = 0.0d0
28913        dGCLdOM1 = 0.0d0
28914        dGCLdOM2 = 0.0d0
28915        dGCLdOM12 = 0.0d0
28916        dPOLdOM1 = 0.0d0
28917        dPOLdOM2 = 0.0d0
28918        RETURN
28919       END SUBROUTINE elgrad_init
28920
28921
28922       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28923       use comm_momo
28924       use calc_data
28925        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28926        eps_out=80.0d0
28927        itypi = itype(i,1)
28928        itypj = itype(j,5)
28929 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28930 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28931 !c!       t_bath = 300
28932 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28933        Rb=0.001986d0
28934        BetaT = 1.0d0 / (298.0d0 * Rb)
28935 !c! Gay-berne var's
28936        sig0ij = sigmacat( itypi,itypj )
28937        chi1   = chi1cat( itypi, itypj )
28938        chi2   = 0.0d0
28939        chi12  = 0.0d0
28940        chip1  = chipp1cat( itypi, itypj )
28941        chip2  = 0.0d0
28942        chip12 = 0.0d0
28943 !c! not used by momo potential, but needed by sc_angular which is shared
28944 !c! by all energy_potential subroutines
28945        alf1   = 0.0d0
28946        alf2   = 0.0d0
28947        alf12  = 0.0d0
28948        dxj = 0.0d0 !dc_norm( 1, nres+j )
28949        dyj = 0.0d0 !dc_norm( 2, nres+j )
28950        dzj = 0.0d0 !dc_norm( 3, nres+j )
28951 !c! distance from center of chain(?) to polar/charged head
28952        d1 = dheadcat(1, 1, itypi, itypj)
28953        d2 = dheadcat(2, 1, itypi, itypj)
28954 !c! ai*aj from Fgb
28955        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28956 !c!       a12sq = a12sq * a12sq
28957 !c! charge of amino acid itypi is...
28958        Qi  = icharge(itypi)
28959        Qj  = ichargecat(itypj)
28960        Qij = Qi * Qj
28961 !c! chis1,2,12
28962        chis1 = chis1cat(itypi,itypj)
28963        chis2 = 0.0d0
28964        chis12 = 0.0d0
28965        sig1 = sigmap1cat(itypi,itypj)
28966        sig2 = sigmap2cat(itypi,itypj)
28967 !c! alpha factors from Fcav/Gcav
28968        b1cav = alphasurcat(1,itypi,itypj)
28969        b2cav = alphasurcat(2,itypi,itypj)
28970        b3cav = alphasurcat(3,itypi,itypj)
28971        b4cav = alphasurcat(4,itypi,itypj)
28972        wqd = wquadcat(itypi, itypj)
28973 !c! used by Fgb
28974        eps_in = epsintabcat(itypi,itypj)
28975        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28976 !c!-------------------------------------------------------------------
28977 !c! tail location and distance calculations
28978        Rtail = 0.0d0
28979        DO k = 1, 3
28980       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
28981       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28982        END DO
28983 !c! tail distances will be themselves usefull elswhere
28984 !c1 (in Gcav, for example)
28985        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28986        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28987        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28988        Rtail = dsqrt(  &
28989         (Rtail_distance(1)*Rtail_distance(1))  &
28990       + (Rtail_distance(2)*Rtail_distance(2))  &
28991       + (Rtail_distance(3)*Rtail_distance(3)))
28992 !c!-------------------------------------------------------------------
28993 !c! Calculate location and distance between polar heads
28994 !c! distance between heads
28995 !c! for each one of our three dimensional space...
28996        d1 = dheadcat(1, 1, itypi, itypj)
28997        d2 = dheadcat(2, 1, itypi, itypj)
28998
28999        DO k = 1,3
29000 !c! location of polar head is computed by taking hydrophobic centre
29001 !c! and moving by a d1 * dc_norm vector
29002 !c! see unres publications for very informative images
29003       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
29004       chead(k,2) = c(k, j)
29005 !c! distance
29006 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
29007 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
29008       Rhead_distance(k) = chead(k,2) - chead(k,1)
29009        END DO
29010 !c! pitagoras (root of sum of squares)
29011        Rhead = dsqrt(   &
29012         (Rhead_distance(1)*Rhead_distance(1)) &
29013       + (Rhead_distance(2)*Rhead_distance(2)) &
29014       + (Rhead_distance(3)*Rhead_distance(3)))
29015 !c!-------------------------------------------------------------------
29016 !c! zero everything that should be zero'ed
29017        Egb = 0.0d0
29018        ECL = 0.0d0
29019        Elj = 0.0d0
29020        Equad = 0.0d0
29021        Epol = 0.0d0
29022        eheadtail = 0.0d0
29023        dGCLdOM1 = 0.0d0
29024        dGCLdOM2 = 0.0d0
29025        dGCLdOM12 = 0.0d0
29026        dPOLdOM1 = 0.0d0
29027        dPOLdOM2 = 0.0d0
29028        RETURN
29029       END SUBROUTINE elgrad_init_cat
29030
29031       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
29032       use comm_momo
29033       use calc_data
29034        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
29035        eps_out=80.0d0
29036        itypi = 10
29037        itypj = itype(j,5)
29038 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
29039 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
29040 !c!       t_bath = 300
29041 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
29042        Rb=0.001986d0
29043        BetaT = 1.0d0 / (298.0d0 * Rb)
29044 !c! Gay-berne var's
29045        sig0ij = sigmacat( itypi,itypj )
29046        chi1   = chi1cat( itypi, itypj )
29047        chi2   = 0.0d0
29048        chi12  = 0.0d0
29049        chip1  = chipp1cat( itypi, itypj )
29050        chip2  = 0.0d0
29051        chip12 = 0.0d0
29052 !c! not used by momo potential, but needed by sc_angular which is shared
29053 !c! by all energy_potential subroutines
29054        alf1   = 0.0d0
29055        alf2   = 0.0d0
29056        alf12  = 0.0d0
29057        dxj = 0.0d0 !dc_norm( 1, nres+j )
29058        dyj = 0.0d0 !dc_norm( 2, nres+j )
29059        dzj = 0.0d0 !dc_norm( 3, nres+j )
29060 !c! distance from center of chain(?) to polar/charged head
29061        d1 = dheadcat(1, 1, itypi, itypj)
29062        d2 = dheadcat(2, 1, itypi, itypj)
29063 !c! ai*aj from Fgb
29064        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
29065 !c!       a12sq = a12sq * a12sq
29066 !c! charge of amino acid itypi is...
29067        Qi  = 0
29068        Qj  = ichargecat(itypj)
29069 !       Qij = Qi * Qj
29070 !c! chis1,2,12
29071        chis1 = chis1cat(itypi,itypj)
29072        chis2 = 0.0d0
29073        chis12 = 0.0d0
29074        sig1 = sigmap1cat(itypi,itypj)
29075        sig2 = sigmap2cat(itypi,itypj)
29076 !c! alpha factors from Fcav/Gcav
29077        b1cav = alphasurcat(1,itypi,itypj)
29078        b2cav = alphasurcat(2,itypi,itypj)
29079        b3cav = alphasurcat(3,itypi,itypj)
29080        b4cav = alphasurcat(4,itypi,itypj)
29081        wqd = wquadcat(itypi, itypj)
29082 !c! used by Fgb
29083        eps_in = epsintabcat(itypi,itypj)
29084        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
29085 !c!-------------------------------------------------------------------
29086 !c! tail location and distance calculations
29087        Rtail = 0.0d0
29088        DO k = 1, 3
29089       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
29090       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
29091        END DO
29092 !c! tail distances will be themselves usefull elswhere
29093 !c1 (in Gcav, for example)
29094        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
29095        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
29096        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
29097        Rtail = dsqrt(  &
29098         (Rtail_distance(1)*Rtail_distance(1))  &
29099       + (Rtail_distance(2)*Rtail_distance(2))  &
29100       + (Rtail_distance(3)*Rtail_distance(3)))
29101 !c!-------------------------------------------------------------------
29102 !c! Calculate location and distance between polar heads
29103 !c! distance between heads
29104 !c! for each one of our three dimensional space...
29105        d1 = dheadcat(1, 1, itypi, itypj)
29106        d2 = dheadcat(2, 1, itypi, itypj)
29107
29108        DO k = 1,3
29109 !c! location of polar head is computed by taking hydrophobic centre
29110 !c! and moving by a d1 * dc_norm vector
29111 !c! see unres publications for very informative images
29112       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
29113       chead(k,2) = c(k, j)
29114 !c! distance
29115 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
29116 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
29117       Rhead_distance(k) = chead(k,2) - chead(k,1)
29118        END DO
29119 !c! pitagoras (root of sum of squares)
29120        Rhead = dsqrt(   &
29121         (Rhead_distance(1)*Rhead_distance(1)) &
29122       + (Rhead_distance(2)*Rhead_distance(2)) &
29123       + (Rhead_distance(3)*Rhead_distance(3)))
29124 !c!-------------------------------------------------------------------
29125 !c! zero everything that should be zero'ed
29126        Egb = 0.0d0
29127        ECL = 0.0d0
29128        Elj = 0.0d0
29129        Equad = 0.0d0
29130        Epol = 0.0d0
29131        eheadtail = 0.0d0
29132        dGCLdOM1 = 0.0d0
29133        dGCLdOM2 = 0.0d0
29134        dGCLdOM12 = 0.0d0
29135        dPOLdOM1 = 0.0d0
29136        dPOLdOM2 = 0.0d0
29137        RETURN
29138       END SUBROUTINE elgrad_init_cat_pep
29139
29140       double precision function tschebyshev(m,n,x,y)
29141       implicit none
29142       integer i,m,n
29143       double precision x(n),y,yy(0:maxvar),aux
29144 !c Tschebyshev polynomial. Note that the first term is omitted
29145 !c m=0: the constant term is included
29146 !c m=1: the constant term is not included
29147       yy(0)=1.0d0
29148       yy(1)=y
29149       do i=2,n
29150       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
29151       enddo
29152       aux=0.0d0
29153       do i=m,n
29154       aux=aux+x(i)*yy(i)
29155       enddo
29156       tschebyshev=aux
29157       return
29158       end function tschebyshev
29159 !C--------------------------------------------------------------------------
29160       double precision function gradtschebyshev(m,n,x,y)
29161       implicit none
29162       integer i,m,n
29163       double precision x(n+1),y,yy(0:maxvar),aux
29164 !c Tschebyshev polynomial. Note that the first term is omitted
29165 !c m=0: the constant term is included
29166 !c m=1: the constant term is not included
29167       yy(0)=1.0d0
29168       yy(1)=2.0d0*y
29169       do i=2,n
29170       yy(i)=2*y*yy(i-1)-yy(i-2)
29171       enddo
29172       aux=0.0d0
29173       do i=m,n
29174       aux=aux+x(i+1)*yy(i)*(i+1)
29175 !C        print *, x(i+1),yy(i),i
29176       enddo
29177       gradtschebyshev=aux
29178       return
29179       end function gradtschebyshev
29180 !!!!!!!!!--------------------------------------------------------------
29181       subroutine lipid_bond(elipbond)
29182       real(kind=8) :: elipbond,fac,dist_sub,sumdist
29183       real(kind=8), dimension(3):: dist
29184       integer(kind=8) :: i,j,k,ibra,ityp,jtyp,ityp1
29185       elipbond=0.0d0
29186 !      print *,"before",ilipbond_start,ilipbond_end
29187       do i=ilipbond_start,ilipbond_end
29188 !       print *,i,i+1,"i,i+1"
29189        ityp=itype(i,4)
29190        ityp1=itype(i+1,4)
29191 !       print *,ityp,ityp1,"itype"
29192        j=i+1
29193        if (ityp.eq.12) ibra=i
29194        if ((ityp.eq.ntyp1_molec(4)).or.(ityp1.ge.ntyp1_molec(4)-1)) cycle
29195        if (ityp.eq.(ntyp1_molec(4)-1)) then
29196        !cofniecie do ostatnie GL1
29197 !       i=ibra
29198        j=ibra
29199        else
29200        j=i
29201        endif
29202        jtyp=itype(j,4)
29203        do k=1,3
29204         dist(k)=c(k,j)-c(k,i+1)
29205        enddo
29206        sumdist=0.0d0
29207        do k=1,3
29208        sumdist=sumdist+dist(k)**2
29209        enddo
29210        dist_sub=sqrt(sumdist)
29211 !       print *,"before",i,j,ityp1,ityp,jtyp
29212        elipbond=elipbond+kbondlip*((dist_sub-lip_bond(jtyp,ityp1))**2)
29213        fac=kbondlip*(dist_sub-lip_bond(jtyp,ityp1))
29214        do k=1,3
29215         gradlipbond(k,i+1)= gradlipbond(k,i+1)-fac*dist(k)/dist_sub
29216         gradlipbond(k,j)=gradlipbond(k,j)+fac*dist(k)/dist_sub
29217        enddo
29218       if (energy_dec) write(iout,*) "lipbond",j,i+1,dist_sub,lip_bond(jtyp,ityp1),kbondlip,fac
29219       enddo
29220       elipbond=elipbond*0.5d0
29221       return
29222       end subroutine lipid_bond
29223 !---------------------------------------------------------------------------------------
29224       subroutine lipid_angle(elipang)
29225       real(kind=8) :: elipang,alfa,xa(3),xb(3),alfaact,alfa0,force,fac,&
29226       scalara,vnorm,wnorm,sss,sss_grad,eangle
29227       integer :: i,j,k,l,m,ibra,ityp1,itypm1,itypp1
29228       elipang=0.0d0
29229 !      print *,"ilipang_start,ilipang_end",ilipang_start,ilipang_end
29230       do i=ilipang_start,ilipang_end
29231 !       do i=4,4
29232
29233 ! the loop is centered on the central residue
29234       itypm1=itype(i-1,4)
29235       ityp1=itype(i,4)
29236       itypp1=itype(i+1,4)
29237 !         print *,i,i,j,"processor",fg_rank
29238       j=i-1
29239       k=i
29240       l=i+1
29241       if (ityp1.eq.12) ibra=i
29242       if ((itypm1.eq.ntyp1_molec(4)).or.(ityp1.eq.ntyp1_molec(4))&
29243          .or.(itypp1.eq.ntyp1_molec(4))) cycle !cycle if any of the angles is dummy
29244       if ((itypm1.eq.ntyp1_molec(4)-1).or.(itypp1.eq.ntyp1_molec(4)-1)) cycle
29245      ! branching is only to one angle
29246       if (ityp1.eq.ntyp1_molec(4)-1) then
29247       k=ibra
29248       j=ibra-1
29249       endif
29250       itypm1=itype(j,4)
29251       ityp1=itype(k,4)
29252       do m=1,3
29253       xa(m)=c(m,j)-c(m,k)
29254       xb(m)=c(m,l)-c(m,k)
29255 !      xb(m)=1.0d0
29256       enddo
29257       vnorm=dsqrt(xa(1)*xa(1)+xa(2)*xa(2)+xa(3)*xa(3))
29258       wnorm=dsqrt(xb(1)*xb(1)+xb(2)*xb(2)+xb(3)*xb(3))
29259       scalara=(xa(1)*xb(1)+xa(2)*xb(2)+xa(3)*xb(3))/(vnorm*wnorm)
29260 !      if (((scalar*scalar).gt.0.99999999d0).and.(alfa0.eq.180.0d0)) cycle
29261
29262       alfaact=scalara
29263 !      sss=sscale_martini_angle(alfaact)
29264 !      sss_grad=sscale_grad_martini_angle(alfaact)
29265 !      print *,sss_grad,"sss_grad",sss
29266 !      if (sss.le.0.0) cycle
29267 !      if (sss_grad.ne.0.0) print *,sss_grad,"sss_grad"
29268       force=lip_angle_force(itypm1,ityp1,itypp1)
29269       alfa0=lip_angle_angle(itypm1,ityp1,itypp1)
29270       eangle=force*(alfaact-dcos(alfa0))*(alfaact-dcos(alfa0))*0.5d0
29271       elipang=elipang+eangle!*(1001.0d0-1000.0d0*sss)
29272       fac=force*(alfaact-dcos(alfa0))!*(1001.0d0-1000.0d0*sss)-sss_grad*eangle*1000.0d0
29273       do m=1,3
29274       gradlipang(m,j)=gradlipang(m,j)+(fac &!/dsqrt(1.0d0-scalar*scalar)&
29275         *(xb(m)-scalara*wnorm*xa(m)/vnorm)&
29276        /(vnorm*wnorm))!-sss_grad*eangle*xa(m)/vnorm
29277
29278       gradlipang(m,l)=gradlipang(m,l)+(fac & !/dsqrt(1.0d0-scalar*scalar)&
29279        *(xa(m)-scalara*vnorm*xb(m)/wnorm)&
29280        /(vnorm*wnorm))!+sss_grad*eangle*xb(m)/wnorm
29281
29282       gradlipang(m,k)=gradlipang(m,k)-(fac)&  !/dsqrt(1.0d0-scalar*scalar)&
29283         *(xb(m)-scalara*wnorm*xa(m)/vnorm)&
29284        /((vnorm*wnorm))-(fac & !/dsqrt(1.0d0-scalar*scalar)&
29285        *(xa(m)-scalara*vnorm*xb(m)/wnorm)&
29286        /(vnorm*wnorm))!-sss_grad*eangle*xa(m)/vnorm&
29287                       !-sss_grad*eangle*xb(m)/wnorm
29288
29289
29290 !        *(xb(m)*vnorm*wnorm)&
29291
29292 !-xa(m)*xa(m)*xb(m)*wnorm/vnorm)&
29293       enddo
29294       if (energy_dec) write(iout,*) "elipang",j,k,l,force,alfa0,alfaact,elipang
29295       enddo
29296       return
29297       end subroutine lipid_angle
29298 !--------------------------------------------------------------------
29299       subroutine lipid_lj(eliplj)
29300       real(kind=8) :: eliplj,fac,sumdist,dist_sub,LJ1,LJ2,LJ,&
29301                       xj,yj,zj,xi,yi,zi,sss,sss_grad
29302       real(kind=8), dimension(3):: dist
29303       integer :: i,j,k,inum,ityp,jtyp
29304         eliplj=0.0d0
29305         do inum=iliplj_start,iliplj_end
29306         i=mlipljlisti(inum)
29307         j=mlipljlistj(inum)
29308 !         print *,inum,i,j,"processor",fg_rank
29309         ityp=itype(i,4)
29310         jtyp=itype(j,4)
29311         xi=c(1,i)
29312         yi=c(2,i)
29313         zi=c(3,i)
29314         call to_box(xi,yi,zi)
29315         xj=c(1,j)
29316         yj=c(2,j)
29317         zj=c(3,j)
29318       call to_box(xj,yj,zj)
29319       xj=boxshift(xj-xi,boxxsize)
29320       yj=boxshift(yj-yi,boxysize)
29321       zj=boxshift(zj-zi,boxzsize)
29322          dist(1)=xj
29323          dist(2)=yj
29324          dist(3)=zj
29325        !  do k=1,3
29326        !   dist(k)=c(k,j)-c(k,i)
29327        !  enddo
29328          sumdist=0.0d0
29329          do k=1,3
29330           sumdist=sumdist+dist(k)**2
29331          enddo
29332
29333          dist_sub=sqrt(sumdist)
29334          sss=sscale_martini(dist_sub)
29335          if (energy_dec) write(iout,*) "LJ LIP bef",i,j,ityp,jtyp,dist_sub
29336          if (sss.le.0.0) cycle
29337          sss_grad=sscale_grad_martini(dist_sub)
29338           LJ1 = (lip_sig(ityp,jtyp)/dist_sub)**6
29339           LJ2 = LJ1**2
29340           LJ = LJ2 - LJ1
29341           LJ = 4.0d0*lip_eps(ityp,jtyp)*LJ
29342           eliplj = eliplj + LJ*sss
29343           fac=4.0d0*lip_eps(ityp,jtyp)*(-6.0d0*LJ1/dist_sub+12.0d0*LJ2/dist_sub)
29344          do k=1,3
29345          gradliplj(k,i)=gradliplj(k,i)+fac*dist(k)/dist_sub*sss-sss_grad*LJ*dist(k)/dist_sub
29346          gradliplj(k,j)=gradliplj(k,j)-fac*dist(k)/dist_sub*sss+sss_grad*LJ*dist(k)/dist_sub
29347          enddo
29348          if (energy_dec) write(iout,'(a7,4i5,2f8.3)') "LJ LIP",i,j,ityp,jtyp,LJ,dist_sub
29349         enddo
29350       return
29351       end subroutine lipid_lj
29352 !--------------------------------------------------------------------------------------
29353       subroutine lipid_elec(elipelec)
29354       real(kind=8) :: elipelec,fac,sumdist,dist_sub,xj,yj,zj,xi,yi,zi,EQ,&
29355       sss,sss_grad
29356       real(kind=8), dimension(3):: dist
29357       integer :: i,j,k,inum,ityp,jtyp
29358         elipelec=0.0d0
29359 !        print *,"processor",fg_rank,ilip_elec_start,ilipelec_end
29360         do inum=ilip_elec_start,ilipelec_end
29361          i=mlipeleclisti(inum)
29362          j=mlipeleclistj(inum)
29363 !         print *,inum,i,j,"processor",fg_rank
29364          ityp=itype(i,4)
29365          jtyp=itype(j,4)
29366         xi=c(1,i)
29367         yi=c(2,i)
29368         zi=c(3,i)
29369         call to_box(xi,yi,zi)
29370         xj=c(1,j)
29371         yj=c(2,j)
29372         zj=c(3,j)
29373       call to_box(xj,yj,zj)
29374       xj=boxshift(xj-xi,boxxsize)
29375       yj=boxshift(yj-yi,boxysize)
29376       zj=boxshift(zj-zi,boxzsize)
29377          dist(1)=xj
29378          dist(2)=yj
29379          dist(3)=zj
29380 !         do k=1,3
29381 !          dist(k)=c(k,j)-c(k,i)
29382 !         enddo
29383          sumdist=0.0d0
29384          do k=1,3
29385           sumdist=sumdist+dist(k)**2
29386          enddo
29387          dist_sub=sqrt(sumdist)
29388          sss=sscale_martini(dist_sub)
29389 !         print *,sss,dist_sub
29390           if (energy_dec) write(iout,*) "EQ LIP",sss,dist_sub,i,j
29391          if (sss.le.0.0) cycle
29392          sss_grad=sscale_grad_martini(dist_sub)
29393 !         print *,"sss",sss,sss_grad
29394          EQ=k_coulomb_lip*(ichargelipid(ityp)*ichargelipid(jtyp)/dist_sub)
29395               elipelec=elipelec+EQ*sss
29396          fac=k_coulomb_lip*(ichargelipid(ityp)*ichargelipid(jtyp)/sumdist)*sss
29397          do k=1,3
29398          gradlipelec(k,i)=gradlipelec(k,i)+fac*dist(k)/dist_sub&
29399                                           -sss_grad*EQ*dist(k)/dist_sub
29400          gradlipelec(k,j)=gradlipelec(k,j)-fac*dist(k)/dist_sub&
29401                                           +sss_grad*EQ*dist(k)/dist_sub
29402          enddo
29403           if (energy_dec) write(iout,*) "EQ LIP",i,j,ityp,jtyp,EQ,dist_sub,elipelec
29404         enddo
29405       return
29406       end subroutine lipid_elec
29407 !-------------------------------------------------------------------------
29408       subroutine make_SCSC_inter_list
29409       include 'mpif.h'
29410       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29411       real(kind=8) :: dist_init, dist_temp,r_buff_list
29412       integer:: contlisti(250*nres),contlistj(250*nres)
29413 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
29414       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
29415       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
29416 !            print *,"START make_SC"
29417         r_buff_list=5.0
29418           ilist_sc=0
29419           do i=iatsc_s,iatsc_e
29420            itypi=iabs(itype(i,1))
29421            if (itypi.eq.ntyp1) cycle
29422            xi=c(1,nres+i)
29423            yi=c(2,nres+i)
29424            zi=c(3,nres+i)
29425           call to_box(xi,yi,zi)
29426            do iint=1,nint_gr(i)
29427 !           print *,"is it wrong", iint,i
29428             do j=istart(i,iint),iend(i,iint)
29429              itypj=iabs(itype(j,1))
29430              if (energy_dec) write(iout,*) "LISTA ZAKRES",istart(i,iint),iend(i,iint),iatsc_s,iatsc_e
29431              if (itypj.eq.ntyp1) cycle
29432              xj=c(1,nres+j)
29433              yj=c(2,nres+j)
29434              zj=c(3,nres+j)
29435              call to_box(xj,yj,zj)
29436 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
29437 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
29438           xj=boxshift(xj-xi,boxxsize)
29439           yj=boxshift(yj-yi,boxysize)
29440           zj=boxshift(zj-zi,boxzsize)
29441           dist_init=xj**2+yj**2+zj**2
29442 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
29443 ! r_buff_list is a read value for a buffer
29444              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29445 ! Here the list is created
29446              ilist_sc=ilist_sc+1
29447 ! this can be substituted by cantor and anti-cantor
29448              contlisti(ilist_sc)=i
29449              contlistj(ilist_sc)=j
29450
29451              endif
29452            enddo
29453            enddo
29454            enddo
29455 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
29456 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29457 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
29458 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
29459 #ifdef DEBUG
29460       write (iout,*) "before MPIREDUCE",ilist_sc
29461       do i=1,ilist_sc
29462       write (iout,*) i,contlisti(i),contlistj(i)
29463       enddo
29464 #endif
29465       if (nfgtasks.gt.1)then
29466
29467       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
29468         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29469 !        write(iout,*) "before bcast",g_ilist_sc
29470       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
29471                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
29472       displ(0)=0
29473       do i=1,nfgtasks-1,1
29474         displ(i)=i_ilist_sc(i-1)+displ(i-1)
29475       enddo
29476 !        write(iout,*) "before gather",displ(0),displ(1)
29477       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
29478                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
29479                    king,FG_COMM,IERR)
29480       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
29481                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
29482                    king,FG_COMM,IERR)
29483       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
29484 !        write(iout,*) "before bcast",g_ilist_sc
29485 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29486       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
29487       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
29488
29489 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29490
29491       else
29492       g_ilist_sc=ilist_sc
29493
29494       do i=1,ilist_sc
29495       newcontlisti(i)=contlisti(i)
29496       newcontlistj(i)=contlistj(i)
29497       enddo
29498       endif
29499
29500 #ifdef DEBUG
29501       write (iout,*) "after MPIREDUCE",g_ilist_sc
29502       do i=1,g_ilist_sc
29503       write (iout,*) i,newcontlisti(i),newcontlistj(i)
29504       enddo
29505 #endif
29506       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
29507       return
29508       end subroutine make_SCSC_inter_list
29509 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
29510
29511       subroutine make_SCp_inter_list
29512       use MD_data,  only: itime_mat
29513
29514       include 'mpif.h'
29515       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29516       real(kind=8) :: dist_init, dist_temp,r_buff_list
29517       integer:: contlistscpi(350*nres),contlistscpj(350*nres)
29518 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
29519       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
29520       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
29521 !            print *,"START make_SC"
29522       r_buff_list=5.0
29523           ilist_scp=0
29524       do i=iatscp_s,iatscp_e
29525       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
29526       xi=0.5D0*(c(1,i)+c(1,i+1))
29527       yi=0.5D0*(c(2,i)+c(2,i+1))
29528       zi=0.5D0*(c(3,i)+c(3,i+1))
29529         call to_box(xi,yi,zi)
29530       do iint=1,nscp_gr(i)
29531
29532       do j=iscpstart(i,iint),iscpend(i,iint)
29533         itypj=iabs(itype(j,1))
29534         if (itypj.eq.ntyp1) cycle
29535 ! Uncomment following three lines for SC-p interactions
29536 !         xj=c(1,nres+j)-xi
29537 !         yj=c(2,nres+j)-yi
29538 !         zj=c(3,nres+j)-zi
29539 ! Uncomment following three lines for Ca-p interactions
29540 !          xj=c(1,j)-xi
29541 !          yj=c(2,j)-yi
29542 !          zj=c(3,j)-zi
29543         xj=c(1,j)
29544         yj=c(2,j)
29545         zj=c(3,j)
29546         call to_box(xj,yj,zj)
29547       xj=boxshift(xj-xi,boxxsize)
29548       yj=boxshift(yj-yi,boxysize)
29549       zj=boxshift(zj-zi,boxzsize)
29550       dist_init=xj**2+yj**2+zj**2
29551 #ifdef DEBUG
29552             ! r_buff_list is a read value for a buffer
29553              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
29554 ! Here the list is created
29555              ilist_scp_first=ilist_scp_first+1
29556 ! this can be substituted by cantor and anti-cantor
29557              contlistscpi_f(ilist_scp_first)=i
29558              contlistscpj_f(ilist_scp_first)=j
29559             endif
29560 #endif
29561 ! r_buff_list is a read value for a buffer
29562              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29563 ! Here the list is created
29564              ilist_scp=ilist_scp+1
29565 ! this can be substituted by cantor and anti-cantor
29566              contlistscpi(ilist_scp)=i
29567              contlistscpj(ilist_scp)=j
29568             endif
29569            enddo
29570            enddo
29571            enddo
29572 #ifdef DEBUG
29573       write (iout,*) "before MPIREDUCE",ilist_scp
29574       do i=1,ilist_scp
29575       write (iout,*) i,contlistscpi(i),contlistscpj(i)
29576       enddo
29577 #endif
29578       if (nfgtasks.gt.1)then
29579
29580       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
29581         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29582 !        write(iout,*) "before bcast",g_ilist_sc
29583       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
29584                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
29585       displ(0)=0
29586       do i=1,nfgtasks-1,1
29587         displ(i)=i_ilist_scp(i-1)+displ(i-1)
29588       enddo
29589 !        write(iout,*) "before gather",displ(0),displ(1)
29590       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
29591                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
29592                    king,FG_COMM,IERR)
29593       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
29594                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
29595                    king,FG_COMM,IERR)
29596       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
29597 !        write(iout,*) "before bcast",g_ilist_sc
29598 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29599       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
29600       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
29601
29602 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29603
29604       else
29605       g_ilist_scp=ilist_scp
29606
29607       do i=1,ilist_scp
29608       newcontlistscpi(i)=contlistscpi(i)
29609       newcontlistscpj(i)=contlistscpj(i)
29610       enddo
29611       endif
29612
29613 #ifdef DEBUG
29614       write (iout,*) "after MPIREDUCE",g_ilist_scp
29615       do i=1,g_ilist_scp
29616       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
29617       enddo
29618
29619 !      if (ifirstrun.eq.0) ifirstrun=1
29620 !      do i=1,ilist_scp_first
29621 !       do j=1,g_ilist_scp
29622 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
29623 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
29624 !        enddo
29625 !       print *,itime_mat,"ERROR matrix needs updating"
29626 !       print *,contlistscpi_f(i),contlistscpj_f(i)
29627 !  126  continue
29628 !      enddo
29629 #endif
29630       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
29631
29632       return
29633       end subroutine make_SCp_inter_list
29634
29635 !-----------------------------------------------------------------------------
29636 !-----------------------------------------------------------------------------
29637
29638
29639       subroutine make_pp_inter_list
29640       include 'mpif.h'
29641       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29642       real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
29643       real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
29644       real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
29645       integer:: contlistppi(250*nres),contlistppj(250*nres)
29646 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
29647       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
29648       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
29649 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
29650             ilist_pp=0
29651       r_buff_list=5.0
29652       do i=iatel_s,iatel_e
29653         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
29654         dxi=dc(1,i)
29655         dyi=dc(2,i)
29656         dzi=dc(3,i)
29657         dx_normi=dc_norm(1,i)
29658         dy_normi=dc_norm(2,i)
29659         dz_normi=dc_norm(3,i)
29660         xmedi=c(1,i)+0.5d0*dxi
29661         ymedi=c(2,i)+0.5d0*dyi
29662         zmedi=c(3,i)+0.5d0*dzi
29663
29664         call to_box(xmedi,ymedi,zmedi)
29665         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
29666 !          write (iout,*) i,j,itype(i,1),itype(j,1)
29667 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
29668
29669 ! 1,j)
29670              do j=ielstart(i),ielend(i)
29671 !          write (iout,*) i,j,itype(i,1),itype(j,1)
29672           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
29673           dxj=dc(1,j)
29674           dyj=dc(2,j)
29675           dzj=dc(3,j)
29676           dx_normj=dc_norm(1,j)
29677           dy_normj=dc_norm(2,j)
29678           dz_normj=dc_norm(3,j)
29679 !          xj=c(1,j)+0.5D0*dxj-xmedi
29680 !          yj=c(2,j)+0.5D0*dyj-ymedi
29681 !          zj=c(3,j)+0.5D0*dzj-zmedi
29682           xj=c(1,j)+0.5D0*dxj
29683           yj=c(2,j)+0.5D0*dyj
29684           zj=c(3,j)+0.5D0*dzj
29685           call to_box(xj,yj,zj)
29686 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
29687 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
29688           xj=boxshift(xj-xmedi,boxxsize)
29689           yj=boxshift(yj-ymedi,boxysize)
29690           zj=boxshift(zj-zmedi,boxzsize)
29691           dist_init=xj**2+yj**2+zj**2
29692       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29693 ! Here the list is created
29694                  ilist_pp=ilist_pp+1
29695 ! this can be substituted by cantor and anti-cantor
29696                  contlistppi(ilist_pp)=i
29697                  contlistppj(ilist_pp)=j
29698               endif
29699 !             enddo
29700              enddo
29701              enddo
29702 #ifdef DEBUG
29703       write (iout,*) "before MPIREDUCE",ilist_pp
29704       do i=1,ilist_pp
29705       write (iout,*) i,contlistppi(i),contlistppj(i)
29706       enddo
29707 #endif
29708       if (nfgtasks.gt.1)then
29709
29710         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
29711           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29712 !        write(iout,*) "before bcast",g_ilist_sc
29713         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
29714                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
29715         displ(0)=0
29716         do i=1,nfgtasks-1,1
29717           displ(i)=i_ilist_pp(i-1)+displ(i-1)
29718         enddo
29719 !        write(iout,*) "before gather",displ(0),displ(1)
29720         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
29721                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
29722                          king,FG_COMM,IERR)
29723         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
29724                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
29725                          king,FG_COMM,IERR)
29726         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
29727 !        write(iout,*) "before bcast",g_ilist_sc
29728 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29729         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
29730         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
29731
29732 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29733
29734         else
29735         g_ilist_pp=ilist_pp
29736
29737         do i=1,ilist_pp
29738         newcontlistppi(i)=contlistppi(i)
29739         newcontlistppj(i)=contlistppj(i)
29740         enddo
29741         endif
29742         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
29743 #ifdef DEBUG
29744       write (iout,*) "after MPIREDUCE",g_ilist_pp
29745       do i=1,g_ilist_pp
29746       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
29747       enddo
29748 #endif
29749       return
29750       end subroutine make_pp_inter_list
29751 !---------------------------------------------------------------------------
29752       subroutine make_cat_pep_list
29753       include 'mpif.h'
29754       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29755       real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
29756       real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
29757       real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
29758       real(kind=8) :: xja,yja,zja
29759       integer:: contlistcatpnormi(300*nres),contlistcatpnormj(300*nres)
29760       integer:: contlistcatscnormi(250*nres),contlistcatscnormj(250*nres)
29761       integer:: contlistcatptrani(250*nres),contlistcatptranj(250*nres)
29762       integer:: contlistcatsctrani(250*nres),contlistcatsctranj(250*nres)
29763       integer:: contlistcatscangi(250*nres),contlistcatscangj(250*nres)
29764       integer:: contlistcatscangfi(250*nres),contlistcatscangfj(250*nres),&
29765                 contlistcatscangfk(250*nres)
29766       integer:: contlistcatscangti(250*nres),contlistcatscangtj(250*nres)
29767       integer:: contlistcatscangtk(250*nres),contlistcatscangtl(250*nres)
29768
29769
29770 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
29771       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_catscnorm,&
29772               ilist_catsctran,ilist_catpnorm,ilist_catptran,itmp,ilist_catscang,&
29773               ilist_catscangf,ilist_catscangt,k
29774       integer displ(0:nprocs),i_ilist_catscnorm(0:nprocs),ierr,&
29775              i_ilist_catpnorm(0:nprocs),i_ilist_catsctran(0:nprocs),&
29776              i_ilist_catptran(0:nprocs),i_ilist_catscang(0:nprocs),&
29777              i_ilist_catscangf(0:nprocs),i_ilist_catscangt(0:nprocs)
29778 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
29779             ilist_catpnorm=0
29780             ilist_catscnorm=0
29781             ilist_catptran=0
29782             ilist_catsctran=0
29783             ilist_catscang=0
29784
29785
29786       r_buff_list=6.0
29787       itmp=0
29788       do i=1,4
29789       itmp=itmp+nres_molec(i)
29790       enddo
29791 !        go to 17
29792 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
29793       do i=ibond_start,ibond_end
29794
29795 !        print *,"I am in EVDW",i
29796       itypi=iabs(itype(i,1))
29797
29798 !        if (i.ne.47) cycle
29799       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
29800 !      itypi1=iabs(itype(i+1,1))
29801       xi=c(1,nres+i)
29802       yi=c(2,nres+i)
29803       zi=c(3,nres+i)
29804       call to_box(xi,yi,zi)
29805       dxi=dc_norm(1,nres+i)
29806       dyi=dc_norm(2,nres+i)
29807       dzi=dc_norm(3,nres+i)
29808         xmedi=c(1,i)+0.5d0*dxi
29809         ymedi=c(2,i)+0.5d0*dyi
29810         zmedi=c(3,i)+0.5d0*dzi
29811         call to_box(xmedi,ymedi,zmedi)
29812
29813 !      dsci_inv=vbld_inv(i+nres)
29814        do j=itmp+1,itmp+nres_molec(5)
29815           dxj=dc(1,j)
29816           dyj=dc(2,j)
29817           dzj=dc(3,j)
29818           dx_normj=dc_norm(1,j)
29819           dy_normj=dc_norm(2,j)
29820           dz_normj=dc_norm(3,j)
29821           xj=c(1,j)
29822           yj=c(2,j)
29823           zj=c(3,j)
29824           call to_box(xj,yj,zj)
29825 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
29826 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
29827           xja=boxshift(xj-xmedi,boxxsize)
29828           yja=boxshift(yj-ymedi,boxysize)
29829           zja=boxshift(zj-zmedi,boxzsize)
29830           dist_init=xja**2+yja**2+zja**2
29831       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29832 ! Here the list is created
29833               if (itype(j,5).le.5) then
29834                  ilist_catpnorm=ilist_catpnorm+1
29835 ! this can be substituted by cantor and anti-cantor
29836                  contlistcatpnormi(ilist_catpnorm)=i
29837                  contlistcatpnormj(ilist_catpnorm)=j
29838               else
29839                  ilist_catptran=ilist_catptran+1
29840 ! this can be substituted by cantor and anti-cantor
29841                  contlistcatptrani(ilist_catptran)=i
29842                  contlistcatptranj(ilist_catptran)=j
29843               endif
29844        endif
29845           xja=boxshift(xj-xi,boxxsize)
29846           yja=boxshift(yj-yi,boxysize)
29847           zja=boxshift(zj-zi,boxzsize)
29848           dist_init=xja**2+yja**2+zja**2
29849       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29850 ! Here the list is created
29851               if (itype(j,5).le.5) then
29852                  ilist_catscnorm=ilist_catscnorm+1
29853 ! this can be substituted by cantor and anti-cantor
29854                  contlistcatscnormi(ilist_catscnorm)=i
29855                  contlistcatscnormj(ilist_catscnorm)=j
29856               else
29857                  ilist_catsctran=ilist_catsctran+1
29858 ! this can be substituted by cantor and anti-cantor
29859                  contlistcatsctrani(ilist_catsctran)=i
29860                  contlistcatsctranj(ilist_catsctran)=j
29861 !                 print *,"KUR**",i,j,itype(i,1)
29862                if (((itype(i,1).eq.1).or.(itype(i,1).eq.15).or.&
29863                    (itype(i,1).eq.16).or.(itype(i,1).eq.17)).and.&
29864                    ((sqrt(dist_init).le.(r_cut_ang+r_buff_list)))) then
29865 !                   print *,"KUR**2",i,j,itype(i,1),ilist_catscang+1
29866
29867                    ilist_catscang=ilist_catscang+1
29868                    contlistcatscangi(ilist_catscang)=i
29869                    contlistcatscangj(ilist_catscang)=j
29870                 endif
29871
29872               endif
29873       endif
29874 !             enddo
29875              enddo
29876              enddo
29877 #ifdef DEBUG
29878       write (iout,*) "before MPIREDUCE",ilist_catsctran,ilist_catptran,&
29879       ilist_catscnorm,ilist_catpnorm,ilist_catscang
29880
29881       do i=1,ilist_catsctran
29882       write (iout,*) i,contlistcatsctrani(i),contlistcatsctranj(i)
29883       enddo
29884       do i=1,ilist_catptran
29885       write (iout,*) i,contlistcatptrani(i),contlistcatsctranj(i)
29886       enddo
29887       do i=1,ilist_catscnorm
29888       write (iout,*) i,contlistcatscnormi(i),contlistcatsctranj(i)
29889       enddo
29890       do i=1,ilist_catpnorm
29891       write (iout,*) i,contlistcatpnormi(i),contlistcatsctranj(i)
29892       enddo
29893       do i=1,ilist_catscang
29894       write (iout,*) i,contlistcatscangi(i),contlistcatscangi(i)
29895       enddo
29896
29897
29898 #endif
29899       if (nfgtasks.gt.1)then
29900
29901         call MPI_Reduce(ilist_catsctran,g_ilist_catsctran,1,&
29902           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29903 !        write(iout,*) "before bcast",g_ilist_sc
29904         call MPI_Gather(ilist_catsctran,1,MPI_INTEGER,&
29905                         i_ilist_catsctran,1,MPI_INTEGER,king,FG_COMM,IERR)
29906         displ(0)=0
29907         do i=1,nfgtasks-1,1
29908           displ(i)=i_ilist_catsctran(i-1)+displ(i-1)
29909         enddo
29910 !        write(iout,*) "before gather",displ(0),displ(1)
29911         call MPI_Gatherv(contlistcatsctrani,ilist_catsctran,MPI_INTEGER,&
29912                          newcontlistcatsctrani,i_ilist_catsctran,displ,MPI_INTEGER,&
29913                          king,FG_COMM,IERR)
29914         call MPI_Gatherv(contlistcatsctranj,ilist_catsctran,MPI_INTEGER,&
29915                          newcontlistcatsctranj,i_ilist_catsctran,displ,MPI_INTEGER,&
29916                          king,FG_COMM,IERR)
29917         call MPI_Bcast(g_ilist_catsctran,1,MPI_INT,king,FG_COMM,IERR)
29918 !        write(iout,*) "before bcast",g_ilist_sc
29919 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29920         call MPI_Bcast(newcontlistcatsctrani,g_ilist_catsctran,MPI_INT,king,FG_COMM,IERR)
29921         call MPI_Bcast(newcontlistcatsctranj,g_ilist_catsctran,MPI_INT,king,FG_COMM,IERR)
29922
29923
29924         call MPI_Reduce(ilist_catptran,g_ilist_catptran,1,&
29925           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29926 !        write(iout,*) "before bcast",g_ilist_sc
29927         call MPI_Gather(ilist_catptran,1,MPI_INTEGER,&
29928                         i_ilist_catptran,1,MPI_INTEGER,king,FG_COMM,IERR)
29929         displ(0)=0
29930         do i=1,nfgtasks-1,1
29931           displ(i)=i_ilist_catptran(i-1)+displ(i-1)
29932         enddo
29933 !        write(iout,*) "before gather",displ(0),displ(1)
29934         call MPI_Gatherv(contlistcatptrani,ilist_catptran,MPI_INTEGER,&
29935                          newcontlistcatptrani,i_ilist_catptran,displ,MPI_INTEGER,&
29936                          king,FG_COMM,IERR)
29937         call MPI_Gatherv(contlistcatptranj,ilist_catptran,MPI_INTEGER,&
29938                          newcontlistcatptranj,i_ilist_catptran,displ,MPI_INTEGER,&
29939                          king,FG_COMM,IERR)
29940         call MPI_Bcast(g_ilist_catptran,1,MPI_INT,king,FG_COMM,IERR)
29941 !        write(iout,*) "before bcast",g_ilist_sc
29942 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29943         call MPI_Bcast(newcontlistcatptrani,g_ilist_catptran,MPI_INT,king,FG_COMM,IERR)
29944         call MPI_Bcast(newcontlistcatptranj,g_ilist_catptran,MPI_INT,king,FG_COMM,IERR)
29945
29946 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29947
29948         call MPI_Reduce(ilist_catscnorm,g_ilist_catscnorm,1,&
29949           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29950 !        write(iout,*) "before bcast",g_ilist_sc
29951         call MPI_Gather(ilist_catscnorm,1,MPI_INTEGER,&
29952                         i_ilist_catscnorm,1,MPI_INTEGER,king,FG_COMM,IERR)
29953         displ(0)=0
29954         do i=1,nfgtasks-1,1
29955           displ(i)=i_ilist_catscnorm(i-1)+displ(i-1)
29956         enddo
29957 !        write(iout,*) "before gather",displ(0),displ(1)
29958         call MPI_Gatherv(contlistcatscnormi,ilist_catscnorm,MPI_INTEGER,&
29959                          newcontlistcatscnormi,i_ilist_catscnorm,displ,MPI_INTEGER,&
29960                          king,FG_COMM,IERR)
29961         call MPI_Gatherv(contlistcatscnormj,ilist_catscnorm,MPI_INTEGER,&
29962                          newcontlistcatscnormj,i_ilist_catscnorm,displ,MPI_INTEGER,&
29963                          king,FG_COMM,IERR)
29964         call MPI_Bcast(g_ilist_catscnorm,1,MPI_INT,king,FG_COMM,IERR)
29965 !        write(iout,*) "before bcast",g_ilist_sc
29966 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29967         call MPI_Bcast(newcontlistcatscnormi,g_ilist_catscnorm,MPI_INT,king,FG_COMM,IERR)
29968         call MPI_Bcast(newcontlistcatscnormj,g_ilist_catscnorm,MPI_INT,king,FG_COMM,IERR)
29969
29970
29971
29972         call MPI_Reduce(ilist_catpnorm,g_ilist_catpnorm,1,&
29973           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29974 !        write(iout,*) "before bcast",g_ilist_sc
29975         call MPI_Gather(ilist_catpnorm,1,MPI_INTEGER,&
29976                         i_ilist_catpnorm,1,MPI_INTEGER,king,FG_COMM,IERR)
29977         displ(0)=0
29978         do i=1,nfgtasks-1,1
29979           displ(i)=i_ilist_catpnorm(i-1)+displ(i-1)
29980         enddo
29981 !        write(iout,*) "before gather",displ(0),displ(1)
29982         call MPI_Gatherv(contlistcatpnormi,ilist_catpnorm,MPI_INTEGER,&
29983                          newcontlistcatpnormi,i_ilist_catpnorm,displ,MPI_INTEGER,&
29984                          king,FG_COMM,IERR)
29985         call MPI_Gatherv(contlistcatpnormj,ilist_catpnorm,MPI_INTEGER,&
29986                          newcontlistcatpnormj,i_ilist_catpnorm,displ,MPI_INTEGER,&
29987                          king,FG_COMM,IERR)
29988         call MPI_Bcast(g_ilist_catpnorm,1,MPI_INT,king,FG_COMM,IERR)
29989 !        write(iout,*) "before bcast",g_ilist_sc
29990 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29991         call MPI_Bcast(newcontlistcatpnormi,g_ilist_catpnorm,MPI_INT,king,FG_COMM,IERR)
29992         call MPI_Bcast(newcontlistcatpnormj,g_ilist_catpnorm,MPI_INT,king,FG_COMM,IERR)
29993
29994
29995
29996         call MPI_Reduce(ilist_catscang,g_ilist_catscang,1,&
29997           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29998 !        write(iout,*) "before bcast",g_ilist_sc
29999         call MPI_Gather(ilist_catscang,1,MPI_INTEGER,&
30000                         i_ilist_catscang,1,MPI_INTEGER,king,FG_COMM,IERR)
30001         displ(0)=0
30002         do i=1,nfgtasks-1,1
30003           displ(i)=i_ilist_catscang(i-1)+displ(i-1)
30004         enddo
30005 !        write(iout,*) "before gather",displ(0),displ(1)
30006         call MPI_Gatherv(contlistcatscangi,ilist_catscang,MPI_INTEGER,&
30007                          newcontlistcatscangi,i_ilist_catscang,displ,MPI_INTEGER,&
30008                          king,FG_COMM,IERR)
30009         call MPI_Gatherv(contlistcatscangj,ilist_catscang,MPI_INTEGER,&
30010                          newcontlistcatscangj,i_ilist_catscang,displ,MPI_INTEGER,&
30011                          king,FG_COMM,IERR)
30012         call MPI_Bcast(g_ilist_catscang,1,MPI_INT,king,FG_COMM,IERR)
30013 !        write(iout,*) "before bcast",g_ilist_sc
30014 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30015         call MPI_Bcast(newcontlistcatscangi,g_ilist_catscang,MPI_INT,king,FG_COMM,IERR)
30016         call MPI_Bcast(newcontlistcatscangj,g_ilist_catscang,MPI_INT,king,FG_COMM,IERR)
30017
30018
30019         else
30020         g_ilist_catscnorm=ilist_catscnorm
30021         g_ilist_catsctran=ilist_catsctran
30022         g_ilist_catpnorm=ilist_catpnorm
30023         g_ilist_catptran=ilist_catptran
30024         g_ilist_catscang=ilist_catscang
30025
30026
30027         do i=1,ilist_catscnorm
30028         newcontlistcatscnormi(i)=contlistcatscnormi(i)
30029         newcontlistcatscnormj(i)=contlistcatscnormj(i)
30030         enddo
30031         do i=1,ilist_catpnorm
30032         newcontlistcatpnormi(i)=contlistcatpnormi(i)
30033         newcontlistcatpnormj(i)=contlistcatpnormj(i)
30034         enddo
30035         do i=1,ilist_catsctran
30036         newcontlistcatsctrani(i)=contlistcatsctrani(i)
30037         newcontlistcatsctranj(i)=contlistcatsctranj(i)
30038         enddo
30039         do i=1,ilist_catptran
30040         newcontlistcatptrani(i)=contlistcatptrani(i)
30041         newcontlistcatptranj(i)=contlistcatptranj(i)
30042         enddo
30043
30044         do i=1,ilist_catscang
30045         newcontlistcatscangi(i)=contlistcatscangi(i)
30046         newcontlistcatscangj(i)=contlistcatscangj(i)
30047         enddo
30048
30049
30050         endif
30051         call int_bounds(g_ilist_catsctran,g_listcatsctran_start,g_listcatsctran_end)
30052         call int_bounds(g_ilist_catptran,g_listcatptran_start,g_listcatptran_end)
30053         call int_bounds(g_ilist_catscnorm,g_listcatscnorm_start,g_listcatscnorm_end)
30054         call int_bounds(g_ilist_catpnorm,g_listcatpnorm_start,g_listcatpnorm_end)
30055         call int_bounds(g_ilist_catscang,g_listcatscang_start,g_listcatscang_end)
30056 ! make new ang list
30057         ilist_catscangf=0
30058         do i=g_listcatscang_start,g_listcatscang_end
30059          do j=2,g_ilist_catscang
30060 !          print *,"RWA",i,j,contlistcatscangj(i),contlistcatscangj(j)
30061           if (j.le.i) cycle
30062           if (newcontlistcatscangj(i).ne.newcontlistcatscangj(j)) cycle
30063                    ilist_catscangf=ilist_catscangf+1
30064                    contlistcatscangfi(ilist_catscangf)=newcontlistcatscangi(i)
30065                    contlistcatscangfj(ilist_catscangf)=newcontlistcatscangj(i)
30066                    contlistcatscangfk(ilist_catscangf)=newcontlistcatscangi(j)
30067 !          print *,"TUTU",g_listcatscang_start,g_listcatscang_end,i,j,g_ilist_catscangf,myrank
30068          enddo
30069         enddo
30070       if (nfgtasks.gt.1)then
30071
30072         call MPI_Reduce(ilist_catscangf,g_ilist_catscangf,1,&
30073           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30074 !        write(iout,*) "before bcast",g_ilist_sc
30075         call MPI_Gather(ilist_catscangf,1,MPI_INTEGER,&
30076                         i_ilist_catscangf,1,MPI_INTEGER,king,FG_COMM,IERR)
30077         displ(0)=0
30078         do i=1,nfgtasks-1,1
30079           displ(i)=i_ilist_catscangf(i-1)+displ(i-1)
30080         enddo
30081 !        write(iout,*) "before gather",displ(0),displ(1)
30082         call MPI_Gatherv(contlistcatscangfi,ilist_catscangf,MPI_INTEGER,&
30083                          newcontlistcatscangfi,i_ilist_catscangf,displ,MPI_INTEGER,&
30084                          king,FG_COMM,IERR)
30085         call MPI_Gatherv(contlistcatscangfj,ilist_catscangf,MPI_INTEGER,&
30086                          newcontlistcatscangfj,i_ilist_catscangf,displ,MPI_INTEGER,&
30087                          king,FG_COMM,IERR)
30088         call MPI_Gatherv(contlistcatscangfk,ilist_catscangf,MPI_INTEGER,&
30089                          newcontlistcatscangfk,i_ilist_catscangf,displ,MPI_INTEGER,&
30090                          king,FG_COMM,IERR)
30091
30092         call MPI_Bcast(g_ilist_catscangf,1,MPI_INT,king,FG_COMM,IERR)
30093 !        write(iout,*) "before bcast",g_ilist_sc
30094 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30095         call MPI_Bcast(newcontlistcatscangfi,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR)
30096         call MPI_Bcast(newcontlistcatscangfj,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR)
30097         call MPI_Bcast(newcontlistcatscangfk,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR)
30098         else
30099         g_ilist_catscangf=ilist_catscangf
30100         do i=1,ilist_catscangf
30101         newcontlistcatscangfi(i)=contlistcatscangfi(i)
30102         newcontlistcatscangfj(i)=contlistcatscangfj(i)
30103         newcontlistcatscangfk(i)=contlistcatscangfk(i)
30104         enddo
30105         endif
30106         call int_bounds(g_ilist_catscangf,g_listcatscangf_start,g_listcatscangf_end)
30107
30108
30109         ilist_catscangt=0
30110         do i=g_listcatscang_start,g_listcatscang_end
30111          do j=1,g_ilist_catscang
30112          do k=1,g_ilist_catscang
30113 !          print *,"TUTU1",g_listcatscang_start,g_listcatscang_end,i,j
30114
30115           if (newcontlistcatscangj(i).ne.newcontlistcatscangj(j)) cycle
30116           if (newcontlistcatscangj(i).ne.newcontlistcatscangj(k)) cycle
30117           if (newcontlistcatscangj(k).ne.newcontlistcatscangj(j)) cycle
30118           if (newcontlistcatscangi(i).eq.newcontlistcatscangi(j)) cycle
30119           if (newcontlistcatscangi(i).eq.newcontlistcatscangi(k)) cycle
30120           if (newcontlistcatscangi(k).eq.newcontlistcatscangi(j)) cycle
30121 !          print *,"TUTU2",g_listcatscang_start,g_listcatscang_end,i,j
30122
30123                    ilist_catscangt=ilist_catscangt+1
30124                    contlistcatscangti(ilist_catscangt)=newcontlistcatscangi(i)
30125                    contlistcatscangtj(ilist_catscangt)=newcontlistcatscangj(i)
30126                    contlistcatscangtk(ilist_catscangt)=newcontlistcatscangi(j)
30127                    contlistcatscangtl(ilist_catscangt)=newcontlistcatscangi(k)
30128
30129          enddo
30130         enddo
30131        enddo
30132       if (nfgtasks.gt.1)then
30133
30134         call MPI_Reduce(ilist_catscangt,g_ilist_catscangt,1,&
30135           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30136 !        write(iout,*) "before bcast",g_ilist_sc
30137         call MPI_Gather(ilist_catscangt,1,MPI_INTEGER,&
30138                         i_ilist_catscangt,1,MPI_INTEGER,king,FG_COMM,IERR)
30139         displ(0)=0
30140         do i=1,nfgtasks-1,1
30141           displ(i)=i_ilist_catscangt(i-1)+displ(i-1)
30142         enddo
30143 !        write(iout,*) "before gather",displ(0),displ(1)
30144         call MPI_Gatherv(contlistcatscangti,ilist_catscangt,MPI_INTEGER,&
30145                          newcontlistcatscangti,i_ilist_catscangt,displ,MPI_INTEGER,&
30146                          king,FG_COMM,IERR)
30147         call MPI_Gatherv(contlistcatscangtj,ilist_catscangt,MPI_INTEGER,&
30148                          newcontlistcatscangtj,i_ilist_catscangt,displ,MPI_INTEGER,&
30149                          king,FG_COMM,IERR)
30150         call MPI_Gatherv(contlistcatscangtk,ilist_catscangt,MPI_INTEGER,&
30151                          newcontlistcatscangtk,i_ilist_catscangt,displ,MPI_INTEGER,&
30152                          king,FG_COMM,IERR)
30153         call MPI_Gatherv(contlistcatscangtl,ilist_catscangt,MPI_INTEGER,&
30154                          newcontlistcatscangtl,i_ilist_catscangt,displ,MPI_INTEGER,&
30155                          king,FG_COMM,IERR)
30156
30157         call MPI_Bcast(g_ilist_catscangt,1,MPI_INT,king,FG_COMM,IERR)
30158 !        write(iout,*) "before bcast",g_ilist_sc
30159 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30160         call MPI_Bcast(newcontlistcatscangti,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30161         call MPI_Bcast(newcontlistcatscangtj,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30162         call MPI_Bcast(newcontlistcatscangtk,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30163         call MPI_Bcast(newcontlistcatscangtl,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30164
30165         else
30166         g_ilist_catscangt=ilist_catscangt
30167         do i=1,ilist_catscangt
30168         newcontlistcatscangti(i)=contlistcatscangti(i)
30169         newcontlistcatscangtj(i)=contlistcatscangtj(i)
30170         newcontlistcatscangtk(i)=contlistcatscangtk(i)
30171         newcontlistcatscangtl(i)=contlistcatscangtl(i)
30172         enddo
30173         endif
30174         call int_bounds(g_ilist_catscangt,g_listcatscangt_start,g_listcatscangt_end)
30175
30176
30177
30178
30179
30180 #ifdef DEBUG
30181       write (iout,*) "after MPIREDUCE",ilist_catsctran,ilist_catptran, &
30182       ilist_catscnorm,ilist_catpnorm
30183
30184       do i=1,g_ilist_catsctran
30185       write (iout,*) i,newcontlistcatsctrani(i),newcontlistcatsctranj(i)
30186       enddo
30187       do i=1,g_ilist_catptran
30188       write (iout,*) i,newcontlistcatptrani(i),newcontlistcatsctranj(i)
30189       enddo
30190       do i=1,g_ilist_catscnorm
30191       write (iout,*) i,newcontlistcatscnormi(i),newcontlistcatscnormj(i)
30192       enddo
30193       do i=1,g_ilist_catpnorm
30194       write (iout,*) i,newcontlistcatpnormi(i),newcontlistcatscnormj(i)
30195       enddo
30196       do i=1,g_ilist_catscang
30197       write (iout,*) i,newcontlistcatscangi(i),newcontlistcatscangj(i)
30198       enddo
30199 #endif
30200       return
30201       end subroutine make_cat_pep_list
30202
30203       subroutine make_cat_cat_list
30204       include 'mpif.h'
30205       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
30206       real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
30207       real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
30208       real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
30209       real(kind=8) :: xja,yja,zja
30210       integer,dimension(:),allocatable:: contlistcatpnormi,contlistcatpnormj
30211 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
30212       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_catscnorm,&
30213               ilist_catsctran,ilist_catpnorm,ilist_catptran,itmp,ilist_catscang,&
30214               ilist_catscangf,ilist_catscangt,k
30215       integer displ(0:nprocs),i_ilist_catscnorm(0:nprocs),ierr,&
30216              i_ilist_catpnorm(0:nprocs),i_ilist_catsctran(0:nprocs),&
30217              i_ilist_catptran(0:nprocs),i_ilist_catscang(0:nprocs),&
30218              i_ilist_catscangf(0:nprocs),i_ilist_catscangt(0:nprocs)
30219             write(iout,*),"START make_catcat"
30220             ilist_catpnorm=0
30221             ilist_catscnorm=0
30222             ilist_catptran=0
30223             ilist_catsctran=0
30224             ilist_catscang=0
30225
30226       if (.not.allocated(contlistcatpnormi)) then
30227        allocate(contlistcatpnormi(900*nres))
30228        allocate(contlistcatpnormj(900*nres))
30229       endif
30230       r_buff_list=3.0
30231       itmp=0
30232       do i=1,4
30233       itmp=itmp+nres_molec(i)
30234       enddo
30235 !        go to 17
30236 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
30237       do i=icatb_start,icatb_end
30238       xi=c(1,i)
30239       yi=c(2,i)
30240       zi=c(3,i)
30241       call to_box(xi,yi,zi)
30242       dxi=dc_norm(1,i)
30243       dyi=dc_norm(2,i)
30244       dzi=dc_norm(3,i)
30245 !      dsci_inv=vbld_inv(i+nres)
30246        do j=i+1,itmp+nres_molec(5)
30247           dxj=dc(1,j)
30248           dyj=dc(2,j)
30249           dzj=dc(3,j)
30250           dx_normj=dc_norm(1,j)
30251           dy_normj=dc_norm(2,j)
30252           dz_normj=dc_norm(3,j)
30253           xj=c(1,j)
30254           yj=c(2,j)
30255           zj=c(3,j)
30256           call to_box(xj,yj,zj)
30257 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
30258 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
30259           xja=boxshift(xj-xi,boxxsize)
30260           yja=boxshift(yj-yi,boxysize)
30261           zja=boxshift(zj-zi,boxzsize)
30262           dist_init=xja**2+yja**2+zja**2
30263       if (sqrt(dist_init).le.(10.0+r_buff_list)) then
30264 ! Here the list is created
30265 !                 if (i.eq.2) then
30266 !                 print *,i,j,dist_init,ilist_catpnorm
30267 !                 endif
30268                  ilist_catpnorm=ilist_catpnorm+1
30269
30270 ! this can be substituted by cantor and anti-cantor
30271                  contlistcatpnormi(ilist_catpnorm)=i
30272                  contlistcatpnormj(ilist_catpnorm)=j
30273        endif
30274 !             enddo
30275              enddo
30276              enddo
30277 #ifdef DEBUG
30278       write (iout,*) "before MPIREDUCE",ilist_catsctran,ilist_catptran,&
30279       ilist_catscnorm,ilist_catpnorm,ilist_catscang
30280
30281       do i=1,ilist_catpnorm
30282       write (iout,*) i,contlistcatpnormi(i)
30283       enddo
30284
30285
30286 #endif
30287       if (nfgtasks.gt.1)then
30288
30289         call MPI_Reduce(ilist_catpnorm,g_ilist_catcatnorm,1,&
30290           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30291 !        write(iout,*) "before bcast",g_ilist_sc
30292         call MPI_Gather(ilist_catpnorm,1,MPI_INTEGER,&
30293                         i_ilist_catpnorm,1,MPI_INTEGER,king,FG_COMM,IERR)
30294         displ(0)=0
30295         do i=1,nfgtasks-1,1
30296           displ(i)=i_ilist_catpnorm(i-1)+displ(i-1)
30297         enddo
30298 !        write(iout,*) "before gather",displ(0),displ(1)
30299         call MPI_Gatherv(contlistcatpnormi,ilist_catpnorm,MPI_INTEGER,&
30300                          newcontlistcatcatnormi,i_ilist_catpnorm,displ,MPI_INTEGER,&
30301                          king,FG_COMM,IERR)
30302         call MPI_Gatherv(contlistcatpnormj,ilist_catpnorm,MPI_INTEGER,&
30303                          newcontlistcatcatnormj,i_ilist_catpnorm,displ,MPI_INTEGER,&
30304                          king,FG_COMM,IERR)
30305         call MPI_Bcast(g_ilist_catcatnorm,1,MPI_INT,king,FG_COMM,IERR)
30306 !        write(iout,*) "before bcast",g_ilist_sc
30307 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30308         call MPI_Bcast(newcontlistcatcatnormi,g_ilist_catcatnorm,MPI_INT,king,FG_COMM,IERR)
30309         call MPI_Bcast(newcontlistcatcatnormj,g_ilist_catcatnorm,MPI_INT,king,FG_COMM,IERR)
30310
30311
30312         else
30313         g_ilist_catcatnorm=ilist_catpnorm
30314         do i=1,ilist_catpnorm
30315         newcontlistcatcatnormi(i)=contlistcatpnormi(i)
30316         newcontlistcatcatnormj(i)=contlistcatpnormj(i)
30317         enddo
30318         endif
30319         call int_bounds(g_ilist_catcatnorm,g_listcatcatnorm_start,g_listcatcatnorm_end)
30320
30321 #ifdef DEBUG
30322       write (iout,*) "after MPIREDUCE",g_ilist_catcatnorm
30323
30324       do i=1,g_ilist_catcatnorm
30325       write (iout,*) i,newcontlistcatcatnormi(i),newcontlistcatcatnormj(i)
30326       enddo
30327 #endif
30328             write(iout,*),"END make_catcat"
30329       return
30330       end subroutine make_cat_cat_list
30331
30332
30333 !-----------------------------------------------------------------------------
30334       double precision function boxshift(x,boxsize)
30335       implicit none
30336       double precision x,boxsize
30337       double precision xtemp
30338       xtemp=dmod(x,boxsize)
30339       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
30340         boxshift=xtemp-boxsize
30341       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
30342         boxshift=xtemp+boxsize
30343       else
30344         boxshift=xtemp
30345       endif
30346       return
30347       end function boxshift
30348 !-----------------------------------------------------------------------------
30349       subroutine to_box(xi,yi,zi)
30350       implicit none
30351 !      include 'DIMENSIONS'
30352 !      include 'COMMON.CHAIN'
30353       double precision xi,yi,zi
30354       xi=dmod(xi,boxxsize)
30355       if (xi.lt.0.0d0) xi=xi+boxxsize
30356       yi=dmod(yi,boxysize)
30357       if (yi.lt.0.0d0) yi=yi+boxysize
30358       zi=dmod(zi,boxzsize)
30359       if (zi.lt.0.0d0) zi=zi+boxzsize
30360       return
30361       end subroutine to_box
30362 !--------------------------------------------------------------------------
30363       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
30364       implicit none
30365 !      include 'DIMENSIONS'
30366 !      include 'COMMON.IOUNITS'
30367 !      include 'COMMON.CHAIN'
30368       double precision xi,yi,zi,sslipi,ssgradlipi
30369       double precision fracinbuf
30370 !      double precision sscalelip,sscagradlip
30371 #ifdef DEBUG
30372       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
30373       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
30374       write (iout,*) "xi yi zi",xi,yi,zi
30375 #endif
30376       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
30377 ! the energy transfer exist
30378         if (zi.lt.buflipbot) then
30379 ! what fraction I am in
30380           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
30381 ! lipbufthick is thickenes of lipid buffore
30382           sslipi=sscalelip(fracinbuf)
30383           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
30384         elseif (zi.gt.bufliptop) then
30385           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
30386           sslipi=sscalelip(fracinbuf)
30387           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
30388         else
30389           sslipi=1.0d0
30390           ssgradlipi=0.0
30391         endif
30392       else
30393         sslipi=0.0d0
30394         ssgradlipi=0.0
30395       endif
30396 #ifdef DEBUG
30397       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
30398 #endif
30399       return
30400       end subroutine lipid_layer
30401 !-------------------------------------------------------------
30402       subroutine ecat_prot_transition(ecation_prottran)
30403       integer:: itypi,itypj,ityptrani,ityptranj,k,l,i,j
30404       real(kind=8),dimension(3):: cjtemp,citemp,diff,dsctemp,vecsc,&
30405                   diffnorm,boxx,r,dEvan1Cm,dEvan2Cm,dEtotalCm
30406       real(kind=8):: ecation_prottran,dista,sdist,De,ene,x0left,&
30407                     alphac,grad,sumvec,simplesum,pom,erdxi,facd1,&
30408                     sss_ele_cut,sss_ele_cut_grad,sss2min,sss2mingrad,&
30409                     ene1,ene2,grad1,grad2,evan1,evan2,rcal,r4,r7,r0p,&
30410                     r06,r012,epscalc,rocal,ract
30411       ecation_prottran=0.0d0
30412       boxx(1)=boxxsize
30413       boxx(2)=boxysize
30414       boxx(3)=boxzsize
30415       do k=g_listcatsctran_start,g_listcatsctran_end
30416         i=newcontlistcatsctrani(k)
30417         j=newcontlistcatsctranj(k)
30418 !        print *,i,j,"in new tran"
30419         do  l=1,3
30420           citemp(l)=c(l,i+nres)
30421           cjtemp(l)=c(l,j)
30422          enddo
30423
30424          itypi=itype(i,1) !as the first is the protein part
30425          itypj=itype(j,5) !as the second part is always cation
30426 ! remapping to internal types
30427 !       read (iiontran,*,err=123,end=123) (agamacattran(k,j,i),k=1,3),&
30428 !       (athetacattran(k,j,i),k=1,6),acatshiftdsc(j,i),bcatshiftdsc(j,i),&
30429 !       demorsecat(j,i),alphamorsecat(j,i),x0catleft(j,i),x0catright(j,i),&
30430 !       x0cattrans(j,i)
30431
30432          if (itypj.eq.6) then
30433           ityptranj=1 !as now only Zn2+ is this needs to be modified for other ions
30434          endif
30435          if (itypi.eq.16) then
30436           ityptrani=1
30437          elseif (itypi.eq.1)  then
30438           ityptrani=2
30439          elseif (itypi.eq.15) then
30440           ityptrani=3
30441          elseif (itypi.eq.17) then
30442           ityptrani=4
30443          elseif (itypi.eq.2)  then
30444           ityptrani=5
30445          else
30446           ityptrani=6
30447          endif
30448
30449          if (ityptrani.gt.ntrantyp(ityptranj)) then
30450 !         do l=1,3
30451 !         write(iout,*),gradcattranc(l,j),gradcattranx(l,i)
30452 !         enddo
30453 !volume excluded
30454          call to_box(cjtemp(1),cjtemp(2),cjtemp(3))
30455          call to_box(citemp(1),citemp(2),citemp(3))
30456          rcal=0.0d0
30457          do l=1,3
30458          r(l)=boxshift(cjtemp(l)-citemp(l),boxx(l))
30459          rcal=rcal+r(l)*r(l)
30460          enddo
30461          ract=sqrt(rcal)
30462          if (ract.gt.r_cut_ele) cycle
30463          sss_ele_cut=sscale_ele(ract)
30464          sss_ele_cut_grad=sscagrad_ele(ract)
30465           rocal=1.5
30466           epscalc=0.2
30467           r0p=0.5*(rocal+sig0(itype(i,1)))
30468           r06 = r0p**6
30469           r012 = r06*r06
30470           Evan1=epscalc*(r012/rcal**6)
30471           Evan2=epscalc*2*(r06/rcal**3)
30472           r4 = rcal**4
30473           r7 = rcal**7
30474           do l=1,3
30475             dEvan1Cm(l) = 12*r(l)*epscalc*r012/r7
30476             dEvan2Cm(l) = 12*r(l)*epscalc*r06/r4
30477           enddo
30478           do l=1,3
30479             dEtotalCm(l)=(dEvan1Cm(l)+dEvan2Cm(l))*sss_ele_cut-&
30480                          (Evan1+Evan2)*sss_ele_cut_grad*r(l)/ract
30481           enddo
30482              ecation_prottran = ecation_prottran+&
30483              (Evan1+Evan2)*sss_ele_cut
30484           do  l=1,3
30485             gradcattranx(l,i)=gradcattranx(l,i)+dEtotalCm(l)
30486             gradcattranc(l,i)=gradcattranc(l,i)+dEtotalCm(l)
30487             gradcattranc(l,j)=gradcattranc(l,j)-dEtotalCm(l)
30488            enddo
30489
30490          ene=0.0d0
30491          else
30492 !         cycle
30493          sumvec=0.0d0
30494          simplesum=0.0d0
30495          do l=1,3
30496          vecsc(l)=citemp(l)-c(l,i)
30497          sumvec=sumvec+vecsc(l)**2
30498          simplesum=simplesum+vecsc(l)
30499          enddo
30500          sumvec=dsqrt(sumvec)
30501          call to_box(cjtemp(1),cjtemp(2),cjtemp(3))
30502          call to_box(citemp(1),citemp(2),citemp(3))
30503 !         sumvec=2.0d0
30504          do l=1,3
30505          dsctemp(l)=c(l,i+nres)&
30506                     +(acatshiftdsc(ityptrani,ityptranj)-1.0d0)*vecsc(l)&
30507                     +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec
30508          enddo
30509          call to_box(dsctemp(1),dsctemp(2),dsctemp(3))
30510          sdist=0.0d0
30511          do l=1,3
30512             diff(l)=boxshift(dsctemp(l)-cjtemp(l),boxx(l))
30513            sdist=sdist+diff(l)*diff(l)
30514          enddo
30515          dista=sqrt(sdist)
30516          if (dista.gt.r_cut_ele) cycle
30517
30518          sss_ele_cut=sscale_ele(dista)
30519          sss_ele_cut_grad=sscagrad_ele(dista)
30520          sss2min=sscale2(dista,x0cattrans(ityptrani,ityptranj)-0.1d0,0.2d0)
30521          De=demorsecat(ityptrani,ityptranj)
30522          alphac=alphamorsecat(ityptrani,ityptranj)
30523          if (sss2min.eq.1.0d0) then
30524 !         print *,"ityptrani",ityptrani,ityptranj
30525          x0left=x0catleft(ityptrani,ityptranj) ! to mn
30526          ene=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30527          grad=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30528               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30529               +ene/sss_ele_cut*sss_ele_cut_grad
30530           else if (sss2min.eq.0.0d0) then
30531          x0left=x0catright(ityptrani,ityptranj)
30532          ene=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30533          grad=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30534               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30535               +ene/sss_ele_cut*sss_ele_cut_grad
30536           else
30537          sss2mingrad=sscagrad2(dista,x0cattrans(ityptrani,ityptranj)-0.1d0,0.2d0)
30538          x0left=x0catleft(ityptrani,ityptranj)
30539          ene1=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30540          grad1=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30541               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30542               +ene/sss_ele_cut*sss_ele_cut_grad
30543          x0left=x0catright(ityptrani,ityptranj)
30544          ene2=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30545          grad2=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30546               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30547               +ene/sss_ele_cut*sss_ele_cut_grad
30548          ene=sss2min*ene1+(1.0d0-sss2min)*ene2
30549          grad=sss2min*grad1+(1.0d0-sss2min)*grad2+sss2mingrad*(ene1-ene2)
30550          endif
30551          do l=1,3
30552            diffnorm(l)= diff(l)/dista
30553           enddo
30554           erdxi=scalar(diffnorm(1),dc_norm(1,i+nres))
30555           facd1=bcatshiftdsc(ityptrani,ityptranj)/sumvec
30556
30557          do l=1,3
30558 !       DO k= 1, 3
30559 !      ertail(k) = Rtail_distance(k)/Rtail
30560 !       END DO
30561 !       erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
30562 !       erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
30563 !      facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
30564 !       facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
30565 !       DO k = 1, 3
30566 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
30567 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
30568 !      pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
30569 !      gvdwx(k,i) = gvdwx(k,i) &
30570 !              - (( dFdR + gg(k) ) * pom)
30571          pom=diffnorm(l)+facd1*(diffnorm(l)-erdxi*dc_norm(l,i+nres))
30572 !         write(iout,*),gradcattranc(l,j),gradcattranx(l,i),grad*diff(l)/dista
30573
30574          gradcattranx(l,i)=gradcattranx(l,i)+grad*pom&
30575          +grad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0)
30576 !         *( bcatshiftdsc(ityptrani,ityptranj)*&
30577 !          (1.0d0/sumvec-(vecsc(l)*simplesum)*(sumvec**(-3.0d0))))
30578          gradcattranc(l,i)=gradcattranc(l,i)+grad*diff(l)/dista
30579 !                          +sss_ele_cut_grad*ene*diff(l)/dista/sss_ele_cut
30580          gradcattranc(l,j)=gradcattranc(l,j)-grad*diff(l)/dista
30581 !         -sss_ele_cut_grad*ene*diff(l)/dista/sss_ele_cut
30582          enddo
30583          ecation_prottran=ecation_prottran+ene
30584          if (energy_dec) write(iout,*) "etrancat",i,j,ene,x0left,De,dista,&
30585          alphac
30586          endif
30587       enddo
30588 !      do k=g_listcatptran_start,g_listcatptran_end
30589 !      ene=0.0d0 this will be used if peptide group interaction is needed
30590 !      enddo
30591
30592
30593       return
30594       end subroutine
30595       subroutine ecat_prot_ang(ecation_protang)
30596       integer:: itypi,itypj,ityptrani,ityptranj,k,l,i,j,n,m,&
30597                 ityptrani1,ityptranj1,ityptrani2,ityptranj2,&
30598                 i1,i2,j1,j2,k1,k2,k3,i3,j3,ityptrani3,ityptranj3
30599
30600       real(kind=8),dimension(3):: cjtemp,citemp,diff,dsctemp,vecsc,&
30601                   diffnorm,boxx,dscvec,dscvecnorm,diffnorm2,&
30602                   dscvec2,dscvecnorm2,cjtemp2,citemp2,diff2,dsctemp2,&
30603                   vecsc2,diff1,diffnorm1,diff3,mindiffnorm2
30604       real(kind=8),dimension(3):: dscvec1,dscvecnorm1,cjtemp1,citemp1,vecsc1,dsctemp1,&
30605                   dscvec3,dscvecnorm3,cjtemp3,citemp3,vecsc3,dsctemp3,&
30606                   diffnorm3,diff4,diffnorm4
30607
30608       real(kind=8):: ecation_protang,dista,sdist,De,ene,x0left,&
30609                     alphac,grad,sumvec,sumdscvec,pom,erdxi,facd1,&
30610                     sss_ele_cut,sss_ele_cut_grad,sss2min,sss2mingrad,&
30611                     simplesum,cosval,part1,part2a,part2,part2b,part3,&
30612                     part4a,part4b,part4,bottom,dista2,sdist2,sumvec2,&
30613                     sumdscvec2,simplesum2,dista1,sdist1,sumvec1,simplesum1,&
30614                     sumdscvec1,facd2,scal1a,scal1b,scal2a,scal2b,&
30615                     sss2mingrad1,sss2mingrad2,sss2min1,sss2min2,pom1,pom2,&
30616                     det1ij,det2ij,cosom1,cosom2,cosom12,cosphij,dista3,&
30617                     sumvec3
30618       real(kind=8):: sinom1,sinom2,sinaux,dephiij,sumdscvec3,sumscvec3,&
30619                      cosphi,sdist3,simplesum3,det1t2ij,sss2mingrad3,sss2min3,&
30620                      scal1c,scal2c,scal3a,scal3b,scal3c,facd3,facd2b,scal3d,&
30621                      scal3e,dista4,sdist4,pom3,sssmintot
30622
30623       ecation_protang=0.0d0
30624       boxx(1)=boxxsize
30625       boxx(2)=boxysize
30626       boxx(3)=boxzsize
30627 !      print *,"KUR**3",g_listcatscang_start,g_listcatscang_end
30628 !      go to 19
30629 !      go to 21
30630       do k=g_listcatscang_start,g_listcatscang_end
30631         ene=0.0d0
30632         i=newcontlistcatscangi(k)
30633         j=newcontlistcatscangj(k)
30634          itypi=itype(i,1) !as the first is the protein part
30635          itypj=itype(j,5) !as the second part is always cation
30636 !         print *,"KUR**4",i,j,itypi,itypj
30637 ! remapping to internal types
30638 !       read (iiontran,*,err=123,end=123) (agamacattran(k,j,i),k=1,3),&
30639 !       (athetacattran(k,j,i),k=1,6),acatshiftdsc(j,i),bcatshiftdsc(j,i),&
30640 !       demorsecat(j,i),alphamorsecat(j,i),x0catleft(j,i),x0catright(j,i),&
30641 !       x0cattrans(j,i)
30642          if (itypj.eq.6) then
30643           ityptranj=1 !as now only Zn2+ is this needs to be modified for other ions
30644          endif
30645          if (itypi.eq.16) then
30646           ityptrani=1
30647          elseif (itypi.eq.1)  then
30648           ityptrani=2
30649          elseif (itypi.eq.15) then
30650           ityptrani=3
30651          elseif (itypi.eq.17) then
30652           ityptrani=4
30653          elseif (itypi.eq.2)  then
30654           ityptrani=5
30655          else
30656           ityptrani=6
30657          endif
30658          if (ityptrani.gt.ntrantyp(ityptranj)) cycle
30659          do  l=1,3
30660           citemp(l)=c(l,i+nres)
30661           cjtemp(l)=c(l,j)
30662          enddo
30663          sumvec=0.0d0
30664          simplesum=0.0d0
30665          do l=1,3
30666          vecsc(l)=citemp(l)-c(l,i)
30667          sumvec=sumvec+vecsc(l)**2
30668          simplesum=simplesum+vecsc(l)
30669          enddo
30670          sumvec=dsqrt(sumvec)
30671          sumdscvec=0.0d0
30672         do l=1,3
30673           dsctemp(l)=c(l,i)&
30674 !                     +1.0d0
30675                     +(acatshiftdsc(ityptrani,ityptranj))*vecsc(l)&
30676                     +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec
30677           dscvec(l)= &
30678 !1.0d0
30679                      (acatshiftdsc(ityptrani,ityptranj))*vecsc(l)&
30680                     +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec
30681           sumdscvec=sumdscvec+dscvec(l)**2
30682          enddo
30683          sumdscvec=dsqrt(sumdscvec)
30684          do l=1,3
30685          dscvecnorm(l)=dscvec(l)/sumdscvec
30686          enddo
30687          call to_box(dsctemp(1),dsctemp(2),dsctemp(3))
30688          call to_box(cjtemp(1),cjtemp(2),cjtemp(3))
30689          sdist=0.0d0
30690           do l=1,3
30691             diff(l)=boxshift(dsctemp(l)-cjtemp(l),boxx(l))
30692             sdist=sdist+diff(l)*diff(l)
30693          enddo
30694          dista=sqrt(sdist)
30695          do l=1,3
30696          diffnorm(l)= diff(l)/dista
30697          enddo
30698          cosval=scalar(diffnorm(1),dc_norm(1,i+nres))
30699          grad=0.0d0
30700          sss2min=sscale2(dista,r_cut_ang,1.0d0)
30701          sss2mingrad=sscagrad2(dista,r_cut_ang,1.0d0)
30702          ene=ene&
30703          +tschebyshev(1,6,athetacattran(1,ityptrani,ityptranj),cosval)
30704          grad=gradtschebyshev(0,5,athetacattran(1,ityptrani,ityptranj),cosval)*sss2min
30705
30706          facd1=bcatshiftdsc(ityptrani,ityptranj)/sumvec
30707          erdxi=scalar(diffnorm(1),dc_norm(1,i+nres))
30708          part1=0.0d0
30709          part2=0.0d0
30710          part3=0.0d0
30711          part4=0.0d0
30712          do l=1,3
30713          bottom=sumvec**2*sdist
30714          part1=diff(l)*sumvec*dista
30715          part2a=(acatshiftdsc(ityptrani,ityptranj))*vecsc(l)
30716          part2b=0.0d0
30717          !bcatshiftdsc(ityptrani,ityptranj)/sumvec*&
30718          !(vecsc(l)-cosval*dista*dc_norm(l,i+nres))
30719          part2=(part2a+part2b)*sumvec*dista
30720          part3=cosval*sumvec*dista*dc_norm(l,i+nres)*dista
30721          part4a=diff(l)*acatshiftdsc(ityptrani,ityptranj)
30722          part4b=bcatshiftdsc(ityptrani,ityptranj)/sumvec*&
30723          (diff(l)-cosval*dista*dc_norm(l,i+nres))
30724          part4=cosval*sumvec*(part4a+part4b)*sumvec
30725 !      gradlipang(m,l)=gradlipang(m,l)+(fac &
30726 !       *(xa(m)-scalar*vnorm*xb(m)/wnorm)&
30727 !       /(vnorm*wnorm))
30728
30729 !       DO k= 1, 3
30730 !      ertail(k) = Rtail_distance(k)/Rtail
30731 !       END DO
30732 !       erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
30733 !       erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
30734 !      facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
30735 !       facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
30736 !       DO k = 1, 3
30737 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
30738 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
30739 !      pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
30740 !      gvdwx(k,i) = gvdwx(k,i) &
30741 !              - (( dFdR + gg(k) ) * pom)
30742          pom=diffnorm(l)+facd1*(diffnorm(l)-erdxi*dc_norm(l,i+nres))
30743
30744          gradcatangc(l,j)=gradcatangc(l,j)-grad*&
30745          (dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)-&
30746          ene*sss2mingrad*diffnorm(l)
30747
30748          gradcatangc(l,i)=gradcatangc(l,i)+grad*&
30749          (dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)+&
30750          ene*sss2mingrad*diffnorm(l)
30751
30752          gradcatangx(l,i)=gradcatangx(l,i)+grad*&
30753          (part1+part2-part3-part4)/bottom+&
30754          ene*sss2mingrad*pom+&
30755          ene*sss2mingrad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0)
30756 !         +grad*(dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)&
30757 !         +grad*pom+grad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0)
30758 !&
30759 !         (diff(l)-cosval*dscvecnorm(l)*dista)/(sumdscvec*dista)
30760
30761
30762
30763
30764
30765         enddo
30766 !       print *,i,j,cosval,tschebyshev(1,3,aomicattr(1,ityptranj),cosval)&
30767 !              ,aomicattr(0,ityptranj),ene
30768        if (energy_dec) write(iout,*) i,j,ityptrani,ityptranj,ene,cosval
30769        ecation_protang=ecation_protang+ene*sss2min
30770       enddo
30771  19   continue
30772 !         print *,"KUR**",g_listcatscangf_start,g_listcatscangf_end
30773             do k=g_listcatscangf_start,g_listcatscangf_end
30774         ene=0.0d0
30775         i1=newcontlistcatscangfi(k)
30776         j1=newcontlistcatscangfj(k)
30777          itypi=itype(i1,1) !as the first is the protein part
30778          itypj=itype(j1,5) !as the second part is always cation
30779          if (itypj.eq.6) then
30780           ityptranj1=1 !as now only Zn2+ is this needs to be modified for other ions
30781          endif
30782          if (itypi.eq.16) then
30783           ityptrani1=1
30784          elseif (itypi.eq.1)  then
30785           ityptrani1=2
30786          elseif (itypi.eq.15) then
30787           ityptrani1=3
30788          elseif (itypi.eq.17) then
30789           ityptrani1=4
30790          elseif (itypi.eq.2)  then
30791           ityptrani1=5
30792          else
30793           ityptrani1=6
30794          endif
30795          do  l=1,3
30796           citemp1(l)=c(l,i1+nres)
30797           cjtemp1(l)=c(l,j1)
30798          enddo
30799          sumvec1=0.0d0
30800          simplesum1=0.0d0
30801          do l=1,3
30802          vecsc1(l)=citemp1(l)-c(l,i1)
30803          sumvec1=sumvec1+vecsc1(l)**2
30804          simplesum1=simplesum1+vecsc1(l)
30805          enddo
30806          sumvec1=dsqrt(sumvec1)
30807          sumdscvec1=0.0d0
30808         do l=1,3
30809           dsctemp1(l)=c(l,i1)&
30810 !                     +1.0d0
30811                     +(acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
30812                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
30813           dscvec1(l)= &
30814 !1.0d0
30815                      (acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
30816                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
30817           sumdscvec1=sumdscvec1+dscvec1(l)**2
30818          enddo
30819          sumdscvec1=dsqrt(sumdscvec1)
30820          do l=1,3
30821          dscvecnorm1(l)=dscvec1(l)/sumdscvec1
30822          enddo
30823          call to_box(dsctemp1(1),dsctemp1(2),dsctemp1(3))
30824          call to_box(cjtemp1(1),cjtemp1(2),cjtemp1(3))
30825          sdist1=0.0d0
30826           do l=1,3
30827             diff1(l)=boxshift(dsctemp1(l)-cjtemp1(l),boxx(l))
30828             sdist1=sdist1+diff1(l)*diff1(l)
30829          enddo
30830          dista1=sqrt(sdist1)
30831          do l=1,3
30832          diffnorm1(l)= diff1(l)/dista1
30833          enddo
30834          sss2min1=sscale2(dista1,r_cut_ang,1.0d0)
30835          sss2mingrad1=sscagrad2(dista1,r_cut_ang,1.0d0)
30836          if (ityptrani1.gt.ntrantyp(ityptranj1)) cycle
30837
30838 !-----------------------------------------------------------------
30839 !             do m=k+1,g_listcatscang_end
30840              ene=0.0d0
30841              i2=newcontlistcatscangfk(k)
30842              j2=j1
30843               if (j1.ne.j2) cycle
30844                itypi=itype(i2,1) !as the first is the protein part
30845                itypj=itype(j2,5) !as the second part is always cation
30846               if (itypj.eq.6) then
30847               ityptranj2=1 !as now only Zn2+ is this needs to be modified for other ions
30848               endif
30849              if (itypi.eq.16) then
30850               ityptrani2=1
30851              elseif (itypi.eq.1)  then
30852               ityptrani2=2
30853              elseif (itypi.eq.15) then
30854               ityptrani2=3
30855              elseif (itypi.eq.17) then
30856               ityptrani2=4
30857              elseif (itypi.eq.2)  then
30858               ityptrani2=5
30859              else
30860               ityptrani2=6
30861              endif
30862          if (ityptrani2.gt.ntrantyp(ityptranj2)) cycle
30863
30864            do  l=1,3
30865           citemp2(l)=c(l,i2+nres)
30866           cjtemp2(l)=c(l,j2)
30867          enddo
30868          sumvec2=0.0d0
30869          simplesum2=0.0d0
30870          do l=1,3
30871          vecsc2(l)=citemp2(l)-c(l,i2)
30872          sumvec2=sumvec2+vecsc2(l)**2
30873          simplesum2=simplesum2+vecsc2(l)
30874          enddo
30875          sumvec2=dsqrt(sumvec2)
30876          sumdscvec2=0.0d0
30877         do l=1,3
30878           dsctemp2(l)=c(l,i2)&
30879 !                     +1.0d0
30880                     +(acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
30881                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
30882           dscvec2(l)= &
30883 !1.0d0
30884                      (acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
30885                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
30886           sumdscvec2=sumdscvec2+dscvec2(l)**2
30887          enddo
30888          sumdscvec2=dsqrt(sumdscvec2)
30889          do l=1,3
30890          dscvecnorm2(l)=dscvec2(l)/sumdscvec2
30891          enddo
30892          call to_box(dsctemp2(1),dsctemp2(2),dsctemp2(3))
30893          call to_box(cjtemp2(1),cjtemp2(2),cjtemp2(3))
30894          sdist2=0.0d0
30895           do l=1,3
30896             diff2(l)=boxshift(dsctemp2(l)-cjtemp2(l),boxx(l))
30897 !            diff2(l)=1.0d0
30898             sdist2=sdist2+diff2(l)*diff2(l)
30899          enddo
30900          dista2=sqrt(sdist2)
30901          do l=1,3
30902          diffnorm2(l)= diff2(l)/dista2
30903          enddo
30904 !         print *,i1,i2,diffnorm2(1)
30905          cosval=scalar(diffnorm1(1),diffnorm2(1))
30906          grad=0.0d0
30907          sss2min2=sscale2(dista2,r_cut_ang,1.0d0)
30908          sss2mingrad2=sscagrad2(dista2,r_cut_ang,1.0d0)
30909          ene=ene+tschebyshev(1,3,aomicattr(1,ityptranj1),cosval)
30910          grad=gradtschebyshev(0,2,aomicattr(1,ityptranj1),cosval)*sss2min2*sss2min1
30911          part1=0.0d0
30912          part2=0.0d0
30913          part3=0.0d0
30914          part4=0.0d0
30915          ecation_protang=ecation_protang+ene*sss2min2*sss2min1
30916          facd1=bcatshiftdsc(ityptrani1,ityptranj1)/sumvec1
30917          facd2=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec2
30918          scal1a=scalar(diffnorm1(1),dc_norm(1,i1+nres))
30919          scal1b=scalar(diffnorm2(1),dc_norm(1,i1+nres))
30920          scal2a=scalar(diffnorm1(1),dc_norm(1,i2+nres))
30921          scal2b=scalar(diffnorm2(1),dc_norm(1,i2+nres))
30922
30923        if (energy_dec) write(iout,*) "omi", i,j,ityptrani,ityptranj,ene,cosval,aomicattr(1,ityptranj1),&
30924              aomicattr(2,ityptranj1),aomicattr(3,ityptranj1),tschebyshev(1,3,aomicattr(1,ityptranj1),cosval)
30925
30926 !*sss2min
30927          do l=1,3
30928          pom1=diffnorm1(l)+facd1*(diffnorm1(l)-scal1a*dc_norm(l,i1+nres))
30929          pom2=diffnorm2(l)+facd2*(diffnorm2(l)-scal2b*dc_norm(l,i2+nres))
30930
30931
30932          gradcatangc(l,i1)=gradcatangc(l,i1)+grad*(diff2(l)-&
30933          cosval*diffnorm1(l)*dista2)/(dista2*dista1)+&
30934           ene*sss2mingrad1*diffnorm1(l)*sss2min2
30935
30936
30937          gradcatangx(l,i1)=gradcatangx(l,i1)+grad/(dista2*dista1)*&
30938          (acatshiftdsc(ityptrani1,ityptranj1)*diff2(l)+&
30939          facd1*(diff2(l)-scal1b*dc_norm(l,i1+nres)*dista2)-&
30940          cosval*dista2/dista1*&
30941          (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+&
30942          facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1)))+&
30943          ene*sss2mingrad1*sss2min2*(pom1+&
30944          diffnorm1(l)*(acatshiftdsc(ityptrani1,ityptranj1)-1.0d0))
30945
30946
30947          gradcatangx(l,i2)=gradcatangx(l,i2)+grad/(dista2*dista1)*&
30948          (acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)+&
30949          facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1)-&
30950          cosval*dista1/dista2*&
30951          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&
30952          facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)))+&
30953          ene*sss2mingrad2*sss2min1*(pom2+&
30954          diffnorm2(l)*(acatshiftdsc(ityptrani2,ityptranj2)-1.0d0))
30955
30956
30957          gradcatangx(l,i2)=gradcatangx(l,i2)
30958          gradcatangc(l,i2)=gradcatangc(l,i2)+grad*(diff1(l)-&
30959          cosval*diffnorm2(l)*dista1)/(dista2*dista1)+&
30960           ene*sss2mingrad2*diffnorm2(l)*sss2min1
30961
30962          gradcatangc(l,j2)=gradcatangc(l,j2)-grad*(diff2(l)/dista2/dista1-&
30963          cosval*diff1(l)/dista1/dista1+diff1(l)/dista2/dista1-&
30964          cosval*diff2(l)/dista2/dista2)-&
30965          ene*sss2mingrad1*diffnorm1(l)*sss2min2-&
30966          ene*sss2mingrad2*diffnorm2(l)*sss2min1
30967
30968
30969          enddo
30970
30971               enddo
30972 !            enddo
30973 !#ifdef DUBUG
30974   21  continue
30975 !       do k1=g_listcatscang_start,g_listcatscang_end
30976 !        print *,"KURNA",g_listcatscangt_start,g_listcatscangt_end
30977         do k1=g_listcatscangt_start,g_listcatscangt_end
30978         i1=newcontlistcatscangti(k1)
30979         j1=newcontlistcatscangtj(k1)
30980         itypi=itype(i1,1) !as the first is the protein part
30981         itypj=itype(j1,5) !as the second part is always cation
30982         if (itypj.eq.6) then
30983          ityptranj1=1 !as now only Zn2+ is this needs to be modified for other ions
30984         endif
30985         if (itypi.eq.16) then
30986          ityptrani1=1
30987         elseif (itypi.eq.1)  then
30988          ityptrani1=2
30989         elseif (itypi.eq.15) then
30990          ityptrani1=3
30991         elseif (itypi.eq.17) then
30992          ityptrani1=4
30993         elseif (itypi.eq.2)  then
30994          ityptrani1=5
30995         else
30996          ityptrani1=6
30997         endif
30998         do  l=1,3
30999           citemp1(l)=c(l,i1+nres)
31000           cjtemp1(l)=c(l,j1)
31001         enddo
31002         sumvec1=0.0d0
31003         simplesum1=0.0d0
31004         do l=1,3
31005          vecsc1(l)=citemp1(l)-c(l,i1)
31006          sumvec1=sumvec1+vecsc1(l)**2
31007          simplesum1=simplesum1+vecsc1(l)
31008         enddo
31009         sumvec1=dsqrt(sumvec1)
31010         sumdscvec1=0.0d0
31011         do l=1,3
31012           dsctemp1(l)=c(l,i1)&
31013                     +(acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
31014                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
31015           dscvec1(l)= &
31016                      (acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
31017                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
31018           sumdscvec1=sumdscvec1+dscvec1(l)**2
31019         enddo
31020         sumdscvec1=dsqrt(sumdscvec1)
31021         do l=1,3
31022         dscvecnorm1(l)=dscvec1(l)/sumdscvec1
31023         enddo
31024         call to_box(dsctemp1(1),dsctemp1(2),dsctemp1(3))
31025         call to_box(cjtemp1(1),cjtemp1(2),cjtemp1(3))
31026         sdist1=0.0d0
31027           do l=1,3
31028             diff1(l)=boxshift(dsctemp1(l)-cjtemp1(l),boxx(l))
31029             sdist1=sdist1+diff1(l)*diff1(l)
31030          enddo
31031          dista1=sqrt(sdist1)
31032          do l=1,3
31033          diffnorm1(l)= diff1(l)/dista1
31034          enddo
31035          sss2min1=sscale2(dista1,r_cut_ang,1.0d0)
31036          sss2mingrad1=sscagrad2(dista1,r_cut_ang,1.0d0)
31037          if (ityptrani1.gt.ntrantyp(ityptranj1)) cycle
31038 !---------------before second loop
31039 !        do k2=k1+1,g_listcatscang_end
31040          i2=newcontlistcatscangtk(k1)
31041          j2=j1
31042 !         print *,"TUTU3",i1,i2,j1,j2
31043          if (i2.eq.i1) cycle
31044          if (j2.ne.j1) cycle
31045          itypi=itype(i2,1) !as the first is the protein part
31046          itypj=itype(j2,5) !as the second part is always cation
31047          if (itypj.eq.6) then
31048            ityptranj2=1 !as now only Zn2+ is this needs to be modified for other ions
31049           endif
31050           if (itypi.eq.16) then
31051            ityptrani2=1
31052           elseif (itypi.eq.1)  then
31053            ityptrani2=2
31054           elseif (itypi.eq.15) then
31055            ityptrani2=3
31056           elseif (itypi.eq.17) then
31057            ityptrani2=4
31058           elseif (itypi.eq.2)  then
31059            ityptrani2=5
31060           else
31061            ityptrani2=6
31062           endif
31063           if (ityptrani2.gt.ntrantyp(ityptranj2)) cycle
31064           do  l=1,3
31065            citemp2(l)=c(l,i2+nres)
31066            cjtemp2(l)=c(l,j2)
31067           enddo
31068           sumvec2=0.0d0
31069           simplesum2=0.0d0
31070           do l=1,3
31071            vecsc2(l)=citemp2(l)-c(l,i2)
31072            sumvec2=sumvec2+vecsc2(l)**2
31073            simplesum2=simplesum2+vecsc2(l)
31074           enddo
31075           sumvec2=dsqrt(sumvec2)
31076           sumdscvec2=0.0d0
31077           do l=1,3
31078            dsctemp2(l)=c(l,i2)&
31079                     +(acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
31080                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
31081            dscvec2(l)= &
31082                      (acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
31083                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
31084            sumdscvec2=sumdscvec2+dscvec2(l)**2
31085           enddo
31086           sumdscvec2=dsqrt(sumdscvec2)
31087           do l=1,3
31088            dscvecnorm2(l)=dscvec2(l)/sumdscvec2
31089           enddo
31090           call to_box(dsctemp2(1),dsctemp2(2),dsctemp2(3))
31091           call to_box(cjtemp2(1),cjtemp2(2),cjtemp2(3))
31092          sdist2=0.0d0
31093           do l=1,3
31094             diff2(l)=boxshift(dsctemp2(l)-cjtemp2(l),boxx(l))
31095 !            diff2(l)=1.0d0
31096             sdist2=sdist2+diff2(l)*diff2(l)
31097          enddo
31098          dista2=sqrt(sdist2)
31099          do l=1,3
31100          diffnorm2(l)= diff2(l)/dista2
31101          mindiffnorm2(l)=-diffnorm2(l)
31102          enddo
31103 !         print *,i1,i2,diffnorm2(1)
31104          cosom1=scalar(diffnorm1(1),diffnorm2(1))
31105          sss2min2=sscale2(dista2,r_cut_ang,1.0d0)
31106          sss2mingrad2=sscagrad2(dista2,r_cut_ang,1.0d0)
31107
31108 !---------------- before third loop
31109 !          do k3=g_listcatscang_start,g_listcatscang_end
31110            ene=0.0d0
31111            i3=newcontlistcatscangtl(k1)
31112            j3=j1
31113 !            print *,"TUTU4",i1,i2,i3,j1,j2,j3
31114
31115            if (i3.eq.i2) cycle
31116            if (i3.eq.i1) cycle
31117            if (j3.ne.j1) cycle
31118            itypi=itype(i3,1) !as the first is the protein part
31119            itypj=itype(j3,5) !as the second part is always cation
31120            if (itypj.eq.6) then
31121             ityptranj3=1 !as now only Zn2+ is this needs to be modified for other ions
31122            endif
31123            if (itypi.eq.16) then
31124             ityptrani3=1
31125            elseif (itypi.eq.1)  then
31126             ityptrani3=2
31127            elseif (itypi.eq.15) then
31128             ityptrani3=3
31129            elseif (itypi.eq.17) then
31130             ityptrani3=4
31131            elseif (itypi.eq.2)  then
31132             ityptrani3=5
31133            else
31134             ityptrani3=6
31135            endif
31136            if (ityptrani3.gt.ntrantyp(ityptranj3)) cycle
31137            do  l=1,3
31138             citemp3(l)=c(l,i3+nres)
31139             cjtemp3(l)=c(l,j3)
31140           enddo
31141           sumvec3=0.0d0
31142           simplesum3=0.0d0
31143           do l=1,3
31144            vecsc3(l)=citemp3(l)-c(l,i3)
31145            sumvec3=sumvec3+vecsc3(l)**2
31146            simplesum3=simplesum3+vecsc3(l)
31147           enddo
31148           sumvec3=dsqrt(sumvec3)
31149           sumdscvec3=0.0d0
31150           do l=1,3
31151            dsctemp3(l)=c(l,i3)&
31152                     +(acatshiftdsc(ityptrani3,ityptranj3))*vecsc3(l)&
31153                     +bcatshiftdsc(ityptrani3,ityptranj3)*vecsc3(l)/sumvec3
31154            dscvec3(l)= &
31155                      (acatshiftdsc(ityptrani3,ityptranj3))*vecsc3(l)&
31156                     +bcatshiftdsc(ityptrani3,ityptranj3)*vecsc3(l)/sumvec3
31157            sumdscvec3=sumdscvec3+dscvec3(l)**2
31158           enddo
31159           sumdscvec3=dsqrt(sumdscvec3)
31160           do l=1,3
31161            dscvecnorm3(l)=dscvec3(l)/sumdscvec3
31162           enddo
31163           call to_box(dsctemp3(1),dsctemp3(2),dsctemp3(3))
31164           call to_box(cjtemp3(1),cjtemp3(2),cjtemp3(3))
31165           sdist3=0.0d0
31166           do l=1,3
31167             diff3(l)=boxshift(dsctemp3(l)-dsctemp2(l),boxx(l))
31168             sdist3=sdist3+diff3(l)*diff3(l)
31169          enddo
31170          dista3=sqrt(sdist3)
31171          do l=1,3
31172          diffnorm3(l)= diff3(l)/dista3
31173          enddo
31174          sdist4=0.0d0
31175           do l=1,3
31176             diff4(l)=boxshift(dsctemp3(l)-cjtemp2(l),boxx(l))
31177 !            diff2(l)=1.0d0
31178             sdist4=sdist4+diff4(l)*diff4(l)
31179          enddo
31180          dista4=sqrt(sdist4)
31181          do l=1,3
31182          diffnorm4(l)= diff4(l)/dista4
31183          enddo
31184
31185          sss2min3=sscale2(dista4,r_cut_ang,1.0d0)
31186          sss2mingrad3=sscagrad2(dista4,r_cut_ang,1.0d0)
31187          sssmintot=sss2min3*sss2min2*sss2min1
31188          if (ityptrani3.gt.ntrantyp(ityptranj3)) cycle
31189          cosom12=scalar(diffnorm3(1),diffnorm1(1))
31190          cosom2=scalar(diffnorm3(1),mindiffnorm2(1))
31191          sinom1=dsqrt(1.0d0-cosom1*cosom1)
31192          sinom2=dsqrt(1.0d0-cosom2*cosom2)
31193          cosphi=cosom12-cosom1*cosom2
31194          sinaux=sinom1*sinom2
31195          ene=ene+mytschebyshev(1,3,agamacattran(1,ityptrani2,ityptranj2),cosphi,sinaux)
31196          call mygradtschebyshev(1,3,agamacattran(1,ityptrani2,ityptranj2)&
31197           ,cosphi,sinaux,dephiij,det1t2ij)
31198
31199           det1ij=-det1t2ij*sinom2*cosom1/sinom1-dephiij*cosom2
31200           det2ij=-det1t2ij*sinom1*cosom2/sinom2-dephiij*cosom1
31201           facd1=bcatshiftdsc(ityptrani1,ityptranj1)/sumvec1
31202           facd2=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec2
31203 !          facd2b=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec3
31204           facd3=bcatshiftdsc(ityptrani3,ityptranj3)/sumvec3
31205           scal1a=scalar(diffnorm1(1),dc_norm(1,i1+nres))
31206           scal1b=scalar(diffnorm2(1),dc_norm(1,i1+nres))
31207           scal1c=scalar(diffnorm3(1),dc_norm(1,i1+nres))
31208           scal2a=scalar(diffnorm1(1),dc_norm(1,i2+nres))
31209           scal2b=scalar(diffnorm2(1),dc_norm(1,i2+nres))
31210           scal2c=scalar(diffnorm3(1),dc_norm(1,i2+nres))
31211           scal3a=scalar(diffnorm1(1),dc_norm(1,i3+nres))
31212           scal3b=scalar(mindiffnorm2(1),dc_norm(1,i3+nres))
31213           scal3d=scalar(diffnorm2(1),dc_norm(1,i3+nres))
31214           scal3c=scalar(diffnorm3(1),dc_norm(1,i3+nres))
31215           scal3e=scalar(diffnorm4(1),dc_norm(1,i3+nres))
31216
31217
31218           do l=1,3
31219          pom1=diffnorm1(l)+facd1*(diffnorm1(l)-scal1a*dc_norm(l,i1+nres))
31220          pom2=diffnorm2(l)+facd2*(diffnorm2(l)-scal2b*dc_norm(l,i2+nres))
31221          pom3=diffnorm4(l)+facd3*(diffnorm4(l)-scal3e*dc_norm(l,i3+nres))
31222
31223           gradcatangc(l,i1)=gradcatangc(l,i1)&
31224           +det1ij*sssmintot*(diff2(l)-diffnorm1(l)*cosom1*dista2)/(dista2*dista1)+&
31225           dephiij*sssmintot*(diff3(l)-diffnorm1(l)*cosom12*dista3)/(dista3*dista1)&
31226          +ene*sss2mingrad1*diffnorm1(l)*sss2min2*sss2min3
31227
31228
31229           gradcatangc(l,i2)=gradcatangc(l,i2)+(&
31230           det1ij*(diff1(l)-diffnorm2(l)*cosom1*dista1)/(dista2*dista1)+&
31231           det2ij*(-diff3(l)+mindiffnorm2(l)*cosom2*dista3)/(dista3*dista2)&
31232           -det2ij*(-diff2(l)-diffnorm3(l)*cosom2*dista2)/(dista3*dista2)&
31233           -dephiij*(diff1(l)-diffnorm3(l)*cosom12*dista1)/(dista3*dista1))*sssmintot&
31234          +ene*sss2mingrad2*diffnorm2(l)*sss2min1*sss2min3
31235
31236
31237
31238           gradcatangc(l,i3)=gradcatangc(l,i3)&
31239           +det2ij*(-diff2(l)-diffnorm3(l)*cosom2*dista2)/(dista3*dista2)*sssmintot&
31240           +dephiij*(diff1(l)-diffnorm3(l)*cosom12*dista1)/(dista3*dista1)*sssmintot&
31241          +ene*sss2mingrad3*diffnorm4(l)*sss2min1*sss2min2
31242
31243
31244           gradcatangc(l,j1)=gradcatangc(l,j1)-&
31245           sssmintot*(det1ij*(diff2(l)-diffnorm1(l)*cosom1*dista2)/(dista2*dista1)+&
31246           dephiij*(diff3(l)-diffnorm1(l)*cosom12*dista3)/(dista3*dista1))&
31247           -(det1ij*(diff1(l)-diffnorm2(l)*cosom1*dista1)/(dista1*dista2)+&
31248           det2ij*(-diff3(l)+mindiffnorm2(l)*cosom2*dista3)/(dista3*dista2))*sssmintot&
31249          -ene*sss2mingrad1*diffnorm1(l)*sss2min2*sss2min3&
31250          -ene*sss2mingrad2*diffnorm2(l)*sss2min1*sss2min3&
31251          -ene*sss2mingrad3*diffnorm4(l)*sss2min1*sss2min2
31252
31253
31254          gradcatangx(l,i1)=gradcatangx(l,i1)+(det1ij/(dista2*dista1)*&
31255          (acatshiftdsc(ityptrani1,ityptranj1)*diff2(l)+&
31256          facd1*(diff2(l)-scal1b*dc_norm(l,i1+nres)*dista2)-&
31257          cosom1*dista2/dista1*&
31258          (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+&
31259          facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1)))&
31260          +dephiij/(dista3*dista1)*&
31261          (acatshiftdsc(ityptrani1,ityptranj1)*diff3(l)+&
31262          facd1*(diff3(l)-scal1c*dc_norm(l,i1+nres)*dista3)-&
31263          cosom12*dista3/dista1*&
31264          (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+&
31265          facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1))))*sssmintot&
31266          +ene*sss2mingrad1*sss2min2*sss2min3*(pom1+&
31267           diffnorm1(l)*(acatshiftdsc(ityptrani1,ityptranj1)-1.0d0))
31268
31269
31270          gradcatangx(l,i3)=gradcatangx(l,i3)+(&
31271          det2ij/(dista3*dista2)*&
31272          (acatshiftdsc(ityptrani3,ityptranj3)*(-diff2(l))+&
31273          facd3*(-diff2(l)-scal3b*dc_norm(l,i3+nres)*dista2)-&
31274          cosom2*dista2/dista3*&
31275          (acatshiftdsc(ityptrani3,ityptranj3)*diff3(l)+&
31276          facd3*(diff3(l)-scal3c*dc_norm(l,i3+nres)*dista3)))&
31277          +dephiij/(dista3*dista1)*&
31278          (acatshiftdsc(ityptrani3,ityptranj3)*diff1(l)+&
31279          facd3*(diff1(l)-scal3a*dc_norm(l,i3+nres)*dista1)-&
31280          cosom12*dista1/dista3*&
31281          (acatshiftdsc(ityptrani3,ityptranj3)*diff3(l)+&
31282          facd3*(diff3(l)-scal3c*dc_norm(l,i3+nres)*dista3))))*sssmintot&
31283          +ene*sss2mingrad3*sss2min2*sss2min1*(pom3+&
31284           diffnorm4(l)*(acatshiftdsc(ityptrani3,ityptranj3)-1.0d0))
31285
31286
31287          gradcatangx(l,i2)=gradcatangx(l,i2)+(&!
31288          det1ij/(dista2*dista1)*&!
31289          (acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)&!
31290          +facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1)&
31291          -cosom1*dista1/dista2*&!
31292          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&!
31293          facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)))+&
31294          det2ij/(dista3*dista2)*&!
31295          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&!
31296          facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)&
31297          -(acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&!
31298           facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3))&
31299          -cosom2*dista3/dista2*&!
31300          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&!
31301           facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2))&
31302          +cosom2*dista2/dista3*&!
31303          (acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&!
31304          facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3)))&
31305          +dephiij/(dista3*dista1)*&!
31306          (-(acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)+&!
31307          facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1))+&
31308          cosom12*dista1/dista3*&!
31309          (acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&!
31310           facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3))))*sssmintot&
31311          +ene*sss2mingrad2*sss2min3*sss2min1*(pom2+&
31312           diffnorm2(l)*(acatshiftdsc(ityptrani2,ityptranj2)-1.0d0))
31313
31314
31315           enddo
31316 !          print *,i1,i2,i3,j1,j2,j3,"tors",ene,sinaux,cosphi
31317 !          print *,"param",agamacattran(1,ityptrani2,ityptranj2),ityptranj2,ityptrani2
31318           ecation_protang=ecation_protang+ene*sssmintot
31319          enddo
31320 !        enddo
31321 !       enddo
31322 !#endif
31323       return
31324       end subroutine
31325 !--------------------------------------------------------------------------
31326 !c------------------------------------------------------------------------------
31327       double precision function mytschebyshev(m,n,x,y,yt)
31328       implicit none
31329       integer i,m,n
31330       double precision x(n),y,yt,yy(0:100),aux
31331 !c Tschebyshev polynomial in y multiplied by sin(t1)sin(t2) (yt).
31332 !c Note that the first term is omitted
31333 !c m=0: the constant term is included
31334 !c m=1: the constant term is not included
31335       yy(0)=1.0d0
31336       yy(1)=y
31337       do i=2,n
31338         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)*yt*yt
31339       enddo
31340       aux=0.0d0
31341       do i=m,n
31342         aux=aux+x(i)*yy(i)
31343       enddo
31344 !c      print *,(yy(i),i=1,n)
31345       mytschebyshev=aux
31346       return
31347       end function
31348 !C--------------------------------------------------------------------------
31349 !C--------------------------------------------------------------------------
31350       subroutine mygradtschebyshev(m,n,x,y,yt,fy,fyt)
31351       implicit none
31352       integer i,m,n
31353       double precision x(n+1),y,yt,fy,fyt,yy(0:100),yb(0:100), &
31354       ybt(0:100)
31355 !c Derivative of Tschebyshev polynomial in y multiplied by sin(t1)sin(t2) (yt).
31356 !c Note that the first term is omitted
31357 !c m=0: the constant term is included
31358 !c m=1: the constant term is not included
31359       yy(0)=1.0d0
31360       yy(1)=y
31361       yb(0)=0.0d0
31362       yb(1)=1.0d0
31363       ybt(0)=0.0d0
31364       ybt(1)=0.0d0
31365       do i=2,n
31366         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)*yt*yt
31367         yb(i)=2*yy(i-1)+2*yy(1)*yb(i-1)-yb(i-2)*yt*yt
31368         ybt(i)=2*yy(1)*ybt(i-1)-ybt(i-2)*yt*yt-2*yy(i-2)*yt
31369       enddo
31370       fy=0.0d0
31371       fyt=0.0d0
31372       do i=m,n
31373         fy=fy+x(i)*yb(i)
31374         fyt=fyt+x(i)*ybt(i)
31375       enddo
31376       return
31377       end subroutine
31378        subroutine fodstep(nsteps)
31379        use geometry_data, only: c, nres, theta, alph
31380        use geometry, only:alpha,beta,dist
31381        integer, intent(in) :: nsteps
31382        integer idxtomod, j, i
31383       double precision RD0, RD1, fi
31384 !      double precision alpha
31385 !      double precision beta
31386 !      double precision dist
31387 !      double precision compute_RD
31388       double precision TT
31389       real :: r21(5)
31390 !c    ! Założenia: dla łańcucha zapisanego w tablicy c zawierającego
31391 !c    ! nres elementów CA i CB da się wyznaczyć kąty płaskie
31392 !c    ! theta (procedura Alpha) i kąty torsyjne (procedura beta),
31393 !c    ! zapisywane w tablicach theta i alph.
31394 !c    ! Na podstawie danych z tych tablic da się odtworzyć
31395 !c    ! strukturę 3D łańcucha procedurą chainbuild.
31396 !c    !
31397 !      print *,"fodstep: nres=",nres
31398       RD0 = compute_RD()
31399 !      print *, "RD0before step: ",RD0
31400       do j=1,nsteps
31401 !c      ! Wyznaczenie kątów theta na podstawie struktury
31402 !c      ! zapisanej w tablicy c
31403       do i=3,nres
31404         TT=alpha(i-2,i-1,i)
31405         theta(i)=TT
31406 !c       print *,"TT=",TT
31407       end do
31408 !c      ! Wyznaczenie kątów phi na podstawie struktury
31409 !c      ! zapisanej w tablicy c
31410       do i=4,nres
31411         phi(i)=beta(i-3,i-2,i-1,i)
31412       end do
31413 !c      ! Wyznaczenie odległości między atomami
31414 !c      ! vbld(i)=dist(i-1,i)
31415       do i=2,nres
31416         vbld(i)=dist(i-1,i)
31417       end do
31418 !c      ! losujemy kilka liczb
31419       call random_number(r21)
31420 !c          ! r21(1): indeks pozycji do zmiany
31421 !c          ! r21(2): kąt (r21(2)/20.0-1/40.0)
31422 !c          ! r21(3): wybór tablicy
31423       RD0 = compute_RD()
31424 !c     print *, "RD before step: ",RD0
31425       fi = (r21(2)/20.0-1.0/40.0) ! o tyle radianów zmienimy losowy kąt
31426       if (r21(3) .le. 0.5) then
31427           idxtomod = 3+r21(1)*(nres - 2)
31428           theta(idxtomod) = theta(idxtomod)+fi
31429 !          print *,"Zmiana kąta theta(",&
31430 !         idxtomod,") o fi = ",fi
31431       else
31432           idxtomod = 4+r21(1)*(nres - 3)
31433           phi(idxtomod) = phi(idxtomod)+fi
31434 !          print *,"Zmiana kąta phi(",&
31435 !         idxtomod,") o fi = ",fi
31436       end if
31437 !c     ! odtwarzamy łańcuch
31438       call chainbuild
31439 !c     ! czy coś się polepszyło?
31440       RD1 = compute_RD()
31441       if (RD1 .gt. RD0) then  ! nie, wycofujemy zmianę
31442 !           print *, "RD  after step: ",RD1," rejected"
31443            if (r21(3) .le. 0.5) then
31444                theta(idxtomod) = theta(idxtomod)-fi
31445            else
31446                phi(idxtomod) = phi(idxtomod)-fi
31447            end if
31448            call chainbuild    ! odtworzenie pierwotnej wersji (bez zmienionego kąta)
31449       else
31450 !           print *, "RD  after step: ",RD1," accepted"
31451       continue
31452       end if
31453       end do
31454       end subroutine
31455 !c-----------------------------------------------------------------------------------------
31456       subroutine orientation_matrix(res) ! obliczenie macierzy oraz przygotowanie ea z tymi przeksztalceniami
31457       use geometry_data, only: c, nres
31458       use energy_data, only: itype
31459       double precision, intent(out) :: res(4,4)
31460       double precision resM(4,4)
31461       double precision M(4,4)
31462       double precision M2(4,4)
31463       integer i, j, maxi, maxj
31464 !      double precision sq
31465       double precision maxd, dd
31466       double precision v1(3)
31467       double precision v2(3)
31468       double precision vecnea(3)
31469       double precision mean_ea(3)
31470       double precision fi
31471 !c    ! liczymy atomy efektywne i zapisujemy w tablicy ea
31472       do i=1,nres
31473 !c         if (itype(i,1) .ne. 10) then
31474           if (itype(i,1) .ne. 10) then
31475               ea(1,i) =  c(1,i+nres)
31476               ea(2,i) =  c(2,i+nres)
31477               ea(3,i) =  c(3,i+nres)
31478           else
31479               ea(1,i) = c(1,i)
31480               ea(2,i) = c(2,i)
31481               ea(3,i) = c(3,i)
31482           end if
31483       end do
31484       call IdentityM(resM)
31485       if (nres .le. 2) then
31486           print *, "nres too small (should be at least 2), stopping"
31487           stop
31488       end if
31489       do i=1,3
31490           v1(i)=ea(i,1)
31491           v2(i)=ea(i,2)
31492       end do
31493 !c     ! szukamy najwiekszej odleglosci miedzy atomami efektywnymi ea
31494       call Dist3d(maxd,v1,v2)
31495 !c       ! odleglosc miedzy pierwsza para atomow efektywnych
31496       maxi = 1
31497       maxj = 2
31498       do i=1,nres-1
31499           do j=i+1,nres
31500               v1(1)=ea(1,i)
31501               v1(2)=ea(2,i)
31502               v1(3)=ea(3,i)
31503               v2(1)=ea(1,j)
31504               v2(2)=ea(2,j)
31505               v2(3)=ea(3,j)
31506               call Dist3d(dd,v1,v2)
31507               if (dd .gt. maxd) then
31508                   maxd = dd
31509                   maxi = i
31510                   maxj = j
31511               end if
31512           end do
31513       end do
31514       vecnea(1)=ea(1,maxi)-ea(1,maxj)
31515       vecnea(2)=ea(2,maxi)-ea(2,maxj)
31516       vecnea(3)=ea(3,maxi)-ea(3,maxj)
31517       if (vecnea(1) .lt. 0) then
31518           vecnea(1) = -vecnea(1)
31519           vecnea(2) = -vecnea(2)
31520           vecnea(3) = -vecnea(3)
31521       end if
31522 !c     ! obliczenie kata obrotu wokol osi Z
31523       fi = -atan2(vecnea(2),vecnea(1))
31524       call RotateZ(M,fi)
31525 !c     ! obliczenie kata obrotu wokol osi Y
31526       fi = atan2(vecnea(3), sqrt(sq(vecnea(1))+sq(vecnea(2))))
31527       call RotateY(M2,fi)
31528       M = matmul(M2,M)
31529 !c    ! Przeksztalcamy wszystkie atomy efektywne
31530 !c    ! uzyskujac najwieksza odleglosc ulożona wzdluz OX
31531 !c    ! ea = transform_eatoms(ea,M)
31532       do i=1,nres
31533           v1(1)=ea(1,i)
31534           v1(2)=ea(2,i)
31535           v1(3)=ea(3,i)
31536           call tranform_point(v2,v1,M)
31537           ea(1,i)=v2(1)
31538           ea(2,i)=v2(2)
31539           ea(3,i)=v2(3)
31540       end do
31541       resM = M
31542 !c      ! Teraz szukamy najdluzszego rzutu na plaszczyzne YZ
31543 !c      ! (czyli w liczeniu odleglosci bierzemy pod uwage tylko wsp. y, z)
31544       maxd = sqrt( sq(ea(2,1)-ea(2,2)) + sq(ea(3,1)-ea(3,2))) ! aktualnie max odl
31545       maxi = 1  ! indeksy atomow
31546       maxj = 2  ! miedzy ktorymi jest max odl (chwilowe)
31547       do i=1,nres-1
31548         do j=i+1,nres
31549             dd = sqrt( (ea(2,i)-ea(2,j))**2 + (ea(3,i)-ea(3,j))**2)
31550             if (dd .gt. maxd) then
31551                 maxd = dd
31552                 maxi = i
31553                 maxj = j
31554             end if
31555         end do
31556       end do
31557 !c   ! Teraz obrocimy wszystko wokol OX tak, zeby znaleziony rzut
31558 !c   ! byl rownolegly do OY
31559       vecnea(1) = ea(1,maxi)-ea(1,maxj)
31560       vecnea(2) = ea(2,maxi)-ea(2,maxj)
31561       vecnea(3) = ea(3,maxi)-ea(3,maxj)
31562 !c   ! jeśli współrzędna vecnea.y < 0, to robimy odwrotnie
31563       if (vecnea(2) .lt. 0) then
31564          vecnea(1) = -vecnea(1)
31565          vecnea(2) = -vecnea(2)
31566          vecnea(3) = -vecnea(3)
31567       end if
31568 !c     ! obliczenie kąta obrotu wokół osi X
31569       fi = -atan2(vecnea(3),vecnea(2))
31570       call RotateX(M,fi)
31571 !c    ! Przeksztalcamy wszystkie atomy efektywne
31572       do i=1,nres
31573          v1(1)=ea(1,i)
31574          v1(2)=ea(2,i)
31575          v1(3)=ea(3,i)
31576          call tranform_point(v2,v1,M)
31577          ea(1,i)=v2(1)
31578          ea(2,i)=v2(2)
31579          ea(3,i)=v2(3)
31580       end do
31581       resM = matmul(M,resM)  ! zbieramy wynik (sprawdzic kolejnosc M,resM)
31582 !c     ! centrujemy
31583       mean_ea(1) = 0
31584       mean_ea(2) = 0
31585       mean_ea(3) = 0
31586       do i=1,nres
31587          mean_ea(1) = mean_ea(1) + ea(1,i)
31588          mean_ea(2) = mean_ea(2) + ea(2,i)
31589          mean_ea(3) = mean_ea(3) + ea(3,i)
31590       end do
31591       v1(1) = -mean_ea(1)/nres
31592       v1(2) = -mean_ea(2)/nres
31593       v1(3) = -mean_ea(3)/nres
31594       call TranslateV(M,v1)
31595       resM = matmul(M,resM)
31596 !c     ! przesuwamy
31597       do i=1,nres
31598          ea(1,i) = ea(1,i) + v1(1)
31599          ea(2,i) = ea(2,i) + v1(2)
31600          ea(3,i) = ea(3,i) + v1(3)
31601       end do
31602       res = resM
31603 !c     ! wynikowa macierz przeksztalcenia lancucha
31604 !c     ! (ale lancuch w ea juz mamy przeksztalcony)
31605       return
31606       end subroutine
31607       double precision function compute_rd
31608       use geometry_data, only: nres
31609       use energy_data, only: itype
31610       implicit none
31611       double precision or_mat(4,4)
31612 !      double precision hydrophobicity
31613       integer neatoms
31614       double precision cutoff
31615       double precision ho(70000)
31616       double precision ht(70000)
31617       double precision hosum, htsum
31618       double precision marg, sigmax, sigmay, sigmaz
31619       integer i, j
31620       double precision v1(3)
31621       double precision v2(3)
31622       double precision rijdivc, coll, tmpkwadrat, tmppotega, dist
31623       double precision OdivT, OdivR, ot_one, or_one, RD_classic
31624       call orientation_matrix(or_mat)
31625 !c     ! tam juz liczy sie tablica ea
31626       neatoms = nres
31627       cutoff = 8.99d0
31628 !c     ! granica oddzialywania w A (powyzej ignorujemy oddzialywanie)
31629 !c     ! Najpierw liczymy "obserwowana hydrofobowosc"
31630       hosum = 0.0d0  ! na sume pol ho, do celow pozniejszej normalizacji
31631       do j=1,neatoms
31632         ho(j)=0.0d0
31633         do i=1,neatoms
31634           if (j .eq. i) then ! nie uwzgledniamy oddzialywania atomu z samym soba
31635              cycle
31636           end if
31637           v1(1)=ea(1,i)
31638           v1(2)=ea(2,i)
31639           v1(3)=ea(3,i)
31640           v2(1)=ea(1,j)
31641           v2(2)=ea(2,j)
31642           v2(3)=ea(3,j)
31643           call Dist3d(dist,v1,v2) ! odleglosc miedzy atomami
31644           if (dist .gt. cutoff) then  ! za daleko, nie uwzgledniamy
31645             cycle
31646           end if
31647           rijdivc = dist / cutoff
31648           coll = 0.0d0
31649           tmppotega = rijdivc*rijdivc
31650           tmpkwadrat = tmppotega
31651           coll = coll + 7*tmpkwadrat
31652           tmppotega = tmppotega * tmpkwadrat  ! do potęgi 4
31653           coll = coll - 9*tmppotega
31654           tmppotega = tmppotega * tmpkwadrat  ! do potęgi 6
31655           coll = coll + 5*tmppotega
31656           tmppotega = tmppotega * tmpkwadrat  ! do potęgi 8
31657           coll = coll - tmppotega
31658 !c        ! Wersja: Bryliński 2007
31659 !c        ! EAtoms[j].collectedhp += EAtoms[i].hyphob*(1 - 0.5 * coll);
31660 !c        ! ea$ho[j] = ea$ho[j] + hydrophobicity(ea$resid[i])*(1-0.5*coll)
31661 !c        ! Wersja: Banach Konieczny Roterman 2014
31662 !c        ! EAtoms[j].collectedhp += (EAtoms[i].hyphob+EAtoms[j].hyphob)*(1 - 0.5 * coll);
31663 !c        ponizej bylo itype(i,1) w miejscu itype(i)  oraz itype(j,1) w miejscu itype(j)
31664          ho(j) = ho(j) + (hydrophobicity(itype(i,1))+&
31665         hydrophobicity(itype(j,1)))*(1.0d0-0.5_8*coll)
31666       end do
31667       hosum = hosum + ho(j)
31668       end do
31669 !c     ! Normalizujemy
31670       do i=1,neatoms
31671       ho(i) = ho(i) / hosum
31672       end do
31673 !c     ! Koniec liczenia hydrofobowosci obserwowanej (profil ho)
31674 !c     ! Teraz liczymy "teoretyczna hydrofobowosc", wedlug kropli i rozkladu Gaussa
31675       htsum = 0.0d0
31676 !c     ! tu zbieramy sume ht, uzyjemy potem do normalizacji
31677 !c  ! Ustalimy teraz parametry rozkladu Gaussa, czyli sigmy (srodek jest w (0,0,0)).
31678 !c  ! To bedzie (max odl od srodka + margines) / 3, oddzielnie dla kazdej wspolrzednej.
31679       marg  = 9.0d0
31680       htsum = 0.0d0
31681 !c  ! jeszcze raz zerujemy
31682 !c  ! szukamy ekstremalnej wartosci wspolrzednej x (max wart bezwzgl)
31683       sigmax = ea(1,1)
31684       do i=2,neatoms
31685       if (abs(ea(1,i))>sigmax) then
31686           sigmax = abs(ea(1,i))
31687       end if
31688       end do
31689       sigmax = (marg + sigmax) / 3.0d0
31690 !c  ! szukamy ekstremalnej wartosci wspolrzednej y (max wart bezwzgl)
31691       sigmay = ea(2,1)
31692       do i=2,neatoms
31693       if (abs(ea(2,i))>sigmay) then
31694          sigmay = abs(ea(2,i))
31695       end if
31696       end do
31697       sigmay = (marg + sigmay) / 3.0d0
31698 !c  ! szukamy ekstremalnej wartosci wspolrzednej z (max wart bezwzgl)
31699       sigmaz = ea(3,1)
31700       do i=2,neatoms
31701       if (abs(ea(3,i))>sigmaz) then
31702         sigmaz = abs(ea(3,i))
31703       end if
31704       end do
31705       sigmaz = (marg + sigmaz) / 3.0d0
31706 !c  !sigmax = (marg + max(abs(max(ea$acoor[,1])), abs(min(ea$acoor[,1]))))/3.0
31707 !c  !sigmay = (marg + max(abs(max(ea$acoor[,2])), abs(min(ea$acoor[,2]))))/3.0
31708 !c  !sigmaz = (marg + max(abs(max(ea$acoor[,3])), abs(min(ea$acoor[,3]))))/3.0
31709 !c  ! print *,"sigmax =",sigmax,"  sigmay =",sigmay," sigmaz = ",sigmaz
31710       do j=1,neatoms
31711       ht(j)= exp(-(ea(1,j))**2/(2*sigmax**2))&
31712       * exp(-(ea(2,j))**2/(2*sigmay**2)) &
31713       * exp(-(ea(3,j))**2/(2*sigmaz**2))
31714       htsum = htsum + ht(j)
31715       end do
31716 !c  ! Normalizujemy
31717       do i=1, neatoms
31718         ht(i) = ht(i) / htsum
31719       end do
31720 !c  ! Teraz liczymy RD
31721       OdivT = 0.0d0
31722       OdivR = 0.0d0
31723       do j=1,neatoms
31724         if (ho(j) .ne. 0) then
31725            ot_one = ho(j) * log(ho(j)/ht(j)) / log(2.0d0)
31726            OdivT  = OdivT + ot_one
31727            or_one = ho(j) * log(ho(j)/ (1.0d0/neatoms)) / log(2.0_8)
31728            OdivR  = OdivR + or_one
31729         endif
31730       end do
31731       RD_classic = OdivT / (OdivT+OdivR)
31732       compute_rd = RD_classic
31733       return
31734       end function
31735       function hydrophobicity(id)  ! do przepisania (bylo: identyfikowanie aa po nazwach)
31736       integer id
31737       double precision hydrophobicity
31738       hydrophobicity = 0.0d0
31739       if (id .eq. 1) then
31740          hydrophobicity = 1.000d0  ! CYS
31741          return
31742       endif
31743       if (id .eq. 2) then
31744          hydrophobicity = 0.828d0  ! MET
31745          return
31746       endif
31747       if (id .eq. 3) then
31748          hydrophobicity = 0.906d0  ! PHE
31749          return
31750       endif
31751       if (id .eq. 4) then
31752          hydrophobicity = 0.883d0  ! ILE
31753          return
31754       endif
31755       if (id .eq. 5) then
31756          hydrophobicity = 0.783d0  ! LEU
31757          return
31758       endif
31759       if (id .eq. 6) then
31760          hydrophobicity = 0.811d0  ! VAL
31761          return
31762       endif
31763       if (id .eq. 7) then
31764          hydrophobicity = 0.856d0  ! TRP
31765          return
31766       endif
31767       if (id .eq. 8) then
31768          hydrophobicity = 0.700d0  ! TYR
31769          return
31770       endif
31771       if (id .eq. 9) then
31772          hydrophobicity = 0.572d0  ! ALA
31773          return
31774       endif
31775       if (id .eq. 10) then
31776          hydrophobicity = 0.550d0  ! GLY
31777          return
31778       endif
31779       if (id .eq. 11) then
31780          hydrophobicity = 0.478d0  ! THR
31781          return
31782       endif
31783       if (id .eq. 12) then
31784          hydrophobicity = 0.422d0  ! SER
31785          return
31786       endif
31787       if (id .eq. 13) then
31788          hydrophobicity = 0.250d0  ! GLN
31789          return
31790       endif
31791       if (id .eq. 14) then
31792          hydrophobicity = 0.278d0  ! ASN
31793          return
31794       endif
31795       if (id .eq. 15) then
31796          hydrophobicity = 0.083d0  ! GLU
31797          return
31798       endif
31799       if (id .eq. 16) then
31800          hydrophobicity = 0.167d0  ! ASP
31801          return
31802       endif
31803       if (id .eq. 17) then
31804          hydrophobicity = 0.628d0  ! HIS
31805          return
31806       endif
31807       if (id .eq. 18) then
31808          hydrophobicity = 0.272d0  ! ARG
31809          return
31810       endif
31811       if (id .eq. 19) then
31812          hydrophobicity = 0.000d0  ! LYS
31813          return
31814       endif
31815       if (id .eq. 20) then
31816          hydrophobicity = 0.300d0  ! PRO
31817          return
31818       endif
31819       return
31820       end function hydrophobicity
31821       subroutine mycrossprod(res,b,c)
31822         implicit none
31823         double precision, intent(out) ::  res(3)
31824         double precision, intent(in)  ::  b(3)
31825         double precision, intent(in)  ::  c(3)
31826 !c       ! Tylko dla wektorów trójwymiarowych, ale nie sprawdzamy tego tutaj
31827         res(1) = b(2)*c(3)-b(3)*c(2)
31828         res(2) = b(3)*c(1)-b(1)*c(3)
31829         res(3) = b(1)*c(2)-b(2)*c(1)
31830       return
31831       end subroutine
31832       subroutine mydotprod(res,b,c)
31833         implicit none
31834         double precision, intent(out) ::  res
31835         double precision, intent(in)  ::  b(3)
31836         double precision, intent(in)  ::  c(3)
31837 !c    ! Tylko dla wektorów trójwymiarowych, ale nie sprawdzamy tego tutaj
31838         res = b(1)*c(1)+b(2)*c(2)+b(3)*c(3)
31839        return
31840       end subroutine
31841 !c ! cosinus k¹ta miêdzy wektorami trójwymiarowymi
31842       subroutine cosfi(res, x, y)
31843         implicit none
31844         double precision, intent(out) ::  res
31845         double precision, intent(in)  ::  x(3)
31846         double precision, intent(in)  ::  y(3)
31847         double precision LxLy
31848         LxLy=sqrt(x(1)*x(1)+x(2)*x(2)+x(3)*x(3)) *&
31849             sqrt(y(1)*y(1)+y(2)*y(2)+y(3)*y(3))
31850         if (LxLy==0.0) then
31851           res = 0.0d0
31852         else
31853           call mydotprod(res,x,y)
31854           res = res / LxLy
31855         end if
31856       return
31857       end subroutine
31858
31859
31860       subroutine Dist3d(res,v1,v2)
31861         implicit none
31862         double precision, intent(out) ::  res
31863         double precision, intent(in)  ::  v1(3)
31864         double precision, intent(in)  ::  v2(3)
31865 !        double precision sq
31866         res = sqrt( sq(v1(1)-v2(1)) + sq(v1(2)-v2(2)) + sq(v1(3)-v2(3)))
31867       return
31868       end subroutine
31869 !c ! Przeksztalca wsp. 3d uzywajac macierzy przeksztalcenia M (4x4)
31870       subroutine tranform_point(res,v3d,M)
31871         implicit none
31872         double precision, intent(out) ::  res(3)
31873         double precision, intent(in)  ::  v3d(3)
31874         double precision, intent(in)  ::  M(4,4)
31875
31876         res(1) = M(1,1)*v3d(1) + M(1,2)*v3d(2) + M(1,3)*v3d(3) + M(1,4)
31877         res(2) = M(2,1)*v3d(1) + M(2,2)*v3d(2) + M(2,3)*v3d(3) + M(2,4)
31878         res(3) = M(3,1)*v3d(1) + M(3,2)*v3d(2) + M(3,3)*v3d(3) + M(3,4)
31879       return
31880       end subroutine
31881 !c ! TranslateV: macierz translacji o wektor V
31882       subroutine TranslateV(res,V)
31883         implicit none
31884         double precision, intent(out) ::  res(4,4)
31885         double precision, intent(in)  ::  v(3)
31886         res(1,1) = 1.0d0
31887         res(1,2) = 0
31888         res(1,3) = 0
31889         res(1,4) = v(1)
31890         res(2,1) = 0
31891         res(2,2) = 1.0d0
31892         res(2,3) = 0
31893         res(2,4) = v(2)
31894         res(3,1) = 0
31895         res(3,2) = 0
31896         res(3,3) = 1.0d0
31897         res(3,4) = v(3)
31898         res(4,1) = 0
31899         res(4,2) = 0
31900         res(4,3) = 0
31901         res(4,4) = 1.0d0
31902       return
31903       end subroutine
31904 !c ! RotateX: macierz obrotu wokol osi OX o kat fi
31905       subroutine RotateX(res,fi)
31906         implicit none
31907         double precision, intent(out) ::  res(4,4)
31908         double precision, intent(in)  ::  fi
31909         res(1,1) = 1.0d0
31910         res(1,2) = 0
31911         res(1,3) = 0
31912         res(1,4) = 0
31913         res(2,1) = 0
31914         res(2,2) = cos(fi)
31915         res(2,3) = -sin(fi)
31916         res(2,4) = 0
31917         res(3,1) = 0
31918         res(3,2) = sin(fi)
31919         res(3,3) = cos(fi)
31920         res(3,4) = 0
31921         res(4,1) = 0
31922         res(4,2) = 0
31923         res(4,3) = 0
31924         res(4,4) = 1.0d0
31925       return
31926       end subroutine
31927 !c ! RotateY: macierz obrotu wokol osi OY o kat fi
31928       subroutine RotateY(res,fi)
31929         implicit none
31930         double precision, intent(out) ::  res(4,4)
31931         double precision, intent(in)  ::  fi
31932         res(1,1) = cos(fi)
31933         res(1,2) = 0
31934         res(1,3) = sin(fi)
31935         res(1,4) = 0
31936         res(2,1) = 0
31937         res(2,2) = 1.0d0
31938         res(2,3) = 0
31939         res(2,4) = 0
31940         res(3,1) = -sin(fi)
31941         res(3,2) = 0
31942         res(3,3) = cos(fi)
31943         res(3,4) = 0
31944         res(4,1) = 0
31945         res(4,2) = 0
31946         res(4,3) = 0
31947         res(4,4) = 1.0d0
31948       return
31949       end subroutine
31950 !c ! RotateZ: macierz obrotu wokol osi OZ o kat fi
31951       subroutine RotateZ(res,fi)
31952         implicit none
31953         double precision, intent(out) ::  res(4,4)
31954         double precision, intent(in)  ::  fi
31955         res(1,1) = cos(fi)
31956         res(1,2) = -sin(fi)
31957         res(1,3) = 0
31958         res(1,4) = 0
31959         res(2,1) = sin(fi)
31960         res(2,2) = cos(fi)
31961         res(2,3) = 0
31962         res(2,4) = 0
31963         res(3,1) = 0
31964         res(3,2) = 0
31965         res(3,3) = 1.0d0
31966         res(3,4) = 0
31967         res(4,1) = 0
31968         res(4,2) = 0
31969         res(4,3) = 0
31970         res(4,4) = 1.0d0
31971       return
31972       end subroutine
31973 !c ! IdentityM
31974       subroutine IdentityM(res)
31975         implicit none
31976         double precision, intent(out) ::  res(4,4)
31977         res(1,1) = 1.0d0
31978         res(1,2) = 0
31979         res(1,3) = 0
31980         res(1,4) = 0
31981         res(2,1) = 0
31982         res(2,2) = 1.0d0
31983         res(2,3) = 0
31984         res(2,4) = 0
31985         res(3,1) = 0
31986         res(3,2) = 0
31987         res(3,3) = 1.0d0
31988         res(3,4) = 0
31989         res(4,1) = 0
31990         res(4,2) = 0
31991         res(4,3) = 0
31992         res(4,4) = 1.0d0
31993       return
31994       end subroutine
31995       double precision function sq(x)
31996         double precision x
31997         sq = x*x
31998       return
31999       end function sq
32000
32001 #ifdef LBFGS
32002       double precision function funcgrad(x,g)
32003       use MD_data, only: totT,usampl
32004       implicit none
32005       double precision energia(0:n_ene)
32006       double precision x(nvar),g(nvar)
32007       integer i
32008       call var_to_geom(nvar,x)
32009       call zerograd
32010       call chainbuild
32011       call etotal(energia(0))
32012       call sum_gradient
32013       funcgrad=energia(0)
32014       call cart2intgrad(nvar,g)
32015       if (usampl) then
32016          do i=1,nres-3
32017            gloc(i,icg)=gloc(i,icg)+dugamma(i)
32018          enddo
32019          do i=1,nres-2
32020            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
32021          enddo
32022       endif
32023       do i=1,nvar
32024         g(i)=g(i)+gloc(i,icg)
32025       enddo
32026       return
32027       end function funcgrad
32028       subroutine cart2intgrad(n,g)
32029       integer n
32030       double precision g(n)
32031       double precision drt(3,3,nres),rdt(3,3,nres),dp(3,3),&
32032       temp(3,3),prordt(3,3,nres),prodrt(3,3,nres)
32033       double precision xx(3),xx1(3),alphi,omegi,xj,dpjk,yp,xp,xxp,yyp
32034       double precision cosalphi,sinalphi,cosomegi,sinomegi,theta2,&
32035        cost2,sint2,rj,dxoiij,tempkl,dxoijk,dsci,zzp,dj,dpkl
32036       double precision fromto(3,3),aux(6)
32037       integer i,ii,j,jjj,k,l,m,indi,ind,ind1
32038        logical sideonly
32039       sideonly=.false.
32040       g=0.0d0
32041       if (sideonly) goto 10
32042       do i=1,nres-2
32043         rdt(1,1,i)=-rt(1,2,i)
32044         rdt(1,2,i)= rt(1,1,i)
32045         rdt(1,3,i)= 0.0d0
32046         rdt(2,1,i)=-rt(2,2,i)
32047         rdt(2,2,i)= rt(2,1,i)
32048         rdt(2,3,i)= 0.0d0
32049         rdt(3,1,i)=-rt(3,2,i)
32050         rdt(3,2,i)= rt(3,1,i)
32051         rdt(3,3,i)= 0.0d0
32052       enddo
32053       do i=2,nres-2
32054         drt(1,1,i)= 0.0d0
32055         drt(1,2,i)= 0.0d0
32056         drt(1,3,i)= 0.0d0
32057         drt(2,1,i)= rt(3,1,i)
32058         drt(2,2,i)= rt(3,2,i)
32059         drt(2,3,i)= rt(3,3,i)
32060         drt(3,1,i)=-rt(2,1,i)
32061         drt(3,2,i)=-rt(2,2,i)
32062         drt(3,3,i)=-rt(2,3,i)
32063       enddo
32064       ind1=0
32065       do i=1,nres-2
32066         ind1=ind1+1
32067         if (n.gt.nphi) then
32068
32069         do j=1,3
32070           do k=1,2
32071             dpjk=0.0D0
32072             do l=1,3
32073               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
32074             enddo
32075             dp(j,k)=dpjk
32076             prordt(j,k,i)=dp(j,k)
32077           enddo
32078           dp(j,3)=0.0D0
32079           g(nphi+i)=g(nphi+i)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg)
32080         enddo
32081         xx1(1)=-0.5D0*xloc(2,i+1)
32082         xx1(2)= 0.5D0*xloc(1,i+1)
32083         do j=1,3
32084           xj=0.0D0
32085           do k=1,2
32086             xj=xj+r(j,k,i)*xx1(k)
32087           enddo
32088           xx(j)=xj
32089         enddo
32090         do j=1,3
32091           rj=0.0D0
32092           do k=1,3
32093             rj=rj+prod(j,k,i)*xx(k)
32094           enddo
32095           g(nphi+i)=g(nphi+i)+rj*gradx(j,i+1,icg)
32096         enddo
32097         if (i.lt.nres-2) then
32098         do j=1,3
32099           dxoiij=0.0D0
32100           do k=1,3
32101             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
32102           enddo
32103           g(nphi+i)=g(nphi+i)+dxoiij*gradx(j,i+2,icg)
32104         enddo
32105         endif
32106
32107         endif
32108
32109
32110         if (i.gt.1) then
32111         do j=1,3
32112           do k=1,3
32113             dpjk=0.0
32114             do l=2,3
32115               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
32116             enddo
32117             dp(j,k)=dpjk
32118             prodrt(j,k,i)=dp(j,k)
32119           enddo
32120           g(i-1)=g(i-1)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg)
32121         enddo
32122         endif
32123         xx(1)= 0.0D0
32124         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
32125         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
32126         if (i.gt.1) then
32127         do j=1,3
32128           rj=0.0D0
32129           do k=2,3
32130             rj=rj+prod(j,k,i)*xx(k)
32131           enddo
32132           g(i-1)=g(i-1)-rj*gradx(j,i+1,icg)
32133         enddo
32134         endif
32135         if (i.gt.1) then
32136         do j=1,3
32137           dxoiij=0.0D0
32138           do k=1,3
32139             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
32140           enddo
32141           g(i-1)=g(i-1)+dxoiij*gradx(j,i+2,icg)
32142         enddo
32143         endif
32144         do j=i+1,nres-2
32145           ind1=ind1+1
32146           call build_fromto(i+1,j+1,fromto)
32147           do k=1,3
32148             do l=1,3
32149               tempkl=0.0D0
32150               do m=1,2
32151                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l)
32152               enddo
32153               temp(k,l)=tempkl
32154             enddo
32155           enddo
32156           if (n.gt.nphi) then
32157           do k=1,3
32158             g(nphi+i)=g(nphi+i)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg)
32159           enddo
32160           do k=1,3
32161             dxoijk=0.0D0
32162             do l=1,3
32163               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
32164             enddo
32165             g(nphi+i)=g(nphi+i)+dxoijk*gradx(k,j+2,icg)
32166           enddo
32167           endif
32168           do k=1,3
32169             do l=1,3
32170               tempkl=0.0D0
32171               do m=1,3
32172                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l)
32173               enddo
32174               temp(k,l)=tempkl
32175             enddo
32176           enddo
32177           if (i.gt.1) then
32178           do k=1,3
32179             g(i-1)=g(i-1)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg)
32180           enddo
32181           do k=1,3
32182             dxoijk=0.0D0
32183             do l=1,3
32184               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
32185             enddo
32186             g(i-1)=g(i-1)+dxoijk*gradx(k,j+2,icg)
32187           enddo
32188           endif
32189         enddo
32190       enddo
32191
32192       if (nvar.le.nphi+ntheta) return
32193
32194    10 continue
32195       do i=2,nres-1
32196         if (iabs(itype(i,1)).eq.10 .or. itype(i,1).eq.ntyp1& !) cycle
32197          .or. mask_side(i).eq.0 ) cycle
32198         ii=ialph(i,1)
32199         dsci=vbld(i+nres)
32200 #ifdef OSF
32201         alphi=alph(i)
32202         omegi=omeg(i)
32203         if(alphi.ne.alphi) alphi=100.0
32204         if(omegi.ne.omegi) omegi=-100.0
32205 #else
32206         alphi=alph(i)
32207         omegi=omeg(i)
32208 #endif
32209         cosalphi=dcos(alphi)
32210         sinalphi=dsin(alphi)
32211         cosomegi=dcos(omegi)
32212         sinomegi=dsin(omegi)
32213         temp(1,1)=-dsci*sinalphi
32214         temp(2,1)= dsci*cosalphi*cosomegi
32215         temp(3,1)=-dsci*cosalphi*sinomegi
32216         temp(1,2)=0.0D0
32217         temp(2,2)=-dsci*sinalphi*sinomegi
32218         temp(3,2)=-dsci*sinalphi*cosomegi
32219         theta2=pi-0.5D0*theta(i+1)
32220         cost2=dcos(theta2)
32221         sint2=dsin(theta2)
32222         jjj=0
32223         do j=1,2
32224           xp=temp(1,j)
32225           yp=temp(2,j)
32226           xxp= xp*cost2+yp*sint2
32227           yyp=-xp*sint2+yp*cost2
32228           zzp=temp(3,j)
32229           xx(1)=xxp
32230           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
32231           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
32232           do k=1,3
32233             dj=0.0D0
32234             do l=1,3
32235               dj=dj+prod(k,l,i-1)*xx(l)
32236             enddo
32237             aux(jjj+k)=dj
32238           enddo
32239           jjj=jjj+3
32240         enddo
32241         do k=1,3
32242           g(ii)=g(ii)+aux(k)*gradx(k,i,icg)
32243           g(ii+nside)=g(ii+nside)+aux(k+3)*gradx(k,i,icg)
32244         enddo
32245       enddo
32246       return
32247       end subroutine cart2intgrad
32248
32249
32250 #endif
32251 !--------------------------------------------------------------------------
32252       end module energy