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)*sss_ele_cut &
12735                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
12736                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss_ele_cut
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)*sss_ele_cut
12752         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)*sss_ele_cut
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 !      write (iout,*) "gg",(gg(k),k=1,3)
12773
12774       do k=1,3
12775         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
12776         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
12777         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
12778         gradpepcat(k,i)= gradpepcat(k,i) +sss_ele_cut*(0.5*(- gg(k))   &
12779                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
12780                  *dsci_inv*2.0 &
12781                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0)
12782         gradpepcat(k,i+1)= gradpepcat(k,i+1) +sss_ele_cut*(0.5*(- gg(k))   &
12783                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
12784                  *dsci_inv*2.0 &
12785                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0)
12786         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)*sss_ele_cut
12787       enddo
12788       end subroutine sc_grad_cat_pep
12789
12790 #ifdef CRYST_THETA
12791 !-----------------------------------------------------------------------------
12792       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
12793
12794       use comm_calcthet
12795 !      implicit real(kind=8) (a-h,o-z)
12796 !      include 'DIMENSIONS'
12797 !      include 'COMMON.LOCAL'
12798 !      include 'COMMON.IOUNITS'
12799 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
12800 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12801 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
12802       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
12803       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
12804 !el      integer :: it
12805 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
12806 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12807 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
12808 !el local variables
12809
12810       delthec=thetai-thet_pred_mean
12811       delthe0=thetai-theta0i
12812 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
12813       t3 = thetai-thet_pred_mean
12814       t6 = t3**2
12815       t9 = term1
12816       t12 = t3*sigcsq
12817       t14 = t12+t6*sigsqtc
12818       t16 = 1.0d0
12819       t21 = thetai-theta0i
12820       t23 = t21**2
12821       t26 = term2
12822       t27 = t21*t26
12823       t32 = termexp
12824       t40 = t32**2
12825       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
12826        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12827        *(-t12*t9-ak*sig0inv*t27)
12828       return
12829       end subroutine mixder
12830 #endif
12831 !-----------------------------------------------------------------------------
12832 ! cartder.F
12833 !-----------------------------------------------------------------------------
12834       subroutine cartder
12835 !-----------------------------------------------------------------------------
12836 ! This subroutine calculates the derivatives of the consecutive virtual
12837 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12838 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12839 ! in the angles alpha and omega, describing the location of a side chain
12840 ! in its local coordinate system.
12841 !
12842 ! The derivatives are stored in the following arrays:
12843 !
12844 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12845 ! The structure is as follows:
12846 !
12847 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12848 ! 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)
12849 !         . . . . . . . . . . . .  . . . . . .
12850 ! 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)
12851 !                          .
12852 !                          .
12853 !                          .
12854 ! 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)
12855 !
12856 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12857 ! The structure is same as above.
12858 !
12859 ! DCDS - the derivatives of the side chain vectors in the local spherical
12860 ! andgles alph and omega:
12861 !
12862 ! 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)
12863 ! 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)
12864 !                          .
12865 !                          .
12866 !                          .
12867 ! 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)
12868 !
12869 ! Version of March '95, based on an early version of November '91.
12870 !
12871 !**********************************************************************
12872 !      implicit real(kind=8) (a-h,o-z)
12873 !      include 'DIMENSIONS'
12874 !      include 'COMMON.VAR'
12875 !      include 'COMMON.CHAIN'
12876 !      include 'COMMON.DERIV'
12877 !      include 'COMMON.GEO'
12878 !      include 'COMMON.LOCAL'
12879 !      include 'COMMON.INTERACT'
12880       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12881       real(kind=8),dimension(3,3) :: dp,temp
12882 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12883       real(kind=8),dimension(3) :: xx,xx1
12884 !el local variables
12885       integer :: i,k,l,j,m,ind,ind1,jjj
12886       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12887                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12888                  sint2,xp,yp,xxp,yyp,zzp,dj
12889
12890 !      common /przechowalnia/ fromto
12891 #ifdef FIVEDIAG
12892       if(.not. allocated(fromto)) allocate(fromto(3,3))
12893 #else
12894       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12895 #endif
12896 ! get the position of the jth ijth fragment of the chain coordinate system
12897 ! in the fromto array.
12898 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12899 !
12900 !      maxdim=(nres-1)*(nres-2)/2
12901 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12902 ! calculate the derivatives of transformation matrix elements in theta
12903 !
12904
12905 !el      call flush(iout) !el
12906       do i=1,nres-2
12907         rdt(1,1,i)=-rt(1,2,i)
12908         rdt(1,2,i)= rt(1,1,i)
12909         rdt(1,3,i)= 0.0d0
12910         rdt(2,1,i)=-rt(2,2,i)
12911         rdt(2,2,i)= rt(2,1,i)
12912         rdt(2,3,i)= 0.0d0
12913         rdt(3,1,i)=-rt(3,2,i)
12914         rdt(3,2,i)= rt(3,1,i)
12915         rdt(3,3,i)= 0.0d0
12916       enddo
12917 !
12918 ! derivatives in phi
12919 !
12920       do i=2,nres-2
12921         drt(1,1,i)= 0.0d0
12922         drt(1,2,i)= 0.0d0
12923         drt(1,3,i)= 0.0d0
12924         drt(2,1,i)= rt(3,1,i)
12925         drt(2,2,i)= rt(3,2,i)
12926         drt(2,3,i)= rt(3,3,i)
12927         drt(3,1,i)=-rt(2,1,i)
12928         drt(3,2,i)=-rt(2,2,i)
12929         drt(3,3,i)=-rt(2,3,i)
12930       enddo
12931 !
12932 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12933 !
12934 #ifndef FIVEDIAG
12935       do i=2,nres-2
12936         ind=indmat(i,i+1)
12937         do k=1,3
12938           do l=1,3
12939             temp(k,l)=rt(k,l,i)
12940           enddo
12941         enddo
12942         do k=1,3
12943           do l=1,3
12944             fromto(k,l,ind)=temp(k,l)
12945           enddo
12946         enddo
12947
12948         do j=i+1,nres-2
12949           ind=indmat(i,j+1)
12950           do k=1,3
12951             do l=1,3
12952               dpkl=0.0d0
12953               do m=1,3
12954                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12955               enddo
12956               dp(k,l)=dpkl
12957               fromto(k,l,ind)=dpkl
12958             enddo
12959           enddo
12960           do k=1,3
12961             do l=1,3
12962               temp(k,l)=dp(k,l)
12963             enddo
12964           enddo
12965         enddo
12966       enddo
12967 #endif
12968 !
12969 ! Calculate derivatives.
12970 !
12971       ind1=0
12972       do i=1,nres-2
12973       ind1=ind1+1
12974 !
12975 ! Derivatives of DC(i+1) in theta(i+2)
12976 !
12977         do j=1,3
12978           do k=1,2
12979             dpjk=0.0D0
12980             do l=1,3
12981               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12982             enddo
12983             dp(j,k)=dpjk
12984             prordt(j,k,i)=dp(j,k)
12985           enddo
12986           dp(j,3)=0.0D0
12987           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12988         enddo
12989 !
12990 ! Derivatives of SC(i+1) in theta(i+2)
12991 !
12992         xx1(1)=-0.5D0*xloc(2,i+1)
12993         xx1(2)= 0.5D0*xloc(1,i+1)
12994         do j=1,3
12995           xj=0.0D0
12996           do k=1,2
12997             xj=xj+r(j,k,i)*xx1(k)
12998           enddo
12999           xx(j)=xj
13000         enddo
13001         do j=1,3
13002           rj=0.0D0
13003           do k=1,3
13004             rj=rj+prod(j,k,i)*xx(k)
13005           enddo
13006           dxdv(j,ind1)=rj
13007         enddo
13008 !
13009 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
13010 ! than the other off-diagonal derivatives.
13011 !
13012         do j=1,3
13013           dxoiij=0.0D0
13014           do k=1,3
13015             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
13016           enddo
13017           dxdv(j,ind1+1)=dxoiij
13018         enddo
13019 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
13020 !
13021 ! Derivatives of DC(i+1) in phi(i+2)
13022 !
13023         do j=1,3
13024           do k=1,3
13025             dpjk=0.0
13026             do l=2,3
13027               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
13028             enddo
13029             dp(j,k)=dpjk
13030             prodrt(j,k,i)=dp(j,k)
13031           enddo
13032           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
13033         enddo
13034 !
13035 ! Derivatives of SC(i+1) in phi(i+2)
13036 !
13037         xx(1)= 0.0D0
13038         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
13039         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
13040         do j=1,3
13041           rj=0.0D0
13042           do k=2,3
13043             rj=rj+prod(j,k,i)*xx(k)
13044           enddo
13045           dxdv(j+3,ind1)=-rj
13046         enddo
13047 !
13048 ! Derivatives of SC(i+1) in phi(i+3).
13049 !
13050         do j=1,3
13051           dxoiij=0.0D0
13052           do k=1,3
13053             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
13054           enddo
13055           dxdv(j+3,ind1+1)=dxoiij
13056         enddo
13057 !
13058 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
13059 ! theta(nres) and phi(i+3) thru phi(nres).
13060 !
13061         do j=i+1,nres-2
13062         ind1=ind1+1
13063         ind=indmat(i+1,j+1)
13064 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
13065 #ifdef FIVEDIAG
13066           call build_fromto(i+1,j+1,fromto)
13067 !c          write(iout,'(7hfromto 9f10.5)')((fromto(k,l),l=1,3),k=1,3)
13068           do k=1,3
13069             do l=1,3
13070               tempkl=0.0D0
13071               do m=1,2
13072                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l)
13073               enddo
13074               temp(k,l)=tempkl
13075             enddo
13076           enddo
13077 #else
13078           do k=1,3
13079             do l=1,3
13080               tempkl=0.0D0
13081               do m=1,2
13082                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
13083               enddo
13084               temp(k,l)=tempkl
13085             enddo
13086           enddo
13087 #endif
13088 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
13089 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
13090 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
13091 ! Derivatives of virtual-bond vectors in theta
13092           do k=1,3
13093             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
13094           enddo
13095 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
13096 ! Derivatives of SC vectors in theta
13097           do k=1,3
13098             dxoijk=0.0D0
13099             do l=1,3
13100               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
13101             enddo
13102             dxdv(k,ind1+1)=dxoijk
13103           enddo
13104 !
13105 !--- Calculate the derivatives in phi
13106 !
13107 #ifdef FIVEDIAG
13108           do k=1,3
13109             do l=1,3
13110               tempkl=0.0D0
13111               do m=1,3
13112                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l)
13113               enddo
13114               temp(k,l)=tempkl
13115             enddo
13116           enddo
13117 #else
13118           do k=1,3
13119             do l=1,3
13120               tempkl=0.0D0
13121               do m=1,3
13122                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
13123               enddo
13124               temp(k,l)=tempkl
13125             enddo
13126           enddo
13127 #endif
13128
13129
13130           do k=1,3
13131             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
13132         enddo
13133           do k=1,3
13134             dxoijk=0.0D0
13135             do l=1,3
13136               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
13137             enddo
13138             dxdv(k+3,ind1+1)=dxoijk
13139           enddo
13140         enddo
13141       enddo
13142 !
13143 ! Derivatives in alpha and omega:
13144 !
13145       do i=2,nres-1
13146 !       dsci=dsc(itype(i,1))
13147         dsci=vbld(i+nres)
13148 #ifdef OSF
13149         alphi=alph(i)
13150         omegi=omeg(i)
13151         if(alphi.ne.alphi) alphi=100.0
13152         if(omegi.ne.omegi) omegi=-100.0
13153 #else
13154       alphi=alph(i)
13155       omegi=omeg(i)
13156 #endif
13157 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
13158       cosalphi=dcos(alphi)
13159       sinalphi=dsin(alphi)
13160       cosomegi=dcos(omegi)
13161       sinomegi=dsin(omegi)
13162       temp(1,1)=-dsci*sinalphi
13163       temp(2,1)= dsci*cosalphi*cosomegi
13164       temp(3,1)=-dsci*cosalphi*sinomegi
13165       temp(1,2)=0.0D0
13166       temp(2,2)=-dsci*sinalphi*sinomegi
13167       temp(3,2)=-dsci*sinalphi*cosomegi
13168       theta2=pi-0.5D0*theta(i+1)
13169       cost2=dcos(theta2)
13170       sint2=dsin(theta2)
13171       jjj=0
13172 !d      print *,((temp(l,k),l=1,3),k=1,2)
13173         do j=1,2
13174         xp=temp(1,j)
13175         yp=temp(2,j)
13176         xxp= xp*cost2+yp*sint2
13177         yyp=-xp*sint2+yp*cost2
13178         zzp=temp(3,j)
13179         xx(1)=xxp
13180         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
13181         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
13182         do k=1,3
13183           dj=0.0D0
13184           do l=1,3
13185             dj=dj+prod(k,l,i-1)*xx(l)
13186             enddo
13187           dxds(jjj+k,i)=dj
13188           enddo
13189         jjj=jjj+3
13190       enddo
13191       enddo
13192       return
13193       end subroutine cartder
13194 #ifdef FIVEDIAG
13195       subroutine build_fromto(i,j,fromto)
13196       implicit none
13197       integer i,j,jj,k,l,m
13198       double precision fromto(3,3),temp(3,3),dp(3,3)
13199       double precision dpkl
13200       save temp
13201 !
13202 ! generate the matrix products of type r(i)t(i)...r(j)t(j) on the fly
13203 !
13204 !      write (iout,*) "temp on entry"
13205 !      write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
13206 !      do i=2,nres-2
13207 !        ind=indmat(i,i+1)
13208       if (j.eq.i+1) then
13209         do k=1,3
13210           do l=1,3
13211             temp(k,l)=rt(k,l,i)
13212           enddo
13213         enddo
13214         do k=1,3
13215           do l=1,3
13216             fromto(k,l)=temp(k,l)
13217           enddo
13218         enddo
13219       else
13220 !        do j=i+1,nres-2
13221 !          ind=indmat(i,j+1)
13222           do k=1,3
13223             do l=1,3
13224               dpkl=0.0d0
13225               do m=1,3
13226                 dpkl=dpkl+temp(k,m)*rt(m,l,j-1)
13227               enddo
13228               dp(k,l)=dpkl
13229               fromto(k,l)=dpkl
13230             enddo
13231           enddo
13232           do k=1,3
13233             do l=1,3
13234               temp(k,l)=dp(k,l)
13235             enddo
13236           enddo
13237       endif
13238 !      write (iout,*) "temp upon exit"
13239 !      write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
13240 !        enddo
13241 !      enddo
13242       return
13243       end subroutine build_fromto
13244 #endif
13245
13246 !-----------------------------------------------------------------------------
13247 ! checkder_p.F
13248 !-----------------------------------------------------------------------------
13249       subroutine check_cartgrad
13250 ! Check the gradient of Cartesian coordinates in internal coordinates.
13251 !      implicit real(kind=8) (a-h,o-z)
13252 !      include 'DIMENSIONS'
13253 !      include 'COMMON.IOUNITS'
13254 !      include 'COMMON.VAR'
13255 !      include 'COMMON.CHAIN'
13256 !      include 'COMMON.GEO'
13257 !      include 'COMMON.LOCAL'
13258 !      include 'COMMON.DERIV'
13259       real(kind=8),dimension(6,nres) :: temp
13260       real(kind=8),dimension(3) :: xx,gg
13261       integer :: i,k,j,ii
13262       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
13263 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
13264 !
13265 ! Check the gradient of the virtual-bond and SC vectors in the internal
13266 ! coordinates.
13267 !
13268       aincr=1.0d-6
13269       aincr2=5.0d-7
13270       call cartder
13271       write (iout,'(a)') '**************** dx/dalpha'
13272       write (iout,'(a)')
13273       do i=2,nres-1
13274       alphi=alph(i)
13275       alph(i)=alph(i)+aincr
13276       do k=1,3
13277         temp(k,i)=dc(k,nres+i)
13278         enddo
13279       call chainbuild
13280       do k=1,3
13281         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
13282         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
13283         enddo
13284         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
13285         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
13286         write (iout,'(a)')
13287       alph(i)=alphi
13288       call chainbuild
13289       enddo
13290       write (iout,'(a)')
13291       write (iout,'(a)') '**************** dx/domega'
13292       write (iout,'(a)')
13293       do i=2,nres-1
13294       omegi=omeg(i)
13295       omeg(i)=omeg(i)+aincr
13296       do k=1,3
13297         temp(k,i)=dc(k,nres+i)
13298         enddo
13299       call chainbuild
13300       do k=1,3
13301           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
13302           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
13303                 (aincr*dabs(dxds(k+3,i))+aincr))
13304         enddo
13305         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
13306             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
13307         write (iout,'(a)')
13308       omeg(i)=omegi
13309       call chainbuild
13310       enddo
13311       write (iout,'(a)')
13312       write (iout,'(a)') '**************** dx/dtheta'
13313       write (iout,'(a)')
13314       do i=3,nres
13315       theti=theta(i)
13316         theta(i)=theta(i)+aincr
13317         do j=i-1,nres-1
13318           do k=1,3
13319             temp(k,j)=dc(k,nres+j)
13320           enddo
13321         enddo
13322         call chainbuild
13323         do j=i-1,nres-1
13324         ii = indmat(i-2,j)
13325 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
13326         do k=1,3
13327           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
13328           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
13329                   (aincr*dabs(dxdv(k,ii))+aincr))
13330           enddo
13331           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13332               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
13333           write(iout,'(a)')
13334         enddo
13335         write (iout,'(a)')
13336         theta(i)=theti
13337         call chainbuild
13338       enddo
13339       write (iout,'(a)') '***************** dx/dphi'
13340       write (iout,'(a)')
13341       do i=4,nres
13342         phi(i)=phi(i)+aincr
13343         do j=i-1,nres-1
13344           do k=1,3
13345             temp(k,j)=dc(k,nres+j)
13346           enddo
13347         enddo
13348         call chainbuild
13349         do j=i-1,nres-1
13350         ii = indmat(i-2,j)
13351 !         print *,'ii=',ii
13352         do k=1,3
13353           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
13354             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
13355                   (aincr*dabs(dxdv(k+3,ii))+aincr))
13356           enddo
13357           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13358               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13359           write(iout,'(a)')
13360         enddo
13361         phi(i)=phi(i)-aincr
13362         call chainbuild
13363       enddo
13364       write (iout,'(a)') '****************** ddc/dtheta'
13365       do i=1,nres-2
13366         thet=theta(i+2)
13367         theta(i+2)=thet+aincr
13368         do j=i,nres
13369           do k=1,3
13370             temp(k,j)=dc(k,j)
13371           enddo
13372         enddo
13373         call chainbuild
13374         do j=i+1,nres-1
13375         ii = indmat(i,j)
13376 !         print *,'ii=',ii
13377         do k=1,3
13378           gg(k)=(dc(k,j)-temp(k,j))/aincr
13379           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
13380                  (aincr*dabs(dcdv(k,ii))+aincr))
13381           enddo
13382           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13383                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
13384         write (iout,'(a)')
13385         enddo
13386         do j=1,nres
13387           do k=1,3
13388             dc(k,j)=temp(k,j)
13389           enddo
13390         enddo
13391         theta(i+2)=thet
13392       enddo
13393       write (iout,'(a)') '******************* ddc/dphi'
13394       do i=1,nres-3
13395         phii=phi(i+3)
13396         phi(i+3)=phii+aincr
13397         do j=1,nres
13398           do k=1,3
13399             temp(k,j)=dc(k,j)
13400           enddo
13401         enddo
13402         call chainbuild
13403         do j=i+2,nres-1
13404         ii = indmat(i+1,j)
13405 !         print *,'ii=',ii
13406         do k=1,3
13407           gg(k)=(dc(k,j)-temp(k,j))/aincr
13408             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
13409                  (aincr*dabs(dcdv(k+3,ii))+aincr))
13410           enddo
13411           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13412                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13413         write (iout,'(a)')
13414         enddo
13415         do j=1,nres
13416           do k=1,3
13417             dc(k,j)=temp(k,j)
13418           enddo
13419         enddo
13420         phi(i+3)=phii
13421       enddo
13422       return
13423       end subroutine check_cartgrad
13424 !-----------------------------------------------------------------------------
13425       subroutine check_ecart
13426 ! Check the gradient of the energy in Cartesian coordinates.
13427 !     implicit real(kind=8) (a-h,o-z)
13428 !     include 'DIMENSIONS'
13429 !     include 'COMMON.CHAIN'
13430 !     include 'COMMON.DERIV'
13431 !     include 'COMMON.IOUNITS'
13432 !     include 'COMMON.VAR'
13433 !     include 'COMMON.CONTACTS'
13434       use comm_srutu
13435 !#ifdef LBFGS
13436 !      use minimm, only: funcgrad
13437 !#endif
13438 !el      integer :: icall
13439 !el      common /srutu/ icall
13440 !      real(kind=8) :: funcgrad
13441       real(kind=8),dimension(6) :: ggg
13442       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13443       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13444       real(kind=8),dimension(6,nres) :: grad_s
13445       real(kind=8),dimension(0:n_ene) :: energia,energia1
13446       integer :: uiparm(1)
13447       real(kind=8) :: urparm(1)
13448 !EL      external fdum
13449       integer :: nf,i,j,k
13450       real(kind=8) :: aincr,etot,etot1,ff
13451       icg=1
13452       nf=0
13453       nfl=0
13454       call zerograd
13455       aincr=1.0D-5
13456       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
13457       nf=0
13458       icall=0
13459       call geom_to_var(nvar,x)
13460       call etotal(energia)
13461       etot=energia(0)
13462 #ifdef LBFGS
13463       ff=funcgrad(x,g)
13464 #else
13465 !el      call enerprint(energia)
13466       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
13467 #endif
13468       icall =1
13469       do i=1,nres
13470         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13471       enddo
13472       do i=1,nres
13473       do j=1,3
13474         grad_s(j,i)=gradc(j,i,icg)
13475         grad_s(j+3,i)=gradx(j,i,icg)
13476         enddo
13477       enddo
13478       call flush(iout)
13479       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13480       do i=1,nres
13481         do j=1,3
13482         xx(j)=c(j,i+nres)
13483         ddc(j)=dc(j,i)
13484         ddx(j)=dc(j,i+nres)
13485         enddo
13486       do j=1,3
13487         dc(j,i)=dc(j,i)+aincr
13488         do k=i+1,nres
13489           c(j,k)=c(j,k)+aincr
13490           c(j,k+nres)=c(j,k+nres)+aincr
13491           enddo
13492           call zerograd
13493           call etotal(energia1)
13494           etot1=energia1(0)
13495         ggg(j)=(etot1-etot)/aincr
13496         dc(j,i)=ddc(j)
13497         do k=i+1,nres
13498           c(j,k)=c(j,k)-aincr
13499           c(j,k+nres)=c(j,k+nres)-aincr
13500           enddo
13501         enddo
13502       do j=1,3
13503         c(j,i+nres)=c(j,i+nres)+aincr
13504         dc(j,i+nres)=dc(j,i+nres)+aincr
13505           call zerograd
13506           call etotal(energia1)
13507           etot1=energia1(0)
13508         ggg(j+3)=(etot1-etot)/aincr
13509         c(j,i+nres)=xx(j)
13510         dc(j,i+nres)=ddx(j)
13511         enddo
13512       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
13513          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
13514       enddo
13515       return
13516       end subroutine check_ecart
13517 #ifdef CARGRAD
13518 !-----------------------------------------------------------------------------
13519       subroutine check_ecartint
13520 ! Check the gradient of the energy in Cartesian coordinates.
13521       use io_base, only: intout
13522       use MD_data, only: iset
13523 !      implicit real*8 (a-h,o-z)
13524 !      include 'DIMENSIONS'
13525 !      include 'COMMON.CONTROL'
13526 !      include 'COMMON.CHAIN'
13527 !      include 'COMMON.DERIV'
13528 !      include 'COMMON.IOUNITS'
13529 !      include 'COMMON.VAR'
13530 !      include 'COMMON.CONTACTS'
13531 !      include 'COMMON.MD'
13532 !      include 'COMMON.LOCAL'
13533 !      include 'COMMON.SPLITELE'
13534       use comm_srutu
13535 !el      integer :: icall
13536 !el      common /srutu/ icall
13537       real(kind=8),dimension(6) :: ggg,ggg1
13538       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
13539       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13540       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
13541       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13542       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13543       real(kind=8),dimension(0:n_ene) :: energia,energia1
13544       integer :: uiparm(1)
13545       real(kind=8) :: urparm(1)
13546 !EL      external fdum
13547       integer :: i,j,k,nf
13548       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13549                    etot21,etot22
13550       r_cut=2.0d0
13551       rlambd=0.3d0
13552       icg=1
13553       nf=0
13554       nfl=0
13555       if (iset.eq.0) iset=1
13556       call intout
13557 !      call intcartderiv
13558 !      call checkintcartgrad
13559       call zerograd
13560       aincr=1.0D-5
13561       write(iout,*) 'Calling CHECK_ECARTINT.,kupa'
13562       nf=0
13563       icall=0
13564       call geom_to_var(nvar,x)
13565       write (iout,*) "split_ene ",split_ene
13566       call flush(iout)
13567       if (.not.split_ene) then
13568         call zerograd
13569         call etotal(energia)
13570         etot=energia(0)
13571         call cartgrad
13572 #ifdef FIVEDIAG
13573         call grad_transform
13574 #endif
13575         icall =1
13576         do i=1,nres
13577           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13578         enddo
13579         do j=1,3
13580           grad_s(j,0)=gcart(j,0)
13581         enddo
13582         do i=1,nres
13583           do j=1,3
13584             grad_s(j,i)=gcart(j,i)
13585             grad_s(j+3,i)=gxcart(j,i)
13586         write(iout,*) "before movement analytical gradient"
13587
13588           enddo
13589         enddo
13590         do i=1,nres
13591           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13592           (gxcart(j,i),j=1,3)
13593         enddo
13594
13595       else
13596 !- split gradient check
13597         call zerograd
13598         call etotal_long(energia)
13599 !el        call enerprint(energia)
13600         call cartgrad
13601 #ifdef FIVEDIAG
13602         call grad_transform
13603 #endif
13604         icall =1
13605         do i=1,nres
13606           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13607           (gxcart(j,i),j=1,3)
13608         enddo
13609         do j=1,3
13610           grad_s(j,0)=gcart(j,0)
13611         enddo
13612         do i=1,nres
13613           do j=1,3
13614             grad_s(j,i)=gcart(j,i)
13615             grad_s(j+3,i)=gxcart(j,i)
13616           enddo
13617         enddo
13618         call zerograd
13619         call etotal_short(energia)
13620         call enerprint(energia)
13621         call cartgrad
13622 #ifdef FIVEDIAG
13623         call grad_transform
13624 #endif
13625
13626         icall =1
13627         do i=1,nres
13628           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13629           (gxcart(j,i),j=1,3)
13630         enddo
13631         do j=1,3
13632           grad_s1(j,0)=gcart(j,0)
13633         enddo
13634         do i=1,nres
13635           do j=1,3
13636             grad_s1(j,i)=gcart(j,i)
13637             grad_s1(j+3,i)=gxcart(j,i)
13638           enddo
13639         enddo
13640       endif
13641       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13642 #ifdef FIVEDIAG
13643       do i=1,nres
13644 #else
13645       do i=nnt,nct
13646 #endif
13647         do j=1,3
13648           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
13649           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
13650         ddc(j)=c(j,i)
13651         ddx(j)=c(j,i+nres)
13652           dcnorm_safe1(j)=dc_norm(j,i-1)
13653           dcnorm_safe2(j)=dc_norm(j,i)
13654           dxnorm_safe(j)=dc_norm(j,i+nres)
13655         enddo
13656       do j=1,3
13657         c(j,i)=ddc(j)+aincr
13658           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
13659           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
13660           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13661           dc(j,i)=c(j,i+1)-c(j,i)
13662           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13663           call int_from_cart1(.false.)
13664           if (.not.split_ene) then
13665            call zerograd
13666             call etotal(energia1)
13667             etot1=energia1(0)
13668 !            write (iout,*) "ij",i,j," etot1",etot1
13669           else
13670 !- split gradient
13671             call etotal_long(energia1)
13672             etot11=energia1(0)
13673             call etotal_short(energia1)
13674             etot12=energia1(0)
13675           endif
13676 !- end split gradient
13677 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13678         c(j,i)=ddc(j)-aincr
13679           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
13680           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
13681           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13682           dc(j,i)=c(j,i+1)-c(j,i)
13683           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13684           call int_from_cart1(.false.)
13685           if (.not.split_ene) then
13686             call zerograd
13687             call etotal(energia1)
13688             etot2=energia1(0)
13689 !            write (iout,*) "ij",i,j," etot2",etot2
13690           ggg(j)=(etot1-etot2)/(2*aincr)
13691           else
13692 !- split gradient
13693             call etotal_long(energia1)
13694             etot21=energia1(0)
13695           ggg(j)=(etot11-etot21)/(2*aincr)
13696             call etotal_short(energia1)
13697             etot22=energia1(0)
13698           ggg1(j)=(etot12-etot22)/(2*aincr)
13699 !- end split gradient
13700 !            write (iout,*) "etot21",etot21," etot22",etot22
13701           endif
13702 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13703         c(j,i)=ddc(j)
13704           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
13705           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
13706           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13707           dc(j,i)=c(j,i+1)-c(j,i)
13708           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13709           dc_norm(j,i-1)=dcnorm_safe1(j)
13710           dc_norm(j,i)=dcnorm_safe2(j)
13711           dc_norm(j,i+nres)=dxnorm_safe(j)
13712         enddo
13713       do j=1,3
13714         c(j,i+nres)=ddx(j)+aincr
13715           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13716           call int_from_cart1(.false.)
13717           if (.not.split_ene) then
13718             call zerograd
13719             call etotal(energia1)
13720             etot1=energia1(0)
13721           else
13722 !- split gradient
13723             call etotal_long(energia1)
13724             etot11=energia1(0)
13725             call etotal_short(energia1)
13726             etot12=energia1(0)
13727           endif
13728 !- end split gradient
13729         c(j,i+nres)=ddx(j)-aincr
13730           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13731           call int_from_cart1(.false.)
13732           if (.not.split_ene) then
13733            call zerograd
13734            call etotal(energia1)
13735             etot2=energia1(0)
13736           ggg(j+3)=(etot1-etot2)/(2*aincr)
13737           else
13738 !- split gradient
13739             call etotal_long(energia1)
13740             etot21=energia1(0)
13741           ggg(j+3)=(etot11-etot21)/(2*aincr)
13742             call etotal_short(energia1)
13743             etot22=energia1(0)
13744           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13745 !- end split gradient
13746           endif
13747 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13748         c(j,i+nres)=ddx(j)
13749           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13750           dc_norm(j,i+nres)=dxnorm_safe(j)
13751           call int_from_cart1(.false.)
13752         enddo
13753       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13754          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13755         if (split_ene) then
13756           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13757          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13758          k=1,6)
13759          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13760          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13761          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13762         endif
13763       enddo
13764       return
13765       end subroutine check_ecartint
13766 #else
13767 !-----------------------------------------------------------------------------
13768       subroutine check_ecartint
13769 ! Check the gradient of the energy in Cartesian coordinates.
13770       use io_base, only: intout
13771       use MD_data, only: iset
13772 !      implicit real*8 (a-h,o-z)
13773 !      include 'DIMENSIONS'
13774 !      include 'COMMON.CONTROL'
13775 !      include 'COMMON.CHAIN'
13776 !      include 'COMMON.DERIV'
13777 !      include 'COMMON.IOUNITS'
13778 !      include 'COMMON.VAR'
13779 !      include 'COMMON.CONTACTS'
13780 !      include 'COMMON.MD'
13781 !      include 'COMMON.LOCAL'
13782 !      include 'COMMON.SPLITELE'
13783       use comm_srutu
13784 !el      integer :: icall
13785 !el      common /srutu/ icall
13786       real(kind=8),dimension(6) :: ggg,ggg1
13787       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13788       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13789       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
13790       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13791       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13792       real(kind=8),dimension(0:n_ene) :: energia,energia1
13793       integer :: uiparm(1)
13794       real(kind=8) :: urparm(1)
13795 !EL      external fdum
13796       integer :: i,j,k,nf
13797       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13798                    etot21,etot22
13799       r_cut=2.0d0
13800       rlambd=0.3d0
13801       icg=1
13802       nf=0
13803       nfl=0
13804       if (iset.eq.0) iset=1
13805       call intout
13806 !      call intcartderiv
13807 !      call checkintcartgrad
13808       call zerograd
13809       aincr=1.0D-6
13810       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
13811       nf=0
13812       icall=0
13813       call geom_to_var(nvar,x)
13814       if (.not.split_ene) then
13815         call etotal(energia)
13816         etot=energia(0)
13817 !        call enerprint(energia)
13818         call cartgrad
13819         icall =1
13820         do i=1,nres
13821           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13822         enddo
13823         do j=1,3
13824           grad_s(j,0)=gcart(j,0)
13825           grad_s(j+3,0)=gxcart(j,0)
13826         enddo
13827         do i=1,nres
13828           do j=1,3
13829             grad_s(j,i)=gcart(j,i)
13830             grad_s(j+3,i)=gxcart(j,i)
13831           enddo
13832         enddo
13833         write(iout,*) "before movement analytical gradient"
13834         do i=1,nres
13835           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13836           (gxcart(j,i),j=1,3)
13837         enddo
13838
13839       else
13840 !- split gradient check
13841         call zerograd
13842         call etotal_long(energia)
13843 !el        call enerprint(energia)
13844         call cartgrad
13845         icall =1
13846         do i=1,nres
13847           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13848           (gxcart(j,i),j=1,3)
13849         enddo
13850         do j=1,3
13851           grad_s(j,0)=gcart(j,0)
13852         enddo
13853         do i=1,nres
13854           do j=1,3
13855             grad_s(j,i)=gcart(j,i)
13856 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
13857             grad_s(j+3,i)=gxcart(j,i)
13858           enddo
13859         enddo
13860         call zerograd
13861         call etotal_short(energia)
13862 !el        call enerprint(energia)
13863         call cartgrad
13864         icall =1
13865         do i=1,nres
13866           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13867           (gxcart(j,i),j=1,3)
13868         enddo
13869         do j=1,3
13870           grad_s1(j,0)=gcart(j,0)
13871         enddo
13872         do i=1,nres
13873           do j=1,3
13874             grad_s1(j,i)=gcart(j,i)
13875             grad_s1(j+3,i)=gxcart(j,i)
13876           enddo
13877         enddo
13878       endif
13879       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13880       do i=0,nres
13881         do j=1,3
13882         xx(j)=c(j,i+nres)
13883         ddc(j)=dc(j,i)
13884         ddx(j)=dc(j,i+nres)
13885           do k=1,3
13886             dcnorm_safe(k)=dc_norm(k,i)
13887             dxnorm_safe(k)=dc_norm(k,i+nres)
13888           enddo
13889         enddo
13890       do j=1,3
13891         dc(j,i)=ddc(j)+aincr
13892           call chainbuild_cart
13893 #ifdef MPI
13894 ! Broadcast the order to compute internal coordinates to the slaves.
13895 !          if (nfgtasks.gt.1)
13896 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
13897 #endif
13898 !          call int_from_cart1(.false.)
13899           if (.not.split_ene) then
13900            call zerograd
13901             call etotal(energia1)
13902             etot1=energia1(0)
13903 !            call enerprint(energia1)
13904           else
13905 !- split gradient
13906             call etotal_long(energia1)
13907             etot11=energia1(0)
13908             call etotal_short(energia1)
13909             etot12=energia1(0)
13910 !            write (iout,*) "etot11",etot11," etot12",etot12
13911           endif
13912 !- end split gradient
13913 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13914         dc(j,i)=ddc(j)-aincr
13915           call chainbuild_cart
13916 !          call int_from_cart1(.false.)
13917           if (.not.split_ene) then
13918                   call zerograd
13919             call etotal(energia1)
13920 !            call enerprint(energia1)
13921             etot2=energia1(0)
13922           ggg(j)=(etot1-etot2)/(2*aincr)
13923           else
13924 !- split gradient
13925             call etotal_long(energia1)
13926             etot21=energia1(0)
13927           ggg(j)=(etot11-etot21)/(2*aincr)
13928             call etotal_short(energia1)
13929             etot22=energia1(0)
13930           ggg1(j)=(etot12-etot22)/(2*aincr)
13931 !- end split gradient
13932 !            write (iout,*) "etot21",etot21," etot22",etot22
13933           endif
13934 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13935         dc(j,i)=ddc(j)
13936           call chainbuild_cart
13937         enddo
13938       do j=1,3
13939         dc(j,i+nres)=ddx(j)+aincr
13940           call chainbuild_cart
13941 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
13942 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13943 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13944 !          write (iout,*) "dxnormnorm",dsqrt(
13945 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13946 !          write (iout,*) "dxnormnormsafe",dsqrt(
13947 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13948 !          write (iout,*)
13949           if (.not.split_ene) then
13950             call zerograd
13951             call etotal(energia1)
13952 !            call enerprint(energia1)
13953             etot1=energia1(0)
13954 !            print *,"ene",energia1(0),energia1(57)
13955           else
13956 !- split gradient
13957             call etotal_long(energia1)
13958             etot11=energia1(0)
13959             call etotal_short(energia1)
13960             etot12=energia1(0)
13961           endif
13962 !- end split gradient
13963 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13964         dc(j,i+nres)=ddx(j)-aincr
13965           call chainbuild_cart
13966 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13967 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13968 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13969 !          write (iout,*)
13970 !          write (iout,*) "dxnormnorm",dsqrt(
13971 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13972 !          write (iout,*) "dxnormnormsafe",dsqrt(
13973 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13974           if (.not.split_ene) then
13975             call zerograd
13976             call etotal(energia1)
13977             etot2=energia1(0)
13978 !            call enerprint(energia1)
13979 !            print *,"ene",energia1(0),energia1(57)
13980           ggg(j+3)=(etot1-etot2)/(2*aincr)
13981           else
13982 !- split gradient
13983             call etotal_long(energia1)
13984             etot21=energia1(0)
13985           ggg(j+3)=(etot11-etot21)/(2*aincr)
13986             call etotal_short(energia1)
13987             etot22=energia1(0)
13988           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13989 !- end split gradient
13990           endif
13991 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13992         dc(j,i+nres)=ddx(j)
13993           call chainbuild_cart
13994         enddo
13995       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13996          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13997         if (split_ene) then
13998           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13999          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
14000          k=1,6)
14001          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
14002          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
14003          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
14004         endif
14005       enddo
14006       return
14007       end subroutine check_ecartint
14008 #endif
14009 !-----------------------------------------------------------------------------
14010       subroutine check_eint
14011 ! Check the gradient of energy in internal coordinates.
14012 !      implicit real(kind=8) (a-h,o-z)
14013 !      include 'DIMENSIONS'
14014 !      include 'COMMON.CHAIN'
14015 !      include 'COMMON.DERIV'
14016 !      include 'COMMON.IOUNITS'
14017 !      include 'COMMON.VAR'
14018 !      include 'COMMON.GEO'
14019       use comm_srutu
14020 !#ifdef LBFGS
14021 !      use minimm, only : funcgrad
14022 !#endif
14023 !el      integer :: icall
14024 !el      common /srutu/ icall
14025 !      real(kind=8) :: funcgrad
14026       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
14027       integer :: uiparm(1)
14028       real(kind=8) :: urparm(1)
14029       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
14030       character(len=6) :: key
14031 !EL      external fdum
14032       integer :: i,ii,nf
14033       real(kind=8) :: xi,aincr,etot,etot1,etot2,ff
14034       call zerograd
14035       aincr=1.0D-7
14036       print '(a)','Calling CHECK_INT.'
14037       nf=0
14038       nfl=0
14039       icg=1
14040       call geom_to_var(nvar,x)
14041       call var_to_geom(nvar,x)
14042       call chainbuild
14043       icall=1
14044 !      print *,'ICG=',ICG
14045       call etotal(energia)
14046       etot = energia(0)
14047 !el      call enerprint(energia)
14048 !      print *,'ICG=',ICG
14049 #ifdef MPL
14050       if (MyID.ne.BossID) then
14051         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
14052         nf=x(nvar+1)
14053         nfl=x(nvar+2)
14054         icg=x(nvar+3)
14055       endif
14056 #endif
14057       nf=1
14058       nfl=3
14059 #ifdef LBFGS
14060       ff=funcgrad(x,gana)
14061 #else
14062
14063 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
14064       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
14065 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
14066 #endif
14067       icall=1
14068       do i=1,nvar
14069         xi=x(i)
14070         x(i)=xi-0.5D0*aincr
14071         call var_to_geom(nvar,x)
14072         call chainbuild
14073         call etotal(energia1)
14074         etot1=energia1(0)
14075         x(i)=xi+0.5D0*aincr
14076         call var_to_geom(nvar,x)
14077         call chainbuild
14078         call etotal(energia2)
14079         etot2=energia2(0)
14080         gg(i)=(etot2-etot1)/aincr
14081         write (iout,*) i,etot1,etot2
14082         x(i)=xi
14083       enddo
14084       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
14085           '     RelDiff*100% '
14086       do i=1,nvar
14087         if (i.le.nphi) then
14088           ii=i
14089           key = ' phi'
14090         else if (i.le.nphi+ntheta) then
14091           ii=i-nphi
14092           key=' theta'
14093         else if (i.le.nphi+ntheta+nside) then
14094            ii=i-(nphi+ntheta)
14095            key=' alpha'
14096         else
14097            ii=i-(nphi+ntheta+nside)
14098            key=' omega'
14099         endif
14100         write (iout,'(i3,a,i3,3(1pd16.6))') &
14101        i,key,ii,gg(i),gana(i),&
14102        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
14103       enddo
14104       return
14105       end subroutine check_eint
14106 !-----------------------------------------------------------------------------
14107 ! econstr_local.F
14108 !-----------------------------------------------------------------------------
14109       subroutine Econstr_back
14110 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
14111 !      implicit real(kind=8) (a-h,o-z)
14112 !      include 'DIMENSIONS'
14113 !      include 'COMMON.CONTROL'
14114 !      include 'COMMON.VAR'
14115 !      include 'COMMON.MD'
14116       use MD_data
14117 !#ifndef LANG0
14118 !      include 'COMMON.LANGEVIN'
14119 !#else
14120 !      include 'COMMON.LANGEVIN.lang0'
14121 !#endif
14122 !      include 'COMMON.CHAIN'
14123 !      include 'COMMON.DERIV'
14124 !      include 'COMMON.GEO'
14125 !      include 'COMMON.LOCAL'
14126 !      include 'COMMON.INTERACT'
14127 !      include 'COMMON.IOUNITS'
14128 !      include 'COMMON.NAMES'
14129 !      include 'COMMON.TIME1'
14130       integer :: i,j,ii,k
14131       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
14132
14133       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
14134       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
14135       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
14136
14137       Uconst_back=0.0d0
14138       do i=1,nres
14139         dutheta(i)=0.0d0
14140         dugamma(i)=0.0d0
14141         do j=1,3
14142           duscdiff(j,i)=0.0d0
14143           duscdiffx(j,i)=0.0d0
14144         enddo
14145       enddo
14146       do i=1,nfrag_back
14147         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
14148 !
14149 ! Deviations from theta angles
14150 !
14151         utheta_i=0.0d0
14152         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
14153           dtheta_i=theta(j)-thetaref(j)
14154           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
14155           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
14156         enddo
14157         utheta(i)=utheta_i/(ii-1)
14158 !
14159 ! Deviations from gamma angles
14160 !
14161         ugamma_i=0.0d0
14162         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
14163           dgamma_i=pinorm(phi(j)-phiref(j))
14164 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
14165           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
14166           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
14167 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
14168         enddo
14169         ugamma(i)=ugamma_i/(ii-2)
14170 !
14171 ! Deviations from local SC geometry
14172 !
14173         uscdiff(i)=0.0d0
14174         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
14175           dxx=xxtab(j)-xxref(j)
14176           dyy=yytab(j)-yyref(j)
14177           dzz=zztab(j)-zzref(j)
14178           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
14179           do k=1,3
14180             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
14181              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
14182              (ii-1)
14183             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
14184              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
14185              (ii-1)
14186             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
14187            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
14188             /(ii-1)
14189           enddo
14190 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
14191 !     &      xxref(j),yyref(j),zzref(j)
14192         enddo
14193         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
14194 !        write (iout,*) i," uscdiff",uscdiff(i)
14195 !
14196 ! Put together deviations from local geometry
14197 !
14198         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
14199           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
14200 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
14201 !     &   " uconst_back",uconst_back
14202         utheta(i)=dsqrt(utheta(i))
14203         ugamma(i)=dsqrt(ugamma(i))
14204         uscdiff(i)=dsqrt(uscdiff(i))
14205       enddo
14206       return
14207       end subroutine Econstr_back
14208 !-----------------------------------------------------------------------------
14209 ! energy_p_new-sep_barrier.F
14210 !-----------------------------------------------------------------------------
14211       real(kind=8) function sscale(r)
14212 !      include "COMMON.SPLITELE"
14213       real(kind=8) :: r,gamm
14214       if(r.lt.r_cut-rlamb) then
14215         sscale=1.0d0
14216       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
14217         gamm=(r-(r_cut-rlamb))/rlamb
14218         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14219       else
14220         sscale=0d0
14221       endif
14222       return
14223       end function sscale
14224       real(kind=8) function sscale_grad(r)
14225 !      include "COMMON.SPLITELE"
14226       real(kind=8) :: r,gamm
14227       if(r.lt.r_cut-rlamb) then
14228         sscale_grad=0.0d0
14229       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
14230         gamm=(r-(r_cut-rlamb))/rlamb
14231         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
14232       else
14233         sscale_grad=0d0
14234       endif
14235       return
14236       end function sscale_grad
14237 !SCALINING MARTINI
14238       real(kind=8) function sscale_martini(r)
14239 !      include "COMMON.SPLITELE"
14240       real(kind=8) :: r,gamm
14241 !      print *,"here2",r_cut_mart,r
14242       if(r.lt.r_cut_mart-rlamb_mart) then
14243         sscale_martini=1.0d0
14244       else if(r.le.r_cut_mart.and.r.ge.r_cut_mart-rlamb_mart) then
14245         gamm=(r-(r_cut_mart-rlamb_mart))/rlamb_mart
14246         sscale_martini=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14247       else
14248         sscale_martini=0.0d0
14249       endif
14250       return
14251       end function sscale_martini
14252       real(kind=8) function sscale_grad_martini(r)
14253 !      include "COMMON.SPLITELE"
14254       real(kind=8) :: r,gamm
14255       if(r.lt.r_cut_mart-rlamb_mart) then
14256         sscale_grad_martini=0.0d0
14257       else if(r.le.r_cut_mart.and.r.ge.r_cut_mart-rlamb_mart) then
14258         gamm=(r-(r_cut_mart-rlamb_mart))/rlamb_mart
14259         sscale_grad_martini=gamm*(6*gamm-6.0d0)/rlamb_mart
14260       else
14261         sscale_grad_martini=0.0d0
14262       endif
14263       return
14264       end function sscale_grad_martini
14265       real(kind=8) function sscale_martini_angle(r)
14266 !      include "COMMON.SPLITELE"
14267       real(kind=8) :: r,gamm,r_cut_angle,rlamb_angle
14268 !      print *,"here2",r_cut_angle,r
14269        r_cut_angle=3.12d0
14270        rlamb_angle=0.1d0
14271       if(r.lt.r_cut_angle-rlamb_angle) then
14272         sscale_martini_angle=1.0d0
14273       else if(r.le.r_cut_angle.and.r.ge.r_cut_angle-rlamb_angle) then
14274         gamm=(r-(r_cut_angle-rlamb_angle))/rlamb_angle
14275         sscale_martini_angle=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14276       else
14277         sscale_martini_angle=0.0d0
14278       endif
14279       return
14280       end function sscale_martini_angle
14281       real(kind=8) function sscale_grad_martini_angle(r)
14282 !      include "COMMON.SPLITELE"
14283       real(kind=8) :: r,gamm,r_cut_angle,rlamb_angle
14284        r_cut_angle=3.12d0
14285        rlamb_angle=0.1d0
14286       if(r.lt.r_cut_angle-rlamb_angle) then
14287         sscale_grad_martini_angle=0.0d0
14288       else if(r.le.r_cut_angle.and.r.ge.r_cut_angle-rlamb_angle) then
14289         gamm=(r-(r_cut_angle-rlamb_angle))/rlamb_angle
14290         sscale_grad_martini_angle=gamm*(6*gamm-6.0d0)/rlamb_angle
14291       else
14292         sscale_grad_martini_angle=0.0d0
14293       endif
14294       return
14295       end function sscale_grad_martini_angle
14296
14297
14298 !!!!!!!!!! PBCSCALE
14299       real(kind=8) function sscale_ele(r)
14300 !      include "COMMON.SPLITELE"
14301       real(kind=8) :: r,gamm
14302       if(r.lt.r_cut_ele-rlamb_ele) then
14303         sscale_ele=1.0d0
14304       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
14305         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
14306         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14307       else
14308         sscale_ele=0d0
14309       endif
14310       return
14311       end function sscale_ele
14312
14313       real(kind=8)  function sscagrad_ele(r)
14314       real(kind=8) :: r,gamm
14315 !      include "COMMON.SPLITELE"
14316       if(r.lt.r_cut_ele-rlamb_ele) then
14317         sscagrad_ele=0.0d0
14318       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
14319         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
14320         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
14321       else
14322         sscagrad_ele=0.0d0
14323       endif
14324       return
14325       end function sscagrad_ele
14326 !!!!!!!!!! PBCSCALE
14327       real(kind=8) function sscale2(r,r_cc,r_ll)
14328 !      include "COMMON.SPLITELE"
14329       real(kind=8) :: r,gamm,r_cc,r_ll
14330       if(r.lt.r_cc-r_ll) then
14331         sscale2=1.0d0
14332       else if(r.le.r_cc.and.r.ge.r_cc-r_ll) then
14333         gamm=(r-(r_cc-r_ll))/r_ll
14334         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14335       else
14336         sscale2=0d0
14337       endif
14338       return
14339       end function sscale2
14340
14341       real(kind=8)  function sscagrad2(r,r_cc,r_ll)
14342       real(kind=8) :: r,gamm,r_cc,r_ll
14343 !      include "COMMON.SPLITELE"
14344       if(r.lt.r_cc-r_ll) then
14345         sscagrad2=0.0d0
14346       else if(r.le.r_cc.and.r.ge.r_cc-r_ll) then
14347         gamm=(r-(r_cc-r_ll))/r_ll
14348         sscagrad2=gamm*(6*gamm-6.0d0)/r_ll
14349       else
14350         sscagrad2=0.0d0
14351       endif
14352       return
14353       end function sscagrad2
14354
14355       real(kind=8) function sscalelip(r)
14356       real(kind=8) r,gamm
14357         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
14358       return
14359       end function sscalelip
14360 !C-----------------------------------------------------------------------
14361       real(kind=8) function sscagradlip(r)
14362       real(kind=8) r,gamm
14363         sscagradlip=r*(6.0d0*r-6.0d0)
14364       return
14365       end function sscagradlip
14366
14367 !!!!!!!!!!!!!!!
14368 !-----------------------------------------------------------------------------
14369       subroutine elj_long(evdw)
14370 !
14371 ! This subroutine calculates the interaction energy of nonbonded side chains
14372 ! assuming the LJ potential of interaction.
14373 !
14374 !      implicit real(kind=8) (a-h,o-z)
14375 !      include 'DIMENSIONS'
14376 !      include 'COMMON.GEO'
14377 !      include 'COMMON.VAR'
14378 !      include 'COMMON.LOCAL'
14379 !      include 'COMMON.CHAIN'
14380 !      include 'COMMON.DERIV'
14381 !      include 'COMMON.INTERACT'
14382 !      include 'COMMON.TORSION'
14383 !      include 'COMMON.SBRIDGE'
14384 !      include 'COMMON.NAMES'
14385 !      include 'COMMON.IOUNITS'
14386 !      include 'COMMON.CONTACTS'
14387       real(kind=8),parameter :: accur=1.0d-10
14388       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14389 !el local variables
14390       integer :: i,iint,j,k,itypi,itypi1,itypj
14391       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
14392       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
14393                       sslipj,ssgradlipj,aa,bb
14394 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
14395       evdw=0.0D0
14396       do i=iatsc_s,iatsc_e
14397         itypi=itype(i,1)
14398         if (itypi.eq.ntyp1) cycle
14399         itypi1=itype(i+1,1)
14400         xi=c(1,nres+i)
14401         yi=c(2,nres+i)
14402         zi=c(3,nres+i)
14403         call to_box(xi,yi,zi)
14404         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14405 !
14406 ! Calculate SC interaction energy.
14407 !
14408         do iint=1,nint_gr(i)
14409 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
14410 !d   &                  'iend=',iend(i,iint)
14411           do j=istart(i,iint),iend(i,iint)
14412             itypj=itype(j,1)
14413             if (itypj.eq.ntyp1) cycle
14414             xj=c(1,nres+j)-xi
14415             yj=c(2,nres+j)-yi
14416             zj=c(3,nres+j)-zi
14417             call to_box(xj,yj,zj)
14418             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14419             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14420              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14421             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14422              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14423             xj=boxshift(xj-xi,boxxsize)
14424             yj=boxshift(yj-yi,boxysize)
14425             zj=boxshift(zj-zi,boxzsize)
14426             rij=xj*xj+yj*yj+zj*zj
14427             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
14428             if (sss.lt.1.0d0) then
14429               rrij=1.0D0/rij
14430               eps0ij=eps(itypi,itypj)
14431               fac=rrij**expon2
14432               e1=fac*fac*aa_aq(itypi,itypj)
14433               e2=fac*bb_aq(itypi,itypj)
14434               evdwij=e1+e2
14435               evdw=evdw+(1.0d0-sss)*evdwij
14436 !
14437 ! Calculate the components of the gradient in DC and X
14438 !
14439               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
14440               gg(1)=xj*fac
14441               gg(2)=yj*fac
14442               gg(3)=zj*fac
14443               do k=1,3
14444                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14445                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14446                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14447                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14448               enddo
14449             endif
14450           enddo      ! j
14451         enddo        ! iint
14452       enddo          ! i
14453       do i=1,nct
14454         do j=1,3
14455           gvdwc(j,i)=expon*gvdwc(j,i)
14456           gvdwx(j,i)=expon*gvdwx(j,i)
14457         enddo
14458       enddo
14459 !******************************************************************************
14460 !
14461 !                              N O T E !!!
14462 !
14463 ! To save time, the factor of EXPON has been extracted from ALL components
14464 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14465 ! use!
14466 !
14467 !******************************************************************************
14468       return
14469       end subroutine elj_long
14470 !-----------------------------------------------------------------------------
14471       subroutine elj_short(evdw)
14472 !
14473 ! This subroutine calculates the interaction energy of nonbonded side chains
14474 ! assuming the LJ potential of interaction.
14475 !
14476 !      implicit real(kind=8) (a-h,o-z)
14477 !      include 'DIMENSIONS'
14478 !      include 'COMMON.GEO'
14479 !      include 'COMMON.VAR'
14480 !      include 'COMMON.LOCAL'
14481 !      include 'COMMON.CHAIN'
14482 !      include 'COMMON.DERIV'
14483 !      include 'COMMON.INTERACT'
14484 !      include 'COMMON.TORSION'
14485 !      include 'COMMON.SBRIDGE'
14486 !      include 'COMMON.NAMES'
14487 !      include 'COMMON.IOUNITS'
14488 !      include 'COMMON.CONTACTS'
14489       real(kind=8),parameter :: accur=1.0d-10
14490       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14491 !el local variables
14492       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
14493       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
14494       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
14495                       sslipj,ssgradlipj
14496 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
14497       evdw=0.0D0
14498       do i=iatsc_s,iatsc_e
14499         itypi=itype(i,1)
14500         if (itypi.eq.ntyp1) cycle
14501         itypi1=itype(i+1,1)
14502         xi=c(1,nres+i)
14503         yi=c(2,nres+i)
14504         zi=c(3,nres+i)
14505         call to_box(xi,yi,zi)
14506         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14507 ! Change 12/1/95
14508         num_conti=0
14509 !
14510 ! Calculate SC interaction energy.
14511 !
14512         do iint=1,nint_gr(i)
14513 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
14514 !d   &                  'iend=',iend(i,iint)
14515           do j=istart(i,iint),iend(i,iint)
14516             itypj=itype(j,1)
14517             if (itypj.eq.ntyp1) cycle
14518             xj=c(1,nres+j)-xi
14519             yj=c(2,nres+j)-yi
14520             zj=c(3,nres+j)-zi
14521 ! Change 12/1/95 to calculate four-body interactions
14522             rij=xj*xj+yj*yj+zj*zj
14523             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
14524             if (sss.gt.0.0d0) then
14525               rrij=1.0D0/rij
14526               eps0ij=eps(itypi,itypj)
14527               fac=rrij**expon2
14528               e1=fac*fac*aa_aq(itypi,itypj)
14529               e2=fac*bb_aq(itypi,itypj)
14530               evdwij=e1+e2
14531               evdw=evdw+sss*evdwij
14532 !
14533 ! Calculate the components of the gradient in DC and X
14534 !
14535               fac=-rrij*(e1+evdwij)*sss
14536               gg(1)=xj*fac
14537               gg(2)=yj*fac
14538               gg(3)=zj*fac
14539               do k=1,3
14540                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14541                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14542                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14543                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14544               enddo
14545             endif
14546           enddo      ! j
14547         enddo        ! iint
14548       enddo          ! i
14549       do i=1,nct
14550         do j=1,3
14551           gvdwc(j,i)=expon*gvdwc(j,i)
14552           gvdwx(j,i)=expon*gvdwx(j,i)
14553         enddo
14554       enddo
14555 !******************************************************************************
14556 !
14557 !                              N O T E !!!
14558 !
14559 ! To save time, the factor of EXPON has been extracted from ALL components
14560 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14561 ! use!
14562 !
14563 !******************************************************************************
14564       return
14565       end subroutine elj_short
14566 !-----------------------------------------------------------------------------
14567       subroutine eljk_long(evdw)
14568 !
14569 ! This subroutine calculates the interaction energy of nonbonded side chains
14570 ! assuming the LJK potential of interaction.
14571 !
14572 !      implicit real(kind=8) (a-h,o-z)
14573 !      include 'DIMENSIONS'
14574 !      include 'COMMON.GEO'
14575 !      include 'COMMON.VAR'
14576 !      include 'COMMON.LOCAL'
14577 !      include 'COMMON.CHAIN'
14578 !      include 'COMMON.DERIV'
14579 !      include 'COMMON.INTERACT'
14580 !      include 'COMMON.IOUNITS'
14581 !      include 'COMMON.NAMES'
14582       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14583       logical :: scheck
14584 !el local variables
14585       integer :: i,iint,j,k,itypi,itypi1,itypj
14586       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14587                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
14588 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14589       evdw=0.0D0
14590       do i=iatsc_s,iatsc_e
14591         itypi=itype(i,1)
14592         if (itypi.eq.ntyp1) cycle
14593         itypi1=itype(i+1,1)
14594         xi=c(1,nres+i)
14595         yi=c(2,nres+i)
14596         zi=c(3,nres+i)
14597           call to_box(xi,yi,zi)
14598
14599 !
14600 ! Calculate SC interaction energy.
14601 !
14602         do iint=1,nint_gr(i)
14603           do j=istart(i,iint),iend(i,iint)
14604             itypj=itype(j,1)
14605             if (itypj.eq.ntyp1) cycle
14606             xj=c(1,nres+j)-xi
14607             yj=c(2,nres+j)-yi
14608             zj=c(3,nres+j)-zi
14609           call to_box(xj,yj,zj)
14610       xj=boxshift(xj-xi,boxxsize)
14611       yj=boxshift(yj-yi,boxysize)
14612       zj=boxshift(zj-zi,boxzsize)
14613
14614             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14615             fac_augm=rrij**expon
14616             e_augm=augm(itypi,itypj)*fac_augm
14617             r_inv_ij=dsqrt(rrij)
14618             rij=1.0D0/r_inv_ij
14619             sss=sscale(rij/sigma(itypi,itypj))
14620             if (sss.lt.1.0d0) then
14621               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14622               fac=r_shift_inv**expon
14623               e1=fac*fac*aa_aq(itypi,itypj)
14624               e2=fac*bb_aq(itypi,itypj)
14625               evdwij=e_augm+e1+e2
14626 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14627 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14628 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14629 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14630 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14631 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14632 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14633               evdw=evdw+(1.0d0-sss)*evdwij
14634 !
14635 ! Calculate the components of the gradient in DC and X
14636 !
14637               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14638               fac=fac*(1.0d0-sss)
14639               gg(1)=xj*fac
14640               gg(2)=yj*fac
14641               gg(3)=zj*fac
14642               do k=1,3
14643                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14644                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14645                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14646                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14647               enddo
14648             endif
14649           enddo      ! j
14650         enddo        ! iint
14651       enddo          ! i
14652       do i=1,nct
14653         do j=1,3
14654           gvdwc(j,i)=expon*gvdwc(j,i)
14655           gvdwx(j,i)=expon*gvdwx(j,i)
14656         enddo
14657       enddo
14658       return
14659       end subroutine eljk_long
14660 !-----------------------------------------------------------------------------
14661       subroutine eljk_short(evdw)
14662 !
14663 ! This subroutine calculates the interaction energy of nonbonded side chains
14664 ! assuming the LJK potential of interaction.
14665 !
14666 !      implicit real(kind=8) (a-h,o-z)
14667 !      include 'DIMENSIONS'
14668 !      include 'COMMON.GEO'
14669 !      include 'COMMON.VAR'
14670 !      include 'COMMON.LOCAL'
14671 !      include 'COMMON.CHAIN'
14672 !      include 'COMMON.DERIV'
14673 !      include 'COMMON.INTERACT'
14674 !      include 'COMMON.IOUNITS'
14675 !      include 'COMMON.NAMES'
14676       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14677       logical :: scheck
14678 !el local variables
14679       integer :: i,iint,j,k,itypi,itypi1,itypj
14680       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14681                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
14682                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14683 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14684       evdw=0.0D0
14685       do i=iatsc_s,iatsc_e
14686         itypi=itype(i,1)
14687         if (itypi.eq.ntyp1) cycle
14688         itypi1=itype(i+1,1)
14689         xi=c(1,nres+i)
14690         yi=c(2,nres+i)
14691         zi=c(3,nres+i)
14692         call to_box(xi,yi,zi)
14693         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14694 !
14695 ! Calculate SC interaction energy.
14696 !
14697         do iint=1,nint_gr(i)
14698           do j=istart(i,iint),iend(i,iint)
14699             itypj=itype(j,1)
14700             if (itypj.eq.ntyp1) cycle
14701             xj=c(1,nres+j)-xi
14702             yj=c(2,nres+j)-yi
14703             zj=c(3,nres+j)-zi
14704             call to_box(xj,yj,zj)
14705             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14706             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14707              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14708             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14709              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14710             xj=boxshift(xj-xi,boxxsize)
14711             yj=boxshift(yj-yi,boxysize)
14712             zj=boxshift(zj-zi,boxzsize)
14713             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14714             fac_augm=rrij**expon
14715             e_augm=augm(itypi,itypj)*fac_augm
14716             r_inv_ij=dsqrt(rrij)
14717             rij=1.0D0/r_inv_ij
14718             sss=sscale(rij/sigma(itypi,itypj))
14719             if (sss.gt.0.0d0) then
14720               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14721               fac=r_shift_inv**expon
14722               e1=fac*fac*aa_aq(itypi,itypj)
14723               e2=fac*bb_aq(itypi,itypj)
14724               evdwij=e_augm+e1+e2
14725 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14726 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14727 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14728 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14729 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14730 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14731 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14732               evdw=evdw+sss*evdwij
14733 !
14734 ! Calculate the components of the gradient in DC and X
14735 !
14736               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14737               fac=fac*sss
14738               gg(1)=xj*fac
14739               gg(2)=yj*fac
14740               gg(3)=zj*fac
14741               do k=1,3
14742                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14743                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14744                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14745                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14746               enddo
14747             endif
14748           enddo      ! j
14749         enddo        ! iint
14750       enddo          ! i
14751       do i=1,nct
14752         do j=1,3
14753           gvdwc(j,i)=expon*gvdwc(j,i)
14754           gvdwx(j,i)=expon*gvdwx(j,i)
14755         enddo
14756       enddo
14757       return
14758       end subroutine eljk_short
14759 !-----------------------------------------------------------------------------
14760        subroutine ebp_long(evdw)
14761 ! This subroutine calculates the interaction energy of nonbonded side chains
14762 ! assuming the Berne-Pechukas potential of interaction.
14763 !
14764        use calc_data
14765 !      implicit real(kind=8) (a-h,o-z)
14766 !      include 'DIMENSIONS'
14767 !      include 'COMMON.GEO'
14768 !      include 'COMMON.VAR'
14769 !      include 'COMMON.LOCAL'
14770 !      include 'COMMON.CHAIN'
14771 !      include 'COMMON.DERIV'
14772 !      include 'COMMON.NAMES'
14773 !      include 'COMMON.INTERACT'
14774 !      include 'COMMON.IOUNITS'
14775 !      include 'COMMON.CALC'
14776        use comm_srutu
14777 !el      integer :: icall
14778 !el      common /srutu/ icall
14779 !     double precision rrsave(maxdim)
14780         logical :: lprn
14781 !el local variables
14782         integer :: iint,itypi,itypi1,itypj
14783         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
14784                         sslipj,ssgradlipj,aa,bb
14785         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
14786         evdw=0.0D0
14787 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14788         evdw=0.0D0
14789 !     if (icall.eq.0) then
14790 !       lprn=.true.
14791 !     else
14792       lprn=.false.
14793 !     endif
14794 !el      ind=0
14795       do i=iatsc_s,iatsc_e
14796       itypi=itype(i,1)
14797       if (itypi.eq.ntyp1) cycle
14798       itypi1=itype(i+1,1)
14799       xi=c(1,nres+i)
14800       yi=c(2,nres+i)
14801       zi=c(3,nres+i)
14802         call to_box(xi,yi,zi)
14803         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14804       dxi=dc_norm(1,nres+i)
14805       dyi=dc_norm(2,nres+i)
14806       dzi=dc_norm(3,nres+i)
14807 !        dsci_inv=dsc_inv(itypi)
14808       dsci_inv=vbld_inv(i+nres)
14809 !
14810 ! Calculate SC interaction energy.
14811 !
14812       do iint=1,nint_gr(i)
14813       do j=istart(i,iint),iend(i,iint)
14814 !el            ind=ind+1
14815       itypj=itype(j,1)
14816       if (itypj.eq.ntyp1) cycle
14817 !            dscj_inv=dsc_inv(itypj)
14818       dscj_inv=vbld_inv(j+nres)
14819 !chi1=chi(itypi,itypj)
14820 !chi2=chi(itypj,itypi)
14821 !chi12=chi1*chi2
14822 !chip1=chip(itypi)
14823       alf1=alp(itypi)
14824       alf2=alp(itypj)
14825       alf12=0.5D0*(alf1+alf2)
14826         xj=c(1,nres+j)-xi
14827         yj=c(2,nres+j)-yi
14828         zj=c(3,nres+j)-zi
14829             call to_box(xj,yj,zj)
14830             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14831             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14832              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14833             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14834              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14835             xj=boxshift(xj-xi,boxxsize)
14836             yj=boxshift(yj-yi,boxysize)
14837             zj=boxshift(zj-zi,boxzsize)
14838         dxj=dc_norm(1,nres+j)
14839         dyj=dc_norm(2,nres+j)
14840         dzj=dc_norm(3,nres+j)
14841         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14842         rij=dsqrt(rrij)
14843       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14844
14845         if (sss.lt.1.0d0) then
14846
14847         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14848         call sc_angular
14849         ! Calculate whole angle-dependent part of epsilon and contributions
14850         ! to its derivatives
14851         fac=(rrij*sigsq)**expon2
14852         e1=fac*fac*aa_aq(itypi,itypj)
14853         e2=fac*bb_aq(itypi,itypj)
14854       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14855         eps2der=evdwij*eps3rt
14856         eps3der=evdwij*eps2rt
14857         evdwij=evdwij*eps2rt*eps3rt
14858       evdw=evdw+evdwij*(1.0d0-sss)
14859         if (lprn) then
14860         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14861       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14862         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14863         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14864         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14865         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14866         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14867         !d     &          evdwij
14868         endif
14869         ! Calculate gradient components.
14870         e1=e1*eps1*eps2rt**2*eps3rt**2
14871       fac=-expon*(e1+evdwij)
14872         sigder=fac/sigsq
14873         fac=rrij*fac
14874         ! Calculate radial part of the gradient
14875         gg(1)=xj*fac
14876         gg(2)=yj*fac
14877         gg(3)=zj*fac
14878         ! Calculate the angular part of the gradient and sum add the contributions
14879         ! to the appropriate components of the Cartesian gradient.
14880       call sc_grad_scale(1.0d0-sss)
14881         endif
14882         enddo      ! j
14883         enddo        ! iint
14884         enddo          ! i
14885         !     stop
14886         return
14887         end subroutine ebp_long
14888         !-----------------------------------------------------------------------------
14889       subroutine ebp_short(evdw)
14890         !
14891         ! This subroutine calculates the interaction energy of nonbonded side chains
14892         ! assuming the Berne-Pechukas potential of interaction.
14893         !
14894         use calc_data
14895 !      implicit real(kind=8) (a-h,o-z)
14896         !      include 'DIMENSIONS'
14897         !      include 'COMMON.GEO'
14898         !      include 'COMMON.VAR'
14899         !      include 'COMMON.LOCAL'
14900         !      include 'COMMON.CHAIN'
14901         !      include 'COMMON.DERIV'
14902         !      include 'COMMON.NAMES'
14903         !      include 'COMMON.INTERACT'
14904         !      include 'COMMON.IOUNITS'
14905         !      include 'COMMON.CALC'
14906         use comm_srutu
14907         !el      integer :: icall
14908         !el      common /srutu/ icall
14909 !     double precision rrsave(maxdim)
14910         logical :: lprn
14911         !el local variables
14912         integer :: iint,itypi,itypi1,itypj
14913         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
14914         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
14915         sslipi,ssgradlipi,sslipj,ssgradlipj
14916         evdw=0.0D0
14917         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14918         evdw=0.0D0
14919         !     if (icall.eq.0) then
14920         !       lprn=.true.
14921         !     else
14922         lprn=.false.
14923         !     endif
14924         !el      ind=0
14925         do i=iatsc_s,iatsc_e
14926       itypi=itype(i,1)
14927         if (itypi.eq.ntyp1) cycle
14928         itypi1=itype(i+1,1)
14929         xi=c(1,nres+i)
14930         yi=c(2,nres+i)
14931         zi=c(3,nres+i)
14932         call to_box(xi,yi,zi)
14933       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14934
14935         dxi=dc_norm(1,nres+i)
14936         dyi=dc_norm(2,nres+i)
14937         dzi=dc_norm(3,nres+i)
14938         !        dsci_inv=dsc_inv(itypi)
14939       dsci_inv=vbld_inv(i+nres)
14940         !
14941         ! Calculate SC interaction energy.
14942         !
14943         do iint=1,nint_gr(i)
14944       do j=istart(i,iint),iend(i,iint)
14945         !el            ind=ind+1
14946       itypj=itype(j,1)
14947         if (itypj.eq.ntyp1) cycle
14948         !            dscj_inv=dsc_inv(itypj)
14949         dscj_inv=vbld_inv(j+nres)
14950         chi1=chi(itypi,itypj)
14951       chi2=chi(itypj,itypi)
14952         chi12=chi1*chi2
14953         chip1=chip(itypi)
14954       chip2=chip(itypj)
14955         chip12=chip1*chip2
14956         alf1=alp(itypi)
14957         alf2=alp(itypj)
14958       alf12=0.5D0*(alf1+alf2)
14959         xj=c(1,nres+j)-xi
14960         yj=c(2,nres+j)-yi
14961         zj=c(3,nres+j)-zi
14962         call to_box(xj,yj,zj)
14963       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14964         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14965         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14966         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14967              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14968             xj=boxshift(xj-xi,boxxsize)
14969             yj=boxshift(yj-yi,boxysize)
14970             zj=boxshift(zj-zi,boxzsize)
14971             dxj=dc_norm(1,nres+j)
14972             dyj=dc_norm(2,nres+j)
14973             dzj=dc_norm(3,nres+j)
14974             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14975             rij=dsqrt(rrij)
14976             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14977
14978             if (sss.gt.0.0d0) then
14979
14980 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14981               call sc_angular
14982 ! Calculate whole angle-dependent part of epsilon and contributions
14983 ! to its derivatives
14984               fac=(rrij*sigsq)**expon2
14985               e1=fac*fac*aa_aq(itypi,itypj)
14986               e2=fac*bb_aq(itypi,itypj)
14987               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14988               eps2der=evdwij*eps3rt
14989               eps3der=evdwij*eps2rt
14990               evdwij=evdwij*eps2rt*eps3rt
14991               evdw=evdw+evdwij*sss
14992               if (lprn) then
14993               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14994               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14995 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14996 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14997 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14998 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14999 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
15000 !d     &          evdwij
15001               endif
15002 ! Calculate gradient components.
15003               e1=e1*eps1*eps2rt**2*eps3rt**2
15004               fac=-expon*(e1+evdwij)
15005               sigder=fac/sigsq
15006               fac=rrij*fac
15007 ! Calculate radial part of the gradient
15008               gg(1)=xj*fac
15009               gg(2)=yj*fac
15010               gg(3)=zj*fac
15011 ! Calculate the angular part of the gradient and sum add the contributions
15012 ! to the appropriate components of the Cartesian gradient.
15013               call sc_grad_scale(sss)
15014             endif
15015           enddo      ! j
15016         enddo        ! iint
15017       enddo          ! i
15018 !     stop
15019       return
15020       end subroutine ebp_short
15021 !-----------------------------------------------------------------------------
15022       subroutine egb_long(evdw)
15023 !
15024 ! This subroutine calculates the interaction energy of nonbonded side chains
15025 ! assuming the Gay-Berne potential of interaction.
15026 !
15027       use calc_data
15028 !      implicit real(kind=8) (a-h,o-z)
15029 !      include 'DIMENSIONS'
15030 !      include 'COMMON.GEO'
15031 !      include 'COMMON.VAR'
15032 !      include 'COMMON.LOCAL'
15033 !      include 'COMMON.CHAIN'
15034 !      include 'COMMON.DERIV'
15035 !      include 'COMMON.NAMES'
15036 !      include 'COMMON.INTERACT'
15037 !      include 'COMMON.IOUNITS'
15038 !      include 'COMMON.CALC'
15039 !      include 'COMMON.CONTROL'
15040       logical :: lprn
15041 !el local variables
15042       integer :: iint,itypi,itypi1,itypj,subchap
15043       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
15044       real(kind=8) :: sss,e1,e2,evdw,sss_grad
15045       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15046                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
15047                     ssgradlipi,ssgradlipj
15048
15049
15050       evdw=0.0D0
15051 !cccc      energy_dec=.false.
15052 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15053       evdw=0.0D0
15054       lprn=.false.
15055 !     if (icall.eq.0) lprn=.false.
15056 !el      ind=0
15057       do i=iatsc_s,iatsc_e
15058         itypi=itype(i,1)
15059         if (itypi.eq.ntyp1) cycle
15060         itypi1=itype(i+1,1)
15061         xi=c(1,nres+i)
15062         yi=c(2,nres+i)
15063         zi=c(3,nres+i)
15064         call to_box(xi,yi,zi)
15065         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15066         dxi=dc_norm(1,nres+i)
15067         dyi=dc_norm(2,nres+i)
15068         dzi=dc_norm(3,nres+i)
15069 !        dsci_inv=dsc_inv(itypi)
15070         dsci_inv=vbld_inv(i+nres)
15071 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
15072 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
15073 !
15074 ! Calculate SC interaction energy.
15075 !
15076         do iint=1,nint_gr(i)
15077           do j=istart(i,iint),iend(i,iint)
15078             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
15079 !              call dyn_ssbond_ene(i,j,evdwij)
15080 !              evdw=evdw+evdwij
15081 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15082 !                              'evdw',i,j,evdwij,' ss'
15083 !              if (energy_dec) write (iout,*) &
15084 !                              'evdw',i,j,evdwij,' ss'
15085 !             do k=j+1,iend(i,iint)
15086 !C search over all next residues
15087 !              if (dyn_ss_mask(k)) then
15088 !C check if they are cysteins
15089 !C              write(iout,*) 'k=',k
15090
15091 !c              write(iout,*) "PRZED TRI", evdwij
15092 !               evdwij_przed_tri=evdwij
15093 !              call triple_ssbond_ene(i,j,k,evdwij)
15094 !c               if(evdwij_przed_tri.ne.evdwij) then
15095 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
15096 !c               endif
15097
15098 !c              write(iout,*) "PO TRI", evdwij
15099 !C call the energy function that removes the artifical triple disulfide
15100 !C bond the soubroutine is located in ssMD.F
15101 !              evdw=evdw+evdwij
15102               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15103                             'evdw',i,j,evdwij,'tss'
15104 !              endif!dyn_ss_mask(k)
15105 !             enddo! k
15106
15107             ELSE
15108 !el            ind=ind+1
15109             itypj=itype(j,1)
15110             if (itypj.eq.ntyp1) cycle
15111 !            dscj_inv=dsc_inv(itypj)
15112             dscj_inv=vbld_inv(j+nres)
15113 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
15114 !     &       1.0d0/vbld(j+nres)
15115 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
15116             sig0ij=sigma(itypi,itypj)
15117             chi1=chi(itypi,itypj)
15118             chi2=chi(itypj,itypi)
15119             chi12=chi1*chi2
15120             chip1=chip(itypi)
15121             chip2=chip(itypj)
15122             chip12=chip1*chip2
15123             alf1=alp(itypi)
15124             alf2=alp(itypj)
15125             alf12=0.5D0*(alf1+alf2)
15126             xj=c(1,nres+j)
15127             yj=c(2,nres+j)
15128             zj=c(3,nres+j)
15129 ! Searching for nearest neighbour
15130             call to_box(xj,yj,zj)
15131             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15132             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15133              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15134             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15135              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15136             xj=boxshift(xj-xi,boxxsize)
15137             yj=boxshift(yj-yi,boxysize)
15138             zj=boxshift(zj-zi,boxzsize)
15139             dxj=dc_norm(1,nres+j)
15140             dyj=dc_norm(2,nres+j)
15141             dzj=dc_norm(3,nres+j)
15142             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15143             rij=dsqrt(rrij)
15144             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15145             sss_ele_cut=sscale_ele(1.0d0/(rij))
15146             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
15147             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
15148             if (sss_ele_cut.le.0.0) cycle
15149             if (sss.lt.1.0d0) then
15150
15151 ! Calculate angle-dependent terms of energy and contributions to their
15152 ! derivatives.
15153               call sc_angular
15154               sigsq=1.0D0/sigsq
15155               sig=sig0ij*dsqrt(sigsq)
15156               rij_shift=1.0D0/rij-sig+sig0ij
15157 ! for diagnostics; uncomment
15158 !              rij_shift=1.2*sig0ij
15159 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15160               if (rij_shift.le.0.0D0) then
15161                 evdw=1.0D20
15162 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
15163 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
15164 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
15165                 return
15166               endif
15167               sigder=-sig*sigsq
15168 !---------------------------------------------------------------
15169               rij_shift=1.0D0/rij_shift
15170               fac=rij_shift**expon
15171               e1=fac*fac*aa
15172               e2=fac*bb
15173               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15174               eps2der=evdwij*eps3rt
15175               eps3der=evdwij*eps2rt
15176 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
15177 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
15178               evdwij=evdwij*eps2rt*eps3rt
15179               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
15180               if (lprn) then
15181               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15182               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15183               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15184                 restyp(itypi,1),i,restyp(itypj,1),j,&
15185                 epsi,sigm,chi1,chi2,chip1,chip2,&
15186                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
15187                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15188                 evdwij
15189               endif
15190
15191               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15192                               'evdw',i,j,evdwij
15193 !              if (energy_dec) write (iout,*) &
15194 !                              'evdw',i,j,evdwij,"egb_long"
15195
15196 ! Calculate gradient components.
15197               e1=e1*eps1*eps2rt**2*eps3rt**2
15198               fac=-expon*(e1+evdwij)*rij_shift
15199               sigder=fac*sigder
15200               fac=rij*fac
15201               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
15202               *rij-sss_grad/(1.0-sss)*rij  &
15203             /sigmaii(itypi,itypj))
15204 !              fac=0.0d0
15205 ! Calculate the radial part of the gradient
15206               gg(1)=xj*fac
15207               gg(2)=yj*fac
15208               gg(3)=zj*fac
15209 ! Calculate angular part of the gradient.
15210               call sc_grad_scale(1.0d0-sss)
15211             ENDIF    !mask_dyn_ss
15212             endif
15213           enddo      ! j
15214         enddo        ! iint
15215       enddo          ! i
15216 !      write (iout,*) "Number of loop steps in EGB:",ind
15217 !ccc      energy_dec=.false.
15218       return
15219       end subroutine egb_long
15220 !-----------------------------------------------------------------------------
15221       subroutine egb_short(evdw)
15222 !
15223 ! This subroutine calculates the interaction energy of nonbonded side chains
15224 ! assuming the Gay-Berne potential of interaction.
15225 !
15226       use calc_data
15227 !      implicit real(kind=8) (a-h,o-z)
15228 !      include 'DIMENSIONS'
15229 !      include 'COMMON.GEO'
15230 !      include 'COMMON.VAR'
15231 !      include 'COMMON.LOCAL'
15232 !      include 'COMMON.CHAIN'
15233 !      include 'COMMON.DERIV'
15234 !      include 'COMMON.NAMES'
15235 !      include 'COMMON.INTERACT'
15236 !      include 'COMMON.IOUNITS'
15237 !      include 'COMMON.CALC'
15238 !      include 'COMMON.CONTROL'
15239       logical :: lprn
15240 !el local variables
15241       integer :: iint,itypi,itypi1,itypj,subchap,countss
15242       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
15243       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
15244       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15245                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
15246                     ssgradlipi,ssgradlipj
15247       evdw=0.0D0
15248 !cccc      energy_dec=.false.
15249 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15250       evdw=0.0D0
15251       lprn=.false.
15252       countss=0
15253 !     if (icall.eq.0) lprn=.false.
15254 !el      ind=0
15255       do i=iatsc_s,iatsc_e
15256         itypi=itype(i,1)
15257         if (itypi.eq.ntyp1) cycle
15258         itypi1=itype(i+1,1)
15259         xi=c(1,nres+i)
15260         yi=c(2,nres+i)
15261         zi=c(3,nres+i)
15262         call to_box(xi,yi,zi)
15263         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15264
15265         dxi=dc_norm(1,nres+i)
15266         dyi=dc_norm(2,nres+i)
15267         dzi=dc_norm(3,nres+i)
15268 !        dsci_inv=dsc_inv(itypi)
15269         dsci_inv=vbld_inv(i+nres)
15270
15271         dxi=dc_norm(1,nres+i)
15272         dyi=dc_norm(2,nres+i)
15273         dzi=dc_norm(3,nres+i)
15274 !        dsci_inv=dsc_inv(itypi)
15275         dsci_inv=vbld_inv(i+nres)
15276         do iint=1,nint_gr(i)
15277           do j=istart(i,iint),iend(i,iint)
15278             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
15279               countss=countss+1
15280               call dyn_ssbond_ene(i,j,evdwij,countss)
15281               evdw=evdw+evdwij
15282               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15283                               'evdw',i,j,evdwij,' ss'
15284              do k=j+1,iend(i,iint)
15285 !C search over all next residues
15286               if (dyn_ss_mask(k)) then
15287 !C check if they are cysteins
15288 !C              write(iout,*) 'k=',k
15289
15290 !c              write(iout,*) "PRZED TRI", evdwij
15291 !               evdwij_przed_tri=evdwij
15292               call triple_ssbond_ene(i,j,k,evdwij)
15293 !c               if(evdwij_przed_tri.ne.evdwij) then
15294 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
15295 !c               endif
15296
15297 !c              write(iout,*) "PO TRI", evdwij
15298 !C call the energy function that removes the artifical triple disulfide
15299 !C bond the soubroutine is located in ssMD.F
15300               evdw=evdw+evdwij
15301               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15302                             'evdw',i,j,evdwij,'tss'
15303               endif!dyn_ss_mask(k)
15304              enddo! k
15305             ELSE
15306
15307 !          typj=itype(j,1)
15308             if (itypj.eq.ntyp1) cycle
15309 !            dscj_inv=dsc_inv(itypj)
15310             dscj_inv=vbld_inv(j+nres)
15311             dscj_inv=dsc_inv(itypj)
15312 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
15313 !     &       1.0d0/vbld(j+nres)
15314 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
15315             sig0ij=sigma(itypi,itypj)
15316             chi1=chi(itypi,itypj)
15317             chi2=chi(itypj,itypi)
15318             chi12=chi1*chi2
15319             chip1=chip(itypi)
15320             chip2=chip(itypj)
15321             chip12=chip1*chip2
15322             alf1=alp(itypi)
15323             alf2=alp(itypj)
15324             alf12=0.5D0*(alf1+alf2)
15325 !            xj=c(1,nres+j)-xi
15326 !            yj=c(2,nres+j)-yi
15327 !            zj=c(3,nres+j)-zi
15328             xj=c(1,nres+j)
15329             yj=c(2,nres+j)
15330             zj=c(3,nres+j)
15331 ! Searching for nearest neighbour
15332             call to_box(xj,yj,zj)
15333             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15334             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15335              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15336             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15337              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15338             xj=boxshift(xj-xi,boxxsize)
15339             yj=boxshift(yj-yi,boxysize)
15340             zj=boxshift(zj-zi,boxzsize)
15341             dxj=dc_norm(1,nres+j)
15342             dyj=dc_norm(2,nres+j)
15343             dzj=dc_norm(3,nres+j)
15344             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15345             rij=dsqrt(rrij)
15346             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15347             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
15348             sss_ele_cut=sscale_ele(1.0d0/(rij))
15349             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
15350             if (sss_ele_cut.le.0.0) cycle
15351
15352             if (sss.gt.0.0d0) then
15353
15354 ! Calculate angle-dependent terms of energy and contributions to their
15355 ! derivatives.
15356               call sc_angular
15357               sigsq=1.0D0/sigsq
15358               sig=sig0ij*dsqrt(sigsq)
15359               rij_shift=1.0D0/rij-sig+sig0ij
15360 ! for diagnostics; uncomment
15361 !              rij_shift=1.2*sig0ij
15362 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15363               if (rij_shift.le.0.0D0) then
15364                 evdw=1.0D20
15365 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
15366 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
15367 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
15368                 return
15369               endif
15370               sigder=-sig*sigsq
15371 !---------------------------------------------------------------
15372               rij_shift=1.0D0/rij_shift
15373               fac=rij_shift**expon
15374               e1=fac*fac*aa
15375               e2=fac*bb
15376               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15377               eps2der=evdwij*eps3rt
15378               eps3der=evdwij*eps2rt
15379 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
15380 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
15381               evdwij=evdwij*eps2rt*eps3rt
15382               evdw=evdw+evdwij*sss*sss_ele_cut
15383               if (lprn) then
15384               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15385               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15386               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15387                 restyp(itypi,1),i,restyp(itypj,1),j,&
15388                 epsi,sigm,chi1,chi2,chip1,chip2,&
15389                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
15390                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15391                 evdwij
15392               endif
15393
15394               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15395                               'evdw',i,j,evdwij
15396 !              if (energy_dec) write (iout,*) &
15397 !                              'evdw',i,j,evdwij,"egb_short"
15398
15399 ! Calculate gradient components.
15400               e1=e1*eps1*eps2rt**2*eps3rt**2
15401               fac=-expon*(e1+evdwij)*rij_shift
15402               sigder=fac*sigder
15403               fac=rij*fac
15404               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
15405             *rij+sss_grad/sss*rij  &
15406             /sigmaii(itypi,itypj))
15407
15408 !              fac=0.0d0
15409 ! Calculate the radial part of the gradient
15410               gg(1)=xj*fac
15411               gg(2)=yj*fac
15412               gg(3)=zj*fac
15413 ! Calculate angular part of the gradient.
15414               call sc_grad_scale(sss)
15415             endif
15416           ENDIF !mask_dyn_ss
15417           enddo      ! j
15418         enddo        ! iint
15419       enddo          ! i
15420 !      write (iout,*) "Number of loop steps in EGB:",ind
15421 !ccc      energy_dec=.false.
15422       return
15423       end subroutine egb_short
15424 !-----------------------------------------------------------------------------
15425       subroutine egbv_long(evdw)
15426 !
15427 ! This subroutine calculates the interaction energy of nonbonded side chains
15428 ! assuming the Gay-Berne-Vorobjev potential of interaction.
15429 !
15430       use calc_data
15431 !      implicit real(kind=8) (a-h,o-z)
15432 !      include 'DIMENSIONS'
15433 !      include 'COMMON.GEO'
15434 !      include 'COMMON.VAR'
15435 !      include 'COMMON.LOCAL'
15436 !      include 'COMMON.CHAIN'
15437 !      include 'COMMON.DERIV'
15438 !      include 'COMMON.NAMES'
15439 !      include 'COMMON.INTERACT'
15440 !      include 'COMMON.IOUNITS'
15441 !      include 'COMMON.CALC'
15442       use comm_srutu
15443 !el      integer :: icall
15444 !el      common /srutu/ icall
15445       logical :: lprn
15446 !el local variables
15447       integer :: iint,itypi,itypi1,itypj
15448       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
15449                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
15450       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
15451       evdw=0.0D0
15452 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15453       evdw=0.0D0
15454       lprn=.false.
15455 !     if (icall.eq.0) lprn=.true.
15456 !el      ind=0
15457       do i=iatsc_s,iatsc_e
15458         itypi=itype(i,1)
15459         if (itypi.eq.ntyp1) cycle
15460         itypi1=itype(i+1,1)
15461         xi=c(1,nres+i)
15462         yi=c(2,nres+i)
15463         zi=c(3,nres+i)
15464         call to_box(xi,yi,zi)
15465         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15466         dxi=dc_norm(1,nres+i)
15467         dyi=dc_norm(2,nres+i)
15468         dzi=dc_norm(3,nres+i)
15469
15470 !        dsci_inv=dsc_inv(itypi)
15471         dsci_inv=vbld_inv(i+nres)
15472 !
15473 ! Calculate SC interaction energy.
15474 !
15475         do iint=1,nint_gr(i)
15476           do j=istart(i,iint),iend(i,iint)
15477 !el            ind=ind+1
15478             itypj=itype(j,1)
15479             if (itypj.eq.ntyp1) cycle
15480 !            dscj_inv=dsc_inv(itypj)
15481             dscj_inv=vbld_inv(j+nres)
15482             sig0ij=sigma(itypi,itypj)
15483             r0ij=r0(itypi,itypj)
15484             chi1=chi(itypi,itypj)
15485             chi2=chi(itypj,itypi)
15486             chi12=chi1*chi2
15487             chip1=chip(itypi)
15488             chip2=chip(itypj)
15489             chip12=chip1*chip2
15490             alf1=alp(itypi)
15491             alf2=alp(itypj)
15492             alf12=0.5D0*(alf1+alf2)
15493             xj=c(1,nres+j)-xi
15494             yj=c(2,nres+j)-yi
15495             zj=c(3,nres+j)-zi
15496             call to_box(xj,yj,zj)
15497             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15498             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15499             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15500             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15501             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15502             xj=boxshift(xj-xi,boxxsize)
15503             yj=boxshift(yj-yi,boxysize)
15504             zj=boxshift(zj-zi,boxzsize)
15505             dxj=dc_norm(1,nres+j)
15506             dyj=dc_norm(2,nres+j)
15507             dzj=dc_norm(3,nres+j)
15508             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15509             rij=dsqrt(rrij)
15510
15511             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15512
15513             if (sss.lt.1.0d0) then
15514
15515 ! Calculate angle-dependent terms of energy and contributions to their
15516 ! derivatives.
15517               call sc_angular
15518               sigsq=1.0D0/sigsq
15519               sig=sig0ij*dsqrt(sigsq)
15520               rij_shift=1.0D0/rij-sig+r0ij
15521 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15522               if (rij_shift.le.0.0D0) then
15523                 evdw=1.0D20
15524                 return
15525               endif
15526               sigder=-sig*sigsq
15527 !---------------------------------------------------------------
15528               rij_shift=1.0D0/rij_shift
15529               fac=rij_shift**expon
15530               e1=fac*fac*aa_aq(itypi,itypj)
15531               e2=fac*bb_aq(itypi,itypj)
15532               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15533               eps2der=evdwij*eps3rt
15534               eps3der=evdwij*eps2rt
15535               fac_augm=rrij**expon
15536               e_augm=augm(itypi,itypj)*fac_augm
15537               evdwij=evdwij*eps2rt*eps3rt
15538               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
15539               if (lprn) then
15540               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15541               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15542               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15543                 restyp(itypi,1),i,restyp(itypj,1),j,&
15544                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15545                 chi1,chi2,chip1,chip2,&
15546                 eps1,eps2rt**2,eps3rt**2,&
15547                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15548                 evdwij+e_augm
15549               endif
15550 ! Calculate gradient components.
15551               e1=e1*eps1*eps2rt**2*eps3rt**2
15552               fac=-expon*(e1+evdwij)*rij_shift
15553               sigder=fac*sigder
15554               fac=rij*fac-2*expon*rrij*e_augm
15555 ! Calculate the radial part of the gradient
15556               gg(1)=xj*fac
15557               gg(2)=yj*fac
15558               gg(3)=zj*fac
15559 ! Calculate angular part of the gradient.
15560               call sc_grad_scale(1.0d0-sss)
15561             endif
15562           enddo      ! j
15563         enddo        ! iint
15564       enddo          ! i
15565       end subroutine egbv_long
15566 !-----------------------------------------------------------------------------
15567       subroutine egbv_short(evdw)
15568 !
15569 ! This subroutine calculates the interaction energy of nonbonded side chains
15570 ! assuming the Gay-Berne-Vorobjev potential of interaction.
15571 !
15572       use calc_data
15573 !      implicit real(kind=8) (a-h,o-z)
15574 !      include 'DIMENSIONS'
15575 !      include 'COMMON.GEO'
15576 !      include 'COMMON.VAR'
15577 !      include 'COMMON.LOCAL'
15578 !      include 'COMMON.CHAIN'
15579 !      include 'COMMON.DERIV'
15580 !      include 'COMMON.NAMES'
15581 !      include 'COMMON.INTERACT'
15582 !      include 'COMMON.IOUNITS'
15583 !      include 'COMMON.CALC'
15584       use comm_srutu
15585 !el      integer :: icall
15586 !el      common /srutu/ icall
15587       logical :: lprn
15588 !el local variables
15589       integer :: iint,itypi,itypi1,itypj
15590       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
15591                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
15592       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
15593       evdw=0.0D0
15594 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15595       evdw=0.0D0
15596       lprn=.false.
15597 !     if (icall.eq.0) lprn=.true.
15598 !el      ind=0
15599       do i=iatsc_s,iatsc_e
15600         itypi=itype(i,1)
15601         if (itypi.eq.ntyp1) cycle
15602         itypi1=itype(i+1,1)
15603         xi=c(1,nres+i)
15604         yi=c(2,nres+i)
15605         zi=c(3,nres+i)
15606         dxi=dc_norm(1,nres+i)
15607         dyi=dc_norm(2,nres+i)
15608         dzi=dc_norm(3,nres+i)
15609         call to_box(xi,yi,zi)
15610         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15611 !        dsci_inv=dsc_inv(itypi)
15612         dsci_inv=vbld_inv(i+nres)
15613 !
15614 ! Calculate SC interaction energy.
15615 !
15616         do iint=1,nint_gr(i)
15617           do j=istart(i,iint),iend(i,iint)
15618 !el            ind=ind+1
15619             itypj=itype(j,1)
15620             if (itypj.eq.ntyp1) cycle
15621 !            dscj_inv=dsc_inv(itypj)
15622             dscj_inv=vbld_inv(j+nres)
15623             sig0ij=sigma(itypi,itypj)
15624             r0ij=r0(itypi,itypj)
15625             chi1=chi(itypi,itypj)
15626             chi2=chi(itypj,itypi)
15627             chi12=chi1*chi2
15628             chip1=chip(itypi)
15629             chip2=chip(itypj)
15630             chip12=chip1*chip2
15631             alf1=alp(itypi)
15632             alf2=alp(itypj)
15633             alf12=0.5D0*(alf1+alf2)
15634             xj=c(1,nres+j)-xi
15635             yj=c(2,nres+j)-yi
15636             zj=c(3,nres+j)-zi
15637             call to_box(xj,yj,zj)
15638             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15639             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15640             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15641             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15642             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15643             xj=boxshift(xj-xi,boxxsize)
15644             yj=boxshift(yj-yi,boxysize)
15645             zj=boxshift(zj-zi,boxzsize)
15646             dxj=dc_norm(1,nres+j)
15647             dyj=dc_norm(2,nres+j)
15648             dzj=dc_norm(3,nres+j)
15649             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15650             rij=dsqrt(rrij)
15651
15652             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15653
15654             if (sss.gt.0.0d0) then
15655
15656 ! Calculate angle-dependent terms of energy and contributions to their
15657 ! derivatives.
15658               call sc_angular
15659               sigsq=1.0D0/sigsq
15660               sig=sig0ij*dsqrt(sigsq)
15661               rij_shift=1.0D0/rij-sig+r0ij
15662 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15663               if (rij_shift.le.0.0D0) then
15664                 evdw=1.0D20
15665                 return
15666               endif
15667               sigder=-sig*sigsq
15668 !---------------------------------------------------------------
15669               rij_shift=1.0D0/rij_shift
15670               fac=rij_shift**expon
15671               e1=fac*fac*aa_aq(itypi,itypj)
15672               e2=fac*bb_aq(itypi,itypj)
15673               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15674               eps2der=evdwij*eps3rt
15675               eps3der=evdwij*eps2rt
15676               fac_augm=rrij**expon
15677               e_augm=augm(itypi,itypj)*fac_augm
15678               evdwij=evdwij*eps2rt*eps3rt
15679               evdw=evdw+(evdwij+e_augm)*sss
15680               if (lprn) then
15681               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15682               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15683               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15684                 restyp(itypi,1),i,restyp(itypj,1),j,&
15685                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15686                 chi1,chi2,chip1,chip2,&
15687                 eps1,eps2rt**2,eps3rt**2,&
15688                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15689                 evdwij+e_augm
15690               endif
15691 ! Calculate gradient components.
15692               e1=e1*eps1*eps2rt**2*eps3rt**2
15693               fac=-expon*(e1+evdwij)*rij_shift
15694               sigder=fac*sigder
15695               fac=rij*fac-2*expon*rrij*e_augm
15696 ! Calculate the radial part of the gradient
15697               gg(1)=xj*fac
15698               gg(2)=yj*fac
15699               gg(3)=zj*fac
15700 ! Calculate angular part of the gradient.
15701               call sc_grad_scale(sss)
15702             endif
15703           enddo      ! j
15704         enddo        ! iint
15705       enddo          ! i
15706       end subroutine egbv_short
15707 !-----------------------------------------------------------------------------
15708       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15709 !
15710 ! This subroutine calculates the average interaction energy and its gradient
15711 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
15712 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
15713 ! The potential depends both on the distance of peptide-group centers and on
15714 ! the orientation of the CA-CA virtual bonds.
15715 !
15716 !      implicit real(kind=8) (a-h,o-z)
15717
15718       use comm_locel
15719 #ifdef MPI
15720       include 'mpif.h'
15721 #endif
15722 !      include 'DIMENSIONS'
15723 !      include 'COMMON.CONTROL'
15724 !      include 'COMMON.SETUP'
15725 !      include 'COMMON.IOUNITS'
15726 !      include 'COMMON.GEO'
15727 !      include 'COMMON.VAR'
15728 !      include 'COMMON.LOCAL'
15729 !      include 'COMMON.CHAIN'
15730 !      include 'COMMON.DERIV'
15731 !      include 'COMMON.INTERACT'
15732 !      include 'COMMON.CONTACTS'
15733 !      include 'COMMON.TORSION'
15734 !      include 'COMMON.VECTORS'
15735 !      include 'COMMON.FFIELD'
15736 !      include 'COMMON.TIME1'
15737       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
15738       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
15739       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15740 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15741       real(kind=8),dimension(4) :: muij
15742 !el      integer :: num_conti,j1,j2
15743 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15744 !el                   dz_normi,xmedi,ymedi,zmedi
15745 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15746 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15747 !el          num_conti,j1,j2
15748 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15749 #ifdef MOMENT
15750       real(kind=8) :: scal_el=1.0d0
15751 #else
15752       real(kind=8) :: scal_el=0.5d0
15753 #endif
15754 ! 12/13/98
15755 ! 13-go grudnia roku pamietnego...
15756       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15757                                              0.0d0,1.0d0,0.0d0,&
15758                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15759 !el local variables
15760       integer :: i,j,k
15761       real(kind=8) :: fac
15762       real(kind=8) :: dxj,dyj,dzj
15763       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
15764
15765 !      allocate(num_cont_hb(nres)) !(maxres)
15766 !d      write(iout,*) 'In EELEC'
15767 !d      do i=1,nloctyp
15768 !d        write(iout,*) 'Type',i
15769 !d        write(iout,*) 'B1',B1(:,i)
15770 !d        write(iout,*) 'B2',B2(:,i)
15771 !d        write(iout,*) 'CC',CC(:,:,i)
15772 !d        write(iout,*) 'DD',DD(:,:,i)
15773 !d        write(iout,*) 'EE',EE(:,:,i)
15774 !d      enddo
15775 !d      call check_vecgrad
15776 !d      stop
15777       if (icheckgrad.eq.1) then
15778         do i=1,nres-1
15779           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
15780           do k=1,3
15781             dc_norm(k,i)=dc(k,i)*fac
15782           enddo
15783 !          write (iout,*) 'i',i,' fac',fac
15784         enddo
15785       endif
15786       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15787           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
15788           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
15789 !        call vec_and_deriv
15790 #ifdef TIMING
15791         time01=MPI_Wtime()
15792 #endif
15793 !        print *, "before set matrices"
15794         call set_matrices
15795 !        print *,"after set martices"
15796 #ifdef TIMING
15797         time_mat=time_mat+MPI_Wtime()-time01
15798 #endif
15799       endif
15800 !d      do i=1,nres-1
15801 !d        write (iout,*) 'i=',i
15802 !d        do k=1,3
15803 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
15804 !d        enddo
15805 !d        do k=1,3
15806 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
15807 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
15808 !d        enddo
15809 !d      enddo
15810       t_eelecij=0.0d0
15811       ees=0.0D0
15812       evdw1=0.0D0
15813       eel_loc=0.0d0
15814       eello_turn3=0.0d0
15815       eello_turn4=0.0d0
15816 !el      ind=0
15817       do i=1,nres
15818         num_cont_hb(i)=0
15819       enddo
15820 !d      print '(a)','Enter EELEC'
15821 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
15822 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
15823 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
15824       do i=1,nres
15825         gel_loc_loc(i)=0.0d0
15826         gcorr_loc(i)=0.0d0
15827       enddo
15828 !
15829 !
15830 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
15831 !
15832 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
15833 !
15834       do i=iturn3_start,iturn3_end
15835         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
15836         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
15837         dxi=dc(1,i)
15838         dyi=dc(2,i)
15839         dzi=dc(3,i)
15840         dx_normi=dc_norm(1,i)
15841         dy_normi=dc_norm(2,i)
15842         dz_normi=dc_norm(3,i)
15843         xmedi=c(1,i)+0.5d0*dxi
15844         ymedi=c(2,i)+0.5d0*dyi
15845         zmedi=c(3,i)+0.5d0*dzi
15846         call to_box(xmedi,ymedi,zmedi)
15847         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15848         num_conti=0
15849         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
15850         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
15851         num_cont_hb(i)=num_conti
15852       enddo
15853       do i=iturn4_start,iturn4_end
15854         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
15855           .or. itype(i+3,1).eq.ntyp1 &
15856           .or. itype(i+4,1).eq.ntyp1) cycle
15857         dxi=dc(1,i)
15858         dyi=dc(2,i)
15859         dzi=dc(3,i)
15860         dx_normi=dc_norm(1,i)
15861         dy_normi=dc_norm(2,i)
15862         dz_normi=dc_norm(3,i)
15863         xmedi=c(1,i)+0.5d0*dxi
15864         ymedi=c(2,i)+0.5d0*dyi
15865         zmedi=c(3,i)+0.5d0*dzi
15866
15867         call to_box(xmedi,ymedi,zmedi)
15868         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15869
15870         num_conti=num_cont_hb(i)
15871         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
15872         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
15873           call eturn4(i,eello_turn4)
15874         num_cont_hb(i)=num_conti
15875       enddo   ! i
15876 !
15877 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
15878 !
15879       do i=iatel_s,iatel_e
15880         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15881         dxi=dc(1,i)
15882         dyi=dc(2,i)
15883         dzi=dc(3,i)
15884         dx_normi=dc_norm(1,i)
15885         dy_normi=dc_norm(2,i)
15886         dz_normi=dc_norm(3,i)
15887         xmedi=c(1,i)+0.5d0*dxi
15888         ymedi=c(2,i)+0.5d0*dyi
15889         zmedi=c(3,i)+0.5d0*dzi
15890         call to_box(xmedi,ymedi,zmedi)
15891         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15892 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
15893         num_conti=num_cont_hb(i)
15894         do j=ielstart(i),ielend(i)
15895           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15896           call eelecij_scale(i,j,ees,evdw1,eel_loc)
15897         enddo ! j
15898         num_cont_hb(i)=num_conti
15899       enddo   ! i
15900 !      write (iout,*) "Number of loop steps in EELEC:",ind
15901 !d      do i=1,nres
15902 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
15903 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
15904 !d      enddo
15905 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
15906 !cc      eel_loc=eel_loc+eello_turn3
15907 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
15908       return
15909       end subroutine eelec_scale
15910 !-----------------------------------------------------------------------------
15911       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
15912 !      implicit real(kind=8) (a-h,o-z)
15913
15914       use comm_locel
15915 !      include 'DIMENSIONS'
15916 #ifdef MPI
15917       include "mpif.h"
15918 #endif
15919 !      include 'COMMON.CONTROL'
15920 !      include 'COMMON.IOUNITS'
15921 !      include 'COMMON.GEO'
15922 !      include 'COMMON.VAR'
15923 !      include 'COMMON.LOCAL'
15924 !      include 'COMMON.CHAIN'
15925 !      include 'COMMON.DERIV'
15926 !      include 'COMMON.INTERACT'
15927 !      include 'COMMON.CONTACTS'
15928 !      include 'COMMON.TORSION'
15929 !      include 'COMMON.VECTORS'
15930 !      include 'COMMON.FFIELD'
15931 !      include 'COMMON.TIME1'
15932       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
15933       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
15934       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15935 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15936       real(kind=8),dimension(4) :: muij
15937       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15938                     dist_temp, dist_init,sss_grad
15939       integer xshift,yshift,zshift
15940
15941 !el      integer :: num_conti,j1,j2
15942 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15943 !el                   dz_normi,xmedi,ymedi,zmedi
15944 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15945 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15946 !el          num_conti,j1,j2
15947 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15948 #ifdef MOMENT
15949       real(kind=8) :: scal_el=1.0d0
15950 #else
15951       real(kind=8) :: scal_el=0.5d0
15952 #endif
15953 ! 12/13/98
15954 ! 13-go grudnia roku pamietnego...
15955       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15956                                              0.0d0,1.0d0,0.0d0,&
15957                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15958 !el local variables
15959       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15960       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15961       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15962       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15963       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15964       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15965       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15966                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15967                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15968                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15969                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15970                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
15971 !      integer :: maxconts
15972 !      maxconts = nres/4
15973 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15974 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15975 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15976 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15977 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15978 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15979 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15980 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15981 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15982 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15983 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15984 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15985 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15986
15987 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15988 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15989
15990 #ifdef MPI
15991           time00=MPI_Wtime()
15992 #endif
15993 !d      write (iout,*) "eelecij",i,j
15994 !el          ind=ind+1
15995           iteli=itel(i)
15996           itelj=itel(j)
15997           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15998           aaa=app(iteli,itelj)
15999           bbb=bpp(iteli,itelj)
16000           ael6i=ael6(iteli,itelj)
16001           ael3i=ael3(iteli,itelj)
16002           dxj=dc(1,j)
16003           dyj=dc(2,j)
16004           dzj=dc(3,j)
16005           dx_normj=dc_norm(1,j)
16006           dy_normj=dc_norm(2,j)
16007           dz_normj=dc_norm(3,j)
16008 !          xj=c(1,j)+0.5D0*dxj-xmedi
16009 !          yj=c(2,j)+0.5D0*dyj-ymedi
16010 !          zj=c(3,j)+0.5D0*dzj-zmedi
16011           xj=c(1,j)+0.5D0*dxj
16012           yj=c(2,j)+0.5D0*dyj
16013           zj=c(3,j)+0.5D0*dzj
16014           call to_box(xj,yj,zj)
16015           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
16016           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
16017           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
16018           xj=boxshift(xj-xmedi,boxxsize)
16019           yj=boxshift(yj-ymedi,boxysize)
16020           zj=boxshift(zj-zmedi,boxzsize)
16021           rij=xj*xj+yj*yj+zj*zj
16022           rrmij=1.0D0/rij
16023           rij=dsqrt(rij)
16024           rmij=1.0D0/rij
16025 ! For extracting the short-range part of Evdwpp
16026           sss=sscale(rij/rpp(iteli,itelj))
16027             sss_ele_cut=sscale_ele(rij)
16028             sss_ele_grad=sscagrad_ele(rij)
16029             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
16030 !             sss_ele_cut=1.0d0
16031 !             sss_ele_grad=0.0d0
16032             if (sss_ele_cut.le.0.0) go to 128
16033
16034           r3ij=rrmij*rmij
16035           r6ij=r3ij*r3ij
16036           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
16037           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
16038           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
16039           fac=cosa-3.0D0*cosb*cosg
16040           ev1=aaa*r6ij*r6ij
16041 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
16042           if (j.eq.i+2) ev1=scal_el*ev1
16043           ev2=bbb*r6ij
16044           fac3=ael6i*r6ij
16045           fac4=ael3i*r3ij
16046           evdwij=ev1+ev2
16047           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
16048           el2=fac4*fac
16049           eesij=el1+el2
16050 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
16051           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
16052           ees=ees+eesij*sss_ele_cut
16053           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
16054 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
16055 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
16056 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
16057 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
16058
16059           if (energy_dec) then
16060               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
16061               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
16062           endif
16063
16064 !
16065 ! Calculate contributions to the Cartesian gradient.
16066 !
16067 #ifdef SPLITELE
16068           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
16069           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
16070           fac1=fac
16071           erij(1)=xj*rmij
16072           erij(2)=yj*rmij
16073           erij(3)=zj*rmij
16074 !
16075 ! Radial derivatives. First process both termini of the fragment (i,j)
16076 !
16077           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
16078           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
16079           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
16080 !          do k=1,3
16081 !            ghalf=0.5D0*ggg(k)
16082 !            gelc(k,i)=gelc(k,i)+ghalf
16083 !            gelc(k,j)=gelc(k,j)+ghalf
16084 !          enddo
16085 ! 9/28/08 AL Gradient compotents will be summed only at the end
16086           do k=1,3
16087             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
16088             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
16089           enddo
16090 !
16091 ! Loop over residues i+1 thru j-1.
16092 !
16093 !grad          do k=i+1,j-1
16094 !grad            do l=1,3
16095 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
16096 !grad            enddo
16097 !grad          enddo
16098           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
16099           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
16100           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
16101           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
16102           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
16103           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
16104 !          do k=1,3
16105 !            ghalf=0.5D0*ggg(k)
16106 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
16107 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
16108 !          enddo
16109 ! 9/28/08 AL Gradient compotents will be summed only at the end
16110           do k=1,3
16111             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16112             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16113           enddo
16114 !
16115 ! Loop over residues i+1 thru j-1.
16116 !
16117 !grad          do k=i+1,j-1
16118 !grad            do l=1,3
16119 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
16120 !grad            enddo
16121 !grad          enddo
16122 #else
16123           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
16124           facel=(el1+eesij)*sss_ele_cut
16125           fac1=fac
16126           fac=-3*rrmij*(facvdw+facvdw+facel)
16127           erij(1)=xj*rmij
16128           erij(2)=yj*rmij
16129           erij(3)=zj*rmij
16130 !
16131 ! Radial derivatives. First process both termini of the fragment (i,j)
16132 !
16133           ggg(1)=fac*xj
16134           ggg(2)=fac*yj
16135           ggg(3)=fac*zj
16136 !          do k=1,3
16137 !            ghalf=0.5D0*ggg(k)
16138 !            gelc(k,i)=gelc(k,i)+ghalf
16139 !            gelc(k,j)=gelc(k,j)+ghalf
16140 !          enddo
16141 ! 9/28/08 AL Gradient compotents will be summed only at the end
16142           do k=1,3
16143             gelc_long(k,j)=gelc(k,j)+ggg(k)
16144             gelc_long(k,i)=gelc(k,i)-ggg(k)
16145           enddo
16146 !
16147 ! Loop over residues i+1 thru j-1.
16148 !
16149 !grad          do k=i+1,j-1
16150 !grad            do l=1,3
16151 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
16152 !grad            enddo
16153 !grad          enddo
16154 ! 9/28/08 AL Gradient compotents will be summed only at the end
16155           ggg(1)=facvdw*xj
16156           ggg(2)=facvdw*yj
16157           ggg(3)=facvdw*zj
16158           do k=1,3
16159             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16160             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16161           enddo
16162 #endif
16163 !
16164 ! Angular part
16165 !
16166           ecosa=2.0D0*fac3*fac1+fac4
16167           fac4=-3.0D0*fac4
16168           fac3=-6.0D0*fac3
16169           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
16170           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
16171           do k=1,3
16172             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
16173             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
16174           enddo
16175 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
16176 !d   &          (dcosg(k),k=1,3)
16177           do k=1,3
16178             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
16179           enddo
16180 !          do k=1,3
16181 !            ghalf=0.5D0*ggg(k)
16182 !            gelc(k,i)=gelc(k,i)+ghalf
16183 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
16184 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16185 !            gelc(k,j)=gelc(k,j)+ghalf
16186 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
16187 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16188 !          enddo
16189 !grad          do k=i+1,j-1
16190 !grad            do l=1,3
16191 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
16192 !grad            enddo
16193 !grad          enddo
16194           do k=1,3
16195             gelc(k,i)=gelc(k,i) &
16196                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16197                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
16198                      *sss_ele_cut
16199             gelc(k,j)=gelc(k,j) &
16200                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16201                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
16202                      *sss_ele_cut
16203             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
16204             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
16205           enddo
16206           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
16207               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
16208               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
16209 !
16210 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
16211 !   energy of a peptide unit is assumed in the form of a second-order
16212 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
16213 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
16214 !   are computed for EVERY pair of non-contiguous peptide groups.
16215 !
16216           if (j.lt.nres-1) then
16217             j1=j+1
16218             j2=j-1
16219           else
16220             j1=j-1
16221             j2=j-2
16222           endif
16223           kkk=0
16224           do k=1,2
16225             do l=1,2
16226               kkk=kkk+1
16227               muij(kkk)=mu(k,i)*mu(l,j)
16228             enddo
16229           enddo
16230 !d         write (iout,*) 'EELEC: i',i,' j',j
16231 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
16232 !d          write(iout,*) 'muij',muij
16233           ury=scalar(uy(1,i),erij)
16234           urz=scalar(uz(1,i),erij)
16235           vry=scalar(uy(1,j),erij)
16236           vrz=scalar(uz(1,j),erij)
16237           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
16238           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
16239           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
16240           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
16241           fac=dsqrt(-ael6i)*r3ij
16242           a22=a22*fac
16243           a23=a23*fac
16244           a32=a32*fac
16245           a33=a33*fac
16246 !d          write (iout,'(4i5,4f10.5)')
16247 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
16248 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
16249 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
16250 !d     &      uy(:,j),uz(:,j)
16251 !d          write (iout,'(4f10.5)')
16252 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
16253 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
16254 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
16255 !d           write (iout,'(9f10.5/)')
16256 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
16257 ! Derivatives of the elements of A in virtual-bond vectors
16258           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
16259           do k=1,3
16260             uryg(k,1)=scalar(erder(1,k),uy(1,i))
16261             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
16262             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
16263             urzg(k,1)=scalar(erder(1,k),uz(1,i))
16264             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
16265             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
16266             vryg(k,1)=scalar(erder(1,k),uy(1,j))
16267             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
16268             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
16269             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
16270             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
16271             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
16272           enddo
16273 ! Compute radial contributions to the gradient
16274           facr=-3.0d0*rrmij
16275           a22der=a22*facr
16276           a23der=a23*facr
16277           a32der=a32*facr
16278           a33der=a33*facr
16279           agg(1,1)=a22der*xj
16280           agg(2,1)=a22der*yj
16281           agg(3,1)=a22der*zj
16282           agg(1,2)=a23der*xj
16283           agg(2,2)=a23der*yj
16284           agg(3,2)=a23der*zj
16285           agg(1,3)=a32der*xj
16286           agg(2,3)=a32der*yj
16287           agg(3,3)=a32der*zj
16288           agg(1,4)=a33der*xj
16289           agg(2,4)=a33der*yj
16290           agg(3,4)=a33der*zj
16291 ! Add the contributions coming from er
16292           fac3=-3.0d0*fac
16293           do k=1,3
16294             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
16295             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
16296             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
16297             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
16298           enddo
16299           do k=1,3
16300 ! Derivatives in DC(i)
16301 !grad            ghalf1=0.5d0*agg(k,1)
16302 !grad            ghalf2=0.5d0*agg(k,2)
16303 !grad            ghalf3=0.5d0*agg(k,3)
16304 !grad            ghalf4=0.5d0*agg(k,4)
16305             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
16306             -3.0d0*uryg(k,2)*vry)!+ghalf1
16307             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
16308             -3.0d0*uryg(k,2)*vrz)!+ghalf2
16309             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
16310             -3.0d0*urzg(k,2)*vry)!+ghalf3
16311             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
16312             -3.0d0*urzg(k,2)*vrz)!+ghalf4
16313 ! Derivatives in DC(i+1)
16314             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
16315             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
16316             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
16317             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
16318             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
16319             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
16320             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
16321             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
16322 ! Derivatives in DC(j)
16323             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
16324             -3.0d0*vryg(k,2)*ury)!+ghalf1
16325             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
16326             -3.0d0*vrzg(k,2)*ury)!+ghalf2
16327             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
16328             -3.0d0*vryg(k,2)*urz)!+ghalf3
16329             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
16330             -3.0d0*vrzg(k,2)*urz)!+ghalf4
16331 ! Derivatives in DC(j+1) or DC(nres-1)
16332             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
16333             -3.0d0*vryg(k,3)*ury)
16334             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
16335             -3.0d0*vrzg(k,3)*ury)
16336             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
16337             -3.0d0*vryg(k,3)*urz)
16338             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
16339             -3.0d0*vrzg(k,3)*urz)
16340 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
16341 !grad              do l=1,4
16342 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
16343 !grad              enddo
16344 !grad            endif
16345           enddo
16346           acipa(1,1)=a22
16347           acipa(1,2)=a23
16348           acipa(2,1)=a32
16349           acipa(2,2)=a33
16350           a22=-a22
16351           a23=-a23
16352           do l=1,2
16353             do k=1,3
16354               agg(k,l)=-agg(k,l)
16355               aggi(k,l)=-aggi(k,l)
16356               aggi1(k,l)=-aggi1(k,l)
16357               aggj(k,l)=-aggj(k,l)
16358               aggj1(k,l)=-aggj1(k,l)
16359             enddo
16360           enddo
16361           if (j.lt.nres-1) then
16362             a22=-a22
16363             a32=-a32
16364             do l=1,3,2
16365               do k=1,3
16366                 agg(k,l)=-agg(k,l)
16367                 aggi(k,l)=-aggi(k,l)
16368                 aggi1(k,l)=-aggi1(k,l)
16369                 aggj(k,l)=-aggj(k,l)
16370                 aggj1(k,l)=-aggj1(k,l)
16371               enddo
16372             enddo
16373           else
16374             a22=-a22
16375             a23=-a23
16376             a32=-a32
16377             a33=-a33
16378             do l=1,4
16379               do k=1,3
16380                 agg(k,l)=-agg(k,l)
16381                 aggi(k,l)=-aggi(k,l)
16382                 aggi1(k,l)=-aggi1(k,l)
16383                 aggj(k,l)=-aggj(k,l)
16384                 aggj1(k,l)=-aggj1(k,l)
16385               enddo
16386             enddo
16387           endif
16388           ENDIF ! WCORR
16389           IF (wel_loc.gt.0.0d0) THEN
16390 ! Contribution to the local-electrostatic energy coming from the i-j pair
16391           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
16392            +a33*muij(4)
16393 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
16394 !           print *,"EELLOC",i,gel_loc_loc(i-1)
16395           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
16396                   'eelloc',i,j,eel_loc_ij
16397 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
16398
16399           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
16400 ! Partial derivatives in virtual-bond dihedral angles gamma
16401           if (i.gt.1) &
16402           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
16403                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
16404                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
16405                  *sss_ele_cut
16406           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
16407                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
16408                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
16409                  *sss_ele_cut
16410            xtemp(1)=xj
16411            xtemp(2)=yj
16412            xtemp(3)=zj
16413
16414 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
16415           do l=1,3
16416             ggg(l)=(agg(l,1)*muij(1)+ &
16417                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
16418             *sss_ele_cut &
16419              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
16420
16421             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
16422             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
16423 !grad            ghalf=0.5d0*ggg(l)
16424 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
16425 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
16426           enddo
16427 !grad          do k=i+1,j2
16428 !grad            do l=1,3
16429 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
16430 !grad            enddo
16431 !grad          enddo
16432 ! Remaining derivatives of eello
16433           do l=1,3
16434             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
16435                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
16436             *sss_ele_cut
16437
16438             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
16439                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
16440             *sss_ele_cut
16441
16442             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
16443                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
16444             *sss_ele_cut
16445
16446             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
16447                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
16448             *sss_ele_cut
16449
16450           enddo
16451           ENDIF
16452 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
16453 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
16454           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
16455              .and. num_conti.le.maxconts) then
16456 !            write (iout,*) i,j," entered corr"
16457 !
16458 ! Calculate the contact function. The ith column of the array JCONT will
16459 ! contain the numbers of atoms that make contacts with the atom I (of numbers
16460 ! greater than I). The arrays FACONT and GACONT will contain the values of
16461 ! the contact function and its derivative.
16462 !           r0ij=1.02D0*rpp(iteli,itelj)
16463 !           r0ij=1.11D0*rpp(iteli,itelj)
16464             r0ij=2.20D0*rpp(iteli,itelj)
16465 !           r0ij=1.55D0*rpp(iteli,itelj)
16466             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
16467 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
16468             if (fcont.gt.0.0D0) then
16469               num_conti=num_conti+1
16470               if (num_conti.gt.maxconts) then
16471 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
16472                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
16473                                ' will skip next contacts for this conf.',num_conti
16474               else
16475                 jcont_hb(num_conti,i)=j
16476 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
16477 !d     &           " jcont_hb",jcont_hb(num_conti,i)
16478                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
16479                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
16480 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
16481 !  terms.
16482                 d_cont(num_conti,i)=rij
16483 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
16484 !     --- Electrostatic-interaction matrix ---
16485                 a_chuj(1,1,num_conti,i)=a22
16486                 a_chuj(1,2,num_conti,i)=a23
16487                 a_chuj(2,1,num_conti,i)=a32
16488                 a_chuj(2,2,num_conti,i)=a33
16489 !     --- Gradient of rij
16490                 do kkk=1,3
16491                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
16492                 enddo
16493                 kkll=0
16494                 do k=1,2
16495                   do l=1,2
16496                     kkll=kkll+1
16497                     do m=1,3
16498                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
16499                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
16500                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
16501                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
16502                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
16503                     enddo
16504                   enddo
16505                 enddo
16506                 ENDIF
16507                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
16508 ! Calculate contact energies
16509                 cosa4=4.0D0*cosa
16510                 wij=cosa-3.0D0*cosb*cosg
16511                 cosbg1=cosb+cosg
16512                 cosbg2=cosb-cosg
16513 !               fac3=dsqrt(-ael6i)/r0ij**3
16514                 fac3=dsqrt(-ael6i)*r3ij
16515 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
16516                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
16517                 if (ees0tmp.gt.0) then
16518                   ees0pij=dsqrt(ees0tmp)
16519                 else
16520                   ees0pij=0
16521                 endif
16522 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
16523                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
16524                 if (ees0tmp.gt.0) then
16525                   ees0mij=dsqrt(ees0tmp)
16526                 else
16527                   ees0mij=0
16528                 endif
16529 !               ees0mij=0.0D0
16530                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
16531                      *sss_ele_cut
16532
16533                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
16534                      *sss_ele_cut
16535
16536 ! Diagnostics. Comment out or remove after debugging!
16537 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
16538 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
16539 !               ees0m(num_conti,i)=0.0D0
16540 ! End diagnostics.
16541 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
16542 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
16543 ! Angular derivatives of the contact function
16544                 ees0pij1=fac3/ees0pij
16545                 ees0mij1=fac3/ees0mij
16546                 fac3p=-3.0D0*fac3*rrmij
16547                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
16548                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
16549 !               ees0mij1=0.0D0
16550                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
16551                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
16552                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
16553                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
16554                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
16555                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
16556                 ecosap=ecosa1+ecosa2
16557                 ecosbp=ecosb1+ecosb2
16558                 ecosgp=ecosg1+ecosg2
16559                 ecosam=ecosa1-ecosa2
16560                 ecosbm=ecosb1-ecosb2
16561                 ecosgm=ecosg1-ecosg2
16562 ! Diagnostics
16563 !               ecosap=ecosa1
16564 !               ecosbp=ecosb1
16565 !               ecosgp=ecosg1
16566 !               ecosam=0.0D0
16567 !               ecosbm=0.0D0
16568 !               ecosgm=0.0D0
16569 ! End diagnostics
16570                 facont_hb(num_conti,i)=fcont
16571                 fprimcont=fprimcont/rij
16572 !d              facont_hb(num_conti,i)=1.0D0
16573 ! Following line is for diagnostics.
16574 !d              fprimcont=0.0D0
16575                 do k=1,3
16576                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
16577                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
16578                 enddo
16579                 do k=1,3
16580                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
16581                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
16582                 enddo
16583 !                gggp(1)=gggp(1)+ees0pijp*xj
16584 !                gggp(2)=gggp(2)+ees0pijp*yj
16585 !                gggp(3)=gggp(3)+ees0pijp*zj
16586 !                gggm(1)=gggm(1)+ees0mijp*xj
16587 !                gggm(2)=gggm(2)+ees0mijp*yj
16588 !                gggm(3)=gggm(3)+ees0mijp*zj
16589                 gggp(1)=gggp(1)+ees0pijp*xj &
16590                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16591                 gggp(2)=gggp(2)+ees0pijp*yj &
16592                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16593                 gggp(3)=gggp(3)+ees0pijp*zj &
16594                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16595
16596                 gggm(1)=gggm(1)+ees0mijp*xj &
16597                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16598
16599                 gggm(2)=gggm(2)+ees0mijp*yj &
16600                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16601
16602                 gggm(3)=gggm(3)+ees0mijp*zj &
16603                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16604
16605 ! Derivatives due to the contact function
16606                 gacont_hbr(1,num_conti,i)=fprimcont*xj
16607                 gacont_hbr(2,num_conti,i)=fprimcont*yj
16608                 gacont_hbr(3,num_conti,i)=fprimcont*zj
16609                 do k=1,3
16610 !
16611 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
16612 !          following the change of gradient-summation algorithm.
16613 !
16614 !grad                  ghalfp=0.5D0*gggp(k)
16615 !grad                  ghalfm=0.5D0*gggm(k)
16616 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
16617 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16618 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16619 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
16620 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16621 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16622 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
16623 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
16624 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16625 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16626 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
16627 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16628 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16629 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
16630                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
16631                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16632                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16633                      *sss_ele_cut
16634
16635                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
16636                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16637                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
16638                      *sss_ele_cut
16639
16640                   gacontp_hb3(k,num_conti,i)=gggp(k) &
16641                      *sss_ele_cut
16642
16643                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
16644                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16645                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16646                      *sss_ele_cut
16647
16648                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
16649                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16650                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
16651                      *sss_ele_cut
16652
16653                   gacontm_hb3(k,num_conti,i)=gggm(k) &
16654                      *sss_ele_cut
16655
16656                 enddo
16657               ENDIF ! wcorr
16658               endif  ! num_conti.le.maxconts
16659             endif  ! fcont.gt.0
16660           endif    ! j.gt.i+1
16661           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
16662             do k=1,4
16663               do l=1,3
16664                 ghalf=0.5d0*agg(l,k)
16665                 aggi(l,k)=aggi(l,k)+ghalf
16666                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
16667                 aggj(l,k)=aggj(l,k)+ghalf
16668               enddo
16669             enddo
16670             if (j.eq.nres-1 .and. i.lt.j-2) then
16671               do k=1,4
16672                 do l=1,3
16673                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
16674                 enddo
16675               enddo
16676             endif
16677           endif
16678  128      continue
16679 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
16680       return
16681       end subroutine eelecij_scale
16682 !-----------------------------------------------------------------------------
16683       subroutine evdwpp_short(evdw1)
16684 !
16685 ! Compute Evdwpp
16686 !
16687 !      implicit real(kind=8) (a-h,o-z)
16688 !      include 'DIMENSIONS'
16689 !      include 'COMMON.CONTROL'
16690 !      include 'COMMON.IOUNITS'
16691 !      include 'COMMON.GEO'
16692 !      include 'COMMON.VAR'
16693 !      include 'COMMON.LOCAL'
16694 !      include 'COMMON.CHAIN'
16695 !      include 'COMMON.DERIV'
16696 !      include 'COMMON.INTERACT'
16697 !      include 'COMMON.CONTACTS'
16698 !      include 'COMMON.TORSION'
16699 !      include 'COMMON.VECTORS'
16700 !      include 'COMMON.FFIELD'
16701       real(kind=8),dimension(3) :: ggg
16702 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
16703 #ifdef MOMENT
16704       real(kind=8) :: scal_el=1.0d0
16705 #else
16706       real(kind=8) :: scal_el=0.5d0
16707 #endif
16708 !el local variables
16709       integer :: i,j,k,iteli,itelj,num_conti,isubchap
16710       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
16711       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
16712                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
16713                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
16714       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16715                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
16716                    sslipj,ssgradlipj,faclipij2
16717       integer xshift,yshift,zshift
16718
16719
16720       evdw1=0.0D0
16721 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
16722 !     & " iatel_e_vdw",iatel_e_vdw
16723       call flush(iout)
16724       do i=iatel_s_vdw,iatel_e_vdw
16725         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
16726         dxi=dc(1,i)
16727         dyi=dc(2,i)
16728         dzi=dc(3,i)
16729         dx_normi=dc_norm(1,i)
16730         dy_normi=dc_norm(2,i)
16731         dz_normi=dc_norm(3,i)
16732         xmedi=c(1,i)+0.5d0*dxi
16733         ymedi=c(2,i)+0.5d0*dyi
16734         zmedi=c(3,i)+0.5d0*dzi
16735         call to_box(xmedi,ymedi,zmedi)
16736         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
16737         num_conti=0
16738 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
16739 !     &   ' ielend',ielend_vdw(i)
16740         call flush(iout)
16741         do j=ielstart_vdw(i),ielend_vdw(i)
16742           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
16743 !el          ind=ind+1
16744           iteli=itel(i)
16745           itelj=itel(j)
16746           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
16747           aaa=app(iteli,itelj)
16748           bbb=bpp(iteli,itelj)
16749           dxj=dc(1,j)
16750           dyj=dc(2,j)
16751           dzj=dc(3,j)
16752           dx_normj=dc_norm(1,j)
16753           dy_normj=dc_norm(2,j)
16754           dz_normj=dc_norm(3,j)
16755 !          xj=c(1,j)+0.5D0*dxj-xmedi
16756 !          yj=c(2,j)+0.5D0*dyj-ymedi
16757 !          zj=c(3,j)+0.5D0*dzj-zmedi
16758           xj=c(1,j)+0.5D0*dxj
16759           yj=c(2,j)+0.5D0*dyj
16760           zj=c(3,j)+0.5D0*dzj
16761           call to_box(xj,yj,zj)
16762           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
16763           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
16764           xj=boxshift(xj-xmedi,boxxsize)
16765           yj=boxshift(yj-ymedi,boxysize)
16766           zj=boxshift(zj-zmedi,boxzsize)
16767           rij=xj*xj+yj*yj+zj*zj
16768           rrmij=1.0D0/rij
16769           rij=dsqrt(rij)
16770           sss=sscale(rij/rpp(iteli,itelj))
16771             sss_ele_cut=sscale_ele(rij)
16772             sss_ele_grad=sscagrad_ele(rij)
16773             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
16774             if (sss_ele_cut.le.0.0) cycle
16775           if (sss.gt.0.0d0) then
16776             rmij=1.0D0/rij
16777             r3ij=rrmij*rmij
16778             r6ij=r3ij*r3ij
16779             ev1=aaa*r6ij*r6ij
16780 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
16781             if (j.eq.i+2) ev1=scal_el*ev1
16782             ev2=bbb*r6ij
16783             evdwij=ev1+ev2
16784             if (energy_dec) then
16785               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
16786             endif
16787             evdw1=evdw1+evdwij*sss*sss_ele_cut
16788 !
16789 ! Calculate contributions to the Cartesian gradient.
16790 !
16791             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
16792 !            ggg(1)=facvdw*xj
16793 !            ggg(2)=facvdw*yj
16794 !            ggg(3)=facvdw*zj
16795           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
16796           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
16797           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
16798           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
16799           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
16800           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
16801
16802             do k=1,3
16803               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16804               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16805             enddo
16806           endif
16807         enddo ! j
16808       enddo   ! i
16809       return
16810       end subroutine evdwpp_short
16811 !-----------------------------------------------------------------------------
16812       subroutine escp_long(evdw2,evdw2_14)
16813 !
16814 ! This subroutine calculates the excluded-volume interaction energy between
16815 ! peptide-group centers and side chains and its gradient in virtual-bond and
16816 ! side-chain vectors.
16817 !
16818 !      implicit real(kind=8) (a-h,o-z)
16819 !      include 'DIMENSIONS'
16820 !      include 'COMMON.GEO'
16821 !      include 'COMMON.VAR'
16822 !      include 'COMMON.LOCAL'
16823 !      include 'COMMON.CHAIN'
16824 !      include 'COMMON.DERIV'
16825 !      include 'COMMON.INTERACT'
16826 !      include 'COMMON.FFIELD'
16827 !      include 'COMMON.IOUNITS'
16828 !      include 'COMMON.CONTROL'
16829       real(kind=8),dimension(3) :: ggg
16830 !el local variables
16831       integer :: i,iint,j,k,iteli,itypj,subchap
16832       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16833       real(kind=8) :: evdw2,evdw2_14,evdwij
16834       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16835                     dist_temp, dist_init
16836
16837       evdw2=0.0D0
16838       evdw2_14=0.0d0
16839 !d    print '(a)','Enter ESCP'
16840 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16841       do i=iatscp_s,iatscp_e
16842         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16843         iteli=itel(i)
16844         xi=0.5D0*(c(1,i)+c(1,i+1))
16845         yi=0.5D0*(c(2,i)+c(2,i+1))
16846         zi=0.5D0*(c(3,i)+c(3,i+1))
16847         call to_box(xi,yi,zi)
16848         do iint=1,nscp_gr(i)
16849
16850         do j=iscpstart(i,iint),iscpend(i,iint)
16851           itypj=itype(j,1)
16852           if (itypj.eq.ntyp1) cycle
16853 ! Uncomment following three lines for SC-p interactions
16854 !         xj=c(1,nres+j)-xi
16855 !         yj=c(2,nres+j)-yi
16856 !         zj=c(3,nres+j)-zi
16857 ! Uncomment following three lines for Ca-p interactions
16858           xj=c(1,j)
16859           yj=c(2,j)
16860           zj=c(3,j)
16861           call to_box(xj,yj,zj)
16862           xj=boxshift(xj-xi,boxxsize)
16863           yj=boxshift(yj-yi,boxysize)
16864           zj=boxshift(zj-zi,boxzsize)
16865           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16866
16867           rij=dsqrt(1.0d0/rrij)
16868             sss_ele_cut=sscale_ele(rij)
16869             sss_ele_grad=sscagrad_ele(rij)
16870 !            print *,sss_ele_cut,sss_ele_grad,&
16871 !            (rij),r_cut_ele,rlamb_ele
16872             if (sss_ele_cut.le.0.0) cycle
16873           sss=sscale((rij/rscp(itypj,iteli)))
16874           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16875           if (sss.lt.1.0d0) then
16876
16877             fac=rrij**expon2
16878             e1=fac*fac*aad(itypj,iteli)
16879             e2=fac*bad(itypj,iteli)
16880             if (iabs(j-i) .le. 2) then
16881               e1=scal14*e1
16882               e2=scal14*e2
16883               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16884             endif
16885             evdwij=e1+e2
16886             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16887             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16888                 'evdw2',i,j,sss,evdwij
16889 !
16890 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16891 !
16892             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16893             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16894             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16895             ggg(1)=xj*fac
16896             ggg(2)=yj*fac
16897             ggg(3)=zj*fac
16898 ! Uncomment following three lines for SC-p interactions
16899 !           do k=1,3
16900 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16901 !           enddo
16902 ! Uncomment following line for SC-p interactions
16903 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16904             do k=1,3
16905               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16906               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16907             enddo
16908           endif
16909         enddo
16910
16911         enddo ! iint
16912       enddo ! i
16913       do i=1,nct
16914         do j=1,3
16915           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16916           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16917           gradx_scp(j,i)=expon*gradx_scp(j,i)
16918         enddo
16919       enddo
16920 !******************************************************************************
16921 !
16922 !                              N O T E !!!
16923 !
16924 ! To save time the factor EXPON has been extracted from ALL components
16925 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16926 ! use!
16927 !
16928 !******************************************************************************
16929       return
16930       end subroutine escp_long
16931 !-----------------------------------------------------------------------------
16932       subroutine escp_short(evdw2,evdw2_14)
16933 !
16934 ! This subroutine calculates the excluded-volume interaction energy between
16935 ! peptide-group centers and side chains and its gradient in virtual-bond and
16936 ! side-chain vectors.
16937 !
16938 !      implicit real(kind=8) (a-h,o-z)
16939 !      include 'DIMENSIONS'
16940 !      include 'COMMON.GEO'
16941 !      include 'COMMON.VAR'
16942 !      include 'COMMON.LOCAL'
16943 !      include 'COMMON.CHAIN'
16944 !      include 'COMMON.DERIV'
16945 !      include 'COMMON.INTERACT'
16946 !      include 'COMMON.FFIELD'
16947 !      include 'COMMON.IOUNITS'
16948 !      include 'COMMON.CONTROL'
16949       real(kind=8),dimension(3) :: ggg
16950 !el local variables
16951       integer :: i,iint,j,k,iteli,itypj,subchap
16952       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16953       real(kind=8) :: evdw2,evdw2_14,evdwij
16954       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16955                     dist_temp, dist_init
16956
16957       evdw2=0.0D0
16958       evdw2_14=0.0d0
16959 !d    print '(a)','Enter ESCP'
16960 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16961       do i=iatscp_s,iatscp_e
16962         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16963         iteli=itel(i)
16964         xi=0.5D0*(c(1,i)+c(1,i+1))
16965         yi=0.5D0*(c(2,i)+c(2,i+1))
16966         zi=0.5D0*(c(3,i)+c(3,i+1))
16967         call to_box(xi,yi,zi)
16968         if (zi.lt.0) zi=zi+boxzsize
16969
16970         do iint=1,nscp_gr(i)
16971
16972         do j=iscpstart(i,iint),iscpend(i,iint)
16973           itypj=itype(j,1)
16974           if (itypj.eq.ntyp1) cycle
16975 ! Uncomment following three lines for SC-p interactions
16976 !         xj=c(1,nres+j)-xi
16977 !         yj=c(2,nres+j)-yi
16978 !         zj=c(3,nres+j)-zi
16979 ! Uncomment following three lines for Ca-p interactions
16980 !          xj=c(1,j)-xi
16981 !          yj=c(2,j)-yi
16982 !          zj=c(3,j)-zi
16983           xj=c(1,j)
16984           yj=c(2,j)
16985           zj=c(3,j)
16986           call to_box(xj,yj,zj)
16987           xj=boxshift(xj-xi,boxxsize)
16988           yj=boxshift(yj-yi,boxysize)
16989           zj=boxshift(zj-zi,boxzsize)
16990           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16991           rij=dsqrt(1.0d0/rrij)
16992             sss_ele_cut=sscale_ele(rij)
16993             sss_ele_grad=sscagrad_ele(rij)
16994 !            print *,sss_ele_cut,sss_ele_grad,&
16995 !            (rij),r_cut_ele,rlamb_ele
16996             if (sss_ele_cut.le.0.0) cycle
16997           sss=sscale(rij/rscp(itypj,iteli))
16998           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16999           if (sss.gt.0.0d0) then
17000
17001             fac=rrij**expon2
17002             e1=fac*fac*aad(itypj,iteli)
17003             e2=fac*bad(itypj,iteli)
17004             if (iabs(j-i) .le. 2) then
17005               e1=scal14*e1
17006               e2=scal14*e2
17007               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
17008             endif
17009             evdwij=e1+e2
17010             evdw2=evdw2+evdwij*sss*sss_ele_cut
17011             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
17012                 'evdw2',i,j,sss,evdwij
17013 !
17014 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
17015 !
17016             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
17017             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
17018             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
17019
17020             ggg(1)=xj*fac
17021             ggg(2)=yj*fac
17022             ggg(3)=zj*fac
17023 ! Uncomment following three lines for SC-p interactions
17024 !           do k=1,3
17025 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
17026 !           enddo
17027 ! Uncomment following line for SC-p interactions
17028 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
17029             do k=1,3
17030               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
17031               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
17032             enddo
17033           endif
17034         enddo
17035
17036         enddo ! iint
17037       enddo ! i
17038       do i=1,nct
17039         do j=1,3
17040           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
17041           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
17042           gradx_scp(j,i)=expon*gradx_scp(j,i)
17043         enddo
17044       enddo
17045 !******************************************************************************
17046 !
17047 !                              N O T E !!!
17048 !
17049 ! To save time the factor EXPON has been extracted from ALL components
17050 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
17051 ! use!
17052 !
17053 !******************************************************************************
17054       return
17055       end subroutine escp_short
17056 !-----------------------------------------------------------------------------
17057 ! energy_p_new-sep_barrier.F
17058 !-----------------------------------------------------------------------------
17059       subroutine sc_grad_scale(scalfac)
17060 !      implicit real(kind=8) (a-h,o-z)
17061       use calc_data
17062 !      include 'DIMENSIONS'
17063 !      include 'COMMON.CHAIN'
17064 !      include 'COMMON.DERIV'
17065 !      include 'COMMON.CALC'
17066 !      include 'COMMON.IOUNITS'
17067       real(kind=8),dimension(3) :: dcosom1,dcosom2
17068       real(kind=8) :: scalfac
17069 !el local variables
17070 !      integer :: i,j,k,l
17071
17072       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17073       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17074       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
17075            -2.0D0*alf12*eps3der+sigder*sigsq_om12
17076 ! diagnostics only
17077 !      eom1=0.0d0
17078 !      eom2=0.0d0
17079 !      eom12=evdwij*eps1_om12
17080 ! end diagnostics
17081 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
17082 !     &  " sigder",sigder
17083 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
17084 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
17085       do k=1,3
17086         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
17087         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
17088       enddo
17089       do k=1,3
17090         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
17091          *sss_ele_cut
17092       enddo
17093 !      write (iout,*) "gg",(gg(k),k=1,3)
17094       do k=1,3
17095         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17096                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17097                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
17098                  *sss_ele_cut
17099         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17100                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17101                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
17102          *sss_ele_cut
17103 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
17104 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17105 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
17106 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17107       enddo
17108 !
17109 ! Calculate the components of the gradient in DC and X
17110 !
17111       do l=1,3
17112         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17113         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17114       enddo
17115       return
17116       end subroutine sc_grad_scale
17117 !-----------------------------------------------------------------------------
17118 ! energy_split-sep.F
17119 !-----------------------------------------------------------------------------
17120       subroutine etotal_long(energia)
17121 !
17122 ! Compute the long-range slow-varying contributions to the energy
17123 !
17124 !      implicit real(kind=8) (a-h,o-z)
17125 !      include 'DIMENSIONS'
17126       use MD_data, only: totT,usampl,eq_time
17127 #ifndef ISNAN
17128       external proc_proc
17129 #ifdef WINPGI
17130 !MS$ATTRIBUTES C ::  proc_proc
17131 #endif
17132 #endif
17133 #ifdef MPI
17134       include "mpif.h"
17135       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
17136 #endif
17137 !      include 'COMMON.SETUP'
17138 !      include 'COMMON.IOUNITS'
17139 !      include 'COMMON.FFIELD'
17140 !      include 'COMMON.DERIV'
17141 !      include 'COMMON.INTERACT'
17142 !      include 'COMMON.SBRIDGE'
17143 !      include 'COMMON.CHAIN'
17144 !      include 'COMMON.VAR'
17145 !      include 'COMMON.LOCAL'
17146 !      include 'COMMON.MD'
17147       real(kind=8),dimension(0:n_ene) :: energia
17148 !el local variables
17149       integer :: i,n_corr,n_corr1,ierror,ierr
17150       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
17151                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
17152                   ecorr,ecorr5,ecorr6,eturn6,time00, ehomology_constr
17153 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
17154 !elwrite(iout,*)"in etotal long"
17155
17156       if (modecalc.eq.12.or.modecalc.eq.14) then
17157 #ifdef MPI
17158 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
17159 #else
17160         call int_from_cart1(.false.)
17161 #endif
17162       endif
17163 !elwrite(iout,*)"in etotal long"
17164       ehomology_constr=0.0d0
17165 #ifdef MPI
17166 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
17167 !     & " absolute rank",myrank," nfgtasks",nfgtasks
17168       call flush(iout)
17169       if (nfgtasks.gt.1) then
17170         time00=MPI_Wtime()
17171 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
17172         if (fg_rank.eq.0) then
17173           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
17174 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
17175 !          call flush(iout)
17176 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
17177 ! FG slaves as WEIGHTS array.
17178           weights_(1)=wsc
17179           weights_(2)=wscp
17180           weights_(3)=welec
17181           weights_(4)=wcorr
17182           weights_(5)=wcorr5
17183           weights_(6)=wcorr6
17184           weights_(7)=wel_loc
17185           weights_(8)=wturn3
17186           weights_(9)=wturn4
17187           weights_(10)=wturn6
17188           weights_(11)=wang
17189           weights_(12)=wscloc
17190           weights_(13)=wtor
17191           weights_(14)=wtor_d
17192           weights_(15)=wstrain
17193           weights_(16)=wvdwpp
17194           weights_(17)=wbond
17195           weights_(18)=scal14
17196           weights_(21)=wsccor
17197 ! FG Master broadcasts the WEIGHTS_ array
17198           call MPI_Bcast(weights_(1),n_ene,&
17199               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17200         else
17201 ! FG slaves receive the WEIGHTS array
17202           call MPI_Bcast(weights(1),n_ene,&
17203               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17204           wsc=weights(1)
17205           wscp=weights(2)
17206           welec=weights(3)
17207           wcorr=weights(4)
17208           wcorr5=weights(5)
17209           wcorr6=weights(6)
17210           wel_loc=weights(7)
17211           wturn3=weights(8)
17212           wturn4=weights(9)
17213           wturn6=weights(10)
17214           wang=weights(11)
17215           wscloc=weights(12)
17216           wtor=weights(13)
17217           wtor_d=weights(14)
17218           wstrain=weights(15)
17219           wvdwpp=weights(16)
17220           wbond=weights(17)
17221           scal14=weights(18)
17222           wsccor=weights(21)
17223         endif
17224         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
17225           king,FG_COMM,IERR)
17226          time_Bcast=time_Bcast+MPI_Wtime()-time00
17227          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
17228 !        call chainbuild_cart
17229 !        call int_from_cart1(.false.)
17230       endif
17231 !      write (iout,*) 'Processor',myrank,
17232 !     &  ' calling etotal_short ipot=',ipot
17233 !      call flush(iout)
17234 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
17235 #endif
17236 !d    print *,'nnt=',nnt,' nct=',nct
17237 !
17238 !elwrite(iout,*)"in etotal long"
17239 ! Compute the side-chain and electrostatic interaction energy
17240 !
17241       goto (101,102,103,104,105,106) ipot
17242 ! Lennard-Jones potential.
17243   101 call elj_long(evdw)
17244 !d    print '(a)','Exit ELJ'
17245       goto 107
17246 ! Lennard-Jones-Kihara potential (shifted).
17247   102 call eljk_long(evdw)
17248       goto 107
17249 ! Berne-Pechukas potential (dilated LJ, angular dependence).
17250   103 call ebp_long(evdw)
17251       goto 107
17252 ! Gay-Berne potential (shifted LJ, angular dependence).
17253   104 call egb_long(evdw)
17254       goto 107
17255 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
17256   105 call egbv_long(evdw)
17257       goto 107
17258 ! Soft-sphere potential
17259   106 call e_softsphere(evdw)
17260 !
17261 ! Calculate electrostatic (H-bonding) energy of the main chain.
17262 !
17263   107 continue
17264       call vec_and_deriv
17265       if (ipot.lt.6) then
17266 #ifdef SPLITELE
17267          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
17268              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
17269              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
17270              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
17271 #else
17272          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
17273              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
17274              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
17275              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
17276 #endif
17277            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
17278          else
17279             ees=0
17280             evdw1=0
17281             eel_loc=0
17282             eello_turn3=0
17283             eello_turn4=0
17284          endif
17285       else
17286 !        write (iout,*) "Soft-spheer ELEC potential"
17287         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
17288          eello_turn4)
17289       endif
17290 !
17291 ! Calculate excluded-volume interaction energy between peptide groups
17292 ! and side chains.
17293 !
17294       if (ipot.lt.6) then
17295        if(wscp.gt.0d0) then
17296         call escp_long(evdw2,evdw2_14)
17297        else
17298         evdw2=0
17299         evdw2_14=0
17300        endif
17301       else
17302         call escp_soft_sphere(evdw2,evdw2_14)
17303       endif
17304 !
17305 ! 12/1/95 Multi-body terms
17306 !
17307       n_corr=0
17308       n_corr1=0
17309       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
17310           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
17311          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
17312 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
17313 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
17314       else
17315          ecorr=0.0d0
17316          ecorr5=0.0d0
17317          ecorr6=0.0d0
17318          eturn6=0.0d0
17319       endif
17320       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
17321          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
17322       endif
17323 !
17324 ! If performing constraint dynamics, call the constraint energy
17325 !  after the equilibration time
17326       if(usampl.and.totT.gt.eq_time) then
17327          call EconstrQ
17328          call Econstr_back
17329       else
17330          Uconst=0.0d0
17331          Uconst_back=0.0d0
17332       endif
17333 !
17334 ! Sum the energies
17335 !
17336       do i=1,n_ene
17337         energia(i)=0.0d0
17338       enddo
17339       energia(1)=evdw
17340 #ifdef SCP14
17341       energia(2)=evdw2-evdw2_14
17342       energia(18)=evdw2_14
17343 #else
17344       energia(2)=evdw2
17345       energia(18)=0.0d0
17346 #endif
17347 #ifdef SPLITELE
17348       energia(3)=ees
17349       energia(16)=evdw1
17350 #else
17351       energia(3)=ees+evdw1
17352       energia(16)=0.0d0
17353 #endif
17354       energia(4)=ecorr
17355       energia(5)=ecorr5
17356       energia(6)=ecorr6
17357       energia(7)=eel_loc
17358       energia(8)=eello_turn3
17359       energia(9)=eello_turn4
17360       energia(10)=eturn6
17361       energia(20)=Uconst+Uconst_back
17362       energia(51)=ehomology_constr
17363       call sum_energy(energia,.true.)
17364 !      write (iout,*) "Exit ETOTAL_LONG"
17365       call flush(iout)
17366       return
17367       end subroutine etotal_long
17368 !-----------------------------------------------------------------------------
17369       subroutine etotal_short(energia)
17370 !
17371 ! Compute the short-range fast-varying contributions to the energy
17372 !
17373 !      implicit real(kind=8) (a-h,o-z)
17374 !      include 'DIMENSIONS'
17375 #ifndef ISNAN
17376       external proc_proc
17377 #ifdef WINPGI
17378 !MS$ATTRIBUTES C ::  proc_proc
17379 #endif
17380 #endif
17381 #ifdef MPI
17382       include "mpif.h"
17383       integer :: ierror,ierr
17384       real(kind=8),dimension(n_ene) :: weights_
17385       real(kind=8) :: time00
17386 #endif
17387 !      include 'COMMON.SETUP'
17388 !      include 'COMMON.IOUNITS'
17389 !      include 'COMMON.FFIELD'
17390 !      include 'COMMON.DERIV'
17391 !      include 'COMMON.INTERACT'
17392 !      include 'COMMON.SBRIDGE'
17393 !      include 'COMMON.CHAIN'
17394 !      include 'COMMON.VAR'
17395 !      include 'COMMON.LOCAL'
17396       real(kind=8),dimension(0:n_ene) :: energia
17397 !el local variables
17398       integer :: i,nres6
17399       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
17400       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr, &
17401                       ehomology_constr
17402       nres6=6*nres
17403
17404 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
17405 !      call flush(iout)
17406       if (modecalc.eq.12.or.modecalc.eq.14) then
17407 #ifdef MPI
17408         if (fg_rank.eq.0) call int_from_cart1(.false.)
17409 #else
17410         call int_from_cart1(.false.)
17411 #endif
17412       endif
17413 #ifdef MPI
17414 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
17415 !     & " absolute rank",myrank," nfgtasks",nfgtasks
17416 !      call flush(iout)
17417       if (nfgtasks.gt.1) then
17418         time00=MPI_Wtime()
17419 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
17420         if (fg_rank.eq.0) then
17421           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
17422 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
17423 !          call flush(iout)
17424 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
17425 ! FG slaves as WEIGHTS array.
17426           weights_(1)=wsc
17427           weights_(2)=wscp
17428           weights_(3)=welec
17429           weights_(4)=wcorr
17430           weights_(5)=wcorr5
17431           weights_(6)=wcorr6
17432           weights_(7)=wel_loc
17433           weights_(8)=wturn3
17434           weights_(9)=wturn4
17435           weights_(10)=wturn6
17436           weights_(11)=wang
17437           weights_(12)=wscloc
17438           weights_(13)=wtor
17439           weights_(14)=wtor_d
17440           weights_(15)=wstrain
17441           weights_(16)=wvdwpp
17442           weights_(17)=wbond
17443           weights_(18)=scal14
17444           weights_(21)=wsccor
17445 ! FG Master broadcasts the WEIGHTS_ array
17446           call MPI_Bcast(weights_(1),n_ene,&
17447               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17448         else
17449 ! FG slaves receive the WEIGHTS array
17450           call MPI_Bcast(weights(1),n_ene,&
17451               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17452           wsc=weights(1)
17453           wscp=weights(2)
17454           welec=weights(3)
17455           wcorr=weights(4)
17456           wcorr5=weights(5)
17457           wcorr6=weights(6)
17458           wel_loc=weights(7)
17459           wturn3=weights(8)
17460           wturn4=weights(9)
17461           wturn6=weights(10)
17462           wang=weights(11)
17463           wscloc=weights(12)
17464           wtor=weights(13)
17465           wtor_d=weights(14)
17466           wstrain=weights(15)
17467           wvdwpp=weights(16)
17468           wbond=weights(17)
17469           scal14=weights(18)
17470           wsccor=weights(21)
17471         endif
17472 !        write (iout,*),"Processor",myrank," BROADCAST weights"
17473         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
17474           king,FG_COMM,IERR)
17475 !        write (iout,*) "Processor",myrank," BROADCAST c"
17476         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
17477           king,FG_COMM,IERR)
17478 !        write (iout,*) "Processor",myrank," BROADCAST dc"
17479         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
17480           king,FG_COMM,IERR)
17481 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
17482         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
17483           king,FG_COMM,IERR)
17484 !        write (iout,*) "Processor",myrank," BROADCAST theta"
17485         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
17486           king,FG_COMM,IERR)
17487 !        write (iout,*) "Processor",myrank," BROADCAST phi"
17488         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
17489           king,FG_COMM,IERR)
17490 !        write (iout,*) "Processor",myrank," BROADCAST alph"
17491         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
17492           king,FG_COMM,IERR)
17493 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
17494         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
17495           king,FG_COMM,IERR)
17496 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
17497         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
17498           king,FG_COMM,IERR)
17499          time_Bcast=time_Bcast+MPI_Wtime()-time00
17500 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
17501       endif
17502 !      write (iout,*) 'Processor',myrank,
17503 !     &  ' calling etotal_short ipot=',ipot
17504 !      call flush(iout)
17505 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
17506 #endif
17507 !      call int_from_cart1(.false.)
17508 !
17509 ! Compute the side-chain and electrostatic interaction energy
17510 !
17511       goto (101,102,103,104,105,106) ipot
17512 ! Lennard-Jones potential.
17513   101 call elj_short(evdw)
17514 !d    print '(a)','Exit ELJ'
17515       goto 107
17516 ! Lennard-Jones-Kihara potential (shifted).
17517   102 call eljk_short(evdw)
17518       goto 107
17519 ! Berne-Pechukas potential (dilated LJ, angular dependence).
17520   103 call ebp_short(evdw)
17521       goto 107
17522 ! Gay-Berne potential (shifted LJ, angular dependence).
17523   104 call egb_short(evdw)
17524       goto 107
17525 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
17526   105 call egbv_short(evdw)
17527       goto 107
17528 ! Soft-sphere potential - already dealt with in the long-range part
17529   106 evdw=0.0d0
17530 !  106 call e_softsphere_short(evdw)
17531 !
17532 ! Calculate electrostatic (H-bonding) energy of the main chain.
17533 !
17534   107 continue
17535 !
17536 ! Calculate the short-range part of Evdwpp
17537 !
17538       call evdwpp_short(evdw1)
17539 !
17540 ! Calculate the short-range part of ESCp
17541 !
17542       if (ipot.lt.6) then
17543        call escp_short(evdw2,evdw2_14)
17544       endif
17545 !
17546 ! Calculate the bond-stretching energy
17547 !
17548       call ebond(estr)
17549 !
17550 ! Calculate the disulfide-bridge and other energy and the contributions
17551 ! from other distance constraints.
17552 !      call edis(ehpb)
17553 !
17554 ! Calculate the virtual-bond-angle energy.
17555 !
17556 ! Calculate the SC local energy.
17557 !
17558       call vec_and_deriv
17559       call esc(escloc)
17560 !
17561       if (wang.gt.0d0) then
17562        if (tor_mode.eq.0) then
17563            call ebend(ebe)
17564        else
17565 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
17566 !C energy function
17567         call ebend_kcc(ebe)
17568        endif
17569       else
17570           ebe=0.0d0
17571       endif
17572       ethetacnstr=0.0d0
17573       if (with_theta_constr) call etheta_constr(ethetacnstr)
17574
17575 !       write(iout,*) "in etotal afer ebe",ipot
17576
17577 !      print *,"Processor",myrank," computed UB"
17578 !
17579 ! Calculate the SC local energy.
17580 !
17581       call esc(escloc)
17582 !elwrite(iout,*) "in etotal afer esc",ipot
17583 !      print *,"Processor",myrank," computed USC"
17584 !
17585 ! Calculate the virtual-bond torsional energy.
17586 !
17587 !d    print *,'nterm=',nterm
17588 !      if (wtor.gt.0) then
17589 !       call etor(etors,edihcnstr)
17590 !      else
17591 !       etors=0
17592 !       edihcnstr=0
17593 !      endif
17594       if (wtor.gt.0.0d0) then
17595          if (tor_mode.eq.0) then
17596            call etor(etors)
17597           else
17598 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
17599 !C energy function
17600         call etor_kcc(etors)
17601          endif
17602       else
17603            etors=0.0d0
17604       endif
17605       edihcnstr=0.0d0
17606       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
17607
17608 ! Calculate the virtual-bond torsional energy.
17609 !
17610 !
17611 ! 6/23/01 Calculate double-torsional energy
17612 !
17613       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
17614       call etor_d(etors_d)
17615       endif
17616 !
17617 ! Homology restraints
17618 !
17619       if (constr_homology.ge.1) then
17620         call e_modeller(ehomology_constr)
17621 !      print *,"tu"
17622       else
17623         ehomology_constr=0.0d0
17624       endif
17625
17626 !
17627 ! 21/5/07 Calculate local sicdechain correlation energy
17628 !
17629       if (wsccor.gt.0.0d0) then
17630        call eback_sc_corr(esccor)
17631       else
17632        esccor=0.0d0
17633       endif
17634 !
17635 ! Put energy components into an array
17636 !
17637       do i=1,n_ene
17638        energia(i)=0.0d0
17639       enddo
17640       energia(1)=evdw
17641 #ifdef SCP14
17642       energia(2)=evdw2-evdw2_14
17643       energia(18)=evdw2_14
17644 #else
17645       energia(2)=evdw2
17646       energia(18)=0.0d0
17647 #endif
17648 #ifdef SPLITELE
17649       energia(16)=evdw1
17650 #else
17651       energia(3)=evdw1
17652 #endif
17653       energia(11)=ebe
17654       energia(12)=escloc
17655       energia(13)=etors
17656       energia(14)=etors_d
17657       energia(15)=ehpb
17658       energia(17)=estr
17659       energia(19)=edihcnstr
17660       energia(21)=esccor
17661       energia(51)=ehomology_constr
17662 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
17663       call flush(iout)
17664       call sum_energy(energia,.true.)
17665 !      write (iout,*) "Exit ETOTAL_SHORT"
17666       call flush(iout)
17667       return
17668       end subroutine etotal_short
17669 !-----------------------------------------------------------------------------
17670 ! gnmr1.f
17671 !-----------------------------------------------------------------------------
17672       real(kind=8) function gnmr1(y,ymin,ymax)
17673 !      implicit none
17674       real(kind=8) :: y,ymin,ymax
17675       real(kind=8) :: wykl=4.0d0
17676       if (y.lt.ymin) then
17677         gnmr1=(ymin-y)**wykl/wykl
17678       else if (y.gt.ymax) then
17679        gnmr1=(y-ymax)**wykl/wykl
17680       else
17681        gnmr1=0.0d0
17682       endif
17683       return
17684       end function gnmr1
17685 !-----------------------------------------------------------------------------
17686       real(kind=8) function gnmr1prim(y,ymin,ymax)
17687 !      implicit none
17688       real(kind=8) :: y,ymin,ymax
17689       real(kind=8) :: wykl=4.0d0
17690       if (y.lt.ymin) then
17691        gnmr1prim=-(ymin-y)**(wykl-1)
17692       else if (y.gt.ymax) then
17693        gnmr1prim=(y-ymax)**(wykl-1)
17694       else
17695        gnmr1prim=0.0d0
17696       endif
17697       return
17698       end function gnmr1prim
17699 !----------------------------------------------------------------------------
17700       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
17701       real(kind=8) y,ymin,ymax,sigma
17702       real(kind=8) wykl /4.0d0/
17703       if (y.lt.ymin) then
17704         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
17705       else if (y.gt.ymax) then
17706        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
17707       else
17708         rlornmr1=0.0d0
17709       endif
17710       return
17711       end function rlornmr1
17712 !------------------------------------------------------------------------------
17713       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
17714       real(kind=8) y,ymin,ymax,sigma
17715       real(kind=8) wykl /4.0d0/
17716       if (y.lt.ymin) then
17717         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
17718         ((ymin-y)**wykl+sigma**wykl)**2
17719       else if (y.gt.ymax) then
17720          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
17721         ((y-ymax)**wykl+sigma**wykl)**2
17722       else
17723        rlornmr1prim=0.0d0
17724       endif
17725       return
17726       end function rlornmr1prim
17727
17728       real(kind=8) function harmonic(y,ymax)
17729 !      implicit none
17730       real(kind=8) :: y,ymax
17731       real(kind=8) :: wykl=2.0d0
17732       harmonic=(y-ymax)**wykl
17733       return
17734       end function harmonic
17735 !-----------------------------------------------------------------------------
17736       real(kind=8) function harmonicprim(y,ymax)
17737       real(kind=8) :: y,ymin,ymax
17738       real(kind=8) :: wykl=2.0d0
17739       harmonicprim=(y-ymax)*wykl
17740       return
17741       end function harmonicprim
17742 !-----------------------------------------------------------------------------
17743 ! gradient_p.F
17744 !-----------------------------------------------------------------------------
17745 #ifndef LBFGS
17746       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
17747
17748       use io_base, only:intout,briefout
17749 !      implicit real(kind=8) (a-h,o-z)
17750 !      include 'DIMENSIONS'
17751 !      include 'COMMON.CHAIN'
17752 !      include 'COMMON.DERIV'
17753 !      include 'COMMON.VAR'
17754 !      include 'COMMON.INTERACT'
17755 !      include 'COMMON.FFIELD'
17756 !      include 'COMMON.MD'
17757 !      include 'COMMON.IOUNITS'
17758       real(kind=8),external :: ufparm
17759       integer :: uiparm(1)
17760       real(kind=8) :: urparm(1)
17761       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
17762       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
17763       integer :: n,nf,ind,ind1,i,k,j
17764 !
17765 ! This subroutine calculates total internal coordinate gradient.
17766 ! Depending on the number of function evaluations, either whole energy
17767 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
17768 ! internal coordinates are reevaluated or only the cartesian-in-internal
17769 ! coordinate derivatives are evaluated. The subroutine was designed to work
17770 ! with SUMSL.
17771 !
17772 !
17773       icg=mod(nf,2)+1
17774
17775 !d      print *,'grad',nf,icg
17776       if (nf-nfl+1) 20,30,40
17777    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
17778 !    write (iout,*) 'grad 20'
17779       if (nf.eq.0) return
17780       goto 40
17781    30 call var_to_geom(n,x)
17782       call chainbuild
17783 !    write (iout,*) 'grad 30'
17784 !
17785 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
17786 !
17787    40 call cartder
17788 !     write (iout,*) 'grad 40'
17789 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
17790 !
17791 ! Convert the Cartesian gradient into internal-coordinate gradient.
17792 !
17793       ind=0
17794       ind1=0
17795       do i=1,nres-2
17796       gthetai=0.0D0
17797       gphii=0.0D0
17798       do j=i+1,nres-1
17799         ind=ind+1
17800 !         ind=indmat(i,j)
17801 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
17802        do k=1,3
17803        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
17804         enddo
17805         do k=1,3
17806         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
17807          enddo
17808        enddo
17809       do j=i+1,nres-1
17810         ind1=ind1+1
17811 !         ind1=indmat(i,j)
17812 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
17813         do k=1,3
17814           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
17815           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
17816           enddo
17817         enddo
17818       if (i.gt.1) g(i-1)=gphii
17819       if (n.gt.nphi) g(nphi+i)=gthetai
17820       enddo
17821       if (n.le.nphi+ntheta) goto 10
17822       do i=2,nres-1
17823       if (itype(i,1).ne.10) then
17824           galphai=0.0D0
17825         gomegai=0.0D0
17826         do k=1,3
17827           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17828           enddo
17829         do k=1,3
17830           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17831           enddo
17832           g(ialph(i,1))=galphai
17833         g(ialph(i,1)+nside)=gomegai
17834         endif
17835       enddo
17836 !
17837 ! Add the components corresponding to local energy terms.
17838 !
17839    10 continue
17840       do i=1,nvar
17841 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17842         g(i)=g(i)+gloc(i,icg)
17843       enddo
17844 ! Uncomment following three lines for diagnostics.
17845 !d    call intout
17846 !elwrite(iout,*) "in gradient after calling intout"
17847 !d    call briefout(0,0.0d0)
17848 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17849       return
17850       end subroutine gradient
17851 #endif
17852 !-----------------------------------------------------------------------------
17853       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17854
17855       use comm_chu
17856 !      implicit real(kind=8) (a-h,o-z)
17857 !      include 'DIMENSIONS'
17858 !      include 'COMMON.DERIV'
17859 !      include 'COMMON.IOUNITS'
17860 !      include 'COMMON.GEO'
17861       integer :: n,nf
17862 !el      integer :: jjj
17863 !el      common /chuju/ jjj
17864       real(kind=8) :: energia(0:n_ene)
17865       integer :: uiparm(1)
17866       real(kind=8) :: urparm(1)
17867       real(kind=8) :: f
17868       real(kind=8),external :: ufparm
17869       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17870 !     if (jjj.gt.0) then
17871 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17872 !     endif
17873       nfl=nf
17874       icg=mod(nf,2)+1
17875 !d      print *,'func',nf,nfl,icg
17876       call var_to_geom(n,x)
17877       call zerograd
17878       call chainbuild
17879 !d    write (iout,*) 'ETOTAL called from FUNC'
17880       call etotal(energia)
17881       call sum_gradient
17882       f=energia(0)
17883 !     if (jjj.gt.0) then
17884 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17885 !       write (iout,*) 'f=',etot
17886 !       jjj=0
17887 !     endif
17888       return
17889       end subroutine func
17890 !-----------------------------------------------------------------------------
17891       subroutine cartgrad
17892 !      implicit real(kind=8) (a-h,o-z)
17893 !      include 'DIMENSIONS'
17894       use energy_data
17895       use MD_data, only: totT,usampl,eq_time
17896 #ifdef MPI
17897       include 'mpif.h'
17898 #endif
17899 !      include 'COMMON.CHAIN'
17900 !      include 'COMMON.DERIV'
17901 !      include 'COMMON.VAR'
17902 !      include 'COMMON.INTERACT'
17903 !      include 'COMMON.FFIELD'
17904 !      include 'COMMON.MD'
17905 !      include 'COMMON.IOUNITS'
17906 !      include 'COMMON.TIME1'
17907 !
17908       integer :: i,j
17909       real(kind=8) :: time00,time01
17910
17911 ! This subrouting calculates total Cartesian coordinate gradient.
17912 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17913 !
17914 !#define DEBUG
17915 #ifdef TIMINGtime01
17916       time00=MPI_Wtime()
17917 #endif
17918       icg=1
17919       call sum_gradient
17920 #ifdef TIMING
17921 #endif
17922 !#define DEBUG
17923 !el      write (iout,*) "After sum_gradient"
17924 #ifdef DEBUG
17925       write (iout,*) "After sum_gradient"
17926       do i=1,nres-1
17927         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17928         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17929       enddo
17930 #endif
17931 !#undef DEBUG
17932 ! If performing constraint dynamics, add the gradients of the constraint energy
17933       if(usampl.and.totT.gt.eq_time) then
17934          do i=1,nct
17935            do j=1,3
17936              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17937              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17938            enddo
17939          enddo
17940          do i=1,nres-3
17941            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17942          enddo
17943          do i=1,nres-2
17944            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17945          enddo
17946       endif
17947 !elwrite (iout,*) "After sum_gradient"
17948 #ifdef TIMING
17949       time01=MPI_Wtime()
17950 #endif
17951       call intcartderiv
17952 !elwrite (iout,*) "After sum_gradient"
17953 #ifdef TIMING
17954       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17955 #endif
17956 !     call checkintcartgrad
17957 !     write(iout,*) 'calling int_to_cart'
17958 !#define DEBUG
17959 #ifdef DEBUG
17960       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17961 #endif
17962       do i=0,nct
17963         do j=1,3
17964           gcart(j,i)=gradc(j,i,icg)
17965           gxcart(j,i)=gradx(j,i,icg)
17966 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17967         enddo
17968 #ifdef DEBUG
17969         write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),&
17970           (gxcart(j,i),j=1,3),gloc(i,icg),(gloc_sc(j,i,icg),j=1,3)
17971 #endif
17972       enddo
17973 #ifdef TIMING
17974       time01=MPI_Wtime()
17975 #endif
17976 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17977       call int_to_cart
17978 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17979
17980 #ifdef TIMING
17981             time_inttocart=time_inttocart+MPI_Wtime()-time01
17982 #endif
17983 #ifdef DEBUG
17984             write (iout,*) "gcart and gxcart after int_to_cart"
17985             do i=0,nres-1
17986             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17987             (gxcart(j,i),j=1,3)
17988             enddo
17989 #endif
17990 !#undef DEBUG
17991 #ifdef CARGRAD
17992 #ifdef DEBUG
17993             write (iout,*) "CARGRAD"
17994 #endif
17995 !            do i=nres,0,-1
17996 !            do j=1,3
17997 !              gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17998       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17999 !            enddo
18000       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
18001       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
18002 !            enddo
18003       ! Correction: dummy residues
18004 !            if (nnt.gt.1) then
18005 !              do j=1,3
18006 !      !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
18007 !            gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
18008 !            enddo
18009 !          endif
18010 !          if (nct.lt.nres) then
18011 !            do j=1,3
18012 !      !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
18013 !            gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
18014 !            enddo
18015 !          endif
18016 !         call grad_transform
18017 #endif
18018 #ifdef TIMING
18019           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
18020 #endif
18021 !#undef DEBUG
18022           return
18023           end subroutine cartgrad
18024
18025 #ifdef FIVEDIAG
18026       subroutine grad_transform
18027       implicit none
18028 #ifdef MPI
18029       include 'mpif.h'
18030 #endif
18031       integer i,j,kk,mnum
18032 #ifdef DEBUG
18033       write (iout,*)"Converting virtual-bond gradient to CA/SC gradient"
18034       write (iout,*) "dC/dX gradient"
18035       do i=0,nres
18036         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
18037      &      (gxcart(j,i),j=1,3)
18038       enddo
18039 #endif
18040       do i=nres,1,-1
18041         do j=1,3
18042           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
18043 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
18044         enddo
18045 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
18046 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
18047       enddo
18048 ! Correction: dummy residues
18049       do i=2,nres
18050         mnum=molnum(i)
18051         if (itype(i-1,mnum).eq.ntyp1_molec(mnum) .and.&
18052         itype(i,mnum).ne.ntyp1_molec(mnum)) then
18053           gcart(:,i)=gcart(:,i)+gcart(:,i-1)
18054         else if (itype(i-1,mnum).ne.ntyp1_molec(mnum).and.&
18055           itype(i,mnum).eq.ntyp1_molec(mnum)) then
18056           gcart(:,i-1)=gcart(:,i-1)+gcart(:,i)
18057         endif
18058       enddo
18059 !      if (nnt.gt.1) then
18060 !        do j=1,3
18061 !          gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
18062 !        enddo
18063 !      endif
18064 !      if (nct.lt.nres) then
18065 !        do j=1,3
18066 !!          gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
18067 !          gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
18068 !        enddo
18069 !      endif
18070 #ifdef DEBUG
18071       write (iout,*) "CA/SC gradient"
18072       do i=1,nres
18073         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
18074      &      (gxcart(j,i),j=1,3)
18075       enddo
18076 #endif
18077       return
18078       end subroutine grad_transform
18079 #endif
18080
18081       !-----------------------------------------------------------------------------
18082           subroutine zerograd
18083       !      implicit real(kind=8) (a-h,o-z)
18084       !      include 'DIMENSIONS'
18085       !      include 'COMMON.DERIV'
18086       !      include 'COMMON.CHAIN'
18087       !      include 'COMMON.VAR'
18088       !      include 'COMMON.MD'
18089       !      include 'COMMON.SCCOR'
18090       !
18091       !el local variables
18092           integer :: i,j,intertyp,k
18093       ! Initialize Cartesian-coordinate gradient
18094       !
18095       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
18096       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
18097
18098       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
18099       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
18100       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
18101       !      allocate(gradcorr_long(3,nres))
18102       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
18103       !      allocate(gcorr6_turn_long(3,nres))
18104       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
18105
18106       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
18107
18108       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
18109       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
18110
18111       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
18112       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
18113
18114       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
18115       !      allocate(gscloc(3,nres)) !(3,maxres)
18116       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
18117
18118
18119
18120       !      common /deriv_scloc/
18121       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
18122       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
18123       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
18124       !      common /mpgrad/
18125       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
18126
18127
18128
18129       !          gradc(j,i,icg)=0.0d0
18130       !          gradx(j,i,icg)=0.0d0
18131
18132       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
18133       !elwrite(iout,*) "icg",icg
18134           do i=-1,nres
18135           do j=1,3
18136             gvdwx(j,i)=0.0D0
18137             gradx_scp(j,i)=0.0D0
18138             gvdwc(j,i)=0.0D0
18139             gvdwc_scp(j,i)=0.0D0
18140             gvdwc_scpp(j,i)=0.0d0
18141             gelc(j,i)=0.0D0
18142             gelc_long(j,i)=0.0D0
18143             gradb(j,i)=0.0d0
18144             gradbx(j,i)=0.0d0
18145             gvdwpp(j,i)=0.0d0
18146             gel_loc(j,i)=0.0d0
18147             gel_loc_long(j,i)=0.0d0
18148             ghpbc(j,i)=0.0D0
18149             ghpbx(j,i)=0.0D0
18150             gcorr3_turn(j,i)=0.0d0
18151             gcorr4_turn(j,i)=0.0d0
18152             gradcorr(j,i)=0.0d0
18153             gradcorr_long(j,i)=0.0d0
18154             gradcorr5_long(j,i)=0.0d0
18155             gradcorr6_long(j,i)=0.0d0
18156             gcorr6_turn_long(j,i)=0.0d0
18157             gradcorr5(j,i)=0.0d0
18158             gradcorr6(j,i)=0.0d0
18159             gcorr6_turn(j,i)=0.0d0
18160             gsccorc(j,i)=0.0d0
18161             gsccorx(j,i)=0.0d0
18162             gradc(j,i,icg)=0.0d0
18163             gradx(j,i,icg)=0.0d0
18164             gscloc(j,i)=0.0d0
18165             gsclocx(j,i)=0.0d0
18166             gliptran(j,i)=0.0d0
18167             gliptranx(j,i)=0.0d0
18168             gliptranc(j,i)=0.0d0
18169             gshieldx(j,i)=0.0d0
18170             gshieldc(j,i)=0.0d0
18171             gshieldc_loc(j,i)=0.0d0
18172             gshieldx_ec(j,i)=0.0d0
18173             gshieldc_ec(j,i)=0.0d0
18174             gshieldc_loc_ec(j,i)=0.0d0
18175             gshieldx_t3(j,i)=0.0d0
18176             gshieldc_t3(j,i)=0.0d0
18177             gshieldc_loc_t3(j,i)=0.0d0
18178             gshieldx_t4(j,i)=0.0d0
18179             gshieldc_t4(j,i)=0.0d0
18180             gshieldc_loc_t4(j,i)=0.0d0
18181             gshieldx_ll(j,i)=0.0d0
18182             gshieldc_ll(j,i)=0.0d0
18183             gshieldc_loc_ll(j,i)=0.0d0
18184             gg_tube(j,i)=0.0d0
18185             gg_tube_sc(j,i)=0.0d0
18186             gradafm(j,i)=0.0d0
18187             gradb_nucl(j,i)=0.0d0
18188             gradbx_nucl(j,i)=0.0d0
18189             gvdwpp_nucl(j,i)=0.0d0
18190             gvdwpp(j,i)=0.0d0
18191             gelpp(j,i)=0.0d0
18192             gvdwpsb(j,i)=0.0d0
18193             gvdwpsb1(j,i)=0.0d0
18194             gvdwsbc(j,i)=0.0d0
18195             gvdwsbx(j,i)=0.0d0
18196             gelsbc(j,i)=0.0d0
18197             gradcorr_nucl(j,i)=0.0d0
18198             gradcorr3_nucl(j,i)=0.0d0
18199             gradxorr_nucl(j,i)=0.0d0
18200             gradxorr3_nucl(j,i)=0.0d0
18201             gelsbx(j,i)=0.0d0
18202             gsbloc(j,i)=0.0d0
18203             gsblocx(j,i)=0.0d0
18204             gradpepcat(j,i)=0.0d0
18205             gradpepcatx(j,i)=0.0d0
18206             gradcatcat(j,i)=0.0d0
18207             gvdwx_scbase(j,i)=0.0d0
18208             gvdwc_scbase(j,i)=0.0d0
18209             gvdwx_pepbase(j,i)=0.0d0
18210             gvdwc_pepbase(j,i)=0.0d0
18211             gvdwx_scpho(j,i)=0.0d0
18212             gvdwc_scpho(j,i)=0.0d0
18213             gvdwc_peppho(j,i)=0.0d0
18214             gradnuclcatx(j,i)=0.0d0
18215             gradnuclcat(j,i)=0.0d0
18216             gradlipbond(j,i)=0.0d0
18217             gradlipang(j,i)=0.0d0
18218             gradliplj(j,i)=0.0d0
18219             gradlipelec(j,i)=0.0d0
18220             gradcattranc(j,i)=0.0d0
18221             gradcattranx(j,i)=0.0d0
18222             gradcatangx(j,i)=0.0d0
18223             gradcatangc(j,i)=0.0d0
18224             duscdiff(j,i)=0.0d0
18225             duscdiffx(j,i)=0.0d0
18226           enddo
18227            enddo
18228           do i=0,nres
18229           do j=1,3
18230             do intertyp=1,3
18231              gloc_sc(intertyp,i,icg)=0.0d0
18232             enddo
18233           enddo
18234           enddo
18235           do i=1,nres
18236            do j=1,maxcontsshi
18237            shield_list(j,i)=0
18238           do k=1,3
18239       !C           print *,i,j,k
18240              grad_shield_side(k,j,i)=0.0d0
18241              grad_shield_loc(k,j,i)=0.0d0
18242            enddo
18243            enddo
18244            ishield_list(i)=0
18245           enddo
18246
18247       !
18248       ! Initialize the gradient of local energy terms.
18249       !
18250       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
18251       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
18252       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
18253       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
18254       !      allocate(gel_loc_turn3(nres))
18255       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
18256       !      allocate(gsccor_loc(nres))      !(maxres)
18257
18258           do i=1,4*nres
18259           gloc(i,icg)=0.0D0
18260           enddo
18261           do i=1,nres
18262           gel_loc_loc(i)=0.0d0
18263           gcorr_loc(i)=0.0d0
18264           g_corr5_loc(i)=0.0d0
18265           g_corr6_loc(i)=0.0d0
18266           gel_loc_turn3(i)=0.0d0
18267           gel_loc_turn4(i)=0.0d0
18268           gel_loc_turn6(i)=0.0d0
18269           gsccor_loc(i)=0.0d0
18270           enddo
18271       ! initialize gcart and gxcart
18272       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
18273           do i=0,nres
18274           do j=1,3
18275             gcart(j,i)=0.0d0
18276             gxcart(j,i)=0.0d0
18277           enddo
18278           enddo
18279           return
18280           end subroutine zerograd
18281       !-----------------------------------------------------------------------------
18282           real(kind=8) function fdum()
18283           fdum=0.0D0
18284           return
18285           end function fdum
18286       !-----------------------------------------------------------------------------
18287       ! intcartderiv.F
18288       !-----------------------------------------------------------------------------
18289           subroutine intcartderiv
18290       !      implicit real(kind=8) (a-h,o-z)
18291       !      include 'DIMENSIONS'
18292 #ifdef MPI
18293           include 'mpif.h'
18294 #endif
18295       !      include 'COMMON.SETUP'
18296       !      include 'COMMON.CHAIN'
18297       !      include 'COMMON.VAR'
18298       !      include 'COMMON.GEO'
18299       !      include 'COMMON.INTERACT'
18300       !      include 'COMMON.DERIV'
18301       !      include 'COMMON.IOUNITS'
18302       !      include 'COMMON.LOCAL'
18303       !      include 'COMMON.SCCOR'
18304           real(kind=8) :: pi4,pi34
18305           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
18306           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
18307                   dcosomega,dsinomega !(3,3,maxres)
18308           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
18309
18310           integer :: i,j,k
18311           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
18312                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
18313                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
18314                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
18315           integer :: nres2
18316           nres2=2*nres
18317
18318       !el from module energy-------------
18319       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
18320       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
18321       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
18322
18323       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
18324       !el      allocate(dsintau(3,3,3,0:nres2))
18325       !el      allocate(dtauangle(3,3,3,0:nres2))
18326       !el      allocate(domicron(3,2,2,0:nres2))
18327       !el      allocate(dcosomicron(3,2,2,0:nres2))
18328
18329
18330
18331 #if defined(MPI) && defined(PARINTDER)
18332           if (nfgtasks.gt.1 .and. me.eq.king) &
18333           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
18334 #endif
18335           pi4 = 0.5d0*pipol
18336           pi34 = 3*pi4
18337
18338       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
18339       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
18340
18341       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
18342           do i=1,nres
18343           do j=1,3
18344             dtheta(j,1,i)=0.0d0
18345             dtheta(j,2,i)=0.0d0
18346             dphi(j,1,i)=0.0d0
18347             dphi(j,2,i)=0.0d0
18348             dphi(j,3,i)=0.0d0
18349             dcosomicron(j,1,1,i)=0.0d0
18350             dcosomicron(j,1,2,i)=0.0d0
18351             dcosomicron(j,2,1,i)=0.0d0
18352             dcosomicron(j,2,2,i)=0.0d0
18353           enddo
18354           enddo
18355       ! Derivatives of theta's
18356 #if defined(MPI) && defined(PARINTDER)
18357       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
18358           do i=max0(ithet_start-1,3),ithet_end
18359 #else
18360           do i=3,nres
18361 #endif
18362           cost=dcos(theta(i))
18363           sint=sqrt(1-cost*cost)
18364           do j=1,3
18365             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
18366             vbld(i-1)
18367             if (((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))) &
18368              dtheta(j,1,i)=-dcostheta(j,1,i)/sint
18369             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
18370             vbld(i)
18371             if ((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))&
18372              dtheta(j,2,i)=-dcostheta(j,2,i)/sint
18373           enddo
18374           enddo
18375 #if defined(MPI) && defined(PARINTDER)
18376       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
18377           do i=max0(ithet_start-1,3),ithet_end
18378 #else
18379           do i=3,nres
18380 #endif
18381           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).lt.4) then
18382           cost1=dcos(omicron(1,i))
18383           sint1=sqrt(1-cost1*cost1)
18384           cost2=dcos(omicron(2,i))
18385           sint2=sqrt(1-cost2*cost2)
18386            do j=1,3
18387       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
18388             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
18389             cost1*dc_norm(j,i-2))/ &
18390             vbld(i-1)
18391             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
18392             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
18393             +cost1*(dc_norm(j,i-1+nres)))/ &
18394             vbld(i-1+nres)
18395             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
18396       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
18397       !C Looks messy but better than if in loop
18398             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
18399             +cost2*dc_norm(j,i-1))/ &
18400             vbld(i)
18401             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
18402             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
18403              +cost2*(-dc_norm(j,i-1+nres)))/ &
18404             vbld(i-1+nres)
18405       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
18406             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
18407           enddo
18408            endif
18409           enddo
18410       !elwrite(iout,*) "after vbld write"
18411       ! Derivatives of phi:
18412       ! If phi is 0 or 180 degrees, then the formulas
18413       ! have to be derived by power series expansion of the
18414       ! conventional formulas around 0 and 180.
18415 #ifdef PARINTDER
18416           do i=iphi1_start,iphi1_end
18417 #else
18418           do i=4,nres
18419 #endif
18420       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
18421       ! the conventional case
18422           sint=dsin(theta(i))
18423           sint1=dsin(theta(i-1))
18424           sing=dsin(phi(i))
18425           cost=dcos(theta(i))
18426           cost1=dcos(theta(i-1))
18427           cosg=dcos(phi(i))
18428           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
18429           if ((sint*sint1).eq.0.0d0) then
18430           fac0=0.0d0
18431           else
18432           fac0=1.0d0/(sint1*sint)
18433           endif
18434           fac1=cost*fac0
18435           fac2=cost1*fac0
18436           if (sint1.ne.0.0d0) then
18437           fac3=cosg*cost1/(sint1*sint1)
18438           else
18439           fac3=0.0d0
18440           endif
18441           if (sint.ne.0.0d0) then
18442           fac4=cosg*cost/(sint*sint)
18443           else
18444           fac4=0.0d0
18445           endif
18446       !    Obtaining the gamma derivatives from sine derivative
18447            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
18448              phi(i).gt.pi34.and.phi(i).le.pi.or. &
18449              phi(i).ge.-pi.and.phi(i).le.-pi34) then
18450            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
18451            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
18452            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
18453            do j=1,3
18454             if (sint.ne.0.0d0) then
18455             ctgt=cost/sint
18456             else
18457             ctgt=0.0d0
18458             endif
18459             if (sint1.ne.0.0d0) then
18460             ctgt1=cost1/sint1
18461             else
18462             ctgt1=0.0d0
18463             endif
18464             cosg_inv=1.0d0/cosg
18465 !            if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
18466             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
18467               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
18468             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
18469             dsinphi(j,2,i)= &
18470               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
18471               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18472             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
18473             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
18474               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
18475       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18476             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
18477 !            endif
18478 !             write(iout,*) "just after,close to pi",dphi(j,3,i),&
18479 !              sing*(ctgt1*dtheta(j,2,i-1)),ctgt*dtheta(j,1,i), &
18480 !              (fac0*vp2(j)+sing*dc_norm(j,i-2)),vbld_inv(i-1)
18481
18482       ! Bug fixed 3/24/05 (AL)
18483            enddo
18484       !   Obtaining the gamma derivatives from cosine derivative
18485           else
18486              do j=1,3
18487 !             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
18488              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
18489              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
18490              dc_norm(j,i-3))/vbld(i-2)
18491              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
18492              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
18493              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
18494              dcostheta(j,1,i)
18495              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
18496              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
18497              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
18498              dc_norm(j,i-1))/vbld(i)
18499              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
18500 !#define DEBUG
18501 #ifdef DEBUG
18502              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
18503 #endif
18504 !#undef DEBUG
18505 !             endif
18506            enddo
18507           endif
18508           enddo
18509       !alculate derivative of Tauangle
18510 #ifdef PARINTDER
18511           do i=itau_start,itau_end
18512 #else
18513           do i=3,nres
18514       !elwrite(iout,*) " vecpr",i,nres
18515 #endif
18516            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
18517       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
18518       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
18519       !c dtauangle(j,intertyp,dervityp,residue number)
18520       !c INTERTYP=1 SC...Ca...Ca..Ca
18521       ! the conventional case
18522           sint=dsin(theta(i))
18523           sint1=dsin(omicron(2,i-1))
18524           sing=dsin(tauangle(1,i))
18525           cost=dcos(theta(i))
18526           cost1=dcos(omicron(2,i-1))
18527           cosg=dcos(tauangle(1,i))
18528       !elwrite(iout,*) " vecpr5",i,nres
18529           do j=1,3
18530       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
18531       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
18532           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
18533       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
18534           enddo
18535           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
18536       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac
18537         if ((sint*sint1).eq.0.0d0) then
18538           fac0=0.0d0
18539           else
18540           fac0=1.0d0/(sint1*sint)
18541           endif
18542           fac1=cost*fac0
18543           fac2=cost1*fac0
18544           if (sint1.ne.0.0d0) then
18545           fac3=cosg*cost1/(sint1*sint1)
18546           else
18547           fac3=0.0d0
18548           endif
18549           if (sint.ne.0.0d0) then
18550           fac4=cosg*cost/(sint*sint)
18551           else
18552           fac4=0.0d0
18553           endif
18554
18555       !    Obtaining the gamma derivatives from sine derivative
18556            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
18557              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
18558              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
18559            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
18560            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
18561            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18562           do j=1,3
18563             ctgt=cost/sint
18564             ctgt1=cost1/sint1
18565             cosg_inv=1.0d0/cosg
18566             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18567            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
18568            *vbld_inv(i-2+nres)
18569             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
18570             dsintau(j,1,2,i)= &
18571               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
18572               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18573       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
18574             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
18575       ! Bug fixed 3/24/05 (AL)
18576             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
18577               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
18578       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18579             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
18580            enddo
18581       !   Obtaining the gamma derivatives from cosine derivative
18582           else
18583              do j=1,3
18584              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18585              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
18586              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
18587              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
18588              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18589              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18590              dcostheta(j,1,i)
18591              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
18592              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
18593              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
18594              dc_norm(j,i-1))/vbld(i)
18595              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
18596       !         write (iout,*) "else",i
18597            enddo
18598           endif
18599       !        do k=1,3
18600       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
18601       !        enddo
18602           enddo
18603       !C Second case Ca...Ca...Ca...SC
18604 #ifdef PARINTDER
18605           do i=itau_start,itau_end
18606 #else
18607           do i=4,nres
18608 #endif
18609            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18610             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
18611       ! the conventional case
18612           sint=dsin(omicron(1,i))
18613           sint1=dsin(theta(i-1))
18614           sing=dsin(tauangle(2,i))
18615           cost=dcos(omicron(1,i))
18616           cost1=dcos(theta(i-1))
18617           cosg=dcos(tauangle(2,i))
18618       !        do j=1,3
18619       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18620       !        enddo
18621           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
18622         if ((sint*sint1).eq.0.0d0) then
18623           fac0=0.0d0
18624           else
18625           fac0=1.0d0/(sint1*sint)
18626           endif
18627           fac1=cost*fac0
18628           fac2=cost1*fac0
18629           if (sint1.ne.0.0d0) then
18630           fac3=cosg*cost1/(sint1*sint1)
18631           else
18632           fac3=0.0d0
18633           endif
18634           if (sint.ne.0.0d0) then
18635           fac4=cosg*cost/(sint*sint)
18636           else
18637           fac4=0.0d0
18638           endif
18639       !    Obtaining the gamma derivatives from sine derivative
18640            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
18641              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
18642              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
18643            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
18644            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
18645            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
18646           do j=1,3
18647             ctgt=cost/sint
18648             ctgt1=cost1/sint1
18649             cosg_inv=1.0d0/cosg
18650             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
18651               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
18652       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
18653       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
18654             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
18655             dsintau(j,2,2,i)= &
18656               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
18657               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18658       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
18659       !     & sing*ctgt*domicron(j,1,2,i),
18660       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18661             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
18662       ! Bug fixed 3/24/05 (AL)
18663             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18664              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
18665       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18666             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
18667            enddo
18668       !   Obtaining the gamma derivatives from cosine derivative
18669           else
18670              do j=1,3
18671              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
18672              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18673              dc_norm(j,i-3))/vbld(i-2)
18674              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
18675              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
18676              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
18677              dcosomicron(j,1,1,i)
18678              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
18679              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18680              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
18681              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18682              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
18683       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
18684            enddo
18685           endif
18686           enddo
18687
18688       !CC third case SC...Ca...Ca...SC
18689 #ifdef PARINTDER
18690
18691           do i=itau_start,itau_end
18692 #else
18693           do i=3,nres
18694 #endif
18695       ! the conventional case
18696           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18697           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
18698           sint=dsin(omicron(1,i))
18699           sint1=dsin(omicron(2,i-1))
18700           sing=dsin(tauangle(3,i))
18701           cost=dcos(omicron(1,i))
18702           cost1=dcos(omicron(2,i-1))
18703           cosg=dcos(tauangle(3,i))
18704           do j=1,3
18705           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
18706       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18707           enddo
18708           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
18709         if ((sint*sint1).eq.0.0d0) then
18710           fac0=0.0d0
18711           else
18712           fac0=1.0d0/(sint1*sint)
18713           endif
18714           fac1=cost*fac0
18715           fac2=cost1*fac0
18716           if (sint1.ne.0.0d0) then
18717           fac3=cosg*cost1/(sint1*sint1)
18718           else
18719           fac3=0.0d0
18720           endif
18721           if (sint.ne.0.0d0) then
18722           fac4=cosg*cost/(sint*sint)
18723           else
18724           fac4=0.0d0
18725           endif
18726       !    Obtaining the gamma derivatives from sine derivative
18727            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
18728              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
18729              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
18730            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
18731            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
18732            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18733           do j=1,3
18734             ctgt=cost/sint
18735             ctgt1=cost1/sint1
18736             cosg_inv=1.0d0/cosg
18737             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18738               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
18739               *vbld_inv(i-2+nres)
18740             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
18741             dsintau(j,3,2,i)= &
18742               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
18743               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18744             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
18745       ! Bug fixed 3/24/05 (AL)
18746             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18747               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
18748               *vbld_inv(i-1+nres)
18749       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18750             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
18751            enddo
18752       !   Obtaining the gamma derivatives from cosine derivative
18753           else
18754              do j=1,3
18755              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18756              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18757              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
18758              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
18759              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18760              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18761              dcosomicron(j,1,1,i)
18762              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
18763              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18764              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
18765              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18766              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
18767       !          write(iout,*) "else",i
18768            enddo
18769           endif
18770           enddo
18771
18772 #ifdef CRYST_SC
18773       !   Derivatives of side-chain angles alpha and omega
18774 #if defined(MPI) && defined(PARINTDER)
18775           do i=ibond_start,ibond_end
18776 #else
18777           do i=2,nres-1
18778 #endif
18779             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
18780              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
18781              fac6=fac5/vbld(i)
18782              fac7=fac5*fac5
18783              fac8=fac5/vbld(i+1)
18784              fac9=fac5/vbld(i+nres)
18785              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
18786              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
18787              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
18788              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
18789              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
18790              sina=sqrt(1-cosa*cosa)
18791              sino=dsin(omeg(i))
18792       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
18793              do j=1,3
18794               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
18795               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
18796               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
18797               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
18798               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
18799               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
18800               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
18801               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
18802               vbld(i+nres))
18803               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
18804             enddo
18805       ! obtaining the derivatives of omega from sines
18806             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
18807                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
18808                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
18809                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
18810                dsin(theta(i+1)))
18811                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
18812                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
18813                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
18814                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
18815                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
18816                coso_inv=1.0d0/dcos(omeg(i))
18817                do j=1,3
18818                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
18819                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
18820                (sino*dc_norm(j,i-1))/vbld(i)
18821                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
18822                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
18823                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
18824                -sino*dc_norm(j,i)/vbld(i+1)
18825                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
18826                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
18827                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
18828                vbld(i+nres)
18829                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
18830               enddo
18831              else
18832       !   obtaining the derivatives of omega from cosines
18833              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
18834              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
18835              fac12=fac10*sina
18836              fac13=fac12*fac12
18837              fac14=sina*sina
18838              do j=1,3
18839               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
18840               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
18841               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
18842               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
18843               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
18844               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
18845               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
18846               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
18847               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
18848               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
18849               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
18850               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
18851               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
18852               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
18853               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
18854             enddo
18855             endif
18856            else
18857              do j=1,3
18858              do k=1,3
18859                dalpha(k,j,i)=0.0d0
18860                domega(k,j,i)=0.0d0
18861              enddo
18862              enddo
18863            endif
18864            enddo
18865 #endif
18866 #if defined(MPI) && defined(PARINTDER)
18867           if (nfgtasks.gt.1) then
18868 #ifdef DEBUG
18869       !d      write (iout,*) "Gather dtheta"
18870       !d      call flush(iout)
18871           write (iout,*) "dtheta before gather"
18872           do i=1,nres
18873           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
18874           enddo
18875 #endif
18876           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
18877           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
18878           king,FG_COMM,IERROR)
18879 !#define DEBUG
18880 #ifdef DEBUG
18881       !d      write (iout,*) "Gather dphi"
18882       !d      call flush(iout)
18883           write (iout,*) "dphi before gather"
18884           do i=1,nres
18885           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
18886           enddo
18887 #endif
18888 !#undef DEBUG
18889           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
18890           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
18891           king,FG_COMM,IERROR)
18892       !d      write (iout,*) "Gather dalpha"
18893       !d      call flush(iout)
18894 #ifdef CRYST_SC
18895           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
18896           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18897           king,FG_COMM,IERROR)
18898       !d      write (iout,*) "Gather domega"
18899       !d      call flush(iout)
18900           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
18901           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18902           king,FG_COMM,IERROR)
18903 #endif
18904           endif
18905 #endif
18906 !#define DEBUG
18907 #ifdef DEBUG
18908           write (iout,*) "dtheta after gather"
18909           do i=1,nres
18910           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
18911           enddo
18912           write (iout,*) "dphi after gather"
18913           do i=1,nres
18914           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
18915           enddo
18916           write (iout,*) "dalpha after gather"
18917           do i=1,nres
18918           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
18919           enddo
18920           write (iout,*) "domega after gather"
18921           do i=1,nres
18922           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
18923           enddo
18924 #endif
18925 !#undef DEBUG
18926           return
18927           end subroutine intcartderiv
18928       !-----------------------------------------------------------------------------
18929           subroutine checkintcartgrad
18930       !      implicit real(kind=8) (a-h,o-z)
18931       !      include 'DIMENSIONS'
18932 #ifdef MPI
18933           include 'mpif.h'
18934 #endif
18935       !      include 'COMMON.CHAIN'
18936       !      include 'COMMON.VAR'
18937       !      include 'COMMON.GEO'
18938       !      include 'COMMON.INTERACT'
18939       !      include 'COMMON.DERIV'
18940       !      include 'COMMON.IOUNITS'
18941       !      include 'COMMON.SETUP'
18942           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
18943           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
18944           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
18945           real(kind=8),dimension(3) :: dc_norm_s
18946           real(kind=8) :: aincr=1.0d-5
18947           integer :: i,j
18948           real(kind=8) :: dcji
18949           do i=1,nres
18950           phi_s(i)=phi(i)
18951           theta_s(i)=theta(i)
18952           alph_s(i)=alph(i)
18953           omeg_s(i)=omeg(i)
18954           enddo
18955       ! Check theta gradient
18956           write (iout,*) &
18957            "Analytical (upper) and numerical (lower) gradient of theta"
18958           write (iout,*)
18959           do i=3,nres
18960           do j=1,3
18961             dcji=dc(j,i-2)
18962             dc(j,i-2)=dcji+aincr
18963             call chainbuild_cart
18964             call int_from_cart1(.false.)
18965         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18966         dc(j,i-2)=dcji
18967         dcji=dc(j,i-1)
18968         dc(j,i-1)=dc(j,i-1)+aincr
18969         call chainbuild_cart
18970         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18971         dc(j,i-1)=dcji
18972       enddo
18973 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18974 !el          (dtheta(j,2,i),j=1,3)
18975 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18976 !el          (dthetanum(j,2,i),j=1,3)
18977 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18978 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18979 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18980 !el        write (iout,*)
18981       enddo
18982 ! Check gamma gradient
18983       write (iout,*) &
18984        "Analytical (upper) and numerical (lower) gradient of gamma"
18985       do i=4,nres
18986       do j=1,3
18987         dcji=dc(j,i-3)
18988         dc(j,i-3)=dcji+aincr
18989         call chainbuild_cart
18990         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18991             dc(j,i-3)=dcji
18992         dcji=dc(j,i-2)
18993         dc(j,i-2)=dcji+aincr
18994         call chainbuild_cart
18995         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18996         dc(j,i-2)=dcji
18997         dcji=dc(j,i-1)
18998         dc(j,i-1)=dc(j,i-1)+aincr
18999         call chainbuild_cart
19000         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
19001         dc(j,i-1)=dcji
19002       enddo
19003 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
19004 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
19005 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
19006 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
19007 !el        write (iout,'(5x,3(3f10.5,5x))') &
19008 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
19009 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
19010 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
19011 !el        write (iout,*)
19012       enddo
19013 ! Check alpha gradient
19014       write (iout,*) &
19015        "Analytical (upper) and numerical (lower) gradient of alpha"
19016       do i=2,nres-1
19017        if(itype(i,1).ne.10) then
19018              do j=1,3
19019               dcji=dc(j,i-1)
19020                dc(j,i-1)=dcji+aincr
19021             call chainbuild_cart
19022             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
19023              /aincr
19024               dc(j,i-1)=dcji
19025             dcji=dc(j,i)
19026             dc(j,i)=dcji+aincr
19027             call chainbuild_cart
19028             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
19029              /aincr
19030             dc(j,i)=dcji
19031             dcji=dc(j,i+nres)
19032             dc(j,i+nres)=dc(j,i+nres)+aincr
19033             call chainbuild_cart
19034             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
19035              /aincr
19036            dc(j,i+nres)=dcji
19037           enddo
19038         endif
19039 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
19040 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
19041 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
19042 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
19043 !el        write (iout,'(5x,3(3f10.5,5x))') &
19044 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
19045 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
19046 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
19047 !el        write (iout,*)
19048       enddo
19049 !     Check omega gradient
19050       write (iout,*) &
19051        "Analytical (upper) and numerical (lower) gradient of omega"
19052       do i=2,nres-1
19053        if(itype(i,1).ne.10) then
19054              do j=1,3
19055               dcji=dc(j,i-1)
19056                dc(j,i-1)=dcji+aincr
19057             call chainbuild_cart
19058             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
19059              /aincr
19060               dc(j,i-1)=dcji
19061             dcji=dc(j,i)
19062             dc(j,i)=dcji+aincr
19063             call chainbuild_cart
19064             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
19065              /aincr
19066             dc(j,i)=dcji
19067             dcji=dc(j,i+nres)
19068             dc(j,i+nres)=dc(j,i+nres)+aincr
19069             call chainbuild_cart
19070             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
19071              /aincr
19072            dc(j,i+nres)=dcji
19073           enddo
19074         endif
19075 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
19076 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
19077 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
19078 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
19079 !el        write (iout,'(5x,3(3f10.5,5x))') &
19080 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
19081 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
19082 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
19083 !el        write (iout,*)
19084       enddo
19085       return
19086       end subroutine checkintcartgrad
19087 !-----------------------------------------------------------------------------
19088 ! q_measure.F
19089 !-----------------------------------------------------------------------------
19090       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
19091 !      implicit real(kind=8) (a-h,o-z)
19092 !      include 'DIMENSIONS'
19093 !      include 'COMMON.IOUNITS'
19094 !      include 'COMMON.CHAIN'
19095 !      include 'COMMON.INTERACT'
19096 !      include 'COMMON.VAR'
19097       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
19098       integer :: kkk,nsep=3
19099       real(kind=8) :: qm      !dist,
19100       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
19101       logical :: lprn=.false.
19102       logical :: flag
19103 !      real(kind=8) :: sigm,x
19104
19105 !el      sigm(x)=0.25d0*x     ! local function
19106       qqmax=1.0d10
19107       do kkk=1,nperm
19108       qq = 0.0d0
19109       nl=0
19110        if(flag) then
19111       do il=seg1+nsep,seg2
19112         do jl=seg1,il-nsep
19113           nl=nl+1
19114           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
19115                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
19116                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19117           dij=dist(il,jl)
19118           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
19119           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19120             nl=nl+1
19121             d0ijCM=dsqrt( &
19122                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19123                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19124                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19125             dijCM=dist(il+nres,jl+nres)
19126             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
19127           endif
19128           qq = qq+qqij+qqijCM
19129         enddo
19130       enddo
19131       qq = qq/nl
19132       else
19133       do il=seg1,seg2
19134       if((seg3-il).lt.3) then
19135            secseg=il+3
19136       else
19137            secseg=seg3
19138       endif
19139         do jl=secseg,seg4
19140           nl=nl+1
19141           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
19142                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
19143                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19144           dij=dist(il,jl)
19145           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
19146           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19147             nl=nl+1
19148             d0ijCM=dsqrt( &
19149                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19150                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19151                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19152             dijCM=dist(il+nres,jl+nres)
19153             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
19154           endif
19155           qq = qq+qqij+qqijCM
19156         enddo
19157       enddo
19158       qq = qq/nl
19159       endif
19160       if (qqmax.le.qq) qqmax=qq
19161       enddo
19162       qwolynes=1.0d0-qqmax
19163       return
19164       end function qwolynes
19165 !-----------------------------------------------------------------------------
19166       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
19167 !      implicit real(kind=8) (a-h,o-z)
19168 !      include 'DIMENSIONS'
19169 !      include 'COMMON.IOUNITS'
19170 !      include 'COMMON.CHAIN'
19171 !      include 'COMMON.INTERACT'
19172 !      include 'COMMON.VAR'
19173 !      include 'COMMON.MD'
19174       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
19175       integer :: nsep=3, kkk
19176 !el      real(kind=8) :: dist
19177       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
19178       logical :: lprn=.false.
19179       logical :: flag
19180       real(kind=8) :: sim,dd0,fac,ddqij
19181 !el      sigm(x)=0.25d0*x           ! local function
19182       do kkk=1,nperm
19183       do i=0,nres
19184       do j=1,3
19185         dqwol(j,i)=0.0d0
19186         dxqwol(j,i)=0.0d0
19187       enddo
19188       enddo
19189       nl=0
19190        if(flag) then
19191       do il=seg1+nsep,seg2
19192         do jl=seg1,il-nsep
19193           nl=nl+1
19194           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
19195                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
19196                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19197           dij=dist(il,jl)
19198           sim = 1.0d0/sigm(d0ij)
19199           sim = sim*sim
19200           dd0 = dij-d0ij
19201           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
19202         do k=1,3
19203             ddqij = (c(k,il)-c(k,jl))*fac
19204             dqwol(k,il)=dqwol(k,il)+ddqij
19205             dqwol(k,jl)=dqwol(k,jl)-ddqij
19206           enddo
19207
19208           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19209             nl=nl+1
19210             d0ijCM=dsqrt( &
19211                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19212                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19213                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19214             dijCM=dist(il+nres,jl+nres)
19215             sim = 1.0d0/sigm(d0ijCM)
19216             sim = sim*sim
19217             dd0=dijCM-d0ijCM
19218             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
19219             do k=1,3
19220             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
19221             dxqwol(k,il)=dxqwol(k,il)+ddqij
19222             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
19223             enddo
19224           endif
19225         enddo
19226       enddo
19227        else
19228       do il=seg1,seg2
19229       if((seg3-il).lt.3) then
19230            secseg=il+3
19231       else
19232            secseg=seg3
19233       endif
19234         do jl=secseg,seg4
19235           nl=nl+1
19236           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
19237                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
19238                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19239           dij=dist(il,jl)
19240           sim = 1.0d0/sigm(d0ij)
19241           sim = sim*sim
19242           dd0 = dij-d0ij
19243           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
19244           do k=1,3
19245             ddqij = (c(k,il)-c(k,jl))*fac
19246             dqwol(k,il)=dqwol(k,il)+ddqij
19247             dqwol(k,jl)=dqwol(k,jl)-ddqij
19248           enddo
19249           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19250             nl=nl+1
19251             d0ijCM=dsqrt( &
19252                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19253                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19254                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19255             dijCM=dist(il+nres,jl+nres)
19256             sim = 1.0d0/sigm(d0ijCM)
19257             sim=sim*sim
19258             dd0 = dijCM-d0ijCM
19259             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
19260             do k=1,3
19261              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
19262              dxqwol(k,il)=dxqwol(k,il)+ddqij
19263              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
19264             enddo
19265           endif
19266         enddo
19267       enddo
19268       endif
19269       enddo
19270        do i=0,nres
19271        do j=1,3
19272          dqwol(j,i)=dqwol(j,i)/nl
19273          dxqwol(j,i)=dxqwol(j,i)/nl
19274        enddo
19275        enddo
19276       return
19277       end subroutine qwolynes_prim
19278 !-----------------------------------------------------------------------------
19279       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
19280 !      implicit real(kind=8) (a-h,o-z)
19281 !      include 'DIMENSIONS'
19282 !      include 'COMMON.IOUNITS'
19283 !      include 'COMMON.CHAIN'
19284 !      include 'COMMON.INTERACT'
19285 !      include 'COMMON.VAR'
19286       integer :: seg1,seg2,seg3,seg4
19287       logical :: flag
19288       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
19289       real(kind=8),dimension(3,0:2*nres) :: cdummy
19290       real(kind=8) :: q1,q2
19291       real(kind=8) :: delta=1.0d-10
19292       integer :: i,j
19293
19294       do i=0,nres
19295       do j=1,3
19296         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
19297         cdummy(j,i)=c(j,i)
19298         c(j,i)=c(j,i)+delta
19299         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
19300         qwolan(j,i)=(q2-q1)/delta
19301         c(j,i)=cdummy(j,i)
19302       enddo
19303       enddo
19304       do i=0,nres
19305       do j=1,3
19306         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
19307         cdummy(j,i+nres)=c(j,i+nres)
19308         c(j,i+nres)=c(j,i+nres)+delta
19309         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
19310         qwolxan(j,i)=(q2-q1)/delta
19311         c(j,i+nres)=cdummy(j,i+nres)
19312       enddo
19313       enddo
19314 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
19315 !      do i=0,nct
19316 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
19317 !      enddo
19318 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
19319 !      do i=0,nct
19320 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
19321 !      enddo
19322       return
19323       end subroutine qwol_num
19324 !-----------------------------------------------------------------------------
19325       subroutine EconstrQ
19326 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
19327 !      implicit real(kind=8) (a-h,o-z)
19328 !      include 'DIMENSIONS'
19329 !      include 'COMMON.CONTROL'
19330 !      include 'COMMON.VAR'
19331 !      include 'COMMON.MD'
19332       use MD_data
19333 !#ifndef LANG0
19334 !      include 'COMMON.LANGEVIN'
19335 !#else
19336 !      include 'COMMON.LANGEVIN.lang0'
19337 !#endif
19338 !      include 'COMMON.CHAIN'
19339 !      include 'COMMON.DERIV'
19340 !      include 'COMMON.GEO'
19341 !      include 'COMMON.LOCAL'
19342 !      include 'COMMON.INTERACT'
19343 !      include 'COMMON.IOUNITS'
19344 !      include 'COMMON.NAMES'
19345 !      include 'COMMON.TIME1'
19346       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
19347       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
19348                duconst,duxconst
19349       integer :: kstart,kend,lstart,lend,idummy
19350       real(kind=8) :: delta=1.0d-7
19351       integer :: i,j,k,ii
19352       do i=0,nres
19353        do j=1,3
19354           duconst(j,i)=0.0d0
19355           dudconst(j,i)=0.0d0
19356           duxconst(j,i)=0.0d0
19357           dudxconst(j,i)=0.0d0
19358        enddo
19359       enddo
19360       Uconst=0.0d0
19361       do i=1,nfrag
19362        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
19363          idummy,idummy)
19364        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
19365 ! Calculating the derivatives of Constraint energy with respect to Q
19366        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
19367          qinfrag(i,iset))
19368 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
19369 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
19370 !         hmnum=(hm2-hm1)/delta
19371 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
19372 !     &   qinfrag(i,iset))
19373 !         write(iout,*) "harmonicnum frag", hmnum
19374 ! Calculating the derivatives of Q with respect to cartesian coordinates
19375        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
19376         idummy,idummy)
19377 !         write(iout,*) "dqwol "
19378 !         do ii=1,nres
19379 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
19380 !         enddo
19381 !         write(iout,*) "dxqwol "
19382 !         do ii=1,nres
19383 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
19384 !         enddo
19385 ! Calculating numerical gradients of dU/dQi and dQi/dxi
19386 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
19387 !     &  ,idummy,idummy)
19388 !  The gradients of Uconst in Cs
19389        do ii=0,nres
19390           do j=1,3
19391              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
19392              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
19393           enddo
19394        enddo
19395       enddo
19396       do i=1,npair
19397        kstart=ifrag(1,ipair(1,i,iset),iset)
19398        kend=ifrag(2,ipair(1,i,iset),iset)
19399        lstart=ifrag(1,ipair(2,i,iset),iset)
19400        lend=ifrag(2,ipair(2,i,iset),iset)
19401        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
19402        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
19403 !  Calculating dU/dQ
19404        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
19405 !         hm1=harmonic(qpair(i),qinpair(i,iset))
19406 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
19407 !         hmnum=(hm2-hm1)/delta
19408 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
19409 !     &   qinpair(i,iset))
19410 !         write(iout,*) "harmonicnum pair ", hmnum
19411 ! Calculating dQ/dXi
19412        call qwolynes_prim(kstart,kend,.false.,&
19413         lstart,lend)
19414 !         write(iout,*) "dqwol "
19415 !         do ii=1,nres
19416 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
19417 !         enddo
19418 !         write(iout,*) "dxqwol "
19419 !         do ii=1,nres
19420 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
19421 !        enddo
19422 ! Calculating numerical gradients
19423 !        call qwol_num(kstart,kend,.false.
19424 !     &  ,lstart,lend)
19425 ! The gradients of Uconst in Cs
19426        do ii=0,nres
19427           do j=1,3
19428              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
19429              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
19430           enddo
19431        enddo
19432       enddo
19433 !      write(iout,*) "Uconst inside subroutine ", Uconst
19434 ! Transforming the gradients from Cs to dCs for the backbone
19435       do i=0,nres
19436        do j=i+1,nres
19437          do k=1,3
19438            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
19439          enddo
19440        enddo
19441       enddo
19442 !  Transforming the gradients from Cs to dCs for the side chains
19443       do i=1,nres
19444        do j=1,3
19445          dudxconst(j,i)=duxconst(j,i)
19446        enddo
19447       enddo
19448 !      write(iout,*) "dU/ddc backbone "
19449 !       do ii=0,nres
19450 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
19451 !      enddo
19452 !      write(iout,*) "dU/ddX side chain "
19453 !      do ii=1,nres
19454 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
19455 !      enddo
19456 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
19457 !      call dEconstrQ_num
19458       return
19459       end subroutine EconstrQ
19460 !-----------------------------------------------------------------------------
19461       subroutine dEconstrQ_num
19462 ! Calculating numerical dUconst/ddc and dUconst/ddx
19463 !      implicit real(kind=8) (a-h,o-z)
19464 !      include 'DIMENSIONS'
19465 !      include 'COMMON.CONTROL'
19466 !      include 'COMMON.VAR'
19467 !      include 'COMMON.MD'
19468       use MD_data
19469 !#ifndef LANG0
19470 !      include 'COMMON.LANGEVIN'
19471 !#else
19472 !      include 'COMMON.LANGEVIN.lang0'
19473 !#endif
19474 !      include 'COMMON.CHAIN'
19475 !      include 'COMMON.DERIV'
19476 !      include 'COMMON.GEO'
19477 !      include 'COMMON.LOCAL'
19478 !      include 'COMMON.INTERACT'
19479 !      include 'COMMON.IOUNITS'
19480 !      include 'COMMON.NAMES'
19481 !      include 'COMMON.TIME1'
19482       real(kind=8) :: uzap1,uzap2
19483       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
19484       integer :: kstart,kend,lstart,lend,idummy
19485       real(kind=8) :: delta=1.0d-7
19486 !el local variables
19487       integer :: i,ii,j
19488 !     real(kind=8) ::
19489 !     For the backbone
19490       do i=0,nres-1
19491        do j=1,3
19492           dUcartan(j,i)=0.0d0
19493           cdummy(j,i)=dc(j,i)
19494           dc(j,i)=dc(j,i)+delta
19495           call chainbuild_cart
19496         uzap2=0.0d0
19497           do ii=1,nfrag
19498            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
19499             idummy,idummy)
19500              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
19501             qinfrag(ii,iset))
19502           enddo
19503           do ii=1,npair
19504              kstart=ifrag(1,ipair(1,ii,iset),iset)
19505              kend=ifrag(2,ipair(1,ii,iset),iset)
19506              lstart=ifrag(1,ipair(2,ii,iset),iset)
19507              lend=ifrag(2,ipair(2,ii,iset),iset)
19508              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19509              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
19510              qinpair(ii,iset))
19511           enddo
19512           dc(j,i)=cdummy(j,i)
19513           call chainbuild_cart
19514           uzap1=0.0d0
19515            do ii=1,nfrag
19516            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
19517             idummy,idummy)
19518              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
19519             qinfrag(ii,iset))
19520           enddo
19521           do ii=1,npair
19522              kstart=ifrag(1,ipair(1,ii,iset),iset)
19523              kend=ifrag(2,ipair(1,ii,iset),iset)
19524              lstart=ifrag(1,ipair(2,ii,iset),iset)
19525              lend=ifrag(2,ipair(2,ii,iset),iset)
19526              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19527              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
19528             qinpair(ii,iset))
19529           enddo
19530           ducartan(j,i)=(uzap2-uzap1)/(delta)
19531        enddo
19532       enddo
19533 ! Calculating numerical gradients for dU/ddx
19534       do i=0,nres-1
19535        duxcartan(j,i)=0.0d0
19536        do j=1,3
19537           cdummy(j,i)=dc(j,i+nres)
19538           dc(j,i+nres)=dc(j,i+nres)+delta
19539           call chainbuild_cart
19540         uzap2=0.0d0
19541           do ii=1,nfrag
19542            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
19543             idummy,idummy)
19544              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
19545             qinfrag(ii,iset))
19546           enddo
19547           do ii=1,npair
19548              kstart=ifrag(1,ipair(1,ii,iset),iset)
19549              kend=ifrag(2,ipair(1,ii,iset),iset)
19550              lstart=ifrag(1,ipair(2,ii,iset),iset)
19551              lend=ifrag(2,ipair(2,ii,iset),iset)
19552              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19553              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
19554             qinpair(ii,iset))
19555           enddo
19556           dc(j,i+nres)=cdummy(j,i)
19557           call chainbuild_cart
19558           uzap1=0.0d0
19559            do ii=1,nfrag
19560              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
19561             ifrag(2,ii,iset),.true.,idummy,idummy)
19562              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
19563             qinfrag(ii,iset))
19564           enddo
19565           do ii=1,npair
19566              kstart=ifrag(1,ipair(1,ii,iset),iset)
19567              kend=ifrag(2,ipair(1,ii,iset),iset)
19568              lstart=ifrag(1,ipair(2,ii,iset),iset)
19569              lend=ifrag(2,ipair(2,ii,iset),iset)
19570              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19571              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
19572             qinpair(ii,iset))
19573           enddo
19574           duxcartan(j,i)=(uzap2-uzap1)/(delta)
19575        enddo
19576       enddo
19577       write(iout,*) "Numerical dUconst/ddc backbone "
19578       do ii=0,nres
19579       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
19580       enddo
19581 !      write(iout,*) "Numerical dUconst/ddx side-chain "
19582 !      do ii=1,nres
19583 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
19584 !      enddo
19585       return
19586       end subroutine dEconstrQ_num
19587 !-----------------------------------------------------------------------------
19588 ! ssMD.F
19589 !-----------------------------------------------------------------------------
19590       subroutine check_energies
19591
19592 !      use random, only: ran_number
19593
19594 !      implicit none
19595 !     Includes
19596 !      include 'DIMENSIONS'
19597 !      include 'COMMON.CHAIN'
19598 !      include 'COMMON.VAR'
19599 !      include 'COMMON.IOUNITS'
19600 !      include 'COMMON.SBRIDGE'
19601 !      include 'COMMON.LOCAL'
19602 !      include 'COMMON.GEO'
19603
19604 !     External functions
19605 !EL      double precision ran_number
19606 !EL      external ran_number
19607
19608 !     Local variables
19609       integer :: i,j,k,l,lmax,p,pmax,countss
19610       real(kind=8) :: rmin,rmax
19611       real(kind=8) :: eij
19612
19613       real(kind=8) :: d
19614       real(kind=8) :: wi,rij,tj,pj
19615 !      return
19616       countss=1
19617       i=5
19618       j=14
19619
19620       d=dsc(1)
19621       rmin=2.0D0
19622       rmax=12.0D0
19623
19624       lmax=10000
19625       pmax=1
19626
19627       do k=1,3
19628       c(k,i)=0.0D0
19629       c(k,j)=0.0D0
19630       c(k,nres+i)=0.0D0
19631       c(k,nres+j)=0.0D0
19632       enddo
19633
19634       do l=1,lmax
19635
19636 !t        wi=ran_number(0.0D0,pi)
19637 !        wi=ran_number(0.0D0,pi/6.0D0)
19638 !        wi=0.0D0
19639 !t        tj=ran_number(0.0D0,pi)
19640 !t        pj=ran_number(0.0D0,pi)
19641 !        pj=ran_number(0.0D0,pi/6.0D0)
19642 !        pj=0.0D0
19643
19644       do p=1,pmax
19645 !t           rij=ran_number(rmin,rmax)
19646
19647          c(1,j)=d*sin(pj)*cos(tj)
19648          c(2,j)=d*sin(pj)*sin(tj)
19649          c(3,j)=d*cos(pj)
19650
19651          c(3,nres+i)=-rij
19652
19653          c(1,i)=d*sin(wi)
19654          c(3,i)=-rij-d*cos(wi)
19655
19656          do k=1,3
19657             dc(k,nres+i)=c(k,nres+i)-c(k,i)
19658             dc_norm(k,nres+i)=dc(k,nres+i)/d
19659             dc(k,nres+j)=c(k,nres+j)-c(k,j)
19660             dc_norm(k,nres+j)=dc(k,nres+j)/d
19661          enddo
19662
19663          call dyn_ssbond_ene(i,j,eij,countss)
19664       enddo
19665       enddo
19666       call exit(1)
19667       return
19668       end subroutine check_energies
19669 !-----------------------------------------------------------------------------
19670       subroutine dyn_ssbond_ene(resi,resj,eij,countss)
19671 !      implicit none
19672 !      Includes
19673       use calc_data
19674       use comm_sschecks
19675 !      include 'DIMENSIONS'
19676 !      include 'COMMON.SBRIDGE'
19677 !      include 'COMMON.CHAIN'
19678 !      include 'COMMON.DERIV'
19679 !      include 'COMMON.LOCAL'
19680 !      include 'COMMON.INTERACT'
19681 !      include 'COMMON.VAR'
19682 !      include 'COMMON.IOUNITS'
19683 !      include 'COMMON.CALC'
19684 #ifndef CLUST
19685 #ifndef WHAM
19686        use MD_data
19687 !      include 'COMMON.MD'
19688 !      use MD, only: totT,t_bath
19689 #endif
19690 #endif
19691 !     External functions
19692 !EL      double precision h_base
19693 !EL      external h_base
19694
19695 !     Input arguments
19696       integer :: resi,resj
19697
19698 !     Output arguments
19699       real(kind=8) :: eij
19700
19701 !     Local variables
19702       logical :: havebond
19703       integer itypi,itypj,countss
19704       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
19705       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
19706       real(kind=8),dimension(3) :: dcosom1,dcosom2
19707       real(kind=8) :: ed
19708       real(kind=8) :: pom1,pom2
19709       real(kind=8) :: ljA,ljB,ljXs
19710       real(kind=8),dimension(1:3) :: d_ljB
19711       real(kind=8) :: ssA,ssB,ssC,ssXs
19712       real(kind=8) :: ssxm,ljxm,ssm,ljm
19713       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
19714       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
19715       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
19716 !-------FIRST METHOD
19717       real(kind=8) :: xm
19718       real(kind=8),dimension(1:3) :: d_xm
19719 !-------END FIRST METHOD
19720 !-------SECOND METHOD
19721 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
19722 !-------END SECOND METHOD
19723
19724 !-------TESTING CODE
19725 !el      logical :: checkstop,transgrad
19726 !el      common /sschecks/ checkstop,transgrad
19727
19728       integer :: icheck,nicheck,jcheck,njcheck
19729       real(kind=8),dimension(-1:1) :: echeck
19730       real(kind=8) :: deps,ssx0,ljx0
19731 !-------END TESTING CODE
19732
19733       eij=0.0d0
19734       i=resi
19735       j=resj
19736
19737 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
19738 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
19739
19740       itypi=itype(i,1)
19741       dxi=dc_norm(1,nres+i)
19742       dyi=dc_norm(2,nres+i)
19743       dzi=dc_norm(3,nres+i)
19744       dsci_inv=vbld_inv(i+nres)
19745
19746       itypj=itype(j,1)
19747       xj=c(1,nres+j)-c(1,nres+i)
19748       yj=c(2,nres+j)-c(2,nres+i)
19749       zj=c(3,nres+j)-c(3,nres+i)
19750       dxj=dc_norm(1,nres+j)
19751       dyj=dc_norm(2,nres+j)
19752       dzj=dc_norm(3,nres+j)
19753       dscj_inv=vbld_inv(j+nres)
19754
19755       chi1=chi(itypi,itypj)
19756       chi2=chi(itypj,itypi)
19757       chi12=chi1*chi2
19758       chip1=chip(itypi)
19759       chip2=chip(itypj)
19760       chip12=chip1*chip2
19761       alf1=alp(itypi)
19762       alf2=alp(itypj)
19763       alf12=0.5D0*(alf1+alf2)
19764
19765       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
19766       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19767 !     The following are set in sc_angular
19768 !      erij(1)=xj*rij
19769 !      erij(2)=yj*rij
19770 !      erij(3)=zj*rij
19771 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
19772 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
19773 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
19774       call sc_angular
19775       rij=1.0D0/rij  ! Reset this so it makes sense
19776
19777       sig0ij=sigma(itypi,itypj)
19778       sig=sig0ij*dsqrt(1.0D0/sigsq)
19779
19780       ljXs=sig-sig0ij
19781       ljA=eps1*eps2rt**2*eps3rt**2
19782       ljB=ljA*bb_aq(itypi,itypj)
19783       ljA=ljA*aa_aq(itypi,itypj)
19784       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
19785
19786       ssXs=d0cm
19787       deltat1=1.0d0-om1
19788       deltat2=1.0d0+om2
19789       deltat12=om2-om1+2.0d0
19790       cosphi=om12-om1*om2
19791       ssA=akcm
19792       ssB=akct*deltat12
19793       ssC=ss_depth &
19794          +akth*(deltat1*deltat1+deltat2*deltat2) &
19795          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
19796       ssxm=ssXs-0.5D0*ssB/ssA
19797
19798 !-------TESTING CODE
19799 !$$$c     Some extra output
19800 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
19801 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
19802 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
19803 !$$$      if (ssx0.gt.0.0d0) then
19804 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
19805 !$$$      else
19806 !$$$        ssx0=ssxm
19807 !$$$      endif
19808 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
19809 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
19810 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
19811 !$$$      return
19812 !-------END TESTING CODE
19813
19814 !-------TESTING CODE
19815 !     Stop and plot energy and derivative as a function of distance
19816       if (checkstop) then
19817       ssm=ssC-0.25D0*ssB*ssB/ssA
19818       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19819       if (ssm.lt.ljm .and. &
19820            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
19821         nicheck=1000
19822         njcheck=1
19823         deps=0.5d-7
19824       else
19825         checkstop=.false.
19826       endif
19827       endif
19828       if (.not.checkstop) then
19829       nicheck=0
19830       njcheck=-1
19831       endif
19832
19833       do icheck=0,nicheck
19834       do jcheck=-1,njcheck
19835       if (checkstop) rij=(ssxm-1.0d0)+ &
19836            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
19837 !-------END TESTING CODE
19838
19839       if (rij.gt.ljxm) then
19840       havebond=.false.
19841       ljd=rij-ljXs
19842       fac=(1.0D0/ljd)**expon
19843       e1=fac*fac*aa_aq(itypi,itypj)
19844       e2=fac*bb_aq(itypi,itypj)
19845       eij=eps1*eps2rt*eps3rt*(e1+e2)
19846       eps2der=eij*eps3rt
19847       eps3der=eij*eps2rt
19848       eij=eij*eps2rt*eps3rt
19849
19850       sigder=-sig/sigsq
19851       e1=e1*eps1*eps2rt**2*eps3rt**2
19852       ed=-expon*(e1+eij)/ljd
19853       sigder=ed*sigder
19854       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
19855       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
19856       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
19857            -2.0D0*alf12*eps3der+sigder*sigsq_om12
19858       else if (rij.lt.ssxm) then
19859       havebond=.true.
19860       ssd=rij-ssXs
19861       eij=ssA*ssd*ssd+ssB*ssd+ssC
19862
19863       ed=2*akcm*ssd+akct*deltat12
19864       pom1=akct*ssd
19865       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
19866       eom1=-2*akth*deltat1-pom1-om2*pom2
19867       eom2= 2*akth*deltat2+pom1-om1*pom2
19868       eom12=pom2
19869       else
19870       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
19871
19872       d_ssxm(1)=0.5D0*akct/ssA
19873       d_ssxm(2)=-d_ssxm(1)
19874       d_ssxm(3)=0.0D0
19875
19876       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
19877       d_ljxm(2)=d_ljxm(1)*sigsq_om2
19878       d_ljxm(3)=d_ljxm(1)*sigsq_om12
19879       d_ljxm(1)=d_ljxm(1)*sigsq_om1
19880
19881 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19882       xm=0.5d0*(ssxm+ljxm)
19883       do k=1,3
19884         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
19885       enddo
19886       if (rij.lt.xm) then
19887         havebond=.true.
19888         ssm=ssC-0.25D0*ssB*ssB/ssA
19889         d_ssm(1)=0.5D0*akct*ssB/ssA
19890         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19891         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19892         d_ssm(3)=omega
19893         f1=(rij-xm)/(ssxm-xm)
19894         f2=(rij-ssxm)/(xm-ssxm)
19895         h1=h_base(f1,hd1)
19896         h2=h_base(f2,hd2)
19897         eij=ssm*h1+Ht*h2
19898         delta_inv=1.0d0/(xm-ssxm)
19899         deltasq_inv=delta_inv*delta_inv
19900         fac=ssm*hd1-Ht*hd2
19901         fac1=deltasq_inv*fac*(xm-rij)
19902         fac2=deltasq_inv*fac*(rij-ssxm)
19903         ed=delta_inv*(Ht*hd2-ssm*hd1)
19904         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
19905         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
19906         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
19907       else
19908         havebond=.false.
19909         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19910         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
19911         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
19912         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
19913              alf12/eps3rt)
19914         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
19915         f1=(rij-ljxm)/(xm-ljxm)
19916         f2=(rij-xm)/(ljxm-xm)
19917         h1=h_base(f1,hd1)
19918         h2=h_base(f2,hd2)
19919         eij=Ht*h1+ljm*h2
19920         delta_inv=1.0d0/(ljxm-xm)
19921         deltasq_inv=delta_inv*delta_inv
19922         fac=Ht*hd1-ljm*hd2
19923         fac1=deltasq_inv*fac*(ljxm-rij)
19924         fac2=deltasq_inv*fac*(rij-xm)
19925         ed=delta_inv*(ljm*hd2-Ht*hd1)
19926         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
19927         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
19928         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
19929       endif
19930 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19931
19932 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19933 !$$$        ssd=rij-ssXs
19934 !$$$        ljd=rij-ljXs
19935 !$$$        fac1=rij-ljxm
19936 !$$$        fac2=rij-ssxm
19937 !$$$
19938 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
19939 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
19940 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
19941 !$$$
19942 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
19943 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
19944 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19945 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19946 !$$$        d_ssm(3)=omega
19947 !$$$
19948 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
19949 !$$$        do k=1,3
19950 !$$$          d_ljm(k)=ljm*d_ljB(k)
19951 !$$$        enddo
19952 !$$$        ljm=ljm*ljB
19953 !$$$
19954 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
19955 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
19956 !$$$        d_ss(2)=akct*ssd
19957 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
19958 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
19959 !$$$        d_ss(3)=omega
19960 !$$$
19961 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19962 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19963 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19964 !$$$        do k=1,3
19965 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19966 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19967 !$$$        enddo
19968 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19969 !$$$
19970 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19971 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19972 !$$$        h1=h_base(f1,hd1)
19973 !$$$        h2=h_base(f2,hd2)
19974 !$$$        eij=ss*h1+ljf*h2
19975 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19976 !$$$        deltasq_inv=delta_inv*delta_inv
19977 !$$$        fac=ljf*hd2-ss*hd1
19978 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19979 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19980 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19981 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19982 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19983 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19984 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19985 !$$$
19986 !$$$        havebond=.false.
19987 !$$$        if (ed.gt.0.0d0) havebond=.true.
19988 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19989
19990       endif
19991
19992       if (havebond) then
19993 !#ifndef CLUST
19994 !#ifndef WHAM
19995 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19996 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19997 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19998 !        endif
19999 !#endif
20000 !#endif
20001       dyn_ssbond_ij(countss)=eij
20002       else if (.not.havebond .and. dyn_ssbond_ij(countss).lt.1.0d300) then
20003       dyn_ssbond_ij(countss)=1.0d300
20004 !#ifndef CLUST
20005 !#ifndef WHAM
20006 !        write(iout,'(a15,f12.2,f8.1,2i5)')
20007 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
20008 !#endif
20009 !#endif
20010       endif
20011
20012 !-------TESTING CODE
20013 !el      if (checkstop) then
20014       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
20015            "CHECKSTOP",rij,eij,ed
20016       echeck(jcheck)=eij
20017 !el      endif
20018       enddo
20019       if (checkstop) then
20020       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
20021       endif
20022       enddo
20023       if (checkstop) then
20024       transgrad=.true.
20025       checkstop=.false.
20026       endif
20027 !-------END TESTING CODE
20028
20029       do k=1,3
20030       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
20031       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
20032       enddo
20033       do k=1,3
20034       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
20035       enddo
20036       do k=1,3
20037       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
20038            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
20039            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
20040       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
20041            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
20042            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
20043       enddo
20044 !grad      do k=i,j-1
20045 !grad        do l=1,3
20046 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
20047 !grad        enddo
20048 !grad      enddo
20049
20050       do l=1,3
20051       gvdwc(l,i)=gvdwc(l,i)-gg(l)
20052       gvdwc(l,j)=gvdwc(l,j)+gg(l)
20053       enddo
20054
20055       return
20056       end subroutine dyn_ssbond_ene
20057 !--------------------------------------------------------------------------
20058        subroutine triple_ssbond_ene(resi,resj,resk,eij)
20059 !      implicit none
20060 !      Includes
20061       use calc_data
20062       use comm_sschecks
20063 !      include 'DIMENSIONS'
20064 !      include 'COMMON.SBRIDGE'
20065 !      include 'COMMON.CHAIN'
20066 !      include 'COMMON.DERIV'
20067 !      include 'COMMON.LOCAL'
20068 !      include 'COMMON.INTERACT'
20069 !      include 'COMMON.VAR'
20070 !      include 'COMMON.IOUNITS'
20071 !      include 'COMMON.CALC'
20072 #ifndef CLUST
20073 #ifndef WHAM
20074        use MD_data
20075 !      include 'COMMON.MD'
20076 !      use MD, only: totT,t_bath
20077 #endif
20078 #endif
20079       double precision h_base
20080       external h_base
20081
20082 !c     Input arguments
20083       integer resi,resj,resk,m,itypi,itypj,itypk
20084
20085 !c     Output arguments
20086       double precision eij,eij1,eij2,eij3
20087
20088 !c     Local variables
20089       logical havebond
20090 !c      integer itypi,itypj,k,l
20091       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
20092       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
20093       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
20094       double precision sig0ij,ljd,sig,fac,e1,e2
20095       double precision dcosom1(3),dcosom2(3),ed
20096       double precision pom1,pom2
20097       double precision ljA,ljB,ljXs
20098       double precision d_ljB(1:3)
20099       double precision ssA,ssB,ssC,ssXs
20100       double precision ssxm,ljxm,ssm,ljm
20101       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
20102       eij=0.0
20103       if (dtriss.eq.0) return
20104       i=resi
20105       j=resj
20106       k=resk
20107 !C      write(iout,*) resi,resj,resk
20108       itypi=itype(i,1)
20109       dxi=dc_norm(1,nres+i)
20110       dyi=dc_norm(2,nres+i)
20111       dzi=dc_norm(3,nres+i)
20112       dsci_inv=vbld_inv(i+nres)
20113       xi=c(1,nres+i)
20114       yi=c(2,nres+i)
20115       zi=c(3,nres+i)
20116       call to_box(xi,yi,zi)
20117       itypj=itype(j,1)
20118       xj=c(1,nres+j)
20119       yj=c(2,nres+j)
20120       zj=c(3,nres+j)
20121       call to_box(xj,yj,zj)
20122       dxj=dc_norm(1,nres+j)
20123       dyj=dc_norm(2,nres+j)
20124       dzj=dc_norm(3,nres+j)
20125       dscj_inv=vbld_inv(j+nres)
20126       itypk=itype(k,1)
20127       xk=c(1,nres+k)
20128       yk=c(2,nres+k)
20129       zk=c(3,nres+k)
20130        call to_box(xk,yk,zk)
20131       dxk=dc_norm(1,nres+k)
20132       dyk=dc_norm(2,nres+k)
20133       dzk=dc_norm(3,nres+k)
20134       dscj_inv=vbld_inv(k+nres)
20135       xij=xj-xi
20136       xik=xk-xi
20137       xjk=xk-xj
20138       yij=yj-yi
20139       yik=yk-yi
20140       yjk=yk-yj
20141       zij=zj-zi
20142       zik=zk-zi
20143       zjk=zk-zj
20144       rrij=(xij*xij+yij*yij+zij*zij)
20145       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
20146       rrik=(xik*xik+yik*yik+zik*zik)
20147       rik=dsqrt(rrik)
20148       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
20149       rjk=dsqrt(rrjk)
20150 !C there are three combination of distances for each trisulfide bonds
20151 !C The first case the ith atom is the center
20152 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
20153 !C distance y is second distance the a,b,c,d are parameters derived for
20154 !C this problem d parameter was set as a penalty currenlty set to 1.
20155       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
20156       eij1=0.0d0
20157       else
20158       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
20159       endif
20160 !C second case jth atom is center
20161       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
20162       eij2=0.0d0
20163       else
20164       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
20165       endif
20166 !C the third case kth atom is the center
20167       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
20168       eij3=0.0d0
20169       else
20170       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
20171       endif
20172 !C      eij2=0.0
20173 !C      eij3=0.0
20174 !C      eij1=0.0
20175       eij=eij1+eij2+eij3
20176 !C      write(iout,*)i,j,k,eij
20177 !C The energy penalty calculated now time for the gradient part
20178 !C derivative over rij
20179       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
20180       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
20181           gg(1)=xij*fac/rij
20182           gg(2)=yij*fac/rij
20183           gg(3)=zij*fac/rij
20184       do m=1,3
20185       gvdwx(m,i)=gvdwx(m,i)-gg(m)
20186       gvdwx(m,j)=gvdwx(m,j)+gg(m)
20187       enddo
20188
20189       do l=1,3
20190       gvdwc(l,i)=gvdwc(l,i)-gg(l)
20191       gvdwc(l,j)=gvdwc(l,j)+gg(l)
20192       enddo
20193 !C now derivative over rik
20194       fac=-eij1**2/dtriss* &
20195       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
20196       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
20197           gg(1)=xik*fac/rik
20198           gg(2)=yik*fac/rik
20199           gg(3)=zik*fac/rik
20200       do m=1,3
20201       gvdwx(m,i)=gvdwx(m,i)-gg(m)
20202       gvdwx(m,k)=gvdwx(m,k)+gg(m)
20203       enddo
20204       do l=1,3
20205       gvdwc(l,i)=gvdwc(l,i)-gg(l)
20206       gvdwc(l,k)=gvdwc(l,k)+gg(l)
20207       enddo
20208 !C now derivative over rjk
20209       fac=-eij2**2/dtriss* &
20210       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
20211       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
20212           gg(1)=xjk*fac/rjk
20213           gg(2)=yjk*fac/rjk
20214           gg(3)=zjk*fac/rjk
20215       do m=1,3
20216       gvdwx(m,j)=gvdwx(m,j)-gg(m)
20217       gvdwx(m,k)=gvdwx(m,k)+gg(m)
20218       enddo
20219       do l=1,3
20220       gvdwc(l,j)=gvdwc(l,j)-gg(l)
20221       gvdwc(l,k)=gvdwc(l,k)+gg(l)
20222       enddo
20223       return
20224       end subroutine triple_ssbond_ene
20225
20226
20227
20228 !-----------------------------------------------------------------------------
20229       real(kind=8) function h_base(x,deriv)
20230 !     A smooth function going 0->1 in range [0,1]
20231 !     It should NOT be called outside range [0,1], it will not work there.
20232       implicit none
20233
20234 !     Input arguments
20235       real(kind=8) :: x
20236
20237 !     Output arguments
20238       real(kind=8) :: deriv
20239
20240 !     Local variables
20241       real(kind=8) :: xsq
20242
20243
20244 !     Two parabolas put together.  First derivative zero at extrema
20245 !$$$      if (x.lt.0.5D0) then
20246 !$$$        h_base=2.0D0*x*x
20247 !$$$        deriv=4.0D0*x
20248 !$$$      else
20249 !$$$        deriv=1.0D0-x
20250 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
20251 !$$$        deriv=4.0D0*deriv
20252 !$$$      endif
20253
20254 !     Third degree polynomial.  First derivative zero at extrema
20255       h_base=x*x*(3.0d0-2.0d0*x)
20256       deriv=6.0d0*x*(1.0d0-x)
20257
20258 !     Fifth degree polynomial.  First and second derivatives zero at extrema
20259 !$$$      xsq=x*x
20260 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
20261 !$$$      deriv=x-1.0d0
20262 !$$$      deriv=deriv*deriv
20263 !$$$      deriv=30.0d0*xsq*deriv
20264
20265       return
20266       end function h_base
20267 !-----------------------------------------------------------------------------
20268       subroutine dyn_set_nss
20269 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
20270 !      implicit none
20271       use MD_data, only: totT,t_bath
20272 !     Includes
20273 !      include 'DIMENSIONS'
20274 #ifdef MPI
20275       include "mpif.h"
20276 #endif
20277 !      include 'COMMON.SBRIDGE'
20278 !      include 'COMMON.CHAIN'
20279 !      include 'COMMON.IOUNITS'
20280 !      include 'COMMON.SETUP'
20281 !      include 'COMMON.MD'
20282 !     Local variables
20283       real(kind=8) :: emin
20284       integer :: i,j,imin,ierr,k
20285       integer :: diff,allnss,newnss
20286       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
20287             newihpb,newjhpb,aliass
20288       logical :: found
20289       integer,dimension(0:nfgtasks) :: i_newnss
20290       integer,dimension(0:nfgtasks) :: displ
20291       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
20292       integer :: g_newnss
20293
20294       allnss=0
20295       k=0
20296       do i=1,nres-1
20297       do j=i+1,nres
20298         if ((itype(i,1).eq.1).and.(itype(j,1).eq.1)) then
20299         k=k+1
20300         if (dyn_ssbond_ij(k).lt.1.0d300) then
20301           allnss=allnss+1
20302           allflag(allnss)=0
20303           allihpb(allnss)=i
20304           alljhpb(allnss)=j
20305           aliass(allnss)=k
20306        endif
20307        endif
20308       enddo
20309       enddo
20310
20311 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
20312
20313  1    emin=1.0d300
20314       do i=1,allnss
20315       if (allflag(i).eq.0 .and. &
20316            dyn_ssbond_ij(aliass(allnss)).lt.emin) then
20317         emin=dyn_ssbond_ij(aliass(allnss))
20318         imin=i
20319       endif
20320       enddo
20321       if (emin.lt.1.0d300) then
20322       allflag(imin)=1
20323       do i=1,allnss
20324         if (allflag(i).eq.0 .and. &
20325              (allihpb(i).eq.allihpb(imin) .or. &
20326              alljhpb(i).eq.allihpb(imin) .or. &
20327              allihpb(i).eq.alljhpb(imin) .or. &
20328              alljhpb(i).eq.alljhpb(imin))) then
20329           allflag(i)=-1
20330         endif
20331       enddo
20332       goto 1
20333       endif
20334
20335 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
20336
20337       newnss=0
20338       do i=1,allnss
20339       if (allflag(i).eq.1) then
20340         newnss=newnss+1
20341         newihpb(newnss)=allihpb(i)
20342         newjhpb(newnss)=alljhpb(i)
20343       endif
20344       enddo
20345
20346 #ifdef MPI
20347       if (nfgtasks.gt.1)then
20348
20349       call MPI_Reduce(newnss,g_newnss,1,&
20350         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
20351       call MPI_Gather(newnss,1,MPI_INTEGER,&
20352                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
20353       displ(0)=0
20354       do i=1,nfgtasks-1,1
20355         displ(i)=i_newnss(i-1)+displ(i-1)
20356       enddo
20357       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
20358                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
20359                    king,FG_COMM,IERR)
20360       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
20361                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
20362                    king,FG_COMM,IERR)
20363       if(fg_rank.eq.0) then
20364 !         print *,'g_newnss',g_newnss
20365 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
20366 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
20367        newnss=g_newnss
20368        do i=1,newnss
20369         newihpb(i)=g_newihpb(i)
20370         newjhpb(i)=g_newjhpb(i)
20371        enddo
20372       endif
20373       endif
20374 #endif
20375
20376       diff=newnss-nss
20377
20378 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
20379 !       print *,newnss,nss,maxdim
20380       do i=1,nss
20381       found=.false.
20382 !        print *,newnss
20383       do j=1,newnss
20384 !!          print *,j
20385         if (idssb(i).eq.newihpb(j) .and. &
20386              jdssb(i).eq.newjhpb(j)) found=.true.
20387       enddo
20388 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
20389 !        write(iout,*) "found",found,i,j
20390       if (.not.found.and.fg_rank.eq.0) &
20391           write(iout,'(a15,f12.2,f8.1,2i5)') &
20392            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
20393 #endif
20394       enddo
20395
20396       do i=1,newnss
20397       found=.false.
20398       do j=1,nss
20399 !          print *,i,j
20400         if (newihpb(i).eq.idssb(j) .and. &
20401              newjhpb(i).eq.jdssb(j)) found=.true.
20402       enddo
20403 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
20404 !        write(iout,*) "found",found,i,j
20405       if (.not.found.and.fg_rank.eq.0) &
20406           write(iout,'(a15,f12.2,f8.1,2i5)') &
20407            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
20408 #endif
20409       enddo
20410 !#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
20411       nss=newnss
20412       do i=1,nss
20413       idssb(i)=newihpb(i)
20414       jdssb(i)=newjhpb(i)
20415       enddo
20416 !#else
20417 !      nss=0
20418 !#endif
20419
20420       return
20421       end subroutine dyn_set_nss
20422 ! Lipid transfer energy function
20423       subroutine Eliptransfer(eliptran)
20424 !C this is done by Adasko
20425 !C      print *,"wchodze"
20426 !C structure of box:
20427 !C      water
20428 !C--bordliptop-- buffore starts
20429 !C--bufliptop--- here true lipid starts
20430 !C      lipid
20431 !C--buflipbot--- lipid ends buffore starts
20432 !C--bordlipbot--buffore ends
20433       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
20434       integer :: i
20435       eliptran=0.0
20436 !      print *, "I am in eliptran"
20437       do i=ilip_start,ilip_end
20438 !C       do i=1,1
20439       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
20440        cycle
20441
20442       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
20443       if (positi.le.0.0) positi=positi+boxzsize
20444 !C        print *,i
20445 !C first for peptide groups
20446 !c for each residue check if it is in lipid or lipid water border area
20447        if ((positi.gt.bordlipbot)  &
20448       .and.(positi.lt.bordliptop)) then
20449 !C the energy transfer exist
20450       if (positi.lt.buflipbot) then
20451 !C what fraction I am in
20452        fracinbuf=1.0d0-      &
20453            ((positi-bordlipbot)/lipbufthick)
20454 !C lipbufthick is thickenes of lipid buffore
20455        sslip=sscalelip(fracinbuf)
20456        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
20457        eliptran=eliptran+sslip*pepliptran
20458        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
20459        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
20460 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
20461
20462 !C        print *,"doing sccale for lower part"
20463 !C         print *,i,sslip,fracinbuf,ssgradlip
20464       elseif (positi.gt.bufliptop) then
20465        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
20466        sslip=sscalelip(fracinbuf)
20467        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
20468        eliptran=eliptran+sslip*pepliptran
20469        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
20470        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
20471 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
20472 !C          print *, "doing sscalefor top part"
20473 !C         print *,i,sslip,fracinbuf,ssgradlip
20474       else
20475        eliptran=eliptran+pepliptran
20476 !C         print *,"I am in true lipid"
20477       endif
20478 !C       else
20479 !C       eliptran=elpitran+0.0 ! I am in water
20480        endif
20481        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
20482        enddo
20483 ! here starts the side chain transfer
20484        do i=ilip_start,ilip_end
20485       if (itype(i,1).eq.ntyp1) cycle
20486       positi=(mod(c(3,i+nres),boxzsize))
20487       if (positi.le.0) positi=positi+boxzsize
20488 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20489 !c for each residue check if it is in lipid or lipid water border area
20490 !C       respos=mod(c(3,i+nres),boxzsize)
20491 !C       print *,positi,bordlipbot,buflipbot
20492        if ((positi.gt.bordlipbot) &
20493        .and.(positi.lt.bordliptop)) then
20494 !C the energy transfer exist
20495       if (positi.lt.buflipbot) then
20496        fracinbuf=1.0d0-   &
20497          ((positi-bordlipbot)/lipbufthick)
20498 !C lipbufthick is thickenes of lipid buffore
20499        sslip=sscalelip(fracinbuf)
20500        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
20501        eliptran=eliptran+sslip*liptranene(itype(i,1))
20502        gliptranx(3,i)=gliptranx(3,i) &
20503       +ssgradlip*liptranene(itype(i,1))
20504        gliptranc(3,i-1)= gliptranc(3,i-1) &
20505       +ssgradlip*liptranene(itype(i,1))
20506 !C         print *,"doing sccale for lower part"
20507       elseif (positi.gt.bufliptop) then
20508        fracinbuf=1.0d0-  &
20509       ((bordliptop-positi)/lipbufthick)
20510        sslip=sscalelip(fracinbuf)
20511        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
20512        eliptran=eliptran+sslip*liptranene(itype(i,1))
20513        gliptranx(3,i)=gliptranx(3,i)  &
20514        +ssgradlip*liptranene(itype(i,1))
20515        gliptranc(3,i-1)= gliptranc(3,i-1) &
20516       +ssgradlip*liptranene(itype(i,1))
20517 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20518       else
20519        eliptran=eliptran+liptranene(itype(i,1))
20520 !C         print *,"I am in true lipid"
20521       endif
20522       endif ! if in lipid or buffor
20523 !C       else
20524 !C       eliptran=elpitran+0.0 ! I am in water
20525       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
20526        enddo
20527        return
20528        end  subroutine Eliptransfer
20529 !----------------------------------NANO FUNCTIONS
20530 !C-----------------------------------------------------------------------
20531 !C-----------------------------------------------------------
20532 !C This subroutine is to mimic the histone like structure but as well can be
20533 !C utilizet to nanostructures (infinit) small modification has to be used to
20534 !C make it finite (z gradient at the ends has to be changes as well as the x,y
20535 !C gradient has to be modified at the ends
20536 !C The energy function is Kihara potential
20537 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
20538 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
20539 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
20540 !C simple Kihara potential
20541       subroutine calctube(Etube)
20542       real(kind=8),dimension(3) :: vectube
20543       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20544        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
20545        sc_aa_tube,sc_bb_tube
20546       integer :: i,j,iti
20547       Etube=0.0d0
20548       do i=itube_start,itube_end
20549       enetube(i)=0.0d0
20550       enetube(i+nres)=0.0d0
20551       enddo
20552 !C first we calculate the distance from tube center
20553 !C for UNRES
20554        do i=itube_start,itube_end
20555 !C lets ommit dummy atoms for now
20556        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20557 !C now calculate distance from center of tube and direction vectors
20558       xmin=boxxsize
20559       ymin=boxysize
20560 ! Find minimum distance in periodic box
20561       do j=-1,1
20562        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20563        vectube(1)=vectube(1)+boxxsize*j
20564        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20565        vectube(2)=vectube(2)+boxysize*j
20566        xminact=abs(vectube(1)-tubecenter(1))
20567        yminact=abs(vectube(2)-tubecenter(2))
20568          if (xmin.gt.xminact) then
20569           xmin=xminact
20570           xtemp=vectube(1)
20571          endif
20572          if (ymin.gt.yminact) then
20573            ymin=yminact
20574            ytemp=vectube(2)
20575           endif
20576        enddo
20577       vectube(1)=xtemp
20578       vectube(2)=ytemp
20579       vectube(1)=vectube(1)-tubecenter(1)
20580       vectube(2)=vectube(2)-tubecenter(2)
20581
20582 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20583 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20584
20585 !C as the tube is infinity we do not calculate the Z-vector use of Z
20586 !C as chosen axis
20587       vectube(3)=0.0d0
20588 !C now calculte the distance
20589        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20590 !C now normalize vector
20591       vectube(1)=vectube(1)/tub_r
20592       vectube(2)=vectube(2)/tub_r
20593 !C calculte rdiffrence between r and r0
20594       rdiff=tub_r-tubeR0
20595 !C and its 6 power
20596       rdiff6=rdiff**6.0d0
20597 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20598        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20599 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20600 !C       print *,rdiff,rdiff6,pep_aa_tube
20601 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20602 !C now we calculate gradient
20603        fac=(-12.0d0*pep_aa_tube/rdiff6- &
20604           6.0d0*pep_bb_tube)/rdiff6/rdiff
20605 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20606 !C     &rdiff,fac
20607 !C now direction of gg_tube vector
20608       do j=1,3
20609       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20610       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20611       enddo
20612       enddo
20613 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20614 !C        print *,gg_tube(1,0),"TU"
20615
20616
20617        do i=itube_start,itube_end
20618 !C Lets not jump over memory as we use many times iti
20619        iti=itype(i,1)
20620 !C lets ommit dummy atoms for now
20621        if ((iti.eq.ntyp1)  &
20622 !C in UNRES uncomment the line below as GLY has no side-chain...
20623 !C      .or.(iti.eq.10)
20624       ) cycle
20625       xmin=boxxsize
20626       ymin=boxysize
20627       do j=-1,1
20628        vectube(1)=mod((c(1,i+nres)),boxxsize)
20629        vectube(1)=vectube(1)+boxxsize*j
20630        vectube(2)=mod((c(2,i+nres)),boxysize)
20631        vectube(2)=vectube(2)+boxysize*j
20632
20633        xminact=abs(vectube(1)-tubecenter(1))
20634        yminact=abs(vectube(2)-tubecenter(2))
20635          if (xmin.gt.xminact) then
20636           xmin=xminact
20637           xtemp=vectube(1)
20638          endif
20639          if (ymin.gt.yminact) then
20640            ymin=yminact
20641            ytemp=vectube(2)
20642           endif
20643        enddo
20644       vectube(1)=xtemp
20645       vectube(2)=ytemp
20646 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20647 !C     &     tubecenter(2)
20648       vectube(1)=vectube(1)-tubecenter(1)
20649       vectube(2)=vectube(2)-tubecenter(2)
20650
20651 !C as the tube is infinity we do not calculate the Z-vector use of Z
20652 !C as chosen axis
20653       vectube(3)=0.0d0
20654 !C now calculte the distance
20655        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20656 !C now normalize vector
20657       vectube(1)=vectube(1)/tub_r
20658       vectube(2)=vectube(2)/tub_r
20659
20660 !C calculte rdiffrence between r and r0
20661       rdiff=tub_r-tubeR0
20662 !C and its 6 power
20663       rdiff6=rdiff**6.0d0
20664 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20665        sc_aa_tube=sc_aa_tube_par(iti)
20666        sc_bb_tube=sc_bb_tube_par(iti)
20667        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20668        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
20669            6.0d0*sc_bb_tube/rdiff6/rdiff
20670 !C now direction of gg_tube vector
20671        do j=1,3
20672         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20673         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20674        enddo
20675       enddo
20676       do i=itube_start,itube_end
20677         Etube=Etube+enetube(i)+enetube(i+nres)
20678       enddo
20679 !C        print *,"ETUBE", etube
20680       return
20681       end subroutine calctube
20682 !C TO DO 1) add to total energy
20683 !C       2) add to gradient summation
20684 !C       3) add reading parameters (AND of course oppening of PARAM file)
20685 !C       4) add reading the center of tube
20686 !C       5) add COMMONs
20687 !C       6) add to zerograd
20688 !C       7) allocate matrices
20689
20690
20691 !C-----------------------------------------------------------------------
20692 !C-----------------------------------------------------------
20693 !C This subroutine is to mimic the histone like structure but as well can be
20694 !C utilizet to nanostructures (infinit) small modification has to be used to
20695 !C make it finite (z gradient at the ends has to be changes as well as the x,y
20696 !C gradient has to be modified at the ends
20697 !C The energy function is Kihara potential
20698 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
20699 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
20700 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
20701 !C simple Kihara potential
20702       subroutine calctube2(Etube)
20703           real(kind=8),dimension(3) :: vectube
20704       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20705        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
20706        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
20707       integer:: i,j,iti
20708       Etube=0.0d0
20709       do i=itube_start,itube_end
20710       enetube(i)=0.0d0
20711       enetube(i+nres)=0.0d0
20712       enddo
20713 !C first we calculate the distance from tube center
20714 !C first sugare-phosphate group for NARES this would be peptide group
20715 !C for UNRES
20716        do i=itube_start,itube_end
20717 !C lets ommit dummy atoms for now
20718
20719        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20720 !C now calculate distance from center of tube and direction vectors
20721 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20722 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20723 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20724 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20725       xmin=boxxsize
20726       ymin=boxysize
20727       do j=-1,1
20728        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20729        vectube(1)=vectube(1)+boxxsize*j
20730        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20731        vectube(2)=vectube(2)+boxysize*j
20732
20733        xminact=abs(vectube(1)-tubecenter(1))
20734        yminact=abs(vectube(2)-tubecenter(2))
20735          if (xmin.gt.xminact) then
20736           xmin=xminact
20737           xtemp=vectube(1)
20738          endif
20739          if (ymin.gt.yminact) then
20740            ymin=yminact
20741            ytemp=vectube(2)
20742           endif
20743        enddo
20744       vectube(1)=xtemp
20745       vectube(2)=ytemp
20746       vectube(1)=vectube(1)-tubecenter(1)
20747       vectube(2)=vectube(2)-tubecenter(2)
20748
20749 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20750 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20751
20752 !C as the tube is infinity we do not calculate the Z-vector use of Z
20753 !C as chosen axis
20754       vectube(3)=0.0d0
20755 !C now calculte the distance
20756        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20757 !C now normalize vector
20758       vectube(1)=vectube(1)/tub_r
20759       vectube(2)=vectube(2)/tub_r
20760 !C calculte rdiffrence between r and r0
20761       rdiff=tub_r-tubeR0
20762 !C and its 6 power
20763       rdiff6=rdiff**6.0d0
20764 !C THIS FRAGMENT MAKES TUBE FINITE
20765       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20766       if (positi.le.0) positi=positi+boxzsize
20767 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20768 !c for each residue check if it is in lipid or lipid water border area
20769 !C       respos=mod(c(3,i+nres),boxzsize)
20770 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20771        if ((positi.gt.bordtubebot)  &
20772       .and.(positi.lt.bordtubetop)) then
20773 !C the energy transfer exist
20774       if (positi.lt.buftubebot) then
20775        fracinbuf=1.0d0-  &
20776          ((positi-bordtubebot)/tubebufthick)
20777 !C lipbufthick is thickenes of lipid buffore
20778        sstube=sscalelip(fracinbuf)
20779        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20780 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20781        enetube(i)=enetube(i)+sstube*tubetranenepep
20782 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20783 !C     &+ssgradtube*tubetranene(itype(i,1))
20784 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20785 !C     &+ssgradtube*tubetranene(itype(i,1))
20786 !C         print *,"doing sccale for lower part"
20787       elseif (positi.gt.buftubetop) then
20788        fracinbuf=1.0d0-  &
20789       ((bordtubetop-positi)/tubebufthick)
20790        sstube=sscalelip(fracinbuf)
20791        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20792        enetube(i)=enetube(i)+sstube*tubetranenepep
20793 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20794 !C     &+ssgradtube*tubetranene(itype(i,1))
20795 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20796 !C     &+ssgradtube*tubetranene(itype(i,1))
20797 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20798       else
20799        sstube=1.0d0
20800        ssgradtube=0.0d0
20801        enetube(i)=enetube(i)+sstube*tubetranenepep
20802 !C         print *,"I am in true lipid"
20803       endif
20804       else
20805 !C          sstube=0.0d0
20806 !C          ssgradtube=0.0d0
20807       cycle
20808       endif ! if in lipid or buffor
20809
20810 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20811        enetube(i)=enetube(i)+sstube* &
20812       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
20813 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20814 !C       print *,rdiff,rdiff6,pep_aa_tube
20815 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20816 !C now we calculate gradient
20817        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
20818            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
20819 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20820 !C     &rdiff,fac
20821
20822 !C now direction of gg_tube vector
20823        do j=1,3
20824       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20825       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20826       enddo
20827        gg_tube(3,i)=gg_tube(3,i)  &
20828        +ssgradtube*enetube(i)/sstube/2.0d0
20829        gg_tube(3,i-1)= gg_tube(3,i-1)  &
20830        +ssgradtube*enetube(i)/sstube/2.0d0
20831
20832       enddo
20833 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20834 !C        print *,gg_tube(1,0),"TU"
20835       do i=itube_start,itube_end
20836 !C Lets not jump over memory as we use many times iti
20837        iti=itype(i,1)
20838 !C lets ommit dummy atoms for now
20839        if ((iti.eq.ntyp1) &
20840 !!C in UNRES uncomment the line below as GLY has no side-chain...
20841          .or.(iti.eq.10) &
20842         ) cycle
20843         vectube(1)=c(1,i+nres)
20844         vectube(1)=mod(vectube(1),boxxsize)
20845         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20846         vectube(2)=c(2,i+nres)
20847         vectube(2)=mod(vectube(2),boxysize)
20848         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20849
20850       vectube(1)=vectube(1)-tubecenter(1)
20851       vectube(2)=vectube(2)-tubecenter(2)
20852 !C THIS FRAGMENT MAKES TUBE FINITE
20853       positi=(mod(c(3,i+nres),boxzsize))
20854       if (positi.le.0) positi=positi+boxzsize
20855 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20856 !c for each residue check if it is in lipid or lipid water border area
20857 !C       respos=mod(c(3,i+nres),boxzsize)
20858 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20859
20860        if ((positi.gt.bordtubebot)  &
20861       .and.(positi.lt.bordtubetop)) then
20862 !C the energy transfer exist
20863       if (positi.lt.buftubebot) then
20864        fracinbuf=1.0d0- &
20865           ((positi-bordtubebot)/tubebufthick)
20866 !C lipbufthick is thickenes of lipid buffore
20867        sstube=sscalelip(fracinbuf)
20868        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20869 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20870        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20871 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20872 !C     &+ssgradtube*tubetranene(itype(i,1))
20873 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20874 !C     &+ssgradtube*tubetranene(itype(i,1))
20875 !C         print *,"doing sccale for lower part"
20876       elseif (positi.gt.buftubetop) then
20877        fracinbuf=1.0d0- &
20878       ((bordtubetop-positi)/tubebufthick)
20879
20880        sstube=sscalelip(fracinbuf)
20881        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20882        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20883 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20884 !C     &+ssgradtube*tubetranene(itype(i,1))
20885 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20886 !C     &+ssgradtube*tubetranene(itype(i,1))
20887 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20888       else
20889        sstube=1.0d0
20890        ssgradtube=0.0d0
20891        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20892 !C         print *,"I am in true lipid"
20893       endif
20894       else
20895 !C          sstube=0.0d0
20896 !C          ssgradtube=0.0d0
20897       cycle
20898       endif ! if in lipid or buffor
20899 !CEND OF FINITE FRAGMENT
20900 !C as the tube is infinity we do not calculate the Z-vector use of Z
20901 !C as chosen axis
20902       vectube(3)=0.0d0
20903 !C now calculte the distance
20904        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20905 !C now normalize vector
20906       vectube(1)=vectube(1)/tub_r
20907       vectube(2)=vectube(2)/tub_r
20908 !C calculte rdiffrence between r and r0
20909       rdiff=tub_r-tubeR0
20910 !C and its 6 power
20911       rdiff6=rdiff**6.0d0
20912 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20913        sc_aa_tube=sc_aa_tube_par(iti)
20914        sc_bb_tube=sc_bb_tube_par(iti)
20915        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
20916                    *sstube+enetube(i+nres)
20917 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20918 !C now we calculate gradient
20919        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
20920           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
20921 !C now direction of gg_tube vector
20922        do j=1,3
20923         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20924         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20925        enddo
20926        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
20927        +ssgradtube*enetube(i+nres)/sstube
20928        gg_tube(3,i-1)= gg_tube(3,i-1) &
20929        +ssgradtube*enetube(i+nres)/sstube
20930
20931       enddo
20932       do i=itube_start,itube_end
20933         Etube=Etube+enetube(i)+enetube(i+nres)
20934       enddo
20935 !C        print *,"ETUBE", etube
20936       return
20937       end subroutine calctube2
20938 !=====================================================================================================================================
20939       subroutine calcnano(Etube)
20940        use MD_data, only:totTafm
20941       real(kind=8),dimension(3) :: vectube,cm
20942
20943       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20944        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
20945        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact,tubezcenter,xi,yi,zi!,&
20946 !       vecsim,vectrue
20947        real(kind=8) :: eps,sig,aa_tub_lip,bb_tub_lip
20948        integer:: i,j,iti,r,ilol,ityp
20949 !      totTafm=2.0
20950       Etube=0.0d0
20951       call to_box(tubecenter(1),tubecenter(2),tubecenter(3))
20952 !      print *,itube_start,itube_end,"poczatek"
20953       do i=itube_start,itube_end
20954       enetube(i)=0.0d0
20955       enetube(i+nres)=0.0d0
20956       enddo
20957 !C first we calculate the distance from tube center
20958 !C first sugare-phosphate group for NARES this would be peptide group
20959 !C for UNRES
20960        do i=itube_start,itube_end
20961 !C lets ommit dummy atoms for now
20962        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20963 !C now calculate distance from center of tube and direction vectors
20964
20965 !      do j=-1,1
20966        xi=(c(1,i)+c(1,i+1))/2.0d0
20967        yi=(c(2,i)+c(2,i+1))/2.0d0
20968        zi=((c(3,i)+c(3,i+1))/2.0d0)
20969        call to_box(xi,yi,zi)
20970 !       tubezcenter=totTafm*velNANOconst+tubecenter(3)
20971
20972       vectube(1)=boxshift(xi-tubecenter(1),boxxsize)
20973       vectube(2)=boxshift(yi-tubecenter(2),boxysize)
20974       vectube(3)=boxshift(zi-tubecenter(3),boxzsize)
20975
20976 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20977 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20978 !C as the tube is infinity we do not calculate the Z-vector use of Z
20979 !C as chosen axis
20980 !C      vectube(3)=0.0d0
20981 !C now calculte the distance
20982        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20983 !C now normalize vector
20984       vectube(1)=vectube(1)/tub_r
20985       vectube(2)=vectube(2)/tub_r
20986       vectube(3)=vectube(3)/tub_r
20987 !C calculte rdiffrence between r and r0
20988       rdiff=tub_r-tubeR0
20989 !C and its 6 power
20990       rdiff6=rdiff**6.0d0
20991 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20992        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20993 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20994 !C       print *,rdiff,rdiff6,pep_aa_tube
20995 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20996 !C now we calculate gradient
20997        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20998           6.0d0*pep_bb_tube)/rdiff6/rdiff
20999 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
21000 !C     &rdiff,fac
21001        if (acavtubpep.eq.0.0d0) then
21002 !C go to 667
21003        enecavtube(i)=0.0
21004        faccav=0.0
21005        else
21006        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
21007        enecavtube(i)=  &
21008       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
21009       /denominator
21010        enecavtube(i)=0.0
21011        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
21012       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
21013       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
21014       /denominator**2.0d0
21015 !C         faccav=0.0
21016 !C         fac=fac+faccav
21017 !C 667     continue
21018        endif
21019         if (energy_dec) write(iout,*),"ETUBE_PEP",i,rdiff,enetube(i),enecavtube(i)
21020       do j=1,3
21021       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
21022       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
21023       enddo
21024       enddo
21025
21026        do i=itube_start,itube_end
21027       enecavtube(i)=0.0d0
21028 !C Lets not jump over memory as we use many times iti
21029        iti=itype(i,1)
21030 !C lets ommit dummy atoms for now
21031        if ((iti.eq.ntyp1) &
21032 !C in UNRES uncomment the line below as GLY has no side-chain...
21033 !C      .or.(iti.eq.10)
21034        ) cycle
21035       xi=c(1,i+nres)
21036       yi=c(2,i+nres)
21037       zi=c(3,i+nres)
21038       call to_box(xi,yi,zi)
21039        tubezcenter=totTafm*velNANOconst+tubecenter(3)
21040
21041       vectube(1)=boxshift(xi-tubecenter(1),boxxsize)
21042       vectube(2)=boxshift(yi-tubecenter(2),boxysize)
21043       vectube(3)=boxshift(zi-tubecenter(3),boxzsize)
21044
21045
21046 !C now calculte the distance
21047        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
21048 !C now normalize vector
21049       vectube(1)=vectube(1)/tub_r
21050       vectube(2)=vectube(2)/tub_r
21051       vectube(3)=vectube(3)/tub_r
21052
21053 !C calculte rdiffrence between r and r0
21054       rdiff=tub_r-tubeR0
21055 !C and its 6 power
21056       rdiff6=rdiff**6.0d0
21057        sc_aa_tube=sc_aa_tube_par(iti)
21058        sc_bb_tube=sc_bb_tube_par(iti)
21059        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
21060 !C       enetube(i+nres)=0.0d0
21061 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
21062 !C now we calculate gradient
21063        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
21064           6.0d0*sc_bb_tube/rdiff6/rdiff
21065 !C       fac=0.0
21066 !C now direction of gg_tube vector
21067 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
21068        if (acavtub(iti).eq.0.0d0) then
21069 !C go to 667
21070        enecavtube(i+nres)=0.0d0
21071        faccav=0.0d0
21072        else
21073        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
21074        enecavtube(i+nres)=   &
21075       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
21076       /denominator
21077 !C         enecavtube(i)=0.0
21078        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
21079       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
21080       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
21081       /denominator**2.0d0
21082 !C         faccav=0.0
21083        fac=fac+faccav
21084 !C 667     continue
21085        endif
21086 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
21087 !C     &   enecavtube(i),faccav
21088 !C         print *,"licz=",
21089 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
21090 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
21091        do j=1,3
21092         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
21093         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
21094        enddo
21095         if (energy_dec) write(iout,*),"ETUBE",i,rdiff,enetube(i+nres),enecavtube(i+nres)
21096       enddo
21097
21098
21099
21100       do i=itube_start,itube_end
21101         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
21102        +enecavtube(i+nres)
21103       enddo
21104
21105       do i=ilipbond_start_tub,ilipbond_end_tub
21106        ityp=itype(i,4)
21107 !       print *,"ilipbond_start",ilipbond_start,i,ityp
21108        if (ityp.gt.ntyp_molec(4)) cycle
21109 !C now calculate distance from center of tube and direction vectors
21110        eps=lip_sig(ityp,18)*4.0d0
21111        sig=lip_sig(ityp,18)
21112        aa_tub_lip=eps/(sig**12)
21113        bb_tub_lip=eps/(sig**6)
21114 !      do j=-1,1
21115        xi=c(1,i)
21116        yi=c(2,i)
21117        zi=c(3,i)
21118        call to_box(xi,yi,zi)
21119 !       tubezcenter=totTafm*velNANOconst+tubecenter(3)
21120
21121       vectube(1)=boxshift(xi-tubecenter(1),boxxsize)
21122       vectube(2)=boxshift(yi-tubecenter(2),boxysize)
21123       vectube(3)=boxshift(zi-tubecenter(3),boxzsize)
21124
21125 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
21126 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
21127 !C as the tube is infinity we do not calculate the Z-vector use of Z
21128 !C as chosen axis
21129 !C      vectube(3)=0.0d0
21130 !C now calculte the distance
21131        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
21132 !C now normalize vector
21133       vectube(1)=vectube(1)/tub_r
21134       vectube(2)=vectube(2)/tub_r
21135       vectube(3)=vectube(3)/tub_r
21136 !C calculte rdiffrence between r and r0
21137       rdiff=tub_r-tubeR0
21138 !C and its 6 power
21139       rdiff6=rdiff**6.0d0
21140 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
21141        enetube(i)=aa_tub_lip/rdiff6**2.0d0+bb_tub_lip/rdiff6
21142        Etube=Etube+enetube(i)
21143 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
21144 !C       print *,rdiff,rdiff6,pep_aa_tube
21145 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
21146 !C now we calculate gradient
21147        fac=(-12.0d0*aa_tub_lip/rdiff6-   &
21148           6.0d0*bb_tub_lip)/rdiff6/rdiff
21149        do j=1,3
21150         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
21151        enddo
21152         if (energy_dec) write(iout,*) "ETUBLIP",i,rdiff,enetube(i+nres)
21153       enddo
21154
21155
21156 !-----------------------------------------------------------------------
21157       if (fg_rank.eq.0) then
21158       if (velNANOconst.ne.0) then
21159         do j=1,3
21160          cm(j)=0.0d0
21161         enddo
21162         do i=1,inanomove
21163          ilol=inanotab(i)
21164          do j=1,3
21165           cm(j)=cm(j)+c(j,ilol)
21166          enddo
21167         enddo
21168         do j=1,3
21169          cm(j)=cm(j)/inanomove
21170         enddo
21171         vecsim=velNANOconst*totTafm+distnanoinit
21172         vectrue=cm(3)-tubecenter(3)
21173         etube=etube+0.5d0*forcenanoconst*( vectrue-vecsim)**2
21174         fac=forcenanoconst*(vectrue-vecsim)/inanomove
21175         do  i=1,inanomove
21176           ilol=inanotab(i)
21177           gg_tube(3,ilol-1)=gg_tube(3,ilol-1)+fac
21178         enddo
21179         endif
21180         endif
21181 !        do i=1,20
21182 !         print *,"begin", i,"a"
21183 !         do r=1,10000
21184 !          rdiff=r/100.0d0
21185 !          rdiff6=rdiff**6.0d0
21186 !          sc_aa_tube=sc_aa_tube_par(i)
21187 !          sc_bb_tube=sc_bb_tube_par(i)
21188 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
21189 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
21190 !          enecavtube(i)=   &
21191 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
21192 !         /denominator
21193
21194 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
21195 !         enddo
21196 !         print *,"end",i,"a"
21197 !        enddo
21198 !C        print *,"ETUBE", etube
21199       return
21200       end subroutine calcnano
21201
21202 !===============================================
21203 !--------------------------------------------------------------------------------
21204 !C first for shielding is setting of function of side-chains
21205
21206        subroutine set_shield_fac2
21207        real(kind=8) :: div77_81=0.974996043d0, &
21208       div4_81=0.2222222222d0
21209        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
21210        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
21211        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
21212        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
21213 !C the vector between center of side_chain and peptide group
21214        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
21215        pept_group,costhet_grad,cosphi_grad_long, &
21216        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
21217        sh_frac_dist_grad,pep_side
21218       integer i,j,k
21219 !C      write(2,*) "ivec",ivec_start,ivec_end
21220       do i=1,nres
21221       fac_shield(i)=0.0d0
21222       ishield_list(i)=0
21223       do j=1,3
21224       grad_shield(j,i)=0.0d0
21225       enddo
21226       enddo
21227       do i=ivec_start,ivec_end
21228 !C      do i=1,nres-1
21229 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
21230 !      ishield_list(i)=0
21231       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
21232 !Cif there two consequtive dummy atoms there is no peptide group between them
21233 !C the line below has to be changed for FGPROC>1
21234       VolumeTotal=0.0
21235       do k=1,nres
21236        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
21237        dist_pep_side=0.0
21238        dist_side_calf=0.0
21239        do j=1,3
21240 !C first lets set vector conecting the ithe side-chain with kth side-chain
21241       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
21242 !C      pep_side(j)=2.0d0
21243 !C and vector conecting the side-chain with its proper calfa
21244       side_calf(j)=c(j,k+nres)-c(j,k)
21245 !C      side_calf(j)=2.0d0
21246       pept_group(j)=c(j,i)-c(j,i+1)
21247 !C lets have their lenght
21248       dist_pep_side=pep_side(j)**2+dist_pep_side
21249       dist_side_calf=dist_side_calf+side_calf(j)**2
21250       dist_pept_group=dist_pept_group+pept_group(j)**2
21251       enddo
21252        dist_pep_side=sqrt(dist_pep_side)
21253        dist_pept_group=sqrt(dist_pept_group)
21254        dist_side_calf=sqrt(dist_side_calf)
21255       do j=1,3
21256       pep_side_norm(j)=pep_side(j)/dist_pep_side
21257       side_calf_norm(j)=dist_side_calf
21258       enddo
21259 !C now sscale fraction
21260        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
21261 !       print *,buff_shield,"buff",sh_frac_dist
21262 !C now sscale
21263       if (sh_frac_dist.le.0.0) cycle
21264 !C        print *,ishield_list(i),i
21265 !C If we reach here it means that this side chain reaches the shielding sphere
21266 !C Lets add him to the list for gradient
21267       ishield_list(i)=ishield_list(i)+1
21268 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
21269 !C this list is essential otherwise problem would be O3
21270       shield_list(ishield_list(i),i)=k
21271 !C Lets have the sscale value
21272       if (sh_frac_dist.gt.1.0) then
21273        scale_fac_dist=1.0d0
21274        do j=1,3
21275        sh_frac_dist_grad(j)=0.0d0
21276        enddo
21277       else
21278        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
21279                   *(2.0d0*sh_frac_dist-3.0d0)
21280        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
21281                    /dist_pep_side/buff_shield*0.5d0
21282        do j=1,3
21283        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
21284 !C         sh_frac_dist_grad(j)=0.0d0
21285 !C         scale_fac_dist=1.0d0
21286 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
21287 !C     &                    sh_frac_dist_grad(j)
21288        enddo
21289       endif
21290 !C this is what is now we have the distance scaling now volume...
21291       short=short_r_sidechain(itype(k,1))
21292       long=long_r_sidechain(itype(k,1))
21293       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
21294       sinthet=short/dist_pep_side*costhet
21295 !      print *,"SORT",short,long,sinthet,costhet
21296 !C now costhet_grad
21297 !C       costhet=0.6d0
21298 !C       sinthet=0.8
21299        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
21300 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
21301 !C     &             -short/dist_pep_side**2/costhet)
21302 !C       costhet_fac=0.0d0
21303        do j=1,3
21304        costhet_grad(j)=costhet_fac*pep_side(j)
21305        enddo
21306 !C remember for the final gradient multiply costhet_grad(j)
21307 !C for side_chain by factor -2 !
21308 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
21309 !C pep_side0pept_group is vector multiplication
21310       pep_side0pept_group=0.0d0
21311       do j=1,3
21312       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
21313       enddo
21314       cosalfa=(pep_side0pept_group/ &
21315       (dist_pep_side*dist_side_calf))
21316       fac_alfa_sin=1.0d0-cosalfa**2
21317       fac_alfa_sin=dsqrt(fac_alfa_sin)
21318       rkprim=fac_alfa_sin*(long-short)+short
21319 !C      rkprim=short
21320
21321 !C now costhet_grad
21322        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
21323 !C       cosphi=0.6
21324        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
21325        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
21326          dist_pep_side**2)
21327 !C       sinphi=0.8
21328        do j=1,3
21329        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
21330       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
21331       *(long-short)/fac_alfa_sin*cosalfa/ &
21332       ((dist_pep_side*dist_side_calf))* &
21333       ((side_calf(j))-cosalfa* &
21334       ((pep_side(j)/dist_pep_side)*dist_side_calf))
21335 !C       cosphi_grad_long(j)=0.0d0
21336       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
21337       *(long-short)/fac_alfa_sin*cosalfa &
21338       /((dist_pep_side*dist_side_calf))* &
21339       (pep_side(j)- &
21340       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
21341 !C       cosphi_grad_loc(j)=0.0d0
21342        enddo
21343 !C      print *,sinphi,sinthet
21344       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
21345                    /VSolvSphere_div
21346 !C     &                    *wshield
21347 !C now the gradient...
21348       do j=1,3
21349       grad_shield(j,i)=grad_shield(j,i) &
21350 !C gradient po skalowaniu
21351                  +(sh_frac_dist_grad(j)*VofOverlap &
21352 !C  gradient po costhet
21353           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
21354       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
21355           sinphi/sinthet*costhet*costhet_grad(j) &
21356          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
21357       )*wshield
21358 !C grad_shield_side is Cbeta sidechain gradient
21359       grad_shield_side(j,ishield_list(i),i)=&
21360            (sh_frac_dist_grad(j)*-2.0d0&
21361            *VofOverlap&
21362           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
21363        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
21364           sinphi/sinthet*costhet*costhet_grad(j)&
21365          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
21366           )*wshield
21367 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
21368 !            sinphi/sinthet,&
21369 !           +sinthet/sinphi,"HERE"
21370        grad_shield_loc(j,ishield_list(i),i)=   &
21371           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
21372       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
21373           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
21374            ))&
21375            *wshield
21376 !         print *,grad_shield_loc(j,ishield_list(i),i)
21377       enddo
21378       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
21379       enddo
21380       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
21381
21382 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
21383       enddo
21384       return
21385       end subroutine set_shield_fac2
21386 !----------------------------------------------------------------------------
21387 ! SOUBROUTINE FOR AFM
21388        subroutine AFMvel(Eafmforce)
21389        use MD_data, only:totTafm
21390       real(kind=8),dimension(3) :: diffafm,cbeg,cend
21391       real(kind=8) :: afmdist,Eafmforce
21392        integer :: i,j
21393 !C Only for check grad COMMENT if not used for checkgrad
21394 !C      totT=3.0d0
21395 !C--------------------------------------------------------
21396 !C      print *,"wchodze"
21397       afmdist=0.0d0
21398       Eafmforce=0.0d0
21399       cbeg=0.0d0
21400       cend=0.0d0
21401       if (afmbeg.eq.-1) then
21402         do i=1,nbegafmmat
21403          do j=1,3
21404           cbeg(j)=cbeg(j)+c(j,afmbegcentr(i))/nbegafmmat
21405          enddo
21406         enddo
21407       else
21408       do j=1,3
21409         cbeg(j)=c(j,afmend)
21410       enddo
21411       endif
21412       if (afmend.eq.-1) then
21413         do i=1,nendafmmat
21414          do j=1,3
21415           cend(j)=cend(j)+c(j,afmendcentr(i))/nendafmmat
21416          enddo
21417         enddo
21418       else
21419         cend(j)=c(j,afmend)
21420       endif
21421
21422       do i=1,3
21423       diffafm(i)=cend(i)-cbeg(i)
21424       afmdist=afmdist+diffafm(i)**2
21425       enddo
21426       afmdist=dsqrt(afmdist)
21427 !      totTafm=3.0
21428       Eafmforce=0.5d0*forceAFMconst &
21429       *(distafminit+totTafm*velAFMconst-afmdist)**2
21430 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
21431       if (afmend.eq.-1) then
21432       do i=1,nendafmmat
21433          do j=1,3
21434           gradafm(j,afmendcentr(i)-1)=-forceAFMconst* &
21435           (distafminit+totTafm*velAFMconst-afmdist) &
21436           *diffafm(j)/afmdist/nendafmmat
21437          enddo
21438       enddo
21439       else
21440       do i=1,3
21441       gradafm(i,afmend-1)=-forceAFMconst* &
21442        (distafminit+totTafm*velAFMconst-afmdist) &
21443        *diffafm(i)/afmdist
21444       enddo
21445       endif
21446        if (afmbeg.eq.-1) then
21447         do i=1,nbegafmmat
21448          do j=1,3
21449            gradafm(i,afmbegcentr(i)-1)=forceAFMconst* &
21450           (distafminit+totTafm*velAFMconst-afmdist) &
21451            *diffafm(i)/afmdist
21452          enddo
21453         enddo
21454        else
21455        do i=1,3
21456       gradafm(i,afmbeg-1)=forceAFMconst* &
21457       (distafminit+totTafm*velAFMconst-afmdist) &
21458       *diffafm(i)/afmdist
21459       enddo
21460        endif
21461 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
21462       return
21463       end subroutine AFMvel
21464 !---------------------------------------------------------
21465        subroutine AFMforce(Eafmforce)
21466
21467       real(kind=8),dimension(3) :: diffafm
21468 !      real(kind=8) ::afmdist
21469       real(kind=8) :: afmdist,Eafmforce
21470       integer :: i
21471       afmdist=0.0d0
21472       Eafmforce=0.0d0
21473       do i=1,3
21474       diffafm(i)=c(i,afmend)-c(i,afmbeg)
21475       afmdist=afmdist+diffafm(i)**2
21476       enddo
21477       afmdist=dsqrt(afmdist)
21478 !      print *,afmdist,distafminit
21479       Eafmforce=-forceAFMconst*(afmdist-distafminit)
21480       do i=1,3
21481       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
21482       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
21483       enddo
21484 !C      print *,'AFM',Eafmforce
21485       return
21486       end subroutine AFMforce
21487
21488 !-----------------------------------------------------------------------------
21489 #ifdef WHAM
21490       subroutine read_ssHist
21491 !      implicit none
21492 !      Includes
21493 !      include 'DIMENSIONS'
21494 !      include "DIMENSIONS.FREE"
21495 !      include 'COMMON.FREE'
21496 !     Local variables
21497       integer :: i,j
21498       character(len=80) :: controlcard
21499
21500       do i=1,dyn_nssHist
21501       call card_concat(controlcard,.true.)
21502       read(controlcard,*) &
21503            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
21504       enddo
21505
21506       return
21507       end subroutine read_ssHist
21508 #endif
21509 !-----------------------------------------------------------------------------
21510       integer function indmat(i,j)
21511 !el
21512 ! get the position of the jth ijth fragment of the chain coordinate system
21513 ! in the fromto array.
21514       integer :: i,j
21515
21516       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
21517       return
21518       end function indmat
21519 !-----------------------------------------------------------------------------
21520       real(kind=8) function sigm(x)
21521 !el
21522        real(kind=8) :: x
21523       sigm=0.25d0*x
21524       return
21525       end function sigm
21526 !-----------------------------------------------------------------------------
21527 !-----------------------------------------------------------------------------
21528       subroutine alloc_ener_arrays
21529 !EL Allocation of arrays used by module energy
21530       use MD_data, only: mset
21531 !el local variables
21532       integer :: i,j
21533
21534       if(nres.lt.100) then
21535       maxconts=10*nres
21536       elseif(nres.lt.200) then
21537       maxconts=10*nres      ! Max. number of contacts per residue
21538       else
21539       maxconts=10*nres ! (maxconts=maxres/4)
21540       endif
21541       maxcont=100*nres      ! Max. number of SC contacts
21542       maxvar=6*nres      ! Max. number of variables
21543 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
21544       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
21545 !----------------------
21546 ! arrays in subroutine init_int_table
21547 !el#ifdef MPI
21548 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
21549 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
21550 !el#endif
21551       allocate(nint_gr(nres))
21552       allocate(nscp_gr(nres))
21553       allocate(ielstart(nres))
21554       allocate(ielend(nres))
21555 !(maxres)
21556       allocate(istart(nres,maxint_gr))
21557       allocate(iend(nres,maxint_gr))
21558 !(maxres,maxint_gr)
21559       allocate(iscpstart(nres,maxint_gr))
21560       allocate(iscpend(nres,maxint_gr))
21561 !(maxres,maxint_gr)
21562       allocate(ielstart_vdw(nres))
21563       allocate(ielend_vdw(nres))
21564 !(maxres)
21565       allocate(nint_gr_nucl(nres))
21566       allocate(nscp_gr_nucl(nres))
21567       allocate(ielstart_nucl(nres))
21568       allocate(ielend_nucl(nres))
21569 !(maxres)
21570       allocate(istart_nucl(nres,maxint_gr))
21571       allocate(iend_nucl(nres,maxint_gr))
21572 !(maxres,maxint_gr)
21573       allocate(iscpstart_nucl(nres,maxint_gr))
21574       allocate(iscpend_nucl(nres,maxint_gr))
21575 !(maxres,maxint_gr)
21576       allocate(ielstart_vdw_nucl(nres))
21577       allocate(ielend_vdw_nucl(nres))
21578
21579       allocate(lentyp(0:nfgtasks-1))
21580 !(0:maxprocs-1)
21581 !----------------------
21582 ! commom.contacts
21583 !      common /contacts/
21584       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
21585       allocate(icont(2,maxcont))
21586 !(2,maxcont)
21587 !      common /contacts1/
21588       allocate(num_cont(0:nres+4))
21589 !(maxres)
21590 #ifndef NEWCORR
21591       allocate(jcont(maxconts,nres))
21592 !(maxconts,maxres)
21593       allocate(facont(maxconts,nres))
21594 !(maxconts,maxres)
21595       allocate(gacont(3,maxconts,nres))
21596 !(3,maxconts,maxres)
21597 !      common /contacts_hb/
21598       allocate(gacontp_hb1(3,maxconts,nres))
21599       allocate(gacontp_hb2(3,maxconts,nres))
21600       allocate(gacontp_hb3(3,maxconts,nres))
21601       allocate(gacontm_hb1(3,maxconts,nres))
21602       allocate(gacontm_hb2(3,maxconts,nres))
21603       allocate(gacontm_hb3(3,maxconts,nres))
21604       allocate(gacont_hbr(3,maxconts,nres))
21605       allocate(grij_hb_cont(3,maxconts,nres))
21606         !(3,maxconts,maxres)
21607       allocate(facont_hb(maxconts,nres))
21608
21609       allocate(ees0p(maxconts,nres))
21610       allocate(ees0m(maxconts,nres))
21611       allocate(d_cont(maxconts,nres))
21612       allocate(ees0plist(maxconts,nres))
21613
21614 !(maxconts,maxres)
21615 !(maxres)
21616       allocate(jcont_hb(maxconts,nres))
21617 #endif
21618       allocate(num_cont_hb(nres))
21619 !(maxconts,maxres)
21620 !      common /rotat/
21621       allocate(Ug(2,2,nres))
21622       allocate(Ugder(2,2,nres))
21623       allocate(Ug2(2,2,nres))
21624       allocate(Ug2der(2,2,nres))
21625 !(2,2,maxres)
21626       allocate(obrot(2,nres))
21627       allocate(obrot2(2,nres))
21628       allocate(obrot_der(2,nres))
21629       allocate(obrot2_der(2,nres))
21630 !(2,maxres)
21631 !      common /precomp1/
21632       allocate(mu(2,nres))
21633       allocate(muder(2,nres))
21634       allocate(Ub2(2,nres))
21635       Ub2(1,:)=0.0d0
21636       Ub2(2,:)=0.0d0
21637       allocate(Ub2der(2,nres))
21638       allocate(Ctobr(2,nres))
21639       allocate(Ctobrder(2,nres))
21640       allocate(Dtobr2(2,nres))
21641       allocate(Dtobr2der(2,nres))
21642 !(2,maxres)
21643       allocate(EUg(2,2,nres))
21644       allocate(EUgder(2,2,nres))
21645       allocate(CUg(2,2,nres))
21646       allocate(CUgder(2,2,nres))
21647       allocate(DUg(2,2,nres))
21648       allocate(Dugder(2,2,nres))
21649       allocate(DtUg2(2,2,nres))
21650       allocate(DtUg2der(2,2,nres))
21651 !(2,2,maxres)
21652 !      common /precomp2/
21653       allocate(Ug2Db1t(2,nres))
21654       allocate(Ug2Db1tder(2,nres))
21655       allocate(CUgb2(2,nres))
21656       allocate(CUgb2der(2,nres))
21657 !(2,maxres)
21658       allocate(EUgC(2,2,nres))
21659       allocate(EUgCder(2,2,nres))
21660       allocate(EUgD(2,2,nres))
21661       allocate(EUgDder(2,2,nres))
21662       allocate(DtUg2EUg(2,2,nres))
21663       allocate(Ug2DtEUg(2,2,nres))
21664 !(2,2,maxres)
21665       allocate(Ug2DtEUgder(2,2,2,nres))
21666       allocate(DtUg2EUgder(2,2,2,nres))
21667 !(2,2,2,maxres)
21668       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
21669       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
21670       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
21671       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
21672
21673       allocate(ctilde(2,2,nres))
21674       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
21675       allocate(gtb1(2,nres))
21676       allocate(gtb2(2,nres))
21677       allocate(cc(2,2,nres))
21678       allocate(dd(2,2,nres))
21679       allocate(ee(2,2,nres))
21680       allocate(gtcc(2,2,nres))
21681       allocate(gtdd(2,2,nres))
21682       allocate(gtee(2,2,nres))
21683       allocate(gUb2(2,nres))
21684       allocate(gteUg(2,2,nres))
21685
21686 !      common /rotat_old/
21687       allocate(costab(nres))
21688       allocate(sintab(nres))
21689       allocate(costab2(nres))
21690       allocate(sintab2(nres))
21691 !(maxres)
21692 !      common /dipmat/
21693 !      allocate(a_chuj(2,2,maxconts,nres))
21694 !(2,2,maxconts,maxres)(maxconts=maxres/4)
21695 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))
21696 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
21697 !      common /contdistrib/
21698       allocate(ncont_sent(nres))
21699       allocate(ncont_recv(nres))
21700
21701       allocate(iat_sent(nres))
21702 !(maxres)
21703 #ifndef NEWCORR
21704       print *,"before iint_sent allocate"
21705       allocate(iint_sent(4,nres,nres))
21706       allocate(iint_sent_local(4,nres,nres))
21707       print *,"after iint_sent allocate"
21708 #endif
21709 !(4,maxres,maxres)
21710       allocate(iturn3_sent(4,0:nres+4))
21711       allocate(iturn4_sent(4,0:nres+4))
21712       allocate(iturn3_sent_local(4,nres))
21713       allocate(iturn4_sent_local(4,nres))
21714 !(4,maxres)
21715       allocate(itask_cont_from(0:nfgtasks-1))
21716       allocate(itask_cont_to(0:nfgtasks-1))
21717 !(0:max_fg_procs-1)
21718
21719
21720
21721 !----------------------
21722 ! commom.deriv;
21723 !      common /derivat/
21724 #ifdef NEWCORR
21725       print *,"before dcdv allocate"
21726       allocate(dcdv(6,nres+2))
21727       allocate(dxdv(6,nres+2))
21728 #else
21729       print *,"before dcdv allocate"
21730       allocate(dcdv(6,maxdim))
21731       allocate(dxdv(6,maxdim))
21732 #endif
21733 !(6,maxdim)
21734       allocate(dxds(6,nres))
21735 !(6,maxres)
21736       allocate(gradx(3,-1:nres,0:2))
21737       allocate(gradc(3,-1:nres,0:2))
21738 !(3,maxres,2)
21739       allocate(gvdwx(3,-1:nres))
21740       allocate(gvdwc(3,-1:nres))
21741       allocate(gelc(3,-1:nres))
21742       allocate(gelc_long(3,-1:nres))
21743       allocate(gvdwpp(3,-1:nres))
21744       allocate(gvdwc_scpp(3,-1:nres))
21745       allocate(gradx_scp(3,-1:nres))
21746       allocate(gvdwc_scp(3,-1:nres))
21747       allocate(ghpbx(3,-1:nres))
21748       allocate(ghpbc(3,-1:nres))
21749       allocate(gradcorr(3,-1:nres))
21750       allocate(gradcorr_long(3,-1:nres))
21751       allocate(gradcorr5_long(3,-1:nres))
21752       allocate(gradcorr6_long(3,-1:nres))
21753       allocate(gcorr6_turn_long(3,-1:nres))
21754       allocate(gradxorr(3,-1:nres))
21755       allocate(gradcorr5(3,-1:nres))
21756       allocate(gradcorr6(3,-1:nres))
21757       allocate(gliptran(3,-1:nres))
21758       allocate(gliptranc(3,-1:nres))
21759       allocate(gliptranx(3,-1:nres))
21760       allocate(gshieldx(3,-1:nres))
21761       allocate(gshieldc(3,-1:nres))
21762       allocate(gshieldc_loc(3,-1:nres))
21763       allocate(gshieldx_ec(3,-1:nres))
21764       allocate(gshieldc_ec(3,-1:nres))
21765       allocate(gshieldc_loc_ec(3,-1:nres))
21766       allocate(gshieldx_t3(3,-1:nres))
21767       allocate(gshieldc_t3(3,-1:nres))
21768       allocate(gshieldc_loc_t3(3,-1:nres))
21769       allocate(gshieldx_t4(3,-1:nres))
21770       allocate(gshieldc_t4(3,-1:nres))
21771       allocate(gshieldc_loc_t4(3,-1:nres))
21772       allocate(gshieldx_ll(3,-1:nres))
21773       allocate(gshieldc_ll(3,-1:nres))
21774       allocate(gshieldc_loc_ll(3,-1:nres))
21775       allocate(grad_shield(3,-1:nres))
21776       allocate(gg_tube_sc(3,-1:nres))
21777       allocate(gg_tube(3,-1:nres))
21778       allocate(gradafm(3,-1:nres))
21779       allocate(gradb_nucl(3,-1:nres))
21780       allocate(gradbx_nucl(3,-1:nres))
21781       allocate(gvdwpsb1(3,-1:nres))
21782       allocate(gelpp(3,-1:nres))
21783       allocate(gvdwpsb(3,-1:nres))
21784       allocate(gelsbc(3,-1:nres))
21785       allocate(gelsbx(3,-1:nres))
21786       allocate(gvdwsbx(3,-1:nres))
21787       allocate(gvdwsbc(3,-1:nres))
21788       allocate(gsbloc(3,-1:nres))
21789       allocate(gsblocx(3,-1:nres))
21790       allocate(gradcorr_nucl(3,-1:nres))
21791       allocate(gradxorr_nucl(3,-1:nres))
21792       allocate(gradcorr3_nucl(3,-1:nres))
21793       allocate(gradxorr3_nucl(3,-1:nres))
21794       allocate(gvdwpp_nucl(3,-1:nres))
21795       allocate(gradpepcat(3,-1:nres))
21796       allocate(gradpepcatx(3,-1:nres))
21797       allocate(gradcatcat(3,-1:nres))
21798       allocate(gradnuclcat(3,-1:nres))
21799       allocate(gradnuclcatx(3,-1:nres))
21800       allocate(gradlipbond(3,-1:nres))
21801       allocate(gradlipang(3,-1:nres))
21802       allocate(gradliplj(3,-1:nres))
21803       allocate(gradlipelec(3,-1:nres))
21804       allocate(gradcattranc(3,-1:nres))
21805       allocate(gradcattranx(3,-1:nres))
21806       allocate(gradcatangx(3,-1:nres))
21807       allocate(gradcatangc(3,-1:nres))
21808 !(3,maxres)
21809       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
21810       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
21811 ! grad for shielding surroing
21812       allocate(gloc(0:maxvar,0:2))
21813       allocate(gloc_x(0:maxvar,2))
21814 !(maxvar,2)
21815       allocate(gel_loc(3,-1:nres))
21816       allocate(gel_loc_long(3,-1:nres))
21817       allocate(gcorr3_turn(3,-1:nres))
21818       allocate(gcorr4_turn(3,-1:nres))
21819       allocate(gcorr6_turn(3,-1:nres))
21820       allocate(gradb(3,-1:nres))
21821       allocate(gradbx(3,-1:nres))
21822 !(3,maxres)
21823       allocate(gel_loc_loc(maxvar))
21824       allocate(gel_loc_turn3(maxvar))
21825       allocate(gel_loc_turn4(maxvar))
21826       allocate(gel_loc_turn6(maxvar))
21827       allocate(gcorr_loc(maxvar))
21828       allocate(g_corr5_loc(maxvar))
21829       allocate(g_corr6_loc(maxvar))
21830 !(maxvar)
21831       allocate(gsccorc(3,-1:nres))
21832       allocate(gsccorx(3,-1:nres))
21833 !(3,maxres)
21834       allocate(gsccor_loc(-1:nres))
21835 !(maxres)
21836       allocate(gvdwx_scbase(3,-1:nres))
21837       allocate(gvdwc_scbase(3,-1:nres))
21838       allocate(gvdwx_pepbase(3,-1:nres))
21839       allocate(gvdwc_pepbase(3,-1:nres))
21840       allocate(gvdwx_scpho(3,-1:nres))
21841       allocate(gvdwc_scpho(3,-1:nres))
21842       allocate(gvdwc_peppho(3,-1:nres))
21843
21844       allocate(dtheta(3,2,-1:nres))
21845 !(3,2,maxres)
21846       allocate(gscloc(3,-1:nres))
21847       allocate(gsclocx(3,-1:nres))
21848 !(3,maxres)
21849       allocate(dphi(3,3,-1:nres))
21850       allocate(dalpha(3,3,-1:nres))
21851       allocate(domega(3,3,-1:nres))
21852 !(3,3,maxres)
21853 !      common /deriv_scloc/
21854       allocate(dXX_C1tab(3,nres))
21855       allocate(dYY_C1tab(3,nres))
21856       allocate(dZZ_C1tab(3,nres))
21857       allocate(dXX_Ctab(3,nres))
21858       allocate(dYY_Ctab(3,nres))
21859       allocate(dZZ_Ctab(3,nres))
21860       allocate(dXX_XYZtab(3,nres))
21861       allocate(dYY_XYZtab(3,nres))
21862       allocate(dZZ_XYZtab(3,nres))
21863 !(3,maxres)
21864 !      common /mpgrad/
21865       allocate(jgrad_start(nres))
21866       allocate(jgrad_end(nres))
21867 !(maxres)
21868 !----------------------
21869
21870 !      common /indices/
21871       allocate(ibond_displ(0:nfgtasks-1))
21872       allocate(ibond_count(0:nfgtasks-1))
21873       allocate(ithet_displ(0:nfgtasks-1))
21874       allocate(ithet_count(0:nfgtasks-1))
21875       allocate(iphi_displ(0:nfgtasks-1))
21876       allocate(iphi_count(0:nfgtasks-1))
21877       allocate(iphi1_displ(0:nfgtasks-1))
21878       allocate(iphi1_count(0:nfgtasks-1))
21879       allocate(ivec_displ(0:nfgtasks-1))
21880       allocate(ivec_count(0:nfgtasks-1))
21881       allocate(iset_displ(0:nfgtasks-1))
21882       allocate(iset_count(0:nfgtasks-1))
21883       allocate(iint_count(0:nfgtasks-1))
21884       allocate(iint_displ(0:nfgtasks-1))
21885 !(0:max_fg_procs-1)
21886 !----------------------
21887 ! common.MD
21888 !      common /mdgrad/
21889       allocate(gcart(3,-1:nres))
21890       allocate(gxcart(3,-1:nres))
21891 !(3,0:MAXRES)
21892       allocate(gradcag(3,-1:nres))
21893       allocate(gradxag(3,-1:nres))
21894 !(3,MAXRES)
21895 !      common /back_constr/
21896 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
21897       allocate(dutheta(nres))
21898       allocate(dugamma(nres))
21899 !(maxres)
21900       allocate(duscdiff(3,-1:nres))
21901       allocate(duscdiffx(3,-1:nres))
21902 !(3,maxres)
21903 !el i io:read_fragments
21904 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
21905 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
21906 !      common /qmeas/
21907 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
21908 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
21909       allocate(mset(0:nprocs))  !(maxprocs/20)
21910       mset(:)=0
21911 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
21912 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
21913       allocate(dUdconst(3,0:nres))
21914       allocate(dUdxconst(3,0:nres))
21915       allocate(dqwol(3,0:nres))
21916       allocate(dxqwol(3,0:nres))
21917 !(3,0:MAXRES)
21918 !----------------------
21919 ! common.sbridge
21920 !      common /sbridge/ in io_common: read_bridge
21921 !el    allocate((:),allocatable :: iss      !(maxss)
21922 !      common /links/  in io_common: read_bridge
21923 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
21924 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
21925 !      common /dyn_ssbond/
21926 ! and side-chain vectors in theta or phi.
21927       allocate(dyn_ssbond_ij(10000))
21928 !(maxres,maxres)
21929 !      do i=1,nres
21930 !        do j=i+1,nres
21931       dyn_ssbond_ij(:)=1.0d300
21932 !        enddo
21933 !      enddo
21934
21935 !      if (nss.gt.0) then
21936       allocate(idssb(maxdim),jdssb(maxdim))
21937 !        allocate(newihpb(nss),newjhpb(nss))
21938 !(maxdim)
21939 !      endif
21940       allocate(ishield_list(-1:nres))
21941       allocate(shield_list(maxcontsshi,-1:nres))
21942       allocate(dyn_ss_mask(nres))
21943       allocate(fac_shield(-1:nres))
21944       allocate(enetube(nres*2))
21945       allocate(enecavtube(nres*2))
21946
21947 !(maxres)
21948       dyn_ss_mask(:)=.false.
21949 !----------------------
21950 ! common.sccor
21951 ! Parameters of the SCCOR term
21952 !      common/sccor/
21953 !el in io_conf: parmread
21954 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
21955 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
21956 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
21957 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
21958 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
21959 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
21960 !      allocate(vlor1sccor(maxterm_sccor,20,20))
21961 !      allocate(vlor2sccor(maxterm_sccor,20,20))
21962 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
21963 !----------------
21964       allocate(gloc_sc(3,0:2*nres,0:10))
21965 !(3,0:maxres2,10)maxres2=2*maxres
21966       allocate(dcostau(3,3,3,2*nres))
21967       allocate(dsintau(3,3,3,2*nres))
21968       allocate(dtauangle(3,3,3,2*nres))
21969       allocate(dcosomicron(3,3,3,2*nres))
21970       allocate(domicron(3,3,3,2*nres))
21971 !(3,3,3,maxres2)maxres2=2*maxres
21972 !----------------------
21973 ! common.var
21974 !      common /restr/
21975       allocate(varall(maxvar))
21976 !(maxvar)(maxvar=6*maxres)
21977       allocate(mask_theta(nres))
21978       allocate(mask_phi(nres))
21979       allocate(mask_side(nres))
21980 !(maxres)
21981 !----------------------
21982 ! common.vectors
21983 !      common /vectors/
21984       allocate(uy(3,nres))
21985       allocate(uz(3,nres))
21986 !(3,maxres)
21987       allocate(uygrad(3,3,2,nres))
21988       allocate(uzgrad(3,3,2,nres))
21989 !(3,3,2,maxres)
21990       print *,"before all 300"
21991 ! allocateion of lists JPRDLA
21992       allocate(newcontlistppi(300*nres))
21993       allocate(newcontlistscpi(350*nres))
21994       allocate(newcontlisti(300*nres))
21995       allocate(newcontlistppj(300*nres))
21996       allocate(newcontlistscpj(350*nres))
21997       allocate(newcontlistj(300*nres))
21998       allocate(newcontlistcatsctrani(300*nres))
21999       allocate(newcontlistcatsctranj(300*nres))
22000       allocate(newcontlistcatptrani(300*nres))
22001       allocate(newcontlistcatptranj(300*nres))
22002       allocate(newcontlistcatscnormi(300*nres))
22003       allocate(newcontlistcatscnormj(300*nres))
22004       allocate(newcontlistcatpnormi(300*nres))
22005       allocate(newcontlistcatpnormj(300*nres))
22006       allocate(newcontlistcatcatnormi(900*nres))
22007       allocate(newcontlistcatcatnormj(900*nres))
22008
22009       allocate(newcontlistcatscangi(300*nres))
22010       allocate(newcontlistcatscangj(300*nres))
22011       allocate(newcontlistcatscangfi(300*nres))
22012       allocate(newcontlistcatscangfj(300*nres))
22013       allocate(newcontlistcatscangfk(300*nres))
22014       allocate(newcontlistcatscangti(300*nres))
22015       allocate(newcontlistcatscangtj(300*nres))
22016       allocate(newcontlistcatscangtk(300*nres))
22017       allocate(newcontlistcatscangtl(300*nres))
22018
22019
22020       return
22021       end subroutine alloc_ener_arrays
22022 !-----------------------------------------------------------------
22023       subroutine ebond_nucl(estr_nucl)
22024 !c
22025 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
22026 !c
22027
22028       real(kind=8),dimension(3) :: u,ud
22029       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
22030       real(kind=8) :: estr_nucl,diff
22031       integer :: iti,i,j,k,nbi
22032       estr_nucl=0.0d0
22033 !C      print *,"I enter ebond"
22034       if (energy_dec) &
22035       write (iout,*) "ibondp_start,ibondp_end",&
22036        ibondp_nucl_start,ibondp_nucl_end
22037       do i=ibondp_nucl_start,ibondp_nucl_end
22038
22039         if (itype(i-1,2).eq.ntyp1_molec(2)&
22040             .and.itype(i,2).eq.ntyp1_molec(2)) cycle
22041         if (itype(i-1,2).eq.ntyp1_molec(2)&
22042             .or. itype(i,2).eq.ntyp1_molec(2)) then
22043 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
22044 !C          do j=1,3
22045 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
22046 !C            *dc(j,i-1)/vbld(i)
22047 !C          enddo
22048 !C          if (energy_dec) write(iout,*) &
22049 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
22050         diff = vbld(i)-vbldpDUM
22051         else
22052         diff = vbld(i)-vbldp0_nucl
22053         endif
22054 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
22055 !          do j=1,3
22056 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
22057 !     &      *dc(j,i-1)/vbld(i)
22058 !          enddo
22059 !          if (energy_dec) write(iout,*)
22060 !     &       "estr1",i,vbld(i),distchainmax,
22061 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
22062
22063         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
22064         vbldp0_nucl,diff,AKP_nucl*diff*diff
22065         estr_nucl=estr_nucl+diff*diff
22066 !          print *,estr_nucl
22067         do j=1,3
22068           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
22069         enddo
22070 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
22071       enddo
22072       estr_nucl=0.5d0*AKP_nucl*estr_nucl
22073 !      print *,"partial sum", estr_nucl,AKP_nucl
22074
22075       if (energy_dec) &
22076       write (iout,*) "ibondp_start,ibondp_end",&
22077        ibond_nucl_start,ibond_nucl_end
22078
22079       do i=ibond_nucl_start,ibond_nucl_end
22080 !C        print *, "I am stuck",i
22081       iti=itype(i,2)
22082       if (iti.eq.ntyp1_molec(2)) cycle
22083         nbi=nbondterm_nucl(iti)
22084 !C        print *,iti,nbi
22085         if (nbi.eq.1) then
22086           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
22087
22088           if (energy_dec) &
22089          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
22090          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
22091           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
22092 !            print *,estr_nucl
22093           do j=1,3
22094             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
22095           enddo
22096         else
22097           do j=1,nbi
22098             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
22099             ud(j)=aksc_nucl(j,iti)*diff
22100             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
22101           enddo
22102           uprod=u(1)
22103           do j=2,nbi
22104             uprod=uprod*u(j)
22105           enddo
22106           usum=0.0d0
22107           usumsqder=0.0d0
22108           do j=1,nbi
22109             uprod1=1.0d0
22110             uprod2=1.0d0
22111             do k=1,nbi
22112             if (k.ne.j) then
22113               uprod1=uprod1*u(k)
22114               uprod2=uprod2*u(k)*u(k)
22115             endif
22116             enddo
22117             usum=usum+uprod1
22118             usumsqder=usumsqder+ud(j)*uprod2
22119           enddo
22120           estr_nucl=estr_nucl+uprod/usum
22121           do j=1,3
22122            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
22123           enddo
22124       endif
22125       enddo
22126 !C      print *,"I am about to leave ebond"
22127       return
22128       end subroutine ebond_nucl
22129
22130 !-----------------------------------------------------------------------------
22131       subroutine ebend_nucl(etheta_nucl)
22132       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
22133       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
22134       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
22135       logical :: lprn=.false., lprn1=.false.
22136 !el local variables
22137       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
22138       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
22139       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
22140 ! local variables for constrains
22141       real(kind=8) :: difi,thetiii
22142        integer itheta
22143       etheta_nucl=0.0D0
22144 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
22145       do i=ithet_nucl_start,ithet_nucl_end
22146       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
22147       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
22148       (itype(i,2).eq.ntyp1_molec(2))) cycle
22149       dethetai=0.0d0
22150       dephii=0.0d0
22151       dephii1=0.0d0
22152       theti2=0.5d0*theta(i)
22153       ityp2=ithetyp_nucl(itype(i-1,2))
22154       do k=1,nntheterm_nucl
22155         coskt(k)=dcos(k*theti2)
22156         sinkt(k)=dsin(k*theti2)
22157       enddo
22158       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
22159 #ifdef OSF
22160         phii=phi(i)
22161         if (phii.ne.phii) phii=150.0
22162 #else
22163         phii=phi(i)
22164 #endif
22165         ityp1=ithetyp_nucl(itype(i-2,2))
22166         do k=1,nsingle_nucl
22167           cosph1(k)=dcos(k*phii)
22168           sinph1(k)=dsin(k*phii)
22169         enddo
22170       else
22171         phii=0.0d0
22172         ityp1=nthetyp_nucl+1
22173         do k=1,nsingle_nucl
22174           cosph1(k)=0.0d0
22175           sinph1(k)=0.0d0
22176         enddo
22177       endif
22178
22179       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
22180 #ifdef OSF
22181         phii1=phi(i+1)
22182         if (phii1.ne.phii1) phii1=150.0
22183         phii1=pinorm(phii1)
22184 #else
22185         phii1=phi(i+1)
22186 #endif
22187         ityp3=ithetyp_nucl(itype(i,2))
22188         do k=1,nsingle_nucl
22189           cosph2(k)=dcos(k*phii1)
22190           sinph2(k)=dsin(k*phii1)
22191         enddo
22192       else
22193         phii1=0.0d0
22194         ityp3=nthetyp_nucl+1
22195         do k=1,nsingle_nucl
22196           cosph2(k)=0.0d0
22197           sinph2(k)=0.0d0
22198         enddo
22199       endif
22200       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
22201       do k=1,ndouble_nucl
22202         do l=1,k-1
22203           ccl=cosph1(l)*cosph2(k-l)
22204           ssl=sinph1(l)*sinph2(k-l)
22205           scl=sinph1(l)*cosph2(k-l)
22206           csl=cosph1(l)*sinph2(k-l)
22207           cosph1ph2(l,k)=ccl-ssl
22208           cosph1ph2(k,l)=ccl+ssl
22209           sinph1ph2(l,k)=scl+csl
22210           sinph1ph2(k,l)=scl-csl
22211         enddo
22212       enddo
22213       if (lprn) then
22214       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
22215        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
22216       write (iout,*) "coskt and sinkt",nntheterm_nucl
22217       do k=1,nntheterm_nucl
22218         write (iout,*) k,coskt(k),sinkt(k)
22219       enddo
22220       endif
22221       do k=1,ntheterm_nucl
22222         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
22223         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
22224          *coskt(k)
22225         if (lprn)&
22226        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
22227         " ethetai",ethetai
22228       enddo
22229       if (lprn) then
22230       write (iout,*) "cosph and sinph"
22231       do k=1,nsingle_nucl
22232         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
22233       enddo
22234       write (iout,*) "cosph1ph2 and sinph2ph2"
22235       do k=2,ndouble_nucl
22236         do l=1,k-1
22237           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
22238             sinph1ph2(l,k),sinph1ph2(k,l)
22239         enddo
22240       enddo
22241       write(iout,*) "ethetai",ethetai
22242       endif
22243       do m=1,ntheterm2_nucl
22244         do k=1,nsingle_nucl
22245           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
22246             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
22247             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
22248             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
22249           ethetai=ethetai+sinkt(m)*aux
22250           dethetai=dethetai+0.5d0*m*aux*coskt(m)
22251           dephii=dephii+k*sinkt(m)*(&
22252              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
22253              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
22254           dephii1=dephii1+k*sinkt(m)*(&
22255              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
22256              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
22257           if (lprn) &
22258          write (iout,*) "m",m," k",k," bbthet",&
22259             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
22260             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
22261             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
22262             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
22263         enddo
22264       enddo
22265       if (lprn) &
22266       write(iout,*) "ethetai",ethetai
22267       do m=1,ntheterm3_nucl
22268         do k=2,ndouble_nucl
22269           do l=1,k-1
22270             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
22271              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
22272              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
22273              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
22274             ethetai=ethetai+sinkt(m)*aux
22275             dethetai=dethetai+0.5d0*m*coskt(m)*aux
22276             dephii=dephii+l*sinkt(m)*(&
22277             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
22278              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
22279              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
22280              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
22281             dephii1=dephii1+(k-l)*sinkt(m)*( &
22282             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
22283              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
22284              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
22285              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
22286             if (lprn) then
22287             write (iout,*) "m",m," k",k," l",l," ffthet", &
22288              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
22289              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
22290              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
22291              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
22292             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
22293              cosph1ph2(k,l)*sinkt(m),&
22294              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
22295             endif
22296           enddo
22297         enddo
22298       enddo
22299 10      continue
22300       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
22301       i,theta(i)*rad2deg,phii*rad2deg, &
22302       phii1*rad2deg,ethetai
22303       etheta_nucl=etheta_nucl+ethetai
22304 !        print *,i,"partial sum",etheta_nucl
22305       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
22306       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
22307       gloc(nphi+i-2,icg)=wang_nucl*dethetai
22308       enddo
22309       return
22310       end subroutine ebend_nucl
22311 !----------------------------------------------------
22312       subroutine etor_nucl(etors_nucl)
22313 !      implicit real(kind=8) (a-h,o-z)
22314 !      include 'DIMENSIONS'
22315 !      include 'COMMON.VAR'
22316 !      include 'COMMON.GEO'
22317 !      include 'COMMON.LOCAL'
22318 !      include 'COMMON.TORSION'
22319 !      include 'COMMON.INTERACT'
22320 !      include 'COMMON.DERIV'
22321 !      include 'COMMON.CHAIN'
22322 !      include 'COMMON.NAMES'
22323 !      include 'COMMON.IOUNITS'
22324 !      include 'COMMON.FFIELD'
22325 !      include 'COMMON.TORCNSTR'
22326 !      include 'COMMON.CONTROL'
22327       real(kind=8) :: etors_nucl,edihcnstr
22328       logical :: lprn
22329 !el local variables
22330       integer :: i,j,iblock,itori,itori1
22331       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
22332                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
22333 ! Set lprn=.true. for debugging
22334       lprn=.false.
22335 !     lprn=.true.
22336       etors_nucl=0.0D0
22337 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
22338       do i=iphi_nucl_start,iphi_nucl_end
22339       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
22340            .or. itype(i-3,2).eq.ntyp1_molec(2) &
22341            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
22342       etors_ii=0.0D0
22343       itori=itortyp_nucl(itype(i-2,2))
22344       itori1=itortyp_nucl(itype(i-1,2))
22345       phii=phi(i)
22346 !         print *,i,itori,itori1
22347       gloci=0.0D0
22348 !C Regular cosine and sine terms
22349       do j=1,nterm_nucl(itori,itori1)
22350         v1ij=v1_nucl(j,itori,itori1)
22351         v2ij=v2_nucl(j,itori,itori1)
22352         cosphi=dcos(j*phii)
22353         sinphi=dsin(j*phii)
22354         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
22355         if (energy_dec) etors_ii=etors_ii+&
22356                  v1ij*cosphi+v2ij*sinphi
22357         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
22358       enddo
22359 !C Lorentz terms
22360 !C                         v1
22361 !C  E = SUM ----------------------------------- - v1
22362 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
22363 !C
22364       cosphi=dcos(0.5d0*phii)
22365       sinphi=dsin(0.5d0*phii)
22366       do j=1,nlor_nucl(itori,itori1)
22367         vl1ij=vlor1_nucl(j,itori,itori1)
22368         vl2ij=vlor2_nucl(j,itori,itori1)
22369         vl3ij=vlor3_nucl(j,itori,itori1)
22370         pom=vl2ij*cosphi+vl3ij*sinphi
22371         pom1=1.0d0/(pom*pom+1.0d0)
22372         etors_nucl=etors_nucl+vl1ij*pom1
22373         if (energy_dec) etors_ii=etors_ii+ &
22374                  vl1ij*pom1
22375         pom=-pom*pom1*pom1
22376         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
22377       enddo
22378 !C Subtract the constant term
22379       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
22380         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
22381             'etor',i,etors_ii-v0_nucl(itori,itori1)
22382       if (lprn) &
22383        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
22384        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
22385        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
22386       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
22387 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
22388       enddo
22389       return
22390       end subroutine etor_nucl
22391 !------------------------------------------------------------
22392       subroutine epp_nucl_sub(evdw1,ees)
22393 !C
22394 !C This subroutine calculates the average interaction energy and its gradient
22395 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
22396 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
22397 !C The potential depends both on the distance of peptide-group centers and on
22398 !C the orientation of the CA-CA virtual bonds.
22399 !C
22400       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
22401       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
22402                       sslipj,ssgradlipj,faclipij2
22403       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
22404              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
22405              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
22406       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22407                 dist_temp, dist_init,sss_grad,fac,evdw1ij
22408       integer xshift,yshift,zshift
22409       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
22410       real(kind=8) :: ees,eesij
22411 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
22412       real(kind=8) scal_el /0.5d0/
22413       t_eelecij=0.0d0
22414       ees=0.0D0
22415       evdw1=0.0D0
22416       ind=0
22417 !c
22418 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
22419 !c
22420 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
22421       do i=iatel_s_nucl,iatel_e_nucl
22422       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
22423       dxi=dc(1,i)
22424       dyi=dc(2,i)
22425       dzi=dc(3,i)
22426       dx_normi=dc_norm(1,i)
22427       dy_normi=dc_norm(2,i)
22428       dz_normi=dc_norm(3,i)
22429       xmedi=c(1,i)+0.5d0*dxi
22430       ymedi=c(2,i)+0.5d0*dyi
22431       zmedi=c(3,i)+0.5d0*dzi
22432         call to_box(xmedi,ymedi,zmedi)
22433         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
22434
22435       do j=ielstart_nucl(i),ielend_nucl(i)
22436         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
22437         ind=ind+1
22438         dxj=dc(1,j)
22439         dyj=dc(2,j)
22440         dzj=dc(3,j)
22441 !          xj=c(1,j)+0.5D0*dxj-xmedi
22442 !          yj=c(2,j)+0.5D0*dyj-ymedi
22443 !          zj=c(3,j)+0.5D0*dzj-zmedi
22444         xj=c(1,j)+0.5D0*dxj
22445         yj=c(2,j)+0.5D0*dyj
22446         zj=c(3,j)+0.5D0*dzj
22447      call to_box(xj,yj,zj)
22448      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22449       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
22450       xj=boxshift(xj-xmedi,boxxsize)
22451       yj=boxshift(yj-ymedi,boxysize)
22452       zj=boxshift(zj-zmedi,boxzsize)
22453         rij=xj*xj+yj*yj+zj*zj
22454 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
22455         fac=(r0pp**2/rij)**3
22456         ev1=epspp*fac*fac
22457         ev2=epspp*fac
22458         evdw1ij=ev1-2*ev2
22459         fac=(-ev1-evdw1ij)/rij
22460 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
22461         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
22462         evdw1=evdw1+evdw1ij
22463 !C
22464 !C Calculate contributions to the Cartesian gradient.
22465 !C
22466         ggg(1)=fac*xj
22467         ggg(2)=fac*yj
22468         ggg(3)=fac*zj
22469         do k=1,3
22470           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
22471           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
22472         enddo
22473 !c phoshate-phosphate electrostatic interactions
22474         rij=dsqrt(rij)
22475         fac=1.0d0/rij
22476         eesij=dexp(-BEES*rij)*fac
22477 !          write (2,*)"fac",fac," eesijpp",eesij
22478         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
22479         ees=ees+eesij
22480 !c          fac=-eesij*fac
22481         fac=-(fac+BEES)*eesij*fac
22482         ggg(1)=fac*xj
22483         ggg(2)=fac*yj
22484         ggg(3)=fac*zj
22485 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
22486 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
22487 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
22488         do k=1,3
22489           gelpp(k,i)=gelpp(k,i)-ggg(k)
22490           gelpp(k,j)=gelpp(k,j)+ggg(k)
22491         enddo
22492       enddo ! j
22493       enddo   ! i
22494 !c      ees=332.0d0*ees
22495       ees=AEES*ees
22496       do i=nnt,nct
22497 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
22498       do k=1,3
22499         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
22500 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
22501         gelpp(k,i)=AEES*gelpp(k,i)
22502       enddo
22503 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
22504       enddo
22505 !c      write (2,*) "total EES",ees
22506       return
22507       end subroutine epp_nucl_sub
22508 !---------------------------------------------------------------------
22509       subroutine epsb(evdwpsb,eelpsb)
22510 !      use comm_locel
22511 !C
22512 !C This subroutine calculates the excluded-volume interaction energy between
22513 !C peptide-group centers and side chains and its gradient in virtual-bond and
22514 !C side-chain vectors.
22515 !C
22516       real(kind=8),dimension(3):: ggg
22517       integer :: i,iint,j,k,iteli,itypj,subchap
22518       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
22519                e1,e2,evdwij,rij,evdwpsb,eelpsb
22520       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22521                 dist_temp, dist_init
22522       integer xshift,yshift,zshift
22523
22524 !cd    print '(a)','Enter ESCP'
22525 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
22526       eelpsb=0.0d0
22527       evdwpsb=0.0d0
22528 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
22529       do i=iatscp_s_nucl,iatscp_e_nucl
22530       if (itype(i,2).eq.ntyp1_molec(2) &
22531        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
22532       xi=0.5D0*(c(1,i)+c(1,i+1))
22533       yi=0.5D0*(c(2,i)+c(2,i+1))
22534       zi=0.5D0*(c(3,i)+c(3,i+1))
22535         call to_box(xi,yi,zi)
22536
22537       do iint=1,nscp_gr_nucl(i)
22538
22539       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
22540         itypj=itype(j,2)
22541         if (itypj.eq.ntyp1_molec(2)) cycle
22542 !C Uncomment following three lines for SC-p interactions
22543 !c         xj=c(1,nres+j)-xi
22544 !c         yj=c(2,nres+j)-yi
22545 !c         zj=c(3,nres+j)-zi
22546 !C Uncomment following three lines for Ca-p interactions
22547 !          xj=c(1,j)-xi
22548 !          yj=c(2,j)-yi
22549 !          zj=c(3,j)-zi
22550         xj=c(1,j)
22551         yj=c(2,j)
22552         zj=c(3,j)
22553         call to_box(xj,yj,zj)
22554       xj=boxshift(xj-xi,boxxsize)
22555       yj=boxshift(yj-yi,boxysize)
22556       zj=boxshift(zj-zi,boxzsize)
22557
22558       dist_init=xj**2+yj**2+zj**2
22559
22560         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
22561         fac=rrij**expon2
22562         e1=fac*fac*aad_nucl(itypj)
22563         e2=fac*bad_nucl(itypj)
22564         if (iabs(j-i) .le. 2) then
22565           e1=scal14*e1
22566           e2=scal14*e2
22567         endif
22568         evdwij=e1+e2
22569         evdwpsb=evdwpsb+evdwij
22570         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
22571            'evdw2',i,j,evdwij,"tu4"
22572 !C
22573 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
22574 !C
22575         fac=-(evdwij+e1)*rrij
22576         ggg(1)=xj*fac
22577         ggg(2)=yj*fac
22578         ggg(3)=zj*fac
22579         do k=1,3
22580           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
22581           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
22582         enddo
22583       enddo
22584
22585       enddo ! iint
22586       enddo ! i
22587       do i=1,nct
22588       do j=1,3
22589         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
22590         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
22591       enddo
22592       enddo
22593       return
22594       end subroutine epsb
22595
22596 !------------------------------------------------------
22597       subroutine esb_gb(evdwsb,eelsb)
22598       use comm_locel
22599       use calc_data_nucl
22600       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
22601       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22602       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
22603       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22604                 dist_temp, dist_init,aa,bb,faclip,sig0ij
22605       integer :: ii
22606       logical lprn
22607       evdw=0.0D0
22608       eelsb=0.0d0
22609       ecorr=0.0d0
22610       evdwsb=0.0D0
22611       lprn=.false.
22612       ind=0
22613 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
22614       do i=iatsc_s_nucl,iatsc_e_nucl
22615       num_conti=0
22616       num_conti2=0
22617       itypi=itype(i,2)
22618 !        PRINT *,"I=",i,itypi
22619       if (itypi.eq.ntyp1_molec(2)) cycle
22620       itypi1=itype(i+1,2)
22621       xi=c(1,nres+i)
22622       yi=c(2,nres+i)
22623       zi=c(3,nres+i)
22624       call to_box(xi,yi,zi)
22625       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22626       dxi=dc_norm(1,nres+i)
22627       dyi=dc_norm(2,nres+i)
22628       dzi=dc_norm(3,nres+i)
22629       dsci_inv=vbld_inv(i+nres)
22630 !C
22631 !C Calculate SC interaction energy.
22632 !C
22633       do iint=1,nint_gr_nucl(i)
22634 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
22635         do j=istart_nucl(i,iint),iend_nucl(i,iint)
22636           ind=ind+1
22637 !            print *,"JESTEM"
22638           itypj=itype(j,2)
22639           if (itypj.eq.ntyp1_molec(2)) cycle
22640           dscj_inv=vbld_inv(j+nres)
22641           sig0ij=sigma_nucl(itypi,itypj)
22642           chi1=chi_nucl(itypi,itypj)
22643           chi2=chi_nucl(itypj,itypi)
22644           chi12=chi1*chi2
22645           chip1=chip_nucl(itypi,itypj)
22646           chip2=chip_nucl(itypj,itypi)
22647           chip12=chip1*chip2
22648 !            xj=c(1,nres+j)-xi
22649 !            yj=c(2,nres+j)-yi
22650 !            zj=c(3,nres+j)-zi
22651          xj=c(1,nres+j)
22652          yj=c(2,nres+j)
22653          zj=c(3,nres+j)
22654      call to_box(xj,yj,zj)
22655 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22656 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22657 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22658 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22659 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22660       xj=boxshift(xj-xi,boxxsize)
22661       yj=boxshift(yj-yi,boxysize)
22662       zj=boxshift(zj-zi,boxzsize)
22663
22664           dxj=dc_norm(1,nres+j)
22665           dyj=dc_norm(2,nres+j)
22666           dzj=dc_norm(3,nres+j)
22667           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
22668           rij=dsqrt(rrij)
22669 !C Calculate angle-dependent terms of energy and contributions to their
22670 !C derivatives.
22671           erij(1)=xj*rij
22672           erij(2)=yj*rij
22673           erij(3)=zj*rij
22674           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
22675           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
22676           om12=dxi*dxj+dyi*dyj+dzi*dzj
22677           call sc_angular_nucl
22678           sigsq=1.0D0/sigsq
22679           sig=sig0ij*dsqrt(sigsq)
22680           rij_shift=1.0D0/rij-sig+sig0ij
22681 !            print *,rij_shift,"rij_shift"
22682 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
22683 !c     &       " rij_shift",rij_shift
22684           if (rij_shift.le.0.0D0) then
22685             evdw=1.0D20
22686             return
22687           endif
22688           sigder=-sig*sigsq
22689 !c---------------------------------------------------------------
22690           rij_shift=1.0D0/rij_shift
22691           fac=rij_shift**expon
22692           e1=fac*fac*aa_nucl(itypi,itypj)
22693           e2=fac*bb_nucl(itypi,itypj)
22694           evdwij=eps1*eps2rt*(e1+e2)
22695 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
22696 !c     &       " e1",e1," e2",e2," evdwij",evdwij
22697           eps2der=evdwij
22698           evdwij=evdwij*eps2rt
22699           evdwsb=evdwsb+evdwij
22700           if (lprn) then
22701           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
22702           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
22703           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
22704            restyp(itypi,2),i,restyp(itypj,2),j, &
22705            epsi,sigm,chi1,chi2,chip1,chip2, &
22706            eps1,eps2rt**2,sig,sig0ij, &
22707            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
22708           evdwij
22709           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
22710           endif
22711
22712           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
22713                        'evdw',i,j,evdwij,"tu3"
22714
22715
22716 !C Calculate gradient components.
22717           e1=e1*eps1*eps2rt**2
22718           fac=-expon*(e1+evdwij)*rij_shift
22719           sigder=fac*sigder
22720           fac=rij*fac
22721 !c            fac=0.0d0
22722 !C Calculate the radial part of the gradient
22723           gg(1)=xj*fac
22724           gg(2)=yj*fac
22725           gg(3)=zj*fac
22726 !C Calculate angular part of the gradient.
22727           call sc_grad_nucl
22728           call eelsbij(eelij,num_conti2)
22729           if (energy_dec .and. &
22730          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
22731         write (istat,'(e14.5)') evdwij
22732           eelsb=eelsb+eelij
22733         enddo      ! j
22734       enddo        ! iint
22735       num_cont_hb(i)=num_conti2
22736       enddo          ! i
22737 !c      write (iout,*) "Number of loop steps in EGB:",ind
22738 !cccc      energy_dec=.false.
22739       return
22740       end subroutine esb_gb
22741 !-------------------------------------------------------------------------------
22742       subroutine eelsbij(eesij,num_conti2)
22743       use comm_locel
22744       use calc_data_nucl
22745       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
22746       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
22747       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22748                 dist_temp, dist_init,rlocshield,fracinbuf
22749       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
22750
22751 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
22752       real(kind=8) scal_el /0.5d0/
22753       integer :: iteli,itelj,kkk,kkll,m,isubchap
22754       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
22755       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
22756       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
22757               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
22758               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
22759               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
22760               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
22761               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
22762               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
22763               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
22764       ind=ind+1
22765       itypi=itype(i,2)
22766       itypj=itype(j,2)
22767 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
22768       ael6i=ael6_nucl(itypi,itypj)
22769       ael3i=ael3_nucl(itypi,itypj)
22770       ael63i=ael63_nucl(itypi,itypj)
22771       ael32i=ael32_nucl(itypi,itypj)
22772 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
22773 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
22774       dxj=dc(1,j+nres)
22775       dyj=dc(2,j+nres)
22776       dzj=dc(3,j+nres)
22777       dx_normi=dc_norm(1,i+nres)
22778       dy_normi=dc_norm(2,i+nres)
22779       dz_normi=dc_norm(3,i+nres)
22780       dx_normj=dc_norm(1,j+nres)
22781       dy_normj=dc_norm(2,j+nres)
22782       dz_normj=dc_norm(3,j+nres)
22783 !c      xj=c(1,j)+0.5D0*dxj-xmedi
22784 !c      yj=c(2,j)+0.5D0*dyj-ymedi
22785 !c      zj=c(3,j)+0.5D0*dzj-zmedi
22786       if (ipot_nucl.ne.2) then
22787       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
22788       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
22789       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
22790       else
22791       cosa=om12
22792       cosb=om1
22793       cosg=om2
22794       endif
22795       r3ij=rij*rrij
22796       r6ij=r3ij*r3ij
22797       fac=cosa-3.0D0*cosb*cosg
22798       facfac=fac*fac
22799       fac1=3.0d0*(cosb*cosb+cosg*cosg)
22800       fac3=ael6i*r6ij
22801       fac4=ael3i*r3ij
22802       fac5=ael63i*r6ij
22803       fac6=ael32i*r6ij
22804 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
22805 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
22806       el1=fac3*(4.0D0+facfac-fac1)
22807       el2=fac4*fac
22808       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
22809       el4=fac6*facfac
22810       eesij=el1+el2+el3+el4
22811 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
22812       ees0ij=4.0D0+facfac-fac1
22813
22814       if (energy_dec) then
22815         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
22816         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
22817          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
22818          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
22819          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
22820         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
22821       endif
22822
22823 !C
22824 !C Calculate contributions to the Cartesian gradient.
22825 !C
22826       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
22827       fac1=fac
22828 !c      erij(1)=xj*rmij
22829 !c      erij(2)=yj*rmij
22830 !c      erij(3)=zj*rmij
22831 !*
22832 !* Radial derivatives. First process both termini of the fragment (i,j)
22833 !*
22834       ggg(1)=facel*xj
22835       ggg(2)=facel*yj
22836       ggg(3)=facel*zj
22837       do k=1,3
22838       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22839       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22840       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
22841       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
22842       enddo
22843 !*
22844 !* Angular part
22845 !*
22846       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
22847       fac4=-3.0D0*fac4
22848       fac3=-6.0D0*fac3
22849       fac5= 6.0d0*fac5
22850       fac6=-6.0d0*fac6
22851       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
22852        fac6*fac1*cosg
22853       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
22854        fac6*fac1*cosb
22855       do k=1,3
22856       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
22857       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
22858       enddo
22859       do k=1,3
22860       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
22861       enddo
22862       do k=1,3
22863       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
22864            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
22865            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22866       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
22867            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22868            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22869       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22870       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22871       enddo
22872 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
22873        IF ( j.gt.i+1 .and.&
22874         num_conti.le.maxcont) THEN
22875 !C
22876 !C Calculate the contact function. The ith column of the array JCONT will
22877 !C contain the numbers of atoms that make contacts with the atom I (of numbers
22878 !C greater than I). The arrays FACONT and GACONT will contain the values of
22879 !C the contact function and its derivative.
22880       r0ij=2.20D0*sigma_nucl(itypi,itypj)
22881 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
22882       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
22883 !c        write (2,*) "fcont",fcont
22884       if (fcont.gt.0.0D0) then
22885         num_conti=num_conti+1
22886         num_conti2=num_conti2+1
22887
22888         if (num_conti.gt.maxconts) then
22889           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
22890                     ' will skip next contacts for this conf.',maxconts
22891         else
22892           jcont_hb(num_conti,i)=j
22893 !c            write (iout,*) "num_conti",num_conti,
22894 !c     &        " jcont_hb",jcont_hb(num_conti,i)
22895 !C Calculate contact energies
22896           cosa4=4.0D0*cosa
22897           wij=cosa-3.0D0*cosb*cosg
22898           cosbg1=cosb+cosg
22899           cosbg2=cosb-cosg
22900           fac3=dsqrt(-ael6i)*r3ij
22901 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
22902           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
22903           if (ees0tmp.gt.0) then
22904             ees0pij=dsqrt(ees0tmp)
22905           else
22906             ees0pij=0
22907           endif
22908           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
22909           if (ees0tmp.gt.0) then
22910             ees0mij=dsqrt(ees0tmp)
22911           else
22912             ees0mij=0
22913           endif
22914           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
22915           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
22916 !c            write (iout,*) "i",i," j",j,
22917 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
22918           ees0pij1=fac3/ees0pij
22919           ees0mij1=fac3/ees0mij
22920           fac3p=-3.0D0*fac3*rrij
22921           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
22922           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
22923           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
22924           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
22925           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
22926           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
22927           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
22928           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
22929           ecosap=ecosa1+ecosa2
22930           ecosbp=ecosb1+ecosb2
22931           ecosgp=ecosg1+ecosg2
22932           ecosam=ecosa1-ecosa2
22933           ecosbm=ecosb1-ecosb2
22934           ecosgm=ecosg1-ecosg2
22935 !C End diagnostics
22936           facont_hb(num_conti,i)=fcont
22937           fprimcont=fprimcont/rij
22938           do k=1,3
22939             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
22940             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
22941           enddo
22942           gggp(1)=gggp(1)+ees0pijp*xj
22943           gggp(2)=gggp(2)+ees0pijp*yj
22944           gggp(3)=gggp(3)+ees0pijp*zj
22945           gggm(1)=gggm(1)+ees0mijp*xj
22946           gggm(2)=gggm(2)+ees0mijp*yj
22947           gggm(3)=gggm(3)+ees0mijp*zj
22948 !C Derivatives due to the contact function
22949           gacont_hbr(1,num_conti,i)=fprimcont*xj
22950           gacont_hbr(2,num_conti,i)=fprimcont*yj
22951           gacont_hbr(3,num_conti,i)=fprimcont*zj
22952           do k=1,3
22953 !c
22954 !c Gradient of the correlation terms
22955 !c
22956             gacontp_hb1(k,num_conti,i)= &
22957            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22958           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22959             gacontp_hb2(k,num_conti,i)= &
22960            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
22961           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22962             gacontp_hb3(k,num_conti,i)=gggp(k)
22963             gacontm_hb1(k,num_conti,i)= &
22964            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22965           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22966             gacontm_hb2(k,num_conti,i)= &
22967            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22968           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22969             gacontm_hb3(k,num_conti,i)=gggm(k)
22970           enddo
22971         endif
22972       endif
22973       ENDIF
22974       return
22975       end subroutine eelsbij
22976 !------------------------------------------------------------------
22977       subroutine sc_grad_nucl
22978       use comm_locel
22979       use calc_data_nucl
22980       real(kind=8),dimension(3) :: dcosom1,dcosom2
22981       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
22982       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
22983       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
22984       do k=1,3
22985       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
22986       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
22987       enddo
22988       do k=1,3
22989       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
22990       enddo
22991       do k=1,3
22992       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
22993              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
22994              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22995       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
22996              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22997              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22998       enddo
22999 !C
23000 !C Calculate the components of the gradient in DC and X
23001 !C
23002       do l=1,3
23003       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
23004       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
23005       enddo
23006       return
23007       end subroutine sc_grad_nucl
23008 !-----------------------------------------------------------------------
23009       subroutine esb(esbloc)
23010 !C Calculate the local energy of a side chain and its derivatives in the
23011 !C corresponding virtual-bond valence angles THETA and the spherical angles
23012 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
23013 !C added by Urszula Kozlowska. 07/11/2007
23014 !C
23015       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
23016       real(kind=8),dimension(9):: x
23017      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
23018       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
23019       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
23020       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
23021        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
23022        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
23023        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
23024        integer::it,nlobit,i,j,k
23025 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
23026       delta=0.02d0*pi
23027       esbloc=0.0D0
23028       do i=loc_start_nucl,loc_end_nucl
23029       if (itype(i,2).eq.ntyp1_molec(2)) cycle
23030       costtab(i+1) =dcos(theta(i+1))
23031       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
23032       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
23033       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
23034       cosfac2=0.5d0/(1.0d0+costtab(i+1))
23035       cosfac=dsqrt(cosfac2)
23036       sinfac2=0.5d0/(1.0d0-costtab(i+1))
23037       sinfac=dsqrt(sinfac2)
23038       it=itype(i,2)
23039       if (it.eq.10) goto 1
23040
23041 !c
23042 !C  Compute the axes of tghe local cartesian coordinates system; store in
23043 !c   x_prime, y_prime and z_prime
23044 !c
23045       do j=1,3
23046         x_prime(j) = 0.00
23047         y_prime(j) = 0.00
23048         z_prime(j) = 0.00
23049       enddo
23050 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
23051 !C     &   dc_norm(3,i+nres)
23052       do j = 1,3
23053         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
23054         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
23055       enddo
23056       do j = 1,3
23057         z_prime(j) = -uz(j,i-1)
23058 !           z_prime(j)=0.0
23059       enddo
23060
23061       xx=0.0d0
23062       yy=0.0d0
23063       zz=0.0d0
23064       do j = 1,3
23065         xx = xx + x_prime(j)*dc_norm(j,i+nres)
23066         yy = yy + y_prime(j)*dc_norm(j,i+nres)
23067         zz = zz + z_prime(j)*dc_norm(j,i+nres)
23068       enddo
23069
23070       xxtab(i)=xx
23071       yytab(i)=yy
23072       zztab(i)=zz
23073        it=itype(i,2)
23074       do j = 1,9
23075         x(j) = sc_parmin_nucl(j,it)
23076       enddo
23077 #ifdef CHECK_COORD
23078 !Cc diagnostics - remove later
23079       xx1 = dcos(alph(2))
23080       yy1 = dsin(alph(2))*dcos(omeg(2))
23081       zz1 = -dsin(alph(2))*dsin(omeg(2))
23082       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
23083        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
23084        xx1,yy1,zz1
23085 !C,"  --- ", xx_w,yy_w,zz_w
23086 !c end diagnostics
23087 #endif
23088       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23089       esbloc = esbloc + sumene
23090       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
23091 !        print *,"enecomp",sumene,sumene2
23092         if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
23093 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
23094 #ifdef DEBUG
23095       write (2,*) "x",(x(k),k=1,9)
23096 !C
23097 !C This section to check the numerical derivatives of the energy of ith side
23098 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
23099 !C #define DEBUG in the code to turn it on.
23100 !C
23101       write (2,*) "sumene               =",sumene
23102       aincr=1.0d-7
23103       xxsave=xx
23104       xx=xx+aincr
23105       write (2,*) xx,yy,zz
23106       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23107       de_dxx_num=(sumenep-sumene)/aincr
23108       xx=xxsave
23109       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
23110       yysave=yy
23111       yy=yy+aincr
23112       write (2,*) xx,yy,zz
23113       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23114       de_dyy_num=(sumenep-sumene)/aincr
23115       yy=yysave
23116       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
23117       zzsave=zz
23118       zz=zz+aincr
23119       write (2,*) xx,yy,zz
23120       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23121       de_dzz_num=(sumenep-sumene)/aincr
23122       zz=zzsave
23123       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
23124       costsave=cost2tab(i+1)
23125       sintsave=sint2tab(i+1)
23126       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
23127       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
23128       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
23129       de_dt_num=(sumenep-sumene)/aincr
23130       write (2,*) " t+ sumene from enesc=",sumenep,sumene
23131       cost2tab(i+1)=costsave
23132       sint2tab(i+1)=sintsave
23133 !C End of diagnostics section.
23134 #endif
23135 !C
23136 !C Compute the gradient of esc
23137 !C
23138       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
23139       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
23140       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
23141       de_dtt=0.0d0
23142 #ifdef DEBUG
23143       write (2,*) "x",(x(k),k=1,9)
23144       write (2,*) "xx",xx," yy",yy," zz",zz
23145       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
23146         " de_zz   ",de_zz," de_tt   ",de_tt
23147       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
23148         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
23149 #endif
23150 !C
23151        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
23152        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
23153        cosfac2xx=cosfac2*xx
23154        sinfac2yy=sinfac2*yy
23155        do k = 1,3
23156        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
23157          vbld_inv(i+1)
23158        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
23159          vbld_inv(i)
23160        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
23161        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
23162 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
23163 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
23164 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
23165 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
23166        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
23167        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
23168        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
23169        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
23170        dZZ_Ci1(k)=0.0d0
23171        dZZ_Ci(k)=0.0d0
23172        do j=1,3
23173          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
23174          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
23175        enddo
23176
23177        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
23178        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
23179        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
23180 !c
23181        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
23182        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
23183        enddo
23184
23185        do k=1,3
23186        dXX_Ctab(k,i)=dXX_Ci(k)
23187        dXX_C1tab(k,i)=dXX_Ci1(k)
23188        dYY_Ctab(k,i)=dYY_Ci(k)
23189        dYY_C1tab(k,i)=dYY_Ci1(k)
23190        dZZ_Ctab(k,i)=dZZ_Ci(k)
23191        dZZ_C1tab(k,i)=dZZ_Ci1(k)
23192        dXX_XYZtab(k,i)=dXX_XYZ(k)
23193        dYY_XYZtab(k,i)=dYY_XYZ(k)
23194        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
23195        enddo
23196        do k = 1,3
23197 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
23198 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
23199 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
23200 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
23201 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
23202 !c     &    dt_dci(k)
23203 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
23204 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
23205        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
23206        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
23207        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
23208        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
23209        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
23210        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
23211 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
23212        enddo
23213 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
23214 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
23215
23216 !C to check gradient call subroutine check_grad
23217
23218     1 continue
23219       enddo
23220       return
23221       end subroutine esb
23222 !=-------------------------------------------------------
23223       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
23224 !      implicit none
23225       real(kind=8),dimension(9):: x(9)
23226        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
23227       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
23228       integer i
23229 !c      write (2,*) "enesc"
23230 !c      write (2,*) "x",(x(i),i=1,9)
23231 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
23232       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
23233       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
23234       + x(9)*yy*zz
23235       enesc_nucl=sumene
23236       return
23237       end function enesc_nucl
23238 !-----------------------------------------------------------------------------
23239       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
23240 #ifdef MPI
23241       include 'mpif.h'
23242       integer,parameter :: max_cont=2000
23243       integer,parameter:: max_dim=2*(8*3+6)
23244       integer, parameter :: msglen1=max_cont*max_dim
23245       integer,parameter :: msglen2=2*msglen1
23246       integer source,CorrelType,CorrelID,Error
23247       real(kind=8) :: buffer(max_cont,max_dim)
23248       integer status(MPI_STATUS_SIZE)
23249       integer :: ierror,nbytes
23250 #endif
23251       real(kind=8),dimension(3):: gx(3),gx1(3)
23252       real(kind=8) :: time00
23253       logical lprn,ldone
23254       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
23255       real(kind=8) ecorr,ecorr3
23256       integer :: n_corr,n_corr1,mm,msglen
23257 !C Set lprn=.true. for debugging
23258       lprn=.false.
23259       n_corr=0
23260       n_corr1=0
23261 #ifdef MPI
23262       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
23263
23264       if (nfgtasks.le.1) goto 30
23265       if (lprn) then
23266       write (iout,'(a)') 'Contact function values:'
23267       do i=nnt,nct-1
23268         write (iout,'(2i3,50(1x,i2,f5.2))')  &
23269        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
23270        j=1,num_cont_hb(i))
23271       enddo
23272       endif
23273 !C Caution! Following code assumes that electrostatic interactions concerning
23274 !C a given atom are split among at most two processors!
23275       CorrelType=477
23276       CorrelID=fg_rank+1
23277       ldone=.false.
23278       do i=1,max_cont
23279       do j=1,max_dim
23280         buffer(i,j)=0.0D0
23281       enddo
23282       enddo
23283       mm=mod(fg_rank,2)
23284 !c      write (*,*) 'MyRank',MyRank,' mm',mm
23285       if (mm) 20,20,10
23286    10 continue
23287 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
23288       if (fg_rank.gt.0) then
23289 !C Send correlation contributions to the preceding processor
23290       msglen=msglen1
23291       nn=num_cont_hb(iatel_s_nucl)
23292       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
23293 !c        write (*,*) 'The BUFFER array:'
23294 !c        do i=1,nn
23295 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
23296 !c        enddo
23297       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
23298         msglen=msglen2
23299         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
23300 !C Clear the contacts of the atom passed to the neighboring processor
23301       nn=num_cont_hb(iatel_s_nucl+1)
23302 !c        do i=1,nn
23303 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
23304 !c        enddo
23305           num_cont_hb(iatel_s_nucl)=0
23306       endif
23307 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
23308 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
23309 !cd   & ' msglen=',msglen
23310 !c        write (*,*) 'Processor ',fg_rank,MyRank,
23311 !c     & ' is sending correlation contribution to processor',fg_rank-1,
23312 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
23313       time00=MPI_Wtime()
23314       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
23315        CorrelType,FG_COMM,IERROR)
23316       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
23317 !cd      write (iout,*) 'Processor ',fg_rank,
23318 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
23319 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
23320 !c        write (*,*) 'Processor ',fg_rank,
23321 !c     & ' has sent correlation contribution to processor',fg_rank-1,
23322 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
23323 !c        msglen=msglen1
23324       endif ! (fg_rank.gt.0)
23325       if (ldone) goto 30
23326       ldone=.true.
23327    20 continue
23328 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
23329       if (fg_rank.lt.nfgtasks-1) then
23330 !C Receive correlation contributions from the next processor
23331       msglen=msglen1
23332       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
23333 !cd      write (iout,*) 'Processor',fg_rank,
23334 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
23335 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
23336 !c        write (*,*) 'Processor',fg_rank,
23337 !c     &' is receiving correlation contribution from processor',fg_rank+1,
23338 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
23339       time00=MPI_Wtime()
23340       nbytes=-1
23341       do while (nbytes.le.0)
23342         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
23343         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
23344       enddo
23345 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
23346       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
23347        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
23348       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
23349 !c        write (*,*) 'Processor',fg_rank,
23350 !c     &' has received correlation contribution from processor',fg_rank+1,
23351 !c     & ' msglen=',msglen,' nbytes=',nbytes
23352 !c        write (*,*) 'The received BUFFER array:'
23353 !c        do i=1,max_cont
23354 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
23355 !c        enddo
23356       if (msglen.eq.msglen1) then
23357         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
23358       else if (msglen.eq.msglen2)  then
23359         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
23360         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
23361       else
23362         write (iout,*) &
23363       'ERROR!!!! message length changed while processing correlations.'
23364         write (*,*) &
23365       'ERROR!!!! message length changed while processing correlations.'
23366         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
23367       endif ! msglen.eq.msglen1
23368       endif ! fg_rank.lt.nfgtasks-1
23369       if (ldone) goto 30
23370       ldone=.true.
23371       goto 10
23372    30 continue
23373 #endif
23374       if (lprn) then
23375       write (iout,'(a)') 'Contact function values:'
23376       do i=nnt_molec(2),nct_molec(2)-1
23377         write (iout,'(2i3,50(1x,i2,f5.2))') &
23378        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
23379        j=1,num_cont_hb(i))
23380       enddo
23381       endif
23382       ecorr=0.0D0
23383       ecorr3=0.0d0
23384 !C Remove the loop below after debugging !!!
23385 !      do i=nnt_molec(2),nct_molec(2)
23386 !        do j=1,3
23387 !          gradcorr_nucl(j,i)=0.0D0
23388 !          gradxorr_nucl(j,i)=0.0D0
23389 !          gradcorr3_nucl(j,i)=0.0D0
23390 !          gradxorr3_nucl(j,i)=0.0D0
23391 !        enddo
23392 !      enddo
23393 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
23394 !C Calculate the local-electrostatic correlation terms
23395       do i=iatsc_s_nucl,iatsc_e_nucl
23396       i1=i+1
23397       num_conti=num_cont_hb(i)
23398       num_conti1=num_cont_hb(i+1)
23399 !        print *,i,num_conti,num_conti1
23400       do jj=1,num_conti
23401         j=jcont_hb(jj,i)
23402         do kk=1,num_conti1
23403           j1=jcont_hb(kk,i1)
23404 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
23405 !c     &         ' jj=',jj,' kk=',kk
23406           if (j1.eq.j+1 .or. j1.eq.j-1) then
23407 !C
23408 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
23409 !C The system gains extra energy.
23410 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
23411 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
23412 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
23413 !C
23414             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
23415             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
23416              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
23417             n_corr=n_corr+1
23418           else if (j1.eq.j) then
23419 !C
23420 !C Contacts I-J and I-(J+1) occur simultaneously.
23421 !C The system loses extra energy.
23422 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
23423 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
23424 !C Need to implement full formulas 32 from Liwo et al., 1998.
23425 !C
23426 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
23427 !c     &         ' jj=',jj,' kk=',kk
23428             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
23429           endif
23430         enddo ! kk
23431         do kk=1,num_conti
23432           j1=jcont_hb(kk,i)
23433 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
23434 !c     &         ' jj=',jj,' kk=',kk
23435           if (j1.eq.j+1) then
23436 !C Contacts I-J and (I+1)-J occur simultaneously.
23437 !C The system loses extra energy.
23438             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
23439           endif ! j1==j+1
23440         enddo ! kk
23441       enddo ! jj
23442       enddo ! i
23443       return
23444       end subroutine multibody_hb_nucl
23445 !-----------------------------------------------------------
23446       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
23447 !      implicit real(kind=8) (a-h,o-z)
23448 !      include 'DIMENSIONS'
23449 !      include 'COMMON.IOUNITS'
23450 !      include 'COMMON.DERIV'
23451 !      include 'COMMON.INTERACT'
23452 !      include 'COMMON.CONTACTS'
23453       real(kind=8),dimension(3) :: gx,gx1
23454       logical :: lprn
23455 !el local variables
23456       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
23457       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
23458                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
23459                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
23460                rlocshield
23461
23462       lprn=.false.
23463       eij=facont_hb(jj,i)
23464       ekl=facont_hb(kk,k)
23465       ees0pij=ees0p(jj,i)
23466       ees0pkl=ees0p(kk,k)
23467       ees0mij=ees0m(jj,i)
23468       ees0mkl=ees0m(kk,k)
23469       ekont=eij*ekl
23470       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
23471 !      print *,"ehbcorr_nucl",ekont,ees
23472 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
23473 !C Following 4 lines for diagnostics.
23474 !cd    ees0pkl=0.0D0
23475 !cd    ees0pij=1.0D0
23476 !cd    ees0mkl=0.0D0
23477 !cd    ees0mij=1.0D0
23478 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
23479 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
23480 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
23481 !C Calculate the multi-body contribution to energy.
23482 !      ecorr_nucl=ecorr_nucl+ekont*ees
23483 !C Calculate multi-body contributions to the gradient.
23484       coeffpees0pij=coeffp*ees0pij
23485       coeffmees0mij=coeffm*ees0mij
23486       coeffpees0pkl=coeffp*ees0pkl
23487       coeffmees0mkl=coeffm*ees0mkl
23488       do ll=1,3
23489       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
23490        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
23491        coeffmees0mkl*gacontm_hb1(ll,jj,i))
23492       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
23493       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
23494       coeffmees0mkl*gacontm_hb2(ll,jj,i))
23495       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
23496       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
23497       coeffmees0mij*gacontm_hb1(ll,kk,k))
23498       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
23499       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
23500       coeffmees0mij*gacontm_hb2(ll,kk,k))
23501       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
23502         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
23503         coeffmees0mkl*gacontm_hb3(ll,jj,i))
23504       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
23505       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
23506       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
23507         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
23508         coeffmees0mij*gacontm_hb3(ll,kk,k))
23509       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
23510       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
23511       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
23512       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
23513       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
23514       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
23515       enddo
23516       ehbcorr_nucl=ekont*ees
23517       return
23518       end function ehbcorr_nucl
23519 !-------------------------------------------------------------------------
23520
23521      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
23522 !      implicit real(kind=8) (a-h,o-z)
23523 !      include 'DIMENSIONS'
23524 !      include 'COMMON.IOUNITS'
23525 !      include 'COMMON.DERIV'
23526 !      include 'COMMON.INTERACT'
23527 !      include 'COMMON.CONTACTS'
23528       real(kind=8),dimension(3) :: gx,gx1
23529       logical :: lprn
23530 !el local variables
23531       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
23532       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
23533                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
23534                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
23535                rlocshield
23536
23537       lprn=.false.
23538       eij=facont_hb(jj,i)
23539       ekl=facont_hb(kk,k)
23540       ees0pij=ees0p(jj,i)
23541       ees0pkl=ees0p(kk,k)
23542       ees0mij=ees0m(jj,i)
23543       ees0mkl=ees0m(kk,k)
23544       ekont=eij*ekl
23545       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
23546 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
23547 !C Following 4 lines for diagnostics.
23548 !cd    ees0pkl=0.0D0
23549 !cd    ees0pij=1.0D0
23550 !cd    ees0mkl=0.0D0
23551 !cd    ees0mij=1.0D0
23552 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
23553 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
23554 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
23555 !C Calculate the multi-body contribution to energy.
23556 !      ecorr=ecorr+ekont*ees
23557 !C Calculate multi-body contributions to the gradient.
23558       coeffpees0pij=coeffp*ees0pij
23559       coeffmees0mij=coeffm*ees0mij
23560       coeffpees0pkl=coeffp*ees0pkl
23561       coeffmees0mkl=coeffm*ees0mkl
23562       do ll=1,3
23563       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
23564        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
23565        coeffmees0mkl*gacontm_hb1(ll,jj,i))
23566       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
23567       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
23568       coeffmees0mkl*gacontm_hb2(ll,jj,i))
23569       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
23570       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
23571       coeffmees0mij*gacontm_hb1(ll,kk,k))
23572       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
23573       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
23574       coeffmees0mij*gacontm_hb2(ll,kk,k))
23575       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
23576         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
23577         coeffmees0mkl*gacontm_hb3(ll,jj,i))
23578       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
23579       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
23580       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
23581         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
23582         coeffmees0mij*gacontm_hb3(ll,kk,k))
23583       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
23584       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
23585       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
23586       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
23587       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
23588       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
23589       enddo
23590       ehbcorr3_nucl=ekont*ees
23591       return
23592       end function ehbcorr3_nucl
23593 #ifdef MPI
23594       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
23595       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
23596       real(kind=8):: buffer(dimen1,dimen2)
23597       num_kont=num_cont_hb(atom)
23598       do i=1,num_kont
23599       do k=1,8
23600         do j=1,3
23601           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
23602         enddo ! j
23603       enddo ! k
23604       buffer(i,indx+25)=facont_hb(i,atom)
23605       buffer(i,indx+26)=ees0p(i,atom)
23606       buffer(i,indx+27)=ees0m(i,atom)
23607       buffer(i,indx+28)=d_cont(i,atom)
23608       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
23609       enddo ! i
23610       buffer(1,indx+30)=dfloat(num_kont)
23611       return
23612       end subroutine pack_buffer
23613 !c------------------------------------------------------------------------------
23614       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
23615       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
23616       real(kind=8):: buffer(dimen1,dimen2)
23617 !      double precision zapas
23618 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
23619 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
23620 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
23621 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
23622       num_kont=buffer(1,indx+30)
23623       num_kont_old=num_cont_hb(atom)
23624       num_cont_hb(atom)=num_kont+num_kont_old
23625       do i=1,num_kont
23626       ii=i+num_kont_old
23627       do k=1,8
23628         do j=1,3
23629           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
23630         enddo ! j
23631       enddo ! k
23632       facont_hb(ii,atom)=buffer(i,indx+25)
23633       ees0p(ii,atom)=buffer(i,indx+26)
23634       ees0m(ii,atom)=buffer(i,indx+27)
23635       d_cont(i,atom)=buffer(i,indx+28)
23636       jcont_hb(ii,atom)=buffer(i,indx+29)
23637       enddo ! i
23638       return
23639       end subroutine unpack_buffer
23640 !c------------------------------------------------------------------------------
23641 #endif
23642       subroutine ecatcat(ecationcation)
23643       use MD_data, only: t_bath
23644       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj,irdiff,&
23645       ii
23646       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23647       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
23648       real(kind=8) :: xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23649       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
23650       real(kind=8) :: awat,bwat,cwat,dwat,sss2min2,sss2mingrad2,rdiff,ewater
23651       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23652       gg,r
23653
23654       ecationcation=0.0d0
23655       if (nres_molec(5).le.1) return
23656       rcat0=3.472
23657       epscalc=0.05
23658       r06 = rcat0**6
23659       r012 = r06**2
23660 !        k0 = 332.0*(2.0*2.0)/80.0
23661       itmp=0
23662
23663 !      do i=1,4
23664 !      itmp=itmp+nres_molec(i)
23665 !      enddo
23666 !        write(iout,*) "itmp",g_listcatcatnorm_start, g_listcatcatnorm_end
23667 !      do i=itmp+1,itmp+nres_molec(5)-1
23668        do ii=g_listcatcatnorm_start, g_listcatcatnorm_end
23669         i=newcontlistcatcatnormi(ii)
23670         j=newcontlistcatcatnormj(ii)
23671
23672       xi=c(1,i)
23673       yi=c(2,i)
23674       zi=c(3,i)
23675 !        write (iout,*) i,"TUTUT",c(1,i)
23676         itypi=itype(i,5)
23677       call to_box(xi,yi,zi)
23678       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23679 !        do j=i+1,itmp+nres_molec(5)
23680         itypj=itype(j,5)
23681 !          print *,i,j,itypi,itypj
23682         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
23683 !           print *,i,j,'catcat'
23684          xj=c(1,j)
23685          yj=c(2,j)
23686          zj=c(3,j)
23687       call to_box(xj,yj,zj)
23688 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23689 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23690 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23691 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23692 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23693       xj=boxshift(xj-xi,boxxsize)
23694       yj=boxshift(yj-yi,boxysize)
23695       zj=boxshift(zj-zi,boxzsize)
23696        rcal =xj**2+yj**2+zj**2
23697       ract=sqrt(rcal)
23698         if ((itypi.gt.1).or.(itypj.gt.1)) then
23699        if (sss2min2.eq.0.0d0) cycle
23700        sss2min2=sscale2(ract,12.0d0,1.0d0)
23701        sss2mingrad2=sscagrad2(ract,12.0d0,1.0d0)
23702 !        rcat0=3.472
23703 !        epscalc=0.05
23704 !        r06 = rcat0**6
23705 !        r012 = r06**2
23706 !        k0 = 332*(2*2)/80
23707       Evan1cat=epscalc*(r012/(rcal**6))
23708       Evan2cat=epscalc*2*(r06/(rcal**3))
23709       Eeleccat=k0/ract
23710       r7 = rcal**7
23711       r4 = rcal**4
23712       r(1)=xj
23713       r(2)=yj
23714       r(3)=zj
23715       do k=1,3
23716         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
23717         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
23718         dEeleccat(k)=-k0*r(k)/ract**3
23719       enddo
23720       do k=1,3
23721         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
23722         gradcatcat(k,i)=gradcatcat(k,i)-(gg(k)*sss2min2+(Evan1cat+Evan2cat+Eeleccat)*sss2mingrad2)
23723         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)*sss2min2+(Evan1cat+Evan2cat+Eeleccat)*sss2mingrad2
23724       enddo
23725       if (energy_dec) write (iout,*) "ecatcat",i,j,Evan1cat,Evan2cat,Eeleccat,&
23726        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
23727 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
23728       ecationcation=ecationcation+(Evan1cat+Evan2cat+Eeleccat)*sss2min2
23729        else !this is water part and other non standard molecules
23730
23731        sss2min2=sscale2(ract,10.0d0,1.0d0)! cutoff for water interaction is 15A
23732        if (sss2min2.eq.0.0d0) cycle
23733        sss2mingrad2=sscagrad2(ract,10.0d0,1.0d0)
23734        irdiff=int((ract-2.06d0)*50.0d0)+1
23735
23736        rdiff=ract-((irdiff-1)*0.02d0+2.06d0)
23737        if (irdiff.le.0) then
23738         irdiff=0
23739         rdiff=ract
23740        endif
23741 !       print *,rdiff,ract,irdiff,sss2mingrad2
23742        awat=awaterenta(irdiff)-awaterentro(irdiff)*t_bath/1000.0d0
23743        bwat=bwaterenta(irdiff)-bwaterentro(irdiff)*t_bath/1000.0d0
23744        cwat=cwaterenta(irdiff)-cwaterentro(irdiff)*t_bath/1000.0d0
23745        dwat=dwaterenta(irdiff)-dwaterentro(irdiff)*t_bath/1000.0d0
23746        r(1)=xj
23747        r(2)=yj
23748        r(3)=zj
23749
23750        ewater=awat+bwat*rdiff+cwat*rdiff*rdiff+dwat*rdiff*rdiff*rdiff
23751        ecationcation=ecationcation+ewater*sss2min2
23752        do k=1,3
23753         gg(k)=(bwat+2.0d0*cwat*rdiff+dwat*3.0d0*rdiff*rdiff)*r(k)/ract
23754         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)*sss2min2-sss2mingrad2*ewater*r(k)/ract
23755         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)*sss2min2+sss2mingrad2*ewater*r(k)/ract
23756       enddo
23757        if (energy_dec) write(iout,'(2f8.2,f10.2,2i5)') rdiff,ract,ecationcation,i,j
23758        endif ! end water
23759        enddo
23760 !      enddo
23761        return
23762        end subroutine ecatcat
23763 !---------------------------------------------------------------------------
23764 ! new for K+
23765       subroutine ecats_prot_amber(evdw)
23766 !      subroutine ecat_prot2(ecation_prot)
23767       use calc_data
23768       use comm_momo
23769
23770       logical :: lprn
23771 !el local variables
23772       integer :: iint,itypi1,subchap,isel,itmp
23773       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
23774       real(kind=8) :: evdw,aa,bb
23775       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23776                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
23777                 sslipi,sslipj,faclip,alpha_sco
23778       integer :: ii,ki
23779       real(kind=8) :: fracinbuf
23780       real (kind=8) :: escpho
23781       real (kind=8),dimension(4):: ener
23782       real(kind=8) :: b1,b2,egb
23783       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
23784        Lambf,&
23785        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
23786        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
23787        federmaus,&
23788        d1i,d1j
23789 !       real(kind=8),dimension(3,2)::erhead_tail
23790 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
23791       real(kind=8) ::  facd4, adler, Fgb, facd3
23792       integer troll,jj,istate
23793       real (kind=8) :: dcosom1(3),dcosom2(3)
23794       real(kind=8) ::locbox(3)
23795       locbox(1)=boxxsize
23796           locbox(2)=boxysize
23797       locbox(3)=boxzsize
23798
23799       evdw=0.0D0
23800       if (nres_molec(5).eq.0) return
23801       eps_out=80.0d0
23802 !      sss_ele_cut=1.0d0
23803
23804       itmp=0
23805       do i=1,4
23806       itmp=itmp+nres_molec(i)
23807       enddo
23808 !        go to 17
23809 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23810 !      do i=ibond_start,ibond_end
23811       do ki=g_listcatscnorm_start,g_listcatscnorm_end
23812         i=newcontlistcatscnormi(ki)
23813         j=newcontlistcatscnormj(ki)
23814
23815 !        print *,"I am in EVDW",i
23816       itypi=iabs(itype(i,1))
23817
23818 !        if (i.ne.47) cycle
23819       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
23820       itypi1=iabs(itype(i+1,1))
23821       xi=c(1,nres+i)
23822       yi=c(2,nres+i)
23823       zi=c(3,nres+i)
23824       call to_box(xi,yi,zi)
23825       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23826       dxi=dc_norm(1,nres+i)
23827       dyi=dc_norm(2,nres+i)
23828       dzi=dc_norm(3,nres+i)
23829       dsci_inv=vbld_inv(i+nres)
23830 !       do j=itmp+1,itmp+nres_molec(5)
23831
23832 ! Calculate SC interaction energy.
23833           itypj=iabs(itype(j,5))
23834           if ((itypj.eq.ntyp1)) cycle
23835            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23836
23837           dscj_inv=0.0
23838          xj=c(1,j)
23839          yj=c(2,j)
23840          zj=c(3,j)
23841
23842       call to_box(xj,yj,zj)
23843 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
23844
23845 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23846 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23847 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23848 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23849 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23850       xj=boxshift(xj-xi,boxxsize)
23851       yj=boxshift(yj-yi,boxysize)
23852       zj=boxshift(zj-zi,boxzsize)
23853 !      write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize
23854
23855       dxj=0.0
23856       dyj=0.0
23857       dzj=0.0
23858 !          dxj = dc_norm( 1, nres+j )
23859 !          dyj = dc_norm( 2, nres+j )
23860 !          dzj = dc_norm( 3, nres+j )
23861
23862         itypi = itype(i,1)
23863         itypj = itype(j,5)
23864 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23865 ! sampling performed with amber package
23866 !          alf1   = 0.0d0
23867 !          alf2   = 0.0d0
23868 !          alf12  = 0.0d0
23869 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23870         chi1 = chi1cat(itypi,itypj)
23871         chis1 = chis1cat(itypi,itypj)
23872         chip1 = chipp1cat(itypi,itypj)
23873 !          chi1=0.0d0
23874 !          chis1=0.0d0
23875 !          chip1=0.0d0
23876         chi2=0.0
23877         chip2=0.0
23878         chis2=0.0
23879 !          chis2 = chis(itypj,itypi)
23880         chis12 = chis1 * chis2
23881         sig1 = sigmap1cat(itypi,itypj)
23882         sig2=0.0d0
23883 !          sig2 = sigmap2(itypi,itypj)
23884 ! alpha factors from Fcav/Gcav
23885         b1cav = alphasurcat(1,itypi,itypj)
23886         b2cav = alphasurcat(2,itypi,itypj)
23887         b3cav = alphasurcat(3,itypi,itypj)
23888         b4cav = alphasurcat(4,itypi,itypj)
23889
23890 !        b1cav=0.0d0
23891 !        b2cav=0.0d0
23892 !        b3cav=0.0d0
23893 !        b4cav=0.0d0
23894
23895 ! used to determine whether we want to do quadrupole calculations
23896        eps_in = epsintabcat(itypi,itypj)
23897        if (eps_in.eq.0.0) eps_in=1.0
23898
23899        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23900 !       Rtail = 0.0d0
23901
23902        DO k = 1, 3
23903       ctail(k,1)=c(k,i+nres)
23904       ctail(k,2)=c(k,j)
23905        END DO
23906       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
23907       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
23908 !c! tail distances will be themselves usefull elswhere
23909 !c1 (in Gcav, for example)
23910        do k=1,3
23911        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
23912        enddo
23913        Rtail = dsqrt( &
23914         (Rtail_distance(1)*Rtail_distance(1)) &
23915       + (Rtail_distance(2)*Rtail_distance(2)) &
23916       + (Rtail_distance(3)*Rtail_distance(3)))
23917 ! tail location and distance calculations
23918 ! dhead1
23919        d1 = dheadcat(1, 1, itypi, itypj)
23920 !       d2 = dhead(2, 1, itypi, itypj)
23921        DO k = 1,3
23922 ! location of polar head is computed by taking hydrophobic centre
23923 ! and moving by a d1 * dc_norm vector
23924 ! see unres publications for very informative images
23925       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
23926       chead(k,2) = c(k, j)
23927       enddo
23928       call to_box(chead(1,1),chead(2,1),chead(3,1))
23929       call to_box(chead(1,2),chead(2,2),chead(3,2))
23930 !      write(iout,*) "TEST",chead(1,1),chead(2,1),chead(3,1),dc_norm(k, i+nres),d1
23931 ! distance
23932 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23933 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23934       do k=1,3
23935       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
23936        END DO
23937 ! pitagoras (root of sum of squares)
23938        Rhead = dsqrt( &
23939         (Rhead_distance(1)*Rhead_distance(1)) &
23940       + (Rhead_distance(2)*Rhead_distance(2)) &
23941       + (Rhead_distance(3)*Rhead_distance(3)))
23942 !-------------------------------------------------------------------
23943 ! zero everything that should be zero'ed
23944        evdwij = 0.0d0
23945        ECL = 0.0d0
23946        Elj = 0.0d0
23947        Equad = 0.0d0
23948        Epol = 0.0d0
23949        Fcav=0.0d0
23950        eheadtail = 0.0d0
23951        dGCLdOM1 = 0.0d0
23952        dGCLdOM2 = 0.0d0
23953        dGCLdOM12 = 0.0d0
23954        dPOLdOM1 = 0.0d0
23955        dPOLdOM2 = 0.0d0
23956         Fcav = 0.0d0
23957         Fisocav=0.0d0
23958         dFdR = 0.0d0
23959         dCAVdOM1  = 0.0d0
23960         dCAVdOM2  = 0.0d0
23961         dCAVdOM12 = 0.0d0
23962         dscj_inv = vbld_inv(j+nres)
23963 !          print *,i,j,dscj_inv,dsci_inv
23964 ! rij holds 1/(distance of Calpha atoms)
23965         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23966         rij  = dsqrt(rrij)
23967             sss_ele_cut=sscale_ele(1.0d0/(rij))
23968             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
23969 !            print *,sss_ele_cut,sss_ele_grad,&
23970 !            1.0d0/(rij),r_cut_ele,rlamb_ele
23971             if (sss_ele_cut.le.0.0) cycle
23972         CALL sc_angular
23973 ! this should be in elgrad_init but om's are calculated by sc_angular
23974 ! which in turn is used by older potentials
23975 ! om = omega, sqom = om^2
23976         sqom1  = om1 * om1
23977         sqom2  = om2 * om2
23978         sqom12 = om12 * om12
23979
23980 ! now we calculate EGB - Gey-Berne
23981 ! It will be summed up in evdwij and saved in evdw
23982         sigsq     = 1.0D0  / sigsq
23983         sig       = sig0ij * dsqrt(sigsq)
23984 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23985         rij_shift = Rtail - sig + sig0ij
23986         IF (rij_shift.le.0.0D0) THEN
23987          evdw = 1.0D20
23988       if (evdw.gt.1.0d6) then
23989       write (*,'(2(1x,a3,i3),7f7.2)') &
23990       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23991       1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij,sigsq
23992       write(*,*) facsig,faceps1_inv,om1,chiom1,chi1
23993      write(*,*) "ANISO?!",chi1
23994 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23995 !      Equad,evdwij+Fcav+eheadtail,evdw
23996       endif
23997
23998          RETURN
23999         END IF
24000         sigder = -sig * sigsq
24001         rij_shift = 1.0D0 / rij_shift
24002         fac       = rij_shift**expon
24003         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
24004 !          print *,"ADAM",aa_aq(itypi,itypj)
24005
24006 !          c1        = 0.0d0
24007         c2        = fac  * bb_aq_cat(itypi,itypj)
24008 !          c2        = 0.0d0
24009         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24010         eps2der   = eps3rt * evdwij
24011         eps3der   = eps2rt * evdwij
24012 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24013         evdwij    = eps2rt * eps3rt * evdwij
24014 !#ifdef TSCSC
24015 !          IF (bb_aq(itypi,itypj).gt.0) THEN
24016 !           evdw_p = evdw_p + evdwij
24017 !          ELSE
24018 !           evdw_m = evdw_m + evdwij
24019 !          END IF
24020 !#else
24021         evdw = evdw  &
24022             + evdwij*sss_ele_cut
24023 !#endif
24024         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24025         fac    = -expon * (c1 + evdwij) * rij_shift
24026         sigder = fac * sigder
24027 ! Calculate distance derivative
24028         gg(1) =  fac*sss_ele_cut+evdwij*sss_ele_grad
24029         gg(2) =  fac*sss_ele_cut+evdwij*sss_ele_grad
24030         gg(3) =  fac*sss_ele_cut+evdwij*sss_ele_grad
24031 !       print *,"GG(1),distance grad",gg(1)
24032         fac = chis1 * sqom1 + chis2 * sqom2 &
24033         - 2.0d0 * chis12 * om1 * om2 * om12
24034         pom = 1.0d0 - chis1 * chis2 * sqom12
24035         Lambf = (1.0d0 - (fac / pom))
24036         Lambf = dsqrt(Lambf)
24037         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24038         Chif = Rtail * sparrow
24039         ChiLambf = Chif * Lambf
24040         eagle = dsqrt(ChiLambf)
24041         bat = ChiLambf ** 11.0d0
24042         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
24043         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
24044         botsq = bot * bot
24045         Fcav = top / bot
24046
24047        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
24048        dbot = 12.0d0 * b4cav * bat * Lambf
24049        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow*sss_ele_cut+&
24050         Fcav*sss_ele_grad
24051         Fcav=Fcav*sss_ele_cut
24052         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
24053         dbot = 12.0d0 * b4cav * bat * Chif
24054         eagle = Lambf * pom
24055         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24056         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24057         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24058             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24059
24060         dFdL = ((dtop * bot - top * dbot) / botsq)
24061         dCAVdOM1  = dFdL * ( dFdOM1 )
24062         dCAVdOM2  = dFdL * ( dFdOM2 )
24063         dCAVdOM12 = dFdL * ( dFdOM12 )
24064
24065        DO k= 1, 3
24066       ertail(k) = Rtail_distance(k)/Rtail
24067        END DO
24068        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24069        erdxj = scalar( ertail(1), dC_norm(1,j) )
24070        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
24071        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j)
24072        DO k = 1, 3
24073       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24074       gradpepcatx(k,i) = gradpepcatx(k,i) &
24075               - (( dFdR + gg(k) ) * pom)
24076       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j))
24077 !        gvdwx(k,j) = gvdwx(k,j)   &
24078 !                  + (( dFdR + gg(k) ) * pom)
24079       gradpepcat(k,i) = gradpepcat(k,i)  &
24080               - (( dFdR + gg(k) ) * ertail(k))
24081       gradpepcat(k,j) = gradpepcat(k,j) &
24082               + (( dFdR + gg(k) ) * ertail(k))
24083       gg(k) = 0.0d0
24084        ENDDO
24085 !c! Compute head-head and head-tail energies for each state
24086 !!        if (.false.) then ! turn off electrostatic
24087         if (itype(j,5).gt.0) then ! the normal cation case
24088         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
24089 !        print *,i,itype(i,1),isel
24090         IF (isel.eq.0) THEN
24091          eheadtail = 0.0d0
24092         ELSE IF (isel.eq.1) THEN
24093         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24094           Qi=Qi*2
24095           Qij=Qij*2
24096          endif
24097          CALL enq_cat(epol)
24098          eheadtail = epol
24099         ELSE IF (isel.eq.3) THEN
24100         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24101           Qi=Qi*2
24102           Qij=Qij*2
24103          endif
24104          CALL edq_cat(ecl, elj, epol)
24105         eheadtail = ECL + elj + epol
24106         ELSE IF ((isel.eq.2)) THEN
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          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
24112          eheadtail = ECL + Egb + Epol + Fisocav + Elj
24113        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
24114        else ! here is water and other molecules
24115         isel = iabs(Qi)+2
24116 !        isel=2
24117 !        if (isel.eq.4) isel=2
24118         if (isel.eq.2) then
24119          eheadtail = 0.0d0
24120         else if (isel.eq.3) then
24121         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24122           Qi=Qi*2
24123           Qij=Qij*2
24124          endif
24125         call eqd_cat(ecl,elj,epol)
24126         eheadtail = ECL + elj + epol
24127         else if (isel.eq.4) then
24128         call edd_cat(ecl)
24129         eheadtail = ECL
24130         endif
24131 !       write(iout,*) "not yet implemented",j,itype(j,5)
24132        endif
24133 !!       endif ! turn off electrostatic
24134       evdw = evdw  + Fcav + eheadtail
24135 !      if (evdw.gt.1.0d6) then
24136 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24137 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24138 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24139 !      Equad,evdwij+Fcav+eheadtail,evdw
24140 !      endif
24141
24142        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24143       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24144       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24145       Equad,evdwij+Fcav+eheadtail,evdw
24146 !       evdw = evdw  + Fcav  + eheadtail
24147        if (energy_dec) write(iout,*) "FCAV", &
24148          sig1,sig2,b1cav,b2cav,b3cav,b4cav
24149 !       print *,"before sc_grad_cat", i,j, gradpepcat(1,j)
24150 !        iF (nstate(itypi,itypj).eq.1) THEN
24151       CALL sc_grad_cat
24152 !       print *,"after sc_grad_cat", i,j, gradpepcat(1,j)
24153
24154 !       END IF
24155 !c!-------------------------------------------------------------------
24156 !c! NAPISY KONCOWE
24157        END DO   ! j
24158 !       END DO     ! i
24159 !c      write (iout,*) "Number of loop steps in EGB:",ind
24160 !c      energy_dec=.false.
24161 !              print *,"EVDW KURW",evdw,nres
24162 !!!        return
24163    17   continue
24164 !      go to 23
24165 !      do i=ibond_start,ibond_end
24166
24167       do ki=g_listcatpnorm_start,g_listcatpnorm_end
24168         i=newcontlistcatpnormi(ki)
24169         j=newcontlistcatpnormj(ki)
24170
24171 !        print *,"I am in EVDW",i
24172       itypi=10 ! the peptide group parameters are for glicine
24173
24174 !        if (i.ne.47) cycle
24175       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
24176       itypi1=iabs(itype(i+1,1))
24177       xi=(c(1,i)+c(1,i+1))/2.0
24178       yi=(c(2,i)+c(2,i+1))/2.0
24179       zi=(c(3,i)+c(3,i+1))/2.0
24180         call to_box(xi,yi,zi)
24181       dxi=dc_norm(1,i)
24182       dyi=dc_norm(2,i)
24183       dzi=dc_norm(3,i)
24184       dsci_inv=vbld_inv(i+1)/2.0
24185 !       do j=itmp+1,itmp+nres_molec(5)
24186
24187 ! Calculate SC interaction energy.
24188           itypj=iabs(itype(j,5))
24189           if ((itypj.eq.ntyp1)) cycle
24190            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
24191
24192           dscj_inv=0.0
24193          xj=c(1,j)
24194          yj=c(2,j)
24195          zj=c(3,j)
24196         call to_box(xj,yj,zj)
24197       xj=boxshift(xj-xi,boxxsize)
24198       yj=boxshift(yj-yi,boxysize)
24199       zj=boxshift(zj-zi,boxzsize)
24200
24201         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24202
24203         dxj = 0.0d0! dc_norm( 1, nres+j )
24204         dyj = 0.0d0!dc_norm( 2, nres+j )
24205         dzj = 0.0d0! dc_norm( 3, nres+j )
24206
24207         itypi = 10
24208         itypj = itype(j,5)
24209 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
24210 ! sampling performed with amber package
24211 !          alf1   = 0.0d0
24212 !          alf2   = 0.0d0
24213 !          alf12  = 0.0d0
24214 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
24215         chi1 = chi1cat(itypi,itypj)
24216         chis1 = chis1cat(itypi,itypj)
24217         chip1 = chipp1cat(itypi,itypj)
24218 !          chi1=0.0d0
24219 !          chis1=0.0d0
24220 !          chip1=0.0d0
24221         chi2=0.0
24222         chip2=0.0
24223         chis2=0.0
24224 !          chis2 = chis(itypj,itypi)
24225         chis12 = chis1 * chis2
24226         sig1 = sigmap1cat(itypi,itypj)
24227         sig2=0.0
24228 !          sig2 = sigmap2(itypi,itypj)
24229 ! alpha factors from Fcav/Gcav
24230         b1cav = alphasurcat(1,itypi,itypj)
24231         b2cav = alphasurcat(2,itypi,itypj)
24232         b3cav = alphasurcat(3,itypi,itypj)
24233         b4cav = alphasurcat(4,itypi,itypj)
24234
24235 ! used to determine whether we want to do quadrupole calculations
24236        eps_in = epsintabcat(itypi,itypj)
24237        if (eps_in.eq.0.0) eps_in=1.0
24238
24239        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24240 !       Rtail = 0.0d0
24241
24242        DO k = 1, 3
24243       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
24244       ctail(k,2)=c(k,j)
24245        END DO
24246       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
24247       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
24248 !c! tail distances will be themselves usefull elswhere
24249 !c1 (in Gcav, for example)
24250        do k=1,3
24251        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
24252        enddo
24253
24254 !c! tail distances will be themselves usefull elswhere
24255 !c1 (in Gcav, for example)
24256        Rtail = dsqrt( &
24257         (Rtail_distance(1)*Rtail_distance(1)) &
24258       + (Rtail_distance(2)*Rtail_distance(2)) &
24259       + (Rtail_distance(3)*Rtail_distance(3)))
24260 ! tail location and distance calculations
24261 ! dhead1
24262        d1 = dheadcat(1, 1, itypi, itypj)
24263 !       print *,"d1",d1
24264 !       d1=0.0d0
24265 !       d2 = dhead(2, 1, itypi, itypj)
24266        DO k = 1,3
24267 ! location of polar head is computed by taking hydrophobic centre
24268 ! and moving by a d1 * dc_norm vector
24269 ! see unres publications for very informative images
24270       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
24271       chead(k,2) = c(k, j)
24272        ENDDO
24273 ! distance
24274 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24275 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24276       call to_box(chead(1,1),chead(2,1),chead(3,1))
24277       call to_box(chead(1,2),chead(2,2),chead(3,2))
24278
24279 ! distance
24280 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24281 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24282       do k=1,3
24283       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
24284        END DO
24285
24286 ! pitagoras (root of sum of squares)
24287        Rhead = dsqrt( &
24288         (Rhead_distance(1)*Rhead_distance(1)) &
24289       + (Rhead_distance(2)*Rhead_distance(2)) &
24290       + (Rhead_distance(3)*Rhead_distance(3)))
24291 !-------------------------------------------------------------------
24292 ! zero everything that should be zero'ed
24293        evdwij = 0.0d0
24294        ECL = 0.0d0
24295        Elj = 0.0d0
24296        Equad = 0.0d0
24297        Epol = 0.0d0
24298        Fcav=0.0d0
24299        eheadtail = 0.0d0
24300        dGCLdOM1 = 0.0d0
24301        dGCLdOM2 = 0.0d0
24302        dGCLdOM12 = 0.0d0
24303        dPOLdOM1 = 0.0d0
24304        dPOLdOM2 = 0.0d0
24305         Fcav = 0.0d0
24306         dFdR = 0.0d0
24307         dCAVdOM1  = 0.0d0
24308         dCAVdOM2  = 0.0d0
24309         dCAVdOM12 = 0.0d0
24310         dscj_inv = 0.0d0 ! vbld_inv(j+nres)
24311 !          print *,i,j,dscj_inv,dsci_inv
24312 ! rij holds 1/(distance of Calpha atoms)
24313         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24314         rij  = dsqrt(rrij)
24315             sss_ele_cut=sscale_ele(1.0d0/(rij))
24316             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
24317 !            print *,sss_ele_cut,sss_ele_grad,&
24318 !            1.0d0/(rij),r_cut_ele,rlamb_ele
24319             if (sss_ele_cut.le.0.0) cycle
24320         CALL sc_angular
24321 ! this should be in elgrad_init but om's are calculated by sc_angular
24322 ! which in turn is used by older potentials
24323 ! om = omega, sqom = om^2
24324         om2=0.0d0
24325         om12=0.0d0
24326         sqom1  = om1 * om1
24327         sqom2  = om2 * om2
24328         sqom12 = om12 * om12
24329
24330 ! now we calculate EGB - Gey-Berne
24331 ! It will be summed up in evdwij and saved in evdw
24332         sigsq     = 1.0D0  / sigsq
24333         sig       = sig0ij * dsqrt(sigsq)
24334 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24335         rij_shift = Rtail - sig + sig0ij
24336         IF (rij_shift.le.0.0D0) THEN
24337          evdw = 1.0D20
24338 !      if (evdw.gt.1.0d6) then
24339 !      write (*,'(2(1x,a3,i3),6f6.2)') &
24340 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24341 !      1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij
24342 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24343 !      Equad,evdwij+Fcav+eheadtail,evdw
24344 !      endif
24345          RETURN
24346         END IF
24347         sigder = -sig * sigsq
24348         rij_shift = 1.0D0 / rij_shift
24349         fac       = rij_shift**expon
24350         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
24351 !          print *,"ADAM",aa_aq(itypi,itypj)
24352
24353 !          c1        = 0.0d0
24354         c2        = fac  * bb_aq_cat(itypi,itypj)
24355 !          c2        = 0.0d0
24356         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24357         eps2der   = eps3rt * evdwij
24358         eps3der   = eps2rt * evdwij
24359 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24360         evdwij    = eps2rt * eps3rt * evdwij
24361 !#ifdef TSCSC
24362 !          IF (bb_aq(itypi,itypj).gt.0) THEN
24363 !           evdw_p = evdw_p + evdwij
24364 !          ELSE
24365 !           evdw_m = evdw_m + evdwij
24366 !          END IF
24367 !#else
24368         evdw = evdw  &
24369             + evdwij*sss_ele_cut
24370 !#endif
24371         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24372         fac    = -expon * (c1 + evdwij) * rij_shift
24373         sigder = fac * sigder
24374 ! Calculate distance derivative
24375         gg(1) =  fac*sss_ele_cut+evdwij*sss_ele_grad
24376         gg(2) =  fac*sss_ele_cut+evdwij*sss_ele_grad
24377         gg(3) =  fac*sss_ele_cut+evdwij*sss_ele_grad
24378
24379         fac = chis1 * sqom1 + chis2 * sqom2 &
24380         - 2.0d0 * chis12 * om1 * om2 * om12
24381
24382         pom = 1.0d0 - chis1 * chis2 * sqom12
24383 !          print *,"TUT2",fac,chis1,sqom1,pom
24384         Lambf = (1.0d0 - (fac / pom))
24385         Lambf = dsqrt(Lambf)
24386         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24387         Chif = Rtail * sparrow
24388         ChiLambf = Chif * Lambf
24389         eagle = dsqrt(ChiLambf)
24390         bat = ChiLambf ** 11.0d0
24391         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
24392         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
24393         botsq = bot * bot
24394         Fcav = top / bot
24395
24396        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
24397        dbot = 12.0d0 * b4cav * bat * Lambf
24398        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow*sss_ele_cut+&
24399           Fcav*sss_ele_grad
24400         Fcav=Fcav*sss_ele_cut
24401         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
24402         dbot = 12.0d0 * b4cav * bat * Chif
24403         eagle = Lambf * pom
24404         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24405
24406         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24407         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24408             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24409
24410         dFdL = ((dtop * bot - top * dbot) / botsq)
24411         dCAVdOM1  = dFdL * ( dFdOM1 )
24412 !        dCAVdOM2  = dFdL * ( dFdOM2 )
24413 !        dCAVdOM12 = dFdL * ( dFdOM12 )
24414         dCAVdOM2=0.0d0
24415         dCAVdOM12=0.0d0
24416
24417        DO k= 1, 3
24418       ertail(k) = Rtail_distance(k)/Rtail
24419        END DO
24420        erdxi = scalar( ertail(1), dC_norm(1,i) )
24421        erdxj = scalar( ertail(1), dC_norm(1,j) )
24422        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
24423        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
24424        DO k = 1, 3
24425       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
24426 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
24427 !                  - (( dFdR + gg(k) ) * pom)
24428       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24429 !        gvdwx(k,j) = gvdwx(k,j)   &
24430 !                  + (( dFdR + gg(k) ) * pom)
24431       gradpepcat(k,i) = gradpepcat(k,i)  &
24432               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
24433       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
24434               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
24435
24436       gradpepcat(k,j) = gradpepcat(k,j) &
24437               + (( dFdR + gg(k) ) * ertail(k))
24438       gg(k) = 0.0d0
24439        ENDDO
24440       if (itype(j,5).gt.0) then
24441 !c! Compute head-head and head-tail energies for each state
24442         isel = 3
24443 !c! Dipole-charge interactions
24444          CALL edq_cat_pep(ecl, elj, epol)
24445          eheadtail = ECL + elj + epol
24446 !          print *,"i,",i,eheadtail
24447 !           eheadtail = 0.0d0
24448       else
24449 !HERE WATER and other types of molecules solvents will be added
24450 !      write(iout,*) "not yet implemented"
24451          CALL edd_cat_pep(ecl)
24452          eheadtail=ecl
24453 !      CALL edd_cat_pep
24454 !      eheadtail=0.0d0
24455       endif
24456       evdw = evdw  + Fcav + eheadtail
24457 !      if (evdw.gt.1.0d6) then
24458 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24459 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24460 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24461 !      Equad,evdwij+Fcav+eheadtail,evdw
24462 !      endif
24463        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24464       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24465       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24466       Equad,evdwij+Fcav+eheadtail,evdw
24467 !       evdw = evdw  + Fcav  + eheadtail
24468
24469 !        iF (nstate(itypi,itypj).eq.1) THEN
24470       CALL sc_grad_cat_pep
24471 !       END IF
24472 !c!-------------------------------------------------------------------
24473 !c! NAPISY KONCOWE
24474        END DO   ! j
24475 !       END DO     ! i
24476 !c      write (iout,*) "Number of loop steps in EGB:",ind
24477 !c      energy_dec=.false.
24478 !              print *,"EVDW KURW",evdw,nres
24479  23   continue
24480 !       print *,"before leave sc_grad_cat", i,j, gradpepcat(1,nres-1)
24481
24482       return
24483       end subroutine ecats_prot_amber
24484
24485 !---------------------------------------------------------------------------
24486 ! old for Ca2+
24487        subroutine ecat_prot(ecation_prot)
24488 !      use calc_data
24489 !      use comm_momo
24490        integer i,j,k,subchap,itmp,inum
24491       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
24492       r7,r4
24493       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
24494       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
24495       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
24496       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
24497       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
24498       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
24499       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
24500       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
24501       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
24502       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
24503       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
24504       ndiv,ndivi
24505       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
24506       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
24507       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
24508       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
24509       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
24510       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
24511       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
24512       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
24513       dEvan1Cat
24514       real(kind=8),dimension(6) :: vcatprm
24515       ecation_prot=0.0d0
24516 ! first lets calculate interaction with peptide groups
24517       if (nres_molec(5).eq.0) return
24518       itmp=0
24519       do i=1,4
24520       itmp=itmp+nres_molec(i)
24521       enddo
24522 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
24523       do i=ibond_start,ibond_end
24524 !         cycle
24525
24526        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
24527       xi=0.5d0*(c(1,i)+c(1,i+1))
24528       yi=0.5d0*(c(2,i)+c(2,i+1))
24529       zi=0.5d0*(c(3,i)+c(3,i+1))
24530         call to_box(xi,yi,zi)
24531
24532        do j=itmp+1,itmp+nres_molec(5)
24533 !           print *,"WTF",itmp,j,i
24534 ! all parameters were for Ca2+ to approximate single charge divide by two
24535        ndiv=1.0
24536        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24537        wconst=78*ndiv
24538       wdip =1.092777950857032D2
24539       wdip=wdip/wconst
24540       wmodquad=-2.174122713004870D4
24541       wmodquad=wmodquad/wconst
24542       wquad1 = 3.901232068562804D1
24543       wquad1=wquad1/wconst
24544       wquad2 = 3
24545       wquad2=wquad2/wconst
24546       wvan1 = 0.1
24547       wvan2 = 6
24548 !        itmp=0
24549
24550          xj=c(1,j)
24551          yj=c(2,j)
24552          zj=c(3,j)
24553         call to_box(xj,yj,zj)
24554       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24555 !       enddo
24556 !       enddo
24557        rcpm = sqrt(xj**2+yj**2+zj**2)
24558        drcp_norm(1)=xj/rcpm
24559        drcp_norm(2)=yj/rcpm
24560        drcp_norm(3)=zj/rcpm
24561        dcmag=0.0
24562        do k=1,3
24563        dcmag=dcmag+dc(k,i)**2
24564        enddo
24565        dcmag=dsqrt(dcmag)
24566        do k=1,3
24567        myd_norm(k)=dc(k,i)/dcmag
24568        enddo
24569       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
24570       drcp_norm(3)*myd_norm(3)
24571       rsecp = rcpm**2
24572       Ir = 1.0d0/rcpm
24573       Irsecp = 1.0d0/rsecp
24574       Irthrp = Irsecp/rcpm
24575       Irfourp = Irthrp/rcpm
24576       Irfiftp = Irfourp/rcpm
24577       Irsistp=Irfiftp/rcpm
24578       Irseven=Irsistp/rcpm
24579       Irtwelv=Irsistp*Irsistp
24580       Irthir=Irtwelv/rcpm
24581       sin2thet = (1-costhet*costhet)
24582       sinthet=sqrt(sin2thet)
24583       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
24584            *sin2thet
24585       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
24586            2*wvan2**6*Irsistp)
24587       ecation_prot = ecation_prot+E1+E2
24588 !        print *,"ecatprot",i,j,ecation_prot,rcpm
24589       dE1dr = -2*costhet*wdip*Irthrp-&
24590        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
24591       dE2dr = 3*wquad1*wquad2*Irfourp-     &
24592         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
24593       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
24594       do k=1,3
24595         drdpep(k) = -drcp_norm(k)
24596         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
24597         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
24598         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
24599         dEddci(k) = dEdcos*dcosddci(k)
24600       enddo
24601       do k=1,3
24602       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
24603       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
24604       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
24605       enddo
24606        enddo ! j
24607        enddo ! i
24608 !------------------------------------------sidechains
24609 !        do i=1,nres_molec(1)
24610       do i=ibond_start,ibond_end
24611        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
24612 !         cycle
24613 !        print *,i,ecation_prot
24614       xi=(c(1,i+nres))
24615       yi=(c(2,i+nres))
24616       zi=(c(3,i+nres))
24617                 call to_box(xi,yi,zi)
24618         do k=1,3
24619           cm1(k)=dc(k,i+nres)
24620         enddo
24621          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
24622        do j=itmp+1,itmp+nres_molec(5)
24623        ndiv=1.0
24624        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24625
24626          xj=c(1,j)
24627          yj=c(2,j)
24628          zj=c(3,j)
24629         call to_box(xj,yj,zj)
24630       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24631 !       enddo
24632 !       enddo
24633 ! 15- Glu 16-Asp
24634        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
24635        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
24636        (itype(i,1).eq.25))) then
24637           if(itype(i,1).eq.16) then
24638           inum=1
24639           else
24640           inum=2
24641           endif
24642           do k=1,6
24643           vcatprm(k)=catprm(k,inum)
24644           enddo
24645           dASGL=catprm(7,inum)
24646 !             do k=1,3
24647 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
24648             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
24649             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
24650             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
24651
24652 !                valpha(k)=c(k,i)
24653 !                vcat(k)=c(k,j)
24654             if (subchap.eq.1) then
24655              vcat(1)=xj_temp
24656              vcat(2)=yj_temp
24657              vcat(3)=zj_temp
24658              else
24659             vcat(1)=xj_safe
24660             vcat(2)=yj_safe
24661             vcat(3)=zj_safe
24662              endif
24663             valpha(1)=xi-c(1,i+nres)+c(1,i)
24664             valpha(2)=yi-c(2,i+nres)+c(2,i)
24665             valpha(3)=zi-c(3,i+nres)+c(3,i)
24666
24667 !              enddo
24668       do k=1,3
24669         dx(k) = vcat(k)-vcm(k)
24670       enddo
24671       do k=1,3
24672         v1(k)=(vcm(k)-valpha(k))
24673         v2(k)=(vcat(k)-valpha(k))
24674       enddo
24675       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24676       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
24677       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
24678
24679 !  The weights of the energy function calculated from
24680 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
24681         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24682           ndivi=0.5
24683         else
24684           ndivi=1.0
24685         endif
24686        ndiv=1.0
24687        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24688
24689       wh2o=78*ndivi*ndiv
24690       wc = vcatprm(1)
24691       wc=wc/wh2o
24692       wdip =vcatprm(2)
24693       wdip=wdip/wh2o
24694       wquad1 =vcatprm(3)
24695       wquad1=wquad1/wh2o
24696       wquad2 = vcatprm(4)
24697       wquad2=wquad2/wh2o
24698       wquad2p = 1.0d0-wquad2
24699       wvan1 = vcatprm(5)
24700       wvan2 =vcatprm(6)
24701       opt = dx(1)**2+dx(2)**2
24702       rsecp = opt+dx(3)**2
24703       rs = sqrt(rsecp)
24704       rthrp = rsecp*rs
24705       rfourp = rthrp*rs
24706       rsixp = rfourp*rsecp
24707       reight=rsixp*rsecp
24708       Ir = 1.0d0/rs
24709       Irsecp = 1.0d0/rsecp
24710       Irthrp = Irsecp/rs
24711       Irfourp = Irthrp/rs
24712       Irsixp = 1.0d0/rsixp
24713       Ireight=1.0d0/reight
24714       Irtw=Irsixp*Irsixp
24715       Irthir=Irtw/rs
24716       Irfourt=Irthir/rs
24717       opt1 = (4*rs*dx(3)*wdip)
24718       opt2 = 6*rsecp*wquad1*opt
24719       opt3 = wquad1*wquad2p*Irsixp
24720       opt4 = (wvan1*wvan2**12)
24721       opt5 = opt4*12*Irfourt
24722       opt6 = 2*wvan1*wvan2**6
24723       opt7 = 6*opt6*Ireight
24724       opt8 = wdip/v1m
24725       opt10 = wdip/v2m
24726       opt11 = (rsecp*v2m)**2
24727       opt12 = (rsecp*v1m)**2
24728       opt14 = (v1m*v2m*rsecp)**2
24729       opt15 = -wquad1/v2m**2
24730       opt16 = (rthrp*(v1m*v2m)**2)**2
24731       opt17 = (v1m**2*rthrp)**2
24732       opt18 = -wquad1/rthrp
24733       opt19 = (v1m**2*v2m**2)**2
24734       Ec = wc*Ir
24735       do k=1,3
24736         dEcCat(k) = -(dx(k)*wc)*Irthrp
24737         dEcCm(k)=(dx(k)*wc)*Irthrp
24738         dEcCalp(k)=0.0d0
24739       enddo
24740       Edip=opt8*(v1dpv2)/(rsecp*v2m)
24741       do k=1,3
24742         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
24743                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24744         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
24745                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24746         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
24747                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
24748                   *v1dpv2)/opt14
24749       enddo
24750       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24751       do k=1,3
24752         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
24753                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
24754                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24755         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
24756                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
24757                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24758         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24759                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
24760                   v1dpv2**2)/opt19
24761       enddo
24762       Equad2=wquad1*wquad2p*Irthrp
24763       do k=1,3
24764         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24765         dEquad2Cm(k)=3*dx(k)*rs*opt3
24766         dEquad2Calp(k)=0.0d0
24767       enddo
24768       Evan1=opt4*Irtw
24769       do k=1,3
24770         dEvan1Cat(k)=-dx(k)*opt5
24771         dEvan1Cm(k)=dx(k)*opt5
24772         dEvan1Calp(k)=0.0d0
24773       enddo
24774       Evan2=-opt6*Irsixp
24775       do k=1,3
24776         dEvan2Cat(k)=dx(k)*opt7
24777         dEvan2Cm(k)=-dx(k)*opt7
24778         dEvan2Calp(k)=0.0d0
24779       enddo
24780       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
24781 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
24782
24783       do k=1,3
24784         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
24785                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24786 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
24787         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
24788                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24789         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
24790                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24791       enddo
24792           dscmag = 0.0d0
24793           do k=1,3
24794             dscvec(k) = dc(k,i+nres)
24795             dscmag = dscmag+dscvec(k)*dscvec(k)
24796           enddo
24797           dscmag3 = dscmag
24798           dscmag = sqrt(dscmag)
24799           dscmag3 = dscmag3*dscmag
24800           constA = 1.0d0+dASGL/dscmag
24801           constB = 0.0d0
24802           do k=1,3
24803             constB = constB+dscvec(k)*dEtotalCm(k)
24804           enddo
24805           constB = constB*dASGL/dscmag3
24806           do k=1,3
24807             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24808             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24809              constA*dEtotalCm(k)-constB*dscvec(k)
24810 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
24811             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24812             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24813            enddo
24814       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
24815          if(itype(i,1).eq.14) then
24816           inum=3
24817           else
24818           inum=4
24819           endif
24820           do k=1,6
24821           vcatprm(k)=catprm(k,inum)
24822           enddo
24823           dASGL=catprm(7,inum)
24824 !             do k=1,3
24825 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
24826 !                valpha(k)=c(k,i)
24827 !                vcat(k)=c(k,j)
24828 !              enddo
24829             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
24830             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
24831             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
24832             if (subchap.eq.1) then
24833              vcat(1)=xj_temp
24834              vcat(2)=yj_temp
24835              vcat(3)=zj_temp
24836              else
24837             vcat(1)=xj_safe
24838             vcat(2)=yj_safe
24839             vcat(3)=zj_safe
24840             endif
24841             valpha(1)=xi-c(1,i+nres)+c(1,i)
24842             valpha(2)=yi-c(2,i+nres)+c(2,i)
24843             valpha(3)=zi-c(3,i+nres)+c(3,i)
24844
24845
24846       do k=1,3
24847         dx(k) = vcat(k)-vcm(k)
24848       enddo
24849       do k=1,3
24850         v1(k)=(vcm(k)-valpha(k))
24851         v2(k)=(vcat(k)-valpha(k))
24852       enddo
24853       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24854       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
24855       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
24856 !  The weights of the energy function calculated from
24857 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
24858        ndiv=1.0
24859        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24860
24861       wh2o=78*ndiv
24862       wdip =vcatprm(2)
24863       wdip=wdip/wh2o
24864       wquad1 =vcatprm(3)
24865       wquad1=wquad1/wh2o
24866       wquad2 = vcatprm(4)
24867       wquad2=wquad2/wh2o
24868       wquad2p = 1-wquad2
24869       wvan1 = vcatprm(5)
24870       wvan2 =vcatprm(6)
24871       opt = dx(1)**2+dx(2)**2
24872       rsecp = opt+dx(3)**2
24873       rs = sqrt(rsecp)
24874       rthrp = rsecp*rs
24875       rfourp = rthrp*rs
24876       rsixp = rfourp*rsecp
24877       reight=rsixp*rsecp
24878       Ir = 1.0d0/rs
24879       Irsecp = 1/rsecp
24880       Irthrp = Irsecp/rs
24881       Irfourp = Irthrp/rs
24882       Irsixp = 1/rsixp
24883       Ireight=1/reight
24884       Irtw=Irsixp*Irsixp
24885       Irthir=Irtw/rs
24886       Irfourt=Irthir/rs
24887       opt1 = (4*rs*dx(3)*wdip)
24888       opt2 = 6*rsecp*wquad1*opt
24889       opt3 = wquad1*wquad2p*Irsixp
24890       opt4 = (wvan1*wvan2**12)
24891       opt5 = opt4*12*Irfourt
24892       opt6 = 2*wvan1*wvan2**6
24893       opt7 = 6*opt6*Ireight
24894       opt8 = wdip/v1m
24895       opt10 = wdip/v2m
24896       opt11 = (rsecp*v2m)**2
24897       opt12 = (rsecp*v1m)**2
24898       opt14 = (v1m*v2m*rsecp)**2
24899       opt15 = -wquad1/v2m**2
24900       opt16 = (rthrp*(v1m*v2m)**2)**2
24901       opt17 = (v1m**2*rthrp)**2
24902       opt18 = -wquad1/rthrp
24903       opt19 = (v1m**2*v2m**2)**2
24904       Edip=opt8*(v1dpv2)/(rsecp*v2m)
24905       do k=1,3
24906         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
24907                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24908        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
24909                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24910         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
24911                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
24912                   *v1dpv2)/opt14
24913       enddo
24914       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24915       do k=1,3
24916         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
24917                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
24918                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24919         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
24920                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
24921                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24922         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24923                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
24924                   v1dpv2**2)/opt19
24925       enddo
24926       Equad2=wquad1*wquad2p*Irthrp
24927       do k=1,3
24928         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24929         dEquad2Cm(k)=3*dx(k)*rs*opt3
24930         dEquad2Calp(k)=0.0d0
24931       enddo
24932       Evan1=opt4*Irtw
24933       do k=1,3
24934         dEvan1Cat(k)=-dx(k)*opt5
24935         dEvan1Cm(k)=dx(k)*opt5
24936         dEvan1Calp(k)=0.0d0
24937       enddo
24938       Evan2=-opt6*Irsixp
24939       do k=1,3
24940         dEvan2Cat(k)=dx(k)*opt7
24941         dEvan2Cm(k)=-dx(k)*opt7
24942         dEvan2Calp(k)=0.0d0
24943       enddo
24944        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
24945       do k=1,3
24946         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
24947                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24948         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
24949                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24950         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
24951                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24952       enddo
24953           dscmag = 0.0d0
24954           do k=1,3
24955             dscvec(k) = c(k,i+nres)-c(k,i)
24956 ! TU SPRAWDZ???
24957 !              dscvec(1) = xj
24958 !              dscvec(2) = yj
24959 !              dscvec(3) = zj
24960
24961             dscmag = dscmag+dscvec(k)*dscvec(k)
24962           enddo
24963           dscmag3 = dscmag
24964           dscmag = sqrt(dscmag)
24965           dscmag3 = dscmag3*dscmag
24966           constA = 1+dASGL/dscmag
24967           constB = 0.0d0
24968           do k=1,3
24969             constB = constB+dscvec(k)*dEtotalCm(k)
24970           enddo
24971           constB = constB*dASGL/dscmag3
24972           do k=1,3
24973             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24974             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24975              constA*dEtotalCm(k)-constB*dscvec(k)
24976             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24977             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24978            enddo
24979          else
24980           rcal = 0.0d0
24981           do k=1,3
24982 !              r(k) = c(k,j)-c(k,i+nres)
24983             r(1) = xj
24984             r(2) = yj
24985             r(3) = zj
24986             rcal = rcal+r(k)*r(k)
24987           enddo
24988           ract=sqrt(rcal)
24989           rocal=1.5
24990           epscalc=0.2
24991           r0p=0.5*(rocal+sig0(itype(i,1)))
24992           r06 = r0p**6
24993           r012 = r06*r06
24994           Evan1=epscalc*(r012/rcal**6)
24995           Evan2=epscalc*2*(r06/rcal**3)
24996           r4 = rcal**4
24997           r7 = rcal**7
24998           do k=1,3
24999             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
25000             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
25001           enddo
25002           do k=1,3
25003             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
25004           enddo
25005              ecation_prot = ecation_prot+ Evan1+Evan2
25006           do  k=1,3
25007              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
25008              dEtotalCm(k)
25009             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
25010             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
25011            enddo
25012        endif ! 13-16 residues
25013        enddo !j
25014        enddo !i
25015        return
25016        end subroutine ecat_prot
25017
25018 !----------------------------------------------------------------------------
25019 !---------------------------------------------------------------------------
25020        subroutine ecat_nucl(ecation_nucl)
25021        integer i,j,k,subchap,itmp,inum,itypi,itypj
25022        real(kind=8) :: xi,yi,zi,xj,yj,zj
25023        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
25024        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
25025        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
25026        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
25027        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
25028        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
25029        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
25030        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
25031        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
25032        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
25033        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
25034        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
25035        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
25036        dEcavdCm,boxik
25037        real(kind=8),dimension(14) :: vcatnuclprm
25038        ecation_nucl=0.0d0
25039        boxik(1)=boxxsize
25040        boxik(2)=boxysize
25041        boxik(3)=boxzsize
25042
25043        if (nres_molec(5).eq.0) return
25044        itmp=0
25045        do i=1,4
25046           itmp=itmp+nres_molec(i)
25047        enddo
25048 !       print *,nres_molec(2),"nres2"
25049       do i=ibond_nucl_start,ibond_nucl_end
25050 !       do i=iatsc_s_nucl,iatsc_e_nucl
25051           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
25052           xi=(c(1,i+nres))
25053           yi=(c(2,i+nres))
25054           zi=(c(3,i+nres))
25055       call to_box(xi,yi,zi)
25056       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25057           do k=1,3
25058              cm1(k)=dc(k,i+nres)
25059           enddo
25060           do j=itmp+1,itmp+nres_molec(5)
25061              xj=c(1,j)
25062              yj=c(2,j)
25063              zj=c(3,j)
25064       call to_box(xj,yj,zj)
25065 !      print *,i,j,itmp
25066 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
25067 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25068 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25069 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25070 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25071 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25072       xj=boxshift(xj-xi,boxxsize)
25073       yj=boxshift(yj-yi,boxysize)
25074       zj=boxshift(zj-zi,boxzsize)
25075 !       write(iout,*) 'after shift', xj,yj,zj
25076              dist_init=xj**2+yj**2+zj**2
25077
25078              itypi=itype(i,2)
25079              itypj=itype(j,5)
25080              do k=1,13
25081                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
25082              enddo
25083              do k=1,3
25084                 vcm(k)=c(k,i+nres)
25085                 vsug(k)=c(k,i)
25086                 vcat(k)=c(k,j)
25087              enddo
25088              call to_box(vcm(1),vcm(2),vcm(3))
25089              call to_box(vsug(1),vsug(2),vsug(3))
25090              call to_box(vcat(1),vcat(2),vcat(3))
25091              do k=1,3
25092 !                dx(k) = vcat(k)-vcm(k)
25093 !             enddo
25094                 dx(k)=boxshift(vcat(k)-vcm(k),boxik(k))
25095 !             do k=1,3
25096                 v1(k)=dc(k,i+nres)
25097                 v2(k)=boxshift(vcat(k)-vsug(k),boxik(k))
25098              enddo
25099              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
25100              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
25101 !  The weights of the energy function calculated from
25102 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
25103              wh2o=78
25104              wdip1 = vcatnuclprm(1)
25105              wdip1 = wdip1/wh2o                     !w1
25106              wdip2 = vcatnuclprm(2)
25107              wdip2 = wdip2/wh2o                     !w2
25108              wvan1 = vcatnuclprm(3)
25109              wvan2 = vcatnuclprm(4)                 !pis1
25110              wgbsig = vcatnuclprm(5)                !sigma0
25111              wgbeps = vcatnuclprm(6)                !epsi0
25112              wgbchi = vcatnuclprm(7)                !chi1
25113              wgbchip = vcatnuclprm(8)               !chip1
25114              wcavsig = vcatnuclprm(9)               !sig
25115              wcav1 = vcatnuclprm(10)                !b1
25116              wcav2 = vcatnuclprm(11)                !b2
25117              wcav3 = vcatnuclprm(12)                !b3
25118              wcav4 = vcatnuclprm(13)                !b4
25119              wcavchi = vcatnuclprm(14)              !chis1
25120              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
25121              invrcs6 = 1/rcs2**3
25122              invrcs8 = invrcs6/rcs2
25123              invrcs12 = invrcs6**2
25124              invrcs14 = invrcs12/rcs2
25125              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
25126              rcb = sqrt(rcb2)
25127              invrcb = 1/rcb
25128              invrcb2 = invrcb**2
25129              invrcb4 = invrcb2**2
25130              invrcb6 = invrcb4*invrcb2
25131              cosinus = v1dpdx/(v1m*rcb)
25132              cos2 = cosinus**2
25133              dcosdcatconst = invrcb2/v1m
25134              dcosdcalpconst = invrcb/v1m**2
25135              dcosdcmconst = invrcb2/v1m**2
25136              do k=1,3
25137                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
25138                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
25139                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
25140                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
25141              enddo
25142              rcav = rcb/wcavsig
25143              rcav11 = rcav**11
25144              rcav12 = rcav11*rcav
25145              constcav1 = 1-wcavchi*cos2
25146              constcav2 = sqrt(constcav1)
25147              constgb1 = 1/sqrt(1-wgbchi*cos2)
25148              constgb2 = wgbeps*(1-wgbchip*cos2)**2
25149              constdvan1 = 12*wvan1*wvan2**12*invrcs14
25150              constdvan2 = 6*wvan1*wvan2**6*invrcs8
25151 !----------------------------------------------------------------------------
25152 !Gay-Berne term
25153 !---------------------------------------------------------------------------
25154              sgb = 1/(1-constgb1+(rcb/wgbsig))
25155              sgb6 = sgb**6
25156              sgb7 = sgb6*sgb
25157              sgb12 = sgb6**2
25158              sgb13 = sgb12*sgb
25159              Egb = constgb2*(sgb12-sgb6)
25160              do k=1,3
25161                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
25162                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
25163      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
25164                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
25165                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
25166      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
25167                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
25168                                *(12*sgb13-6*sgb7) &
25169      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
25170              enddo
25171 !----------------------------------------------------------------------------
25172 !cavity term
25173 !---------------------------------------------------------------------------
25174              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
25175              cavdenom = 1+wcav4*rcav12*constcav1**6
25176              Ecav = wcav1*cavnum/cavdenom
25177              invcavdenom2 = 1/cavdenom**2
25178              dcavnumdcos = -wcavchi*cosinus/constcav2 &
25179                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
25180              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
25181              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
25182              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
25183              do k=1,3
25184                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
25185      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
25186                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
25187      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
25188                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
25189                              *dcosdcalp(k)*wcav1*invcavdenom2
25190              enddo
25191 !----------------------------------------------------------------------------
25192 !van der Waals and dipole-charge interaction energy
25193 !---------------------------------------------------------------------------
25194              Evan1 = wvan1*wvan2**12*invrcs12
25195              do k=1,3
25196                 dEvan1Cat(k) = -v2(k)*constdvan1
25197                 dEvan1Cm(k) = 0.0d0
25198                 dEvan1Calp(k) = v2(k)*constdvan1
25199              enddo
25200              Evan2 = -wvan1*wvan2**6*invrcs6
25201              do k=1,3
25202                 dEvan2Cat(k) = v2(k)*constdvan2
25203                 dEvan2Cm(k) = 0.0d0
25204                 dEvan2Calp(k) = -v2(k)*constdvan2
25205              enddo
25206              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
25207              do k=1,3
25208                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
25209                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
25210                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
25211                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
25212                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
25213                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
25214                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
25215                                   +2*wdip2*cosinus*invrcb4)
25216              enddo
25217              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
25218          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
25219              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
25220              do k=1,3
25221                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
25222                                              +dEgbdCat(k)+dEdipCat(k)
25223                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
25224                                            +dEgbdCm(k)+dEdipCm(k)
25225                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
25226                                              +dEdipCalp(k)+dEvan2Calp(k)
25227              enddo
25228              do k=1,3
25229                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
25230                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
25231                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
25232                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
25233              enddo
25234           enddo !j
25235        enddo !i
25236        return
25237        end subroutine ecat_nucl
25238
25239 !-----------------------------------------------------------------------------
25240 !-----------------------------------------------------------------------------
25241       subroutine eprot_sc_base(escbase)
25242       use calc_data
25243 !      implicit real(kind=8) (a-h,o-z)
25244 !      include 'DIMENSIONS'
25245 !      include 'COMMON.GEO'
25246 !      include 'COMMON.VAR'
25247 !      include 'COMMON.LOCAL'
25248 !      include 'COMMON.CHAIN'
25249 !      include 'COMMON.DERIV'
25250 !      include 'COMMON.NAMES'
25251 !      include 'COMMON.INTERACT'
25252 !      include 'COMMON.IOUNITS'
25253 !      include 'COMMON.CALC'
25254 !      include 'COMMON.CONTROL'
25255 !      include 'COMMON.SBRIDGE'
25256       logical :: lprn
25257 !el local variables
25258       integer :: iint,itypi,itypi1,itypj,subchap
25259       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25260       real(kind=8) :: evdw,sig0ij
25261       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25262                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25263                 sslipi,sslipj,faclip
25264       integer :: ii
25265       real(kind=8) :: fracinbuf
25266        real (kind=8) :: escbase
25267        real (kind=8),dimension(4):: ener
25268        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25269        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25270       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
25271       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25272       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
25273       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25274       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25275       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
25276        real(kind=8),dimension(3,2)::chead,erhead_tail
25277        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25278        integer troll
25279        eps_out=80.0d0
25280        escbase=0.0d0
25281 !       do i=1,nres_molec(1)
25282       do i=ibond_start,ibond_end
25283       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25284       itypi  = itype(i,1)
25285       dxi    = dc_norm(1,nres+i)
25286       dyi    = dc_norm(2,nres+i)
25287       dzi    = dc_norm(3,nres+i)
25288       dsci_inv = vbld_inv(i+nres)
25289       xi=c(1,nres+i)
25290       yi=c(2,nres+i)
25291       zi=c(3,nres+i)
25292       call to_box(xi,yi,zi)
25293       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25294        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
25295          itypj= itype(j,2)
25296          if (itype(j,2).eq.ntyp1_molec(2))cycle
25297          xj=c(1,j+nres)
25298          yj=c(2,j+nres)
25299          zj=c(3,j+nres)
25300       call to_box(xj,yj,zj)
25301 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25302 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25303 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25304 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25305 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25306       xj=boxshift(xj-xi,boxxsize)
25307       yj=boxshift(yj-yi,boxysize)
25308       zj=boxshift(zj-zi,boxzsize)
25309
25310         dxj = dc_norm( 1, nres+j )
25311         dyj = dc_norm( 2, nres+j )
25312         dzj = dc_norm( 3, nres+j )
25313 !          print *,i,j,itypi,itypj
25314         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
25315         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
25316 !          d1i=0.0d0
25317 !          d1j=0.0d0
25318 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25319 ! Gay-berne var's
25320         sig0ij = sigma_scbase( itypi,itypj )
25321         if (sig0ij.lt.0.2) print *,"KURWA",sig0ij,itypi,itypj
25322         chi1   = chi_scbase( itypi, itypj,1 )
25323         chi2   = chi_scbase( itypi, itypj,2 )
25324 !          chi1=0.0d0
25325 !          chi2=0.0d0
25326         chi12  = chi1 * chi2
25327         chip1  = chipp_scbase( itypi, itypj,1 )
25328         chip2  = chipp_scbase( itypi, itypj,2 )
25329 !          chip1=0.0d0
25330 !          chip2=0.0d0
25331         chip12 = chip1 * chip2
25332 ! not used by momo potential, but needed by sc_angular which is shared
25333 ! by all energy_potential subroutines
25334         alf1   = 0.0d0
25335         alf2   = 0.0d0
25336         alf12  = 0.0d0
25337         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
25338 !       a12sq = a12sq * a12sq
25339 ! charge of amino acid itypi is...
25340         chis1 = chis_scbase(itypi,itypj,1)
25341         chis2 = chis_scbase(itypi,itypj,2)
25342         chis12 = chis1 * chis2
25343         sig1 = sigmap1_scbase(itypi,itypj)
25344         sig2 = sigmap2_scbase(itypi,itypj)
25345 !       write (*,*) "sig1 = ", sig1
25346 !       write (*,*) "sig2 = ", sig2
25347 ! alpha factors from Fcav/Gcav
25348         b1 = alphasur_scbase(1,itypi,itypj)
25349 !          b1=0.0d0
25350         b2 = alphasur_scbase(2,itypi,itypj)
25351         b3 = alphasur_scbase(3,itypi,itypj)
25352         b4 = alphasur_scbase(4,itypi,itypj)
25353 ! used to determine whether we want to do quadrupole calculations
25354 ! used by Fgb
25355        eps_in = epsintab_scbase(itypi,itypj)
25356        if (eps_in.eq.0.0) eps_in=1.0
25357        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25358 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25359 !-------------------------------------------------------------------
25360 ! tail location and distance calculations
25361        DO k = 1,3
25362 ! location of polar head is computed by taking hydrophobic centre
25363 ! and moving by a d1 * dc_norm vector
25364 ! see unres publications for very informative images
25365       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
25366       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
25367 ! distance
25368 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25369 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25370       Rhead_distance(k) = chead(k,2) - chead(k,1)
25371        END DO
25372 ! pitagoras (root of sum of squares)
25373        Rhead = dsqrt( &
25374         (Rhead_distance(1)*Rhead_distance(1)) &
25375       + (Rhead_distance(2)*Rhead_distance(2)) &
25376       + (Rhead_distance(3)*Rhead_distance(3)))
25377 !-------------------------------------------------------------------
25378 ! zero everything that should be zero'ed
25379        evdwij = 0.0d0
25380        ECL = 0.0d0
25381        Elj = 0.0d0
25382        Equad = 0.0d0
25383        Epol = 0.0d0
25384        Fcav=0.0d0
25385        eheadtail = 0.0d0
25386        dGCLdOM1 = 0.0d0
25387        dGCLdOM2 = 0.0d0
25388        dGCLdOM12 = 0.0d0
25389        dPOLdOM1 = 0.0d0
25390        dPOLdOM2 = 0.0d0
25391         Fcav = 0.0d0
25392         dFdR = 0.0d0
25393         dCAVdOM1  = 0.0d0
25394         dCAVdOM2  = 0.0d0
25395         dCAVdOM12 = 0.0d0
25396         dscj_inv = vbld_inv(j+nres)
25397 !          print *,i,j,dscj_inv,dsci_inv
25398 ! rij holds 1/(distance of Calpha atoms)
25399         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25400         rij  = dsqrt(rrij)
25401 !----------------------------
25402         CALL sc_angular
25403 ! this should be in elgrad_init but om's are calculated by sc_angular
25404 ! which in turn is used by older potentials
25405 ! om = omega, sqom = om^2
25406         sqom1  = om1 * om1
25407         sqom2  = om2 * om2
25408         sqom12 = om12 * om12
25409
25410 ! now we calculate EGB - Gey-Berne
25411 ! It will be summed up in evdwij and saved in evdw
25412         sigsq     = 1.0D0  / sigsq
25413         sig       = sig0ij * dsqrt(sigsq)
25414 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25415         rij_shift = 1.0/rij - sig + sig0ij
25416         IF (rij_shift.le.0.0D0) THEN
25417          evdw = 1.0D20
25418          RETURN
25419         END IF
25420         sigder = -sig * sigsq
25421         rij_shift = 1.0D0 / rij_shift
25422         fac       = rij_shift**expon
25423         c1        = fac  * fac * aa_scbase(itypi,itypj)
25424 !          c1        = 0.0d0
25425         c2        = fac  * bb_scbase(itypi,itypj)
25426 !          c2        = 0.0d0
25427         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25428         eps2der   = eps3rt * evdwij
25429         eps3der   = eps2rt * evdwij
25430 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25431         evdwij    = eps2rt * eps3rt * evdwij
25432         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25433         fac    = -expon * (c1 + evdwij) * rij_shift
25434         sigder = fac * sigder
25435 !          fac    = rij * fac
25436 ! Calculate distance derivative
25437         gg(1) =  fac
25438         gg(2) =  fac
25439         gg(3) =  fac
25440 !          if (b2.gt.0.0) then
25441         fac = chis1 * sqom1 + chis2 * sqom2 &
25442         - 2.0d0 * chis12 * om1 * om2 * om12
25443 ! we will use pom later in Gcav, so dont mess with it!
25444         pom = 1.0d0 - chis1 * chis2 * sqom12
25445         Lambf = (1.0d0 - (fac / pom))
25446         Lambf = dsqrt(Lambf)
25447         sparrow=dsqrt(sig1**2.0d0 + sig2**2.0d0)
25448         if (b1.eq.0.0d0) sparrow=1.0d0
25449         sparrow = 1.0d0 / sparrow
25450 !        write (*,*) "sparrow = ", sparrow,sig1,sig2,b1
25451         Chif = 1.0d0/rij * sparrow
25452         ChiLambf = Chif * Lambf
25453         eagle = dsqrt(ChiLambf)
25454         bat = ChiLambf ** 11.0d0
25455         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25456         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25457         botsq = bot * bot
25458         Fcav = top / bot
25459 !          print *,i,j,Fcav
25460         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25461         dbot = 12.0d0 * b4 * bat * Lambf
25462         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25463 !       dFdR = 0.0d0
25464 !      write (*,*) "dFcav/dR = ", dFdR
25465         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25466         dbot = 12.0d0 * b4 * bat * Chif
25467         eagle = Lambf * pom
25468         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25469         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25470         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25471             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25472
25473         dFdL = ((dtop * bot - top * dbot) / botsq)
25474 !       dFdL = 0.0d0
25475         dCAVdOM1  = dFdL * ( dFdOM1 )
25476         dCAVdOM2  = dFdL * ( dFdOM2 )
25477         dCAVdOM12 = dFdL * ( dFdOM12 )
25478
25479         ertail(1) = xj*rij
25480         ertail(2) = yj*rij
25481         ertail(3) = zj*rij
25482 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
25483 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
25484 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
25485 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
25486 !           print *,"EOMY",eom1,eom2,eom12
25487 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25488 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25489 ! here dtail=0.0
25490 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25491 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25492        DO k = 1, 3
25493 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25494 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25495       pom = ertail(k)
25496 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25497       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
25498               - (( dFdR + gg(k) ) * pom)
25499 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25500 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25501 !     &             - ( dFdR * pom )
25502       pom = ertail(k)
25503 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25504       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
25505               + (( dFdR + gg(k) ) * pom)
25506 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25507 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25508 !c!     &             + ( dFdR * pom )
25509
25510       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
25511               - (( dFdR + gg(k) ) * ertail(k))
25512 !c!     &             - ( dFdR * ertail(k))
25513
25514       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
25515               + (( dFdR + gg(k) ) * ertail(k))
25516 !c!     &             + ( dFdR * ertail(k))
25517
25518       gg(k) = 0.0d0
25519 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25520 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25521       END DO
25522
25523 !          else
25524
25525 !          endif
25526 !Now dipole-dipole
25527        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
25528        w1 = wdipdip_scbase(1,itypi,itypj)
25529        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
25530        w3 = wdipdip_scbase(2,itypi,itypj)
25531 !c!-------------------------------------------------------------------
25532 !c! ECL
25533        fac = (om12 - 3.0d0 * om1 * om2)
25534        c1 = (w1 / (Rhead**3.0d0)) * fac
25535        c2 = (w2 / Rhead ** 6.0d0)  &
25536        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25537        c3= (w3/ Rhead ** 6.0d0)  &
25538        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25539        ECL = c1 - c2 + c3
25540 !c!       write (*,*) "w1 = ", w1
25541 !c!       write (*,*) "w2 = ", w2
25542 !c!       write (*,*) "om1 = ", om1
25543 !c!       write (*,*) "om2 = ", om2
25544 !c!       write (*,*) "om12 = ", om12
25545 !c!       write (*,*) "fac = ", fac
25546 !c!       write (*,*) "c1 = ", c1
25547 !c!       write (*,*) "c2 = ", c2
25548 !c!       write (*,*) "Ecl = ", Ecl
25549 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
25550 !c!       write (*,*) "c2_2 = ",
25551 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25552 !c!-------------------------------------------------------------------
25553 !c! dervative of ECL is GCL...
25554 !c! dECL/dr
25555        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25556        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25557        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25558        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
25559        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25560        dGCLdR = c1 - c2 + c3
25561 !c! dECL/dom1
25562        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25563        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25564        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25565        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
25566        dGCLdOM1 = c1 - c2 + c3
25567 !c! dECL/dom2
25568        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25569        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25570        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25571        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
25572        dGCLdOM2 = c1 - c2 + c3
25573 !c! dECL/dom12
25574        c1 = w1 / (Rhead ** 3.0d0)
25575        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25576        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
25577        dGCLdOM12 = c1 - c2 + c3
25578        DO k= 1, 3
25579       erhead(k) = Rhead_distance(k)/Rhead
25580        END DO
25581        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25582        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25583        facd1 = d1i * vbld_inv(i+nres)
25584        facd2 = d1j * vbld_inv(j+nres)
25585        DO k = 1, 3
25586
25587       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25588       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
25589               - dGCLdR * pom
25590       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25591       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
25592               + dGCLdR * pom
25593
25594       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
25595               - dGCLdR * erhead(k)
25596       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
25597               + dGCLdR * erhead(k)
25598        END DO
25599        endif
25600 !now charge with dipole eg. ARG-dG
25601        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
25602       alphapol1 = alphapol_scbase(itypi,itypj)
25603        w1        = wqdip_scbase(1,itypi,itypj)
25604        w2        = wqdip_scbase(2,itypi,itypj)
25605 !       w1=0.0d0
25606 !       w2=0.0d0
25607 !       pis       = sig0head_scbase(itypi,itypj)
25608 !       eps_head   = epshead_scbase(itypi,itypj)
25609 !c!-------------------------------------------------------------------
25610 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25611        R1 = 0.0d0
25612        DO k = 1, 3
25613 !c! Calculate head-to-tail distances tail is center of side-chain
25614       R1=R1+(c(k,j+nres)-chead(k,1))**2
25615        END DO
25616 !c! Pitagoras
25617        R1 = dsqrt(R1)
25618
25619 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25620 !c!     &        +dhead(1,1,itypi,itypj))**2))
25621 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25622 !c!     &        +dhead(2,1,itypi,itypj))**2))
25623
25624 !c!-------------------------------------------------------------------
25625 !c! ecl
25626        sparrow  = w1  *  om1
25627        hawk     = w2 *  (1.0d0 - sqom2)
25628        Ecl = sparrow / Rhead**2.0d0 &
25629          - hawk    / Rhead**4.0d0
25630 !c!-------------------------------------------------------------------
25631 !c! derivative of ecl is Gcl
25632 !c! dF/dr part
25633        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25634             + 4.0d0 * hawk    / Rhead**5.0d0
25635 !c! dF/dom1
25636        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25637 !c! dF/dom2
25638        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25639 !c--------------------------------------------------------------------
25640 !c Polarization energy
25641 !c Epol
25642        MomoFac1 = (1.0d0 - chi1 * sqom2)
25643        RR1  = R1 * R1 / MomoFac1
25644        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25645        fgb1 = sqrt( RR1 + a12sq * ee1)
25646 !       eps_inout_fac=0.0d0
25647        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25648 ! derivative of Epol is Gpol...
25649        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25650             / (fgb1 ** 5.0d0)
25651        dFGBdR1 = ( (R1 / MomoFac1) &
25652            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25653            / ( 2.0d0 * fgb1 )
25654        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25655              * (2.0d0 - 0.5d0 * ee1) ) &
25656              / (2.0d0 * fgb1)
25657        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25658 !       dPOLdR1 = 0.0d0
25659        dPOLdOM1 = 0.0d0
25660        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25661        DO k = 1, 3
25662       erhead(k) = Rhead_distance(k)/Rhead
25663       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
25664        END DO
25665
25666        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25667        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25668        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25669 !       bat=0.0d0
25670        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25671        facd1 = d1i * vbld_inv(i+nres)
25672        facd2 = d1j * vbld_inv(j+nres)
25673 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25674
25675        DO k = 1, 3
25676       hawk = (erhead_tail(k,1) + &
25677       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25678 !        facd1=0.0d0
25679 !        facd2=0.0d0
25680       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25681       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
25682                - dGCLdR * pom &
25683                - dPOLdR1 *  (erhead_tail(k,1))
25684 !     &             - dGLJdR * pom
25685
25686       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25687       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
25688                + dGCLdR * pom  &
25689                + dPOLdR1 * (erhead_tail(k,1))
25690 !     &             + dGLJdR * pom
25691
25692
25693       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
25694               - dGCLdR * erhead(k) &
25695               - dPOLdR1 * erhead_tail(k,1)
25696 !     &             - dGLJdR * erhead(k)
25697
25698       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
25699               + dGCLdR * erhead(k)  &
25700               + dPOLdR1 * erhead_tail(k,1)
25701 !     &             + dGLJdR * erhead(k)
25702
25703        END DO
25704        endif
25705 !       print *,i,j,evdwij,epol,Fcav,ECL
25706        escbase=escbase+evdwij+epol+Fcav+ECL
25707        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25708       "escbase:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escbase
25709        if (energy_dec) write (iout,*) "evdwij,", evdwij, 1.0/rij, sig, sig0ij
25710        call sc_grad_scbase
25711        enddo
25712       enddo
25713
25714       return
25715       end subroutine eprot_sc_base
25716       SUBROUTINE sc_grad_scbase
25717       use calc_data
25718
25719        real (kind=8) :: dcosom1(3),dcosom2(3)
25720        eom1  =    &
25721             eps2der * eps2rt_om1   &
25722           - 2.0D0 * alf1 * eps3der &
25723           + sigder * sigsq_om1     &
25724           + dCAVdOM1               &
25725           + dGCLdOM1               &
25726           + dPOLdOM1
25727
25728        eom2  =  &
25729             eps2der * eps2rt_om2   &
25730           + 2.0D0 * alf2 * eps3der &
25731           + sigder * sigsq_om2     &
25732           + dCAVdOM2               &
25733           + dGCLdOM2               &
25734           + dPOLdOM2
25735
25736        eom12 =    &
25737             evdwij  * eps1_om12     &
25738           + eps2der * eps2rt_om12   &
25739           - 2.0D0 * alf12 * eps3der &
25740           + sigder *sigsq_om12      &
25741           + dCAVdOM12               &
25742           + dGCLdOM12
25743
25744 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25745 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25746 !               gg(1),gg(2),"rozne"
25747        DO k = 1, 3
25748       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25749       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25750       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25751       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
25752              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25753              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25754       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
25755              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25756              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25757       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
25758       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
25759        END DO
25760
25761        RETURN
25762       END SUBROUTINE sc_grad_scbase
25763
25764
25765       subroutine epep_sc_base(epepbase)
25766       use calc_data
25767       logical :: lprn
25768 !el local variables
25769       integer :: iint,itypi,itypi1,itypj,subchap
25770       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25771       real(kind=8) :: evdw,sig0ij
25772       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25773                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25774                 sslipi,sslipj,faclip
25775       integer :: ii
25776       real(kind=8) :: fracinbuf
25777        real (kind=8) :: epepbase
25778        real (kind=8),dimension(4):: ener
25779        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25780        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25781       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
25782       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25783       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
25784       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25785       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25786       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
25787        real(kind=8),dimension(3,2)::chead,erhead_tail
25788        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25789        integer troll
25790        eps_out=80.0d0
25791        epepbase=0.0d0
25792 !       do i=1,nres_molec(1)-1
25793       do i=ibond_start,ibond_end
25794       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
25795 !C        itypi  = itype(i,1)
25796       dxi    = dc_norm(1,i)
25797       dyi    = dc_norm(2,i)
25798       dzi    = dc_norm(3,i)
25799 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
25800       dsci_inv = vbld_inv(i+1)/2.0
25801       xi=(c(1,i)+c(1,i+1))/2.0
25802       yi=(c(2,i)+c(2,i+1))/2.0
25803       zi=(c(3,i)+c(3,i+1))/2.0
25804         call to_box(xi,yi,zi)
25805        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
25806          itypj= itype(j,2)
25807          if (itype(j,2).eq.ntyp1_molec(2))cycle
25808          xj=c(1,j+nres)
25809          yj=c(2,j+nres)
25810          zj=c(3,j+nres)
25811                 call to_box(xj,yj,zj)
25812       xj=boxshift(xj-xi,boxxsize)
25813       yj=boxshift(yj-yi,boxysize)
25814       zj=boxshift(zj-zi,boxzsize)
25815         dist_init=xj**2+yj**2+zj**2
25816         dxj = dc_norm( 1, nres+j )
25817         dyj = dc_norm( 2, nres+j )
25818         dzj = dc_norm( 3, nres+j )
25819 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
25820 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
25821
25822 ! Gay-berne var's
25823         sig0ij = sigma_pepbase(itypj )
25824         chi1   = chi_pepbase(itypj,1 )
25825         chi2   = chi_pepbase(itypj,2 )
25826 !          chi1=0.0d0
25827 !          chi2=0.0d0
25828         chi12  = chi1 * chi2
25829         chip1  = chipp_pepbase(itypj,1 )
25830         chip2  = chipp_pepbase(itypj,2 )
25831 !          chip1=0.0d0
25832 !          chip2=0.0d0
25833         chip12 = chip1 * chip2
25834         chis1 = chis_pepbase(itypj,1)
25835         chis2 = chis_pepbase(itypj,2)
25836         chis12 = chis1 * chis2
25837         sig1 = sigmap1_pepbase(itypj)
25838         sig2 = sigmap2_pepbase(itypj)
25839 !       write (*,*) "sig1 = ", sig1
25840 !       write (*,*) "sig2 = ", sig2
25841        DO k = 1,3
25842 ! location of polar head is computed by taking hydrophobic centre
25843 ! and moving by a d1 * dc_norm vector
25844 ! see unres publications for very informative images
25845       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
25846 ! + d1i * dc_norm(k, i+nres)
25847       chead(k,2) = c(k, j+nres)
25848 ! + d1j * dc_norm(k, j+nres)
25849 ! distance
25850 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25851 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25852       Rhead_distance(k) = chead(k,2) - chead(k,1)
25853 !        print *,gvdwc_pepbase(k,i)
25854
25855        END DO
25856        Rhead = dsqrt( &
25857         (Rhead_distance(1)*Rhead_distance(1)) &
25858       + (Rhead_distance(2)*Rhead_distance(2)) &
25859       + (Rhead_distance(3)*Rhead_distance(3)))
25860
25861 ! alpha factors from Fcav/Gcav
25862         b1 = alphasur_pepbase(1,itypj)
25863 !          b1=0.0d0
25864         b2 = alphasur_pepbase(2,itypj)
25865         b3 = alphasur_pepbase(3,itypj)
25866         b4 = alphasur_pepbase(4,itypj)
25867         alf1   = 0.0d0
25868         alf2   = 0.0d0
25869         alf12  = 0.0d0
25870         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25871 !          print *,i,j,rrij
25872         rij  = dsqrt(rrij)
25873 !----------------------------
25874        evdwij = 0.0d0
25875        ECL = 0.0d0
25876        Elj = 0.0d0
25877        Equad = 0.0d0
25878        Epol = 0.0d0
25879        Fcav=0.0d0
25880        eheadtail = 0.0d0
25881        dGCLdOM1 = 0.0d0
25882        dGCLdOM2 = 0.0d0
25883        dGCLdOM12 = 0.0d0
25884        dPOLdOM1 = 0.0d0
25885        dPOLdOM2 = 0.0d0
25886         Fcav = 0.0d0
25887         dFdR = 0.0d0
25888         dCAVdOM1  = 0.0d0
25889         dCAVdOM2  = 0.0d0
25890         dCAVdOM12 = 0.0d0
25891         dscj_inv = vbld_inv(j+nres)
25892         CALL sc_angular
25893 ! this should be in elgrad_init but om's are calculated by sc_angular
25894 ! which in turn is used by older potentials
25895 ! om = omega, sqom = om^2
25896         sqom1  = om1 * om1
25897         sqom2  = om2 * om2
25898         sqom12 = om12 * om12
25899
25900 ! now we calculate EGB - Gey-Berne
25901 ! It will be summed up in evdwij and saved in evdw
25902         sigsq     = 1.0D0  / sigsq
25903         sig       = sig0ij * dsqrt(sigsq)
25904         rij_shift = 1.0/rij - sig + sig0ij
25905         IF (rij_shift.le.0.0D0) THEN
25906          evdw = 1.0D20
25907          RETURN
25908         END IF
25909         sigder = -sig * sigsq
25910         rij_shift = 1.0D0 / rij_shift
25911         fac       = rij_shift**expon
25912         c1        = fac  * fac * aa_pepbase(itypj)
25913 !          c1        = 0.0d0
25914         c2        = fac  * bb_pepbase(itypj)
25915 !          c2        = 0.0d0
25916         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25917         eps2der   = eps3rt * evdwij
25918         eps3der   = eps2rt * evdwij
25919 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25920         evdwij    = eps2rt * eps3rt * evdwij
25921         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25922         fac    = -expon * (c1 + evdwij) * rij_shift
25923         sigder = fac * sigder
25924 !          fac    = rij * fac
25925 ! Calculate distance derivative
25926         gg(1) =  fac
25927         gg(2) =  fac
25928         gg(3) =  fac
25929         fac = chis1 * sqom1 + chis2 * sqom2 &
25930         - 2.0d0 * chis12 * om1 * om2 * om12
25931 ! we will use pom later in Gcav, so dont mess with it!
25932         pom = 1.0d0 - chis1 * chis2 * sqom12
25933         Lambf = (1.0d0 - (fac / pom))
25934         Lambf = dsqrt(Lambf)
25935         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25936 !       write (*,*) "sparrow = ", sparrow
25937         Chif = 1.0d0/rij * sparrow
25938         ChiLambf = Chif * Lambf
25939         eagle = dsqrt(ChiLambf)
25940         bat = ChiLambf ** 11.0d0
25941         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25942         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25943         botsq = bot * bot
25944         Fcav = top / bot
25945 !          print *,i,j,Fcav
25946         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25947         dbot = 12.0d0 * b4 * bat * Lambf
25948         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25949 !       dFdR = 0.0d0
25950 !      write (*,*) "dFcav/dR = ", dFdR
25951         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25952         dbot = 12.0d0 * b4 * bat * Chif
25953         eagle = Lambf * pom
25954         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25955         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25956         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25957             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25958
25959         dFdL = ((dtop * bot - top * dbot) / botsq)
25960 !       dFdL = 0.0d0
25961         dCAVdOM1  = dFdL * ( dFdOM1 )
25962         dCAVdOM2  = dFdL * ( dFdOM2 )
25963         dCAVdOM12 = dFdL * ( dFdOM12 )
25964
25965         ertail(1) = xj*rij
25966         ertail(2) = yj*rij
25967         ertail(3) = zj*rij
25968        DO k = 1, 3
25969 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25970 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25971       pom = ertail(k)
25972 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25973       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25974               - (( dFdR + gg(k) ) * pom)/2.0
25975 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
25976 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25977 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25978 !     &             - ( dFdR * pom )
25979       pom = ertail(k)
25980 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25981       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25982               + (( dFdR + gg(k) ) * pom)
25983 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25984 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25985 !c!     &             + ( dFdR * pom )
25986
25987       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25988               - (( dFdR + gg(k) ) * ertail(k))/2.0
25989 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
25990
25991 !c!     &             - ( dFdR * ertail(k))
25992
25993       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25994               + (( dFdR + gg(k) ) * ertail(k))
25995 !c!     &             + ( dFdR * ertail(k))
25996
25997       gg(k) = 0.0d0
25998 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25999 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26000       END DO
26001
26002
26003        w1 = wdipdip_pepbase(1,itypj)
26004        w2 = -wdipdip_pepbase(3,itypj)/2.0
26005        w3 = wdipdip_pepbase(2,itypj)
26006 !       w1=0.0d0
26007 !       w2=0.0d0
26008 !c!-------------------------------------------------------------------
26009 !c! ECL
26010 !       w3=0.0d0
26011        fac = (om12 - 3.0d0 * om1 * om2)
26012        c1 = (w1 / (Rhead**3.0d0)) * fac
26013        c2 = (w2 / Rhead ** 6.0d0)  &
26014        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26015        c3= (w3/ Rhead ** 6.0d0)  &
26016        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
26017
26018        ECL = c1 - c2 + c3
26019
26020        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
26021        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
26022        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
26023        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
26024        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
26025
26026        dGCLdR = c1 - c2 + c3
26027 !c! dECL/dom1
26028        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
26029        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26030        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
26031        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
26032        dGCLdOM1 = c1 - c2 + c3
26033 !c! dECL/dom2
26034        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
26035        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26036        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
26037        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
26038
26039        dGCLdOM2 = c1 - c2 + c3
26040 !c! dECL/dom12
26041        c1 = w1 / (Rhead ** 3.0d0)
26042        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
26043        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
26044        dGCLdOM12 = c1 - c2 + c3
26045        DO k= 1, 3
26046       erhead(k) = Rhead_distance(k)/Rhead
26047        END DO
26048        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26049        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26050 !       facd1 = d1 * vbld_inv(i+nres)
26051 !       facd2 = d2 * vbld_inv(j+nres)
26052        DO k = 1, 3
26053
26054 !        pom = erhead(k)
26055 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26056 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
26057 !                  - dGCLdR * pom
26058       pom = erhead(k)
26059 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26060       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
26061               + dGCLdR * pom
26062
26063       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
26064               - dGCLdR * erhead(k)/2.0d0
26065 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
26066       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
26067               - dGCLdR * erhead(k)/2.0d0
26068 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
26069       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
26070               + dGCLdR * erhead(k)
26071        END DO
26072 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
26073        epepbase=epepbase+evdwij+Fcav+ECL
26074        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
26075       "epepbase:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,epepbase
26076        call sc_grad_pepbase
26077        enddo
26078        enddo
26079       END SUBROUTINE epep_sc_base
26080       SUBROUTINE sc_grad_pepbase
26081       use calc_data
26082
26083        real (kind=8) :: dcosom1(3),dcosom2(3)
26084        eom1  =    &
26085             eps2der * eps2rt_om1   &
26086           - 2.0D0 * alf1 * eps3der &
26087           + sigder * sigsq_om1     &
26088           + dCAVdOM1               &
26089           + dGCLdOM1               &
26090           + dPOLdOM1
26091
26092        eom2  =  &
26093             eps2der * eps2rt_om2   &
26094           + 2.0D0 * alf2 * eps3der &
26095           + sigder * sigsq_om2     &
26096           + dCAVdOM2               &
26097           + dGCLdOM2               &
26098           + dPOLdOM2
26099
26100        eom12 =    &
26101             evdwij  * eps1_om12     &
26102           + eps2der * eps2rt_om12   &
26103           - 2.0D0 * alf12 * eps3der &
26104           + sigder *sigsq_om12      &
26105           + dCAVdOM12               &
26106           + dGCLdOM12
26107 !        om12=0.0
26108 !        eom12=0.0
26109 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
26110 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
26111 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
26112 !                 *dsci_inv*2.0
26113 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
26114 !               gg(1),gg(2),"rozne"
26115        DO k = 1, 3
26116       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
26117       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26118       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26119       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
26120              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
26121              *dsci_inv*2.0 &
26122              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26123       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
26124              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
26125              *dsci_inv*2.0 &
26126              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26127 !         print *,eom12,eom2,om12,om2
26128 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
26129 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
26130       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
26131              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
26132              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26133       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
26134        END DO
26135        RETURN
26136       END SUBROUTINE sc_grad_pepbase
26137       subroutine eprot_sc_phosphate(escpho)
26138       use calc_data
26139 !      implicit real(kind=8) (a-h,o-z)
26140 !      include 'DIMENSIONS'
26141 !      include 'COMMON.GEO'
26142 !      include 'COMMON.VAR'
26143 !      include 'COMMON.LOCAL'
26144 !      include 'COMMON.CHAIN'
26145 !      include 'COMMON.DERIV'
26146 !      include 'COMMON.NAMES'
26147 !      include 'COMMON.INTERACT'
26148 !      include 'COMMON.IOUNITS'
26149 !      include 'COMMON.CALC'
26150 !      include 'COMMON.CONTROL'
26151 !      include 'COMMON.SBRIDGE'
26152       logical :: lprn
26153 !el local variables
26154       integer :: iint,itypi,itypi1,itypj,subchap
26155       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
26156       real(kind=8) :: evdw,sig0ij,aa,bb
26157       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26158                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
26159                 sslipi,sslipj,faclip,alpha_sco
26160       integer :: ii
26161       real(kind=8) :: fracinbuf
26162        real (kind=8) :: escpho
26163        real (kind=8),dimension(4):: ener
26164        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
26165        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
26166       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
26167       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
26168       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
26169       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
26170       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
26171       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
26172        real(kind=8),dimension(3,2)::chead,erhead_tail
26173        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
26174        integer troll
26175        eps_out=80.0d0
26176        escpho=0.0d0
26177 !       do i=1,nres_molec(1)
26178       do i=ibond_start,ibond_end
26179       if (itype(i,1).eq.ntyp1_molec(1)) cycle
26180       itypi  = itype(i,1)
26181       dxi    = dc_norm(1,nres+i)
26182       dyi    = dc_norm(2,nres+i)
26183       dzi    = dc_norm(3,nres+i)
26184       dsci_inv = vbld_inv(i+nres)
26185       xi=c(1,nres+i)
26186       yi=c(2,nres+i)
26187       zi=c(3,nres+i)
26188        call to_box(xi,yi,zi)
26189       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
26190        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
26191          itypj= itype(j,2)
26192          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
26193           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
26194          xj=(c(1,j)+c(1,j+1))/2.0
26195          yj=(c(2,j)+c(2,j+1))/2.0
26196          zj=(c(3,j)+c(3,j+1))/2.0
26197      call to_box(xj,yj,zj)
26198 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
26199 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26200 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26201 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26202 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26203       xj=boxshift(xj-xi,boxxsize)
26204       yj=boxshift(yj-yi,boxysize)
26205       zj=boxshift(zj-zi,boxzsize)
26206           dxj = dc_norm( 1,j )
26207         dyj = dc_norm( 2,j )
26208         dzj = dc_norm( 3,j )
26209         dscj_inv = vbld_inv(j+1)
26210
26211 ! Gay-berne var's
26212         sig0ij = sigma_scpho(itypi )
26213         chi1   = chi_scpho(itypi,1 )
26214         chi2   = chi_scpho(itypi,2 )
26215 !          chi1=0.0d0
26216 !          chi2=0.0d0
26217         chi12  = chi1 * chi2
26218         chip1  = chipp_scpho(itypi,1 )
26219         chip2  = chipp_scpho(itypi,2 )
26220 !          chip1=0.0d0
26221 !          chip2=0.0d0
26222         chip12 = chip1 * chip2
26223         chis1 = chis_scpho(itypi,1)
26224         chis2 = chis_scpho(itypi,2)
26225         chis12 = chis1 * chis2
26226         sig1 = sigmap1_scpho(itypi)
26227         sig2 = sigmap2_scpho(itypi)
26228 !       write (*,*) "sig1 = ", sig1
26229 !       write (*,*) "sig1 = ", sig1
26230 !       write (*,*) "sig2 = ", sig2
26231 ! alpha factors from Fcav/Gcav
26232         alf1   = 0.0d0
26233         alf2   = 0.0d0
26234         alf12  = 0.0d0
26235         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
26236
26237         b1 = alphasur_scpho(1,itypi)
26238 !          b1=0.0d0
26239         b2 = alphasur_scpho(2,itypi)
26240         b3 = alphasur_scpho(3,itypi)
26241         b4 = alphasur_scpho(4,itypi)
26242 ! used to determine whether we want to do quadrupole calculations
26243 ! used by Fgb
26244        eps_in = epsintab_scpho(itypi)
26245        if (eps_in.eq.0.0) eps_in=1.0
26246        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26247 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26248 !-------------------------------------------------------------------
26249 ! tail location and distance calculations
26250         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
26251         d1j = 0.0
26252        DO k = 1,3
26253 ! location of polar head is computed by taking hydrophobic centre
26254 ! and moving by a d1 * dc_norm vector
26255 ! see unres publications for very informative images
26256       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
26257       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
26258 ! distance
26259 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26260 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26261       Rhead_distance(k) = chead(k,2) - chead(k,1)
26262        END DO
26263 ! pitagoras (root of sum of squares)
26264        Rhead = dsqrt( &
26265         (Rhead_distance(1)*Rhead_distance(1)) &
26266       + (Rhead_distance(2)*Rhead_distance(2)) &
26267       + (Rhead_distance(3)*Rhead_distance(3)))
26268        Rhead_sq=Rhead**2.0
26269 !-------------------------------------------------------------------
26270 ! zero everything that should be zero'ed
26271        evdwij = 0.0d0
26272        ECL = 0.0d0
26273        Elj = 0.0d0
26274        Equad = 0.0d0
26275        Epol = 0.0d0
26276        Fcav=0.0d0
26277        eheadtail = 0.0d0
26278        dGCLdR=0.0d0
26279        dGCLdOM1 = 0.0d0
26280        dGCLdOM2 = 0.0d0
26281        dGCLdOM12 = 0.0d0
26282        dPOLdOM1 = 0.0d0
26283        dPOLdOM2 = 0.0d0
26284         Fcav = 0.0d0
26285         dFdR = 0.0d0
26286         dCAVdOM1  = 0.0d0
26287         dCAVdOM2  = 0.0d0
26288         dCAVdOM12 = 0.0d0
26289         dscj_inv = vbld_inv(j+1)/2.0
26290 !dhead_scbasej(itypi,itypj)
26291 !          print *,i,j,dscj_inv,dsci_inv
26292 ! rij holds 1/(distance of Calpha atoms)
26293         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26294         rij  = dsqrt(rrij)
26295 !----------------------------
26296         CALL sc_angular
26297 ! this should be in elgrad_init but om's are calculated by sc_angular
26298 ! which in turn is used by older potentials
26299 ! om = omega, sqom = om^2
26300         sqom1  = om1 * om1
26301         sqom2  = om2 * om2
26302         sqom12 = om12 * om12
26303
26304 ! now we calculate EGB - Gey-Berne
26305 ! It will be summed up in evdwij and saved in evdw
26306         sigsq     = 1.0D0  / sigsq
26307         sig       = sig0ij * dsqrt(sigsq)
26308 !          rij_shift = 1.0D0  / rij - sig + sig0ij
26309         rij_shift = 1.0/rij - sig + sig0ij
26310         IF (rij_shift.le.0.0D0) THEN
26311          evdw = 1.0D20
26312          RETURN
26313         END IF
26314         sigder = -sig * sigsq
26315         rij_shift = 1.0D0 / rij_shift
26316         fac       = rij_shift**expon
26317         c1        = fac  * fac * aa_scpho(itypi)
26318 !          c1        = 0.0d0
26319         c2        = fac  * bb_scpho(itypi)
26320 !          c2        = 0.0d0
26321         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
26322         eps2der   = eps3rt * evdwij
26323         eps3der   = eps2rt * evdwij
26324 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
26325         evdwij    = eps2rt * eps3rt * evdwij
26326         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
26327         fac    = -expon * (c1 + evdwij) * rij_shift
26328         sigder = fac * sigder
26329 !          fac    = rij * fac
26330 ! Calculate distance derivative
26331         gg(1) =  fac
26332         gg(2) =  fac
26333         gg(3) =  fac
26334         fac = chis1 * sqom1 + chis2 * sqom2 &
26335         - 2.0d0 * chis12 * om1 * om2 * om12
26336 ! we will use pom later in Gcav, so dont mess with it!
26337         pom = 1.0d0 - chis1 * chis2 * sqom12
26338         Lambf = (1.0d0 - (fac / pom))
26339         Lambf = dsqrt(Lambf)
26340         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
26341 !       write (*,*) "sparrow = ", sparrow
26342         Chif = 1.0d0/rij * sparrow
26343         ChiLambf = Chif * Lambf
26344         eagle = dsqrt(ChiLambf)
26345         bat = ChiLambf ** 11.0d0
26346         top = b1 * ( eagle + b2 * ChiLambf - b3 )
26347         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
26348         botsq = bot * bot
26349         Fcav = top / bot
26350         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
26351         dbot = 12.0d0 * b4 * bat * Lambf
26352         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
26353 !       dFdR = 0.0d0
26354 !      write (*,*) "dFcav/dR = ", dFdR
26355         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
26356         dbot = 12.0d0 * b4 * bat * Chif
26357         eagle = Lambf * pom
26358         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
26359         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
26360         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
26361             * (chis2 * om2 * om12 - om1) / (eagle * pom)
26362
26363         dFdL = ((dtop * bot - top * dbot) / botsq)
26364 !       dFdL = 0.0d0
26365         dCAVdOM1  = dFdL * ( dFdOM1 )
26366         dCAVdOM2  = dFdL * ( dFdOM2 )
26367         dCAVdOM12 = dFdL * ( dFdOM12 )
26368
26369         ertail(1) = xj*rij
26370         ertail(2) = yj*rij
26371         ertail(3) = zj*rij
26372        DO k = 1, 3
26373 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26374 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26375 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
26376
26377       pom = ertail(k)
26378 !        print *,pom,gg(k),dFdR
26379 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
26380       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
26381               - (( dFdR + gg(k) ) * pom)
26382 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
26383 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26384 !     &             - ( dFdR * pom )
26385 !        pom = ertail(k)
26386 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
26387 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
26388 !                  + (( dFdR + gg(k) ) * pom)
26389 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26390 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26391 !c!     &             + ( dFdR * pom )
26392
26393       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
26394               - (( dFdR + gg(k) ) * ertail(k))
26395 !c!     &             - ( dFdR * ertail(k))
26396
26397       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
26398               + (( dFdR + gg(k) ) * ertail(k))/2.0
26399
26400       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
26401               + (( dFdR + gg(k) ) * ertail(k))/2.0
26402
26403 !c!     &             + ( dFdR * ertail(k))
26404
26405       gg(k) = 0.0d0
26406       ENDDO
26407 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26408 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26409 !      alphapol1 = alphapol_scpho(itypi)
26410        if (wqq_scpho(itypi).ne.0.0) then
26411        Qij=wqq_scpho(itypi)/eps_in
26412        alpha_sco=1.d0/alphi_scpho(itypi)
26413 !       Qij=0.0
26414        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
26415 !c! derivative of Ecl is Gcl...
26416        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
26417             (Rhead*alpha_sco+1) ) / Rhead_sq
26418        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
26419        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
26420        w1        = wqdip_scpho(1,itypi)
26421        w2        = wqdip_scpho(2,itypi)
26422 !       w1=0.0d0
26423 !       w2=0.0d0
26424 !       pis       = sig0head_scbase(itypi,itypj)
26425 !       eps_head   = epshead_scbase(itypi,itypj)
26426 !c!-------------------------------------------------------------------
26427
26428 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26429 !c!     &        +dhead(1,1,itypi,itypj))**2))
26430 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26431 !c!     &        +dhead(2,1,itypi,itypj))**2))
26432
26433 !c!-------------------------------------------------------------------
26434 !c! ecl
26435        sparrow  = w1  *  om1
26436        hawk     = w2 *  (1.0d0 - sqom2)
26437        Ecl = sparrow / Rhead**2.0d0 &
26438          - hawk    / Rhead**4.0d0
26439 !c!-------------------------------------------------------------------
26440        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
26441          1.0/rij,sparrow
26442
26443 !c! derivative of ecl is Gcl
26444 !c! dF/dr part
26445        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26446             + 4.0d0 * hawk    / Rhead**5.0d0
26447 !c! dF/dom1
26448        dGCLdOM1 = (w1) / (Rhead**2.0d0)
26449 !c! dF/dom2
26450        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
26451        endif
26452
26453 !c--------------------------------------------------------------------
26454 !c Polarization energy
26455 !c Epol
26456        R1 = 0.0d0
26457        DO k = 1, 3
26458 !c! Calculate head-to-tail distances tail is center of side-chain
26459       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
26460        END DO
26461 !c! Pitagoras
26462        R1 = dsqrt(R1)
26463
26464       alphapol1 = alphapol_scpho(itypi)
26465 !      alphapol1=0.0
26466        MomoFac1 = (1.0d0 - chi2 * sqom1)
26467        RR1  = R1 * R1 / MomoFac1
26468        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26469 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
26470        fgb1 = sqrt( RR1 + a12sq * ee1)
26471 !       eps_inout_fac=0.0d0
26472        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26473 ! derivative of Epol is Gpol...
26474        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26475             / (fgb1 ** 5.0d0)
26476        dFGBdR1 = ( (R1 / MomoFac1) &
26477            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26478            / ( 2.0d0 * fgb1 )
26479        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26480              * (2.0d0 - 0.5d0 * ee1) ) &
26481              / (2.0d0 * fgb1)
26482        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26483 !       dPOLdR1 = 0.0d0
26484 !       dPOLdOM1 = 0.0d0
26485        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
26486              * (2.0d0 - 0.5d0 * ee1) ) &
26487              / (2.0d0 * fgb1)
26488
26489        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
26490        dPOLdOM2 = 0.0
26491        DO k = 1, 3
26492       erhead(k) = Rhead_distance(k)/Rhead
26493       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
26494        END DO
26495
26496        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26497        erdxj = scalar( erhead(1), dC_norm(1,j) )
26498        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26499 !       bat=0.0d0
26500        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26501        facd1 = d1i * vbld_inv(i+nres)
26502        facd2 = d1j * vbld_inv(j)
26503 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26504
26505        DO k = 1, 3
26506       hawk = (erhead_tail(k,1) + &
26507       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26508 !        facd1=0.0d0
26509 !        facd2=0.0d0
26510 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
26511 !                pom,(erhead_tail(k,1))
26512
26513 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
26514       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26515       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
26516                - dGCLdR * pom &
26517                - dPOLdR1 *  (erhead_tail(k,1))
26518 !     &             - dGLJdR * pom
26519
26520       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26521 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
26522 !                   + dGCLdR * pom  &
26523 !                   + dPOLdR1 * (erhead_tail(k,1))
26524 !     &             + dGLJdR * pom
26525
26526
26527       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
26528               - dGCLdR * erhead(k) &
26529               - dPOLdR1 * erhead_tail(k,1)
26530 !     &             - dGLJdR * erhead(k)
26531
26532       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
26533               + (dGCLdR * erhead(k)  &
26534               + dPOLdR1 * erhead_tail(k,1))/2.0
26535       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
26536               + (dGCLdR * erhead(k)  &
26537               + dPOLdR1 * erhead_tail(k,1))/2.0
26538
26539 !     &             + dGLJdR * erhead(k)
26540 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
26541
26542        END DO
26543 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
26544        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
26545       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
26546        escpho=escpho+evdwij+epol+Fcav+ECL
26547        call sc_grad_scpho
26548        enddo
26549
26550       enddo
26551
26552       return
26553       end subroutine eprot_sc_phosphate
26554       SUBROUTINE sc_grad_scpho
26555       use calc_data
26556
26557        real (kind=8) :: dcosom1(3),dcosom2(3)
26558        eom1  =    &
26559             eps2der * eps2rt_om1   &
26560           - 2.0D0 * alf1 * eps3der &
26561           + sigder * sigsq_om1     &
26562           + dCAVdOM1               &
26563           + dGCLdOM1               &
26564           + dPOLdOM1
26565
26566        eom2  =  &
26567             eps2der * eps2rt_om2   &
26568           + 2.0D0 * alf2 * eps3der &
26569           + sigder * sigsq_om2     &
26570           + dCAVdOM2               &
26571           + dGCLdOM2               &
26572           + dPOLdOM2
26573
26574        eom12 =    &
26575             evdwij  * eps1_om12     &
26576           + eps2der * eps2rt_om12   &
26577           - 2.0D0 * alf12 * eps3der &
26578           + sigder *sigsq_om12      &
26579           + dCAVdOM12               &
26580           + dGCLdOM12
26581 !        om12=0.0
26582 !        eom12=0.0
26583 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
26584 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
26585 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
26586 !                 *dsci_inv*2.0
26587 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
26588 !               gg(1),gg(2),"rozne"
26589        DO k = 1, 3
26590       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26591       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
26592       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26593       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
26594              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
26595              *dscj_inv*2.0 &
26596              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26597       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
26598              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
26599              *dscj_inv*2.0 &
26600              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26601       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
26602              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
26603              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26604
26605 !         print *,eom12,eom2,om12,om2
26606 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
26607 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
26608 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
26609 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
26610 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26611       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
26612        END DO
26613        RETURN
26614       END SUBROUTINE sc_grad_scpho
26615       subroutine eprot_pep_phosphate(epeppho)
26616       use calc_data
26617 !      implicit real(kind=8) (a-h,o-z)
26618 !      include 'DIMENSIONS'
26619 !      include 'COMMON.GEO'
26620 !      include 'COMMON.VAR'
26621 !      include 'COMMON.LOCAL'
26622 !      include 'COMMON.CHAIN'
26623 !      include 'COMMON.DERIV'
26624 !      include 'COMMON.NAMES'
26625 !      include 'COMMON.INTERACT'
26626 !      include 'COMMON.IOUNITS'
26627 !      include 'COMMON.CALC'
26628 !      include 'COMMON.CONTROL'
26629 !      include 'COMMON.SBRIDGE'
26630       logical :: lprn
26631 !el local variables
26632       integer :: iint,itypi,itypi1,itypj,subchap
26633       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
26634       real(kind=8) :: evdw,sig0ij
26635       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26636                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
26637                 sslipi,sslipj,faclip
26638       integer :: ii
26639       real(kind=8) :: fracinbuf
26640        real (kind=8) :: epeppho
26641        real (kind=8),dimension(4):: ener
26642        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
26643        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
26644       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
26645       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
26646       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
26647       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
26648       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
26649       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
26650        real(kind=8),dimension(3,2)::chead,erhead_tail
26651        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
26652        integer troll
26653        real (kind=8) :: dcosom1(3),dcosom2(3)
26654        epeppho=0.0d0
26655 !       do i=1,nres_molec(1)
26656       do i=ibond_start,ibond_end
26657       if (itype(i,1).eq.ntyp1_molec(1)) cycle
26658       itypi  = itype(i,1)
26659       dsci_inv = vbld_inv(i+1)/2.0
26660       dxi    = dc_norm(1,i)
26661       dyi    = dc_norm(2,i)
26662       dzi    = dc_norm(3,i)
26663       xi=(c(1,i)+c(1,i+1))/2.0
26664       yi=(c(2,i)+c(2,i+1))/2.0
26665       zi=(c(3,i)+c(3,i+1))/2.0
26666                call to_box(xi,yi,zi)
26667
26668         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
26669          itypj= itype(j,2)
26670          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
26671           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
26672          xj=(c(1,j)+c(1,j+1))/2.0
26673          yj=(c(2,j)+c(2,j+1))/2.0
26674          zj=(c(3,j)+c(3,j+1))/2.0
26675                 call to_box(xj,yj,zj)
26676       xj=boxshift(xj-xi,boxxsize)
26677       yj=boxshift(yj-yi,boxysize)
26678       zj=boxshift(zj-zi,boxzsize)
26679
26680         dist_init=xj**2+yj**2+zj**2
26681         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26682         rij  = dsqrt(rrij)
26683         dxj = dc_norm( 1,j )
26684         dyj = dc_norm( 2,j )
26685         dzj = dc_norm( 3,j )
26686         dscj_inv = vbld_inv(j+1)/2.0
26687 ! Gay-berne var's
26688         sig0ij = sigma_peppho
26689 !          chi1=0.0d0
26690 !          chi2=0.0d0
26691         chi12  = chi1 * chi2
26692 !          chip1=0.0d0
26693 !          chip2=0.0d0
26694         chip12 = chip1 * chip2
26695 !          chis1 = 0.0d0
26696 !          chis2 = 0.0d0
26697         chis12 = chis1 * chis2
26698         sig1 = sigmap1_peppho
26699         sig2 = sigmap2_peppho
26700 !       write (*,*) "sig1 = ", sig1
26701 !       write (*,*) "sig1 = ", sig1
26702 !       write (*,*) "sig2 = ", sig2
26703 ! alpha factors from Fcav/Gcav
26704         alf1   = 0.0d0
26705         alf2   = 0.0d0
26706         alf12  = 0.0d0
26707         b1 = alphasur_peppho(1)
26708 !          b1=0.0d0
26709         b2 = alphasur_peppho(2)
26710         b3 = alphasur_peppho(3)
26711         b4 = alphasur_peppho(4)
26712         CALL sc_angular
26713        sqom1=om1*om1
26714        evdwij = 0.0d0
26715        ECL = 0.0d0
26716        Elj = 0.0d0
26717        Equad = 0.0d0
26718        Epol = 0.0d0
26719        Fcav=0.0d0
26720        eheadtail = 0.0d0
26721        dGCLdR=0.0d0
26722        dGCLdOM1 = 0.0d0
26723        dGCLdOM2 = 0.0d0
26724        dGCLdOM12 = 0.0d0
26725        dPOLdOM1 = 0.0d0
26726        dPOLdOM2 = 0.0d0
26727         Fcav = 0.0d0
26728         dFdR = 0.0d0
26729         dCAVdOM1  = 0.0d0
26730         dCAVdOM2  = 0.0d0
26731         dCAVdOM12 = 0.0d0
26732         rij_shift = rij
26733         fac       = rij_shift**expon
26734         c1        = fac  * fac * aa_peppho
26735 !          c1        = 0.0d0
26736         c2        = fac  * bb_peppho
26737 !          c2        = 0.0d0
26738         evdwij    =  c1 + c2
26739 ! Now cavity....................
26740        eagle = dsqrt(1.0/rij_shift)
26741        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
26742         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
26743         botsq = bot * bot
26744         Fcav = top / bot
26745         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
26746         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
26747         dFdR = ((dtop * bot - top * dbot) / botsq)
26748        w1        = wqdip_peppho(1)
26749        w2        = wqdip_peppho(2)
26750 !       w1=0.0d0
26751 !       w2=0.0d0
26752 !       pis       = sig0head_scbase(itypi,itypj)
26753 !       eps_head   = epshead_scbase(itypi,itypj)
26754 !c!-------------------------------------------------------------------
26755
26756 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26757 !c!     &        +dhead(1,1,itypi,itypj))**2))
26758 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26759 !c!     &        +dhead(2,1,itypi,itypj))**2))
26760
26761 !c!-------------------------------------------------------------------
26762 !c! ecl
26763        sparrow  = w1  *  om1
26764        hawk     = w2 *  (1.0d0 - sqom1)
26765        Ecl = sparrow * rij_shift**2.0d0 &
26766          - hawk    * rij_shift**4.0d0
26767 !c!-------------------------------------------------------------------
26768 !c! derivative of ecl is Gcl
26769 !c! dF/dr part
26770 !       rij_shift=5.0
26771        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
26772             + 4.0d0 * hawk    * rij_shift**5.0d0
26773 !c! dF/dom1
26774        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
26775 !c! dF/dom2
26776        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
26777        eom1  =    dGCLdOM1+dGCLdOM2
26778        eom2  =    0.0
26779
26780         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
26781 !          fac=0.0
26782         gg(1) =  fac*xj*rij
26783         gg(2) =  fac*yj*rij
26784         gg(3) =  fac*zj*rij
26785        do k=1,3
26786        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
26787        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
26788        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
26789        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
26790        gg(k)=0.0
26791        enddo
26792
26793       DO k = 1, 3
26794       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
26795       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
26796       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
26797       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
26798 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26799       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
26800 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26801       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
26802              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26803       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
26804              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26805       enddo
26806        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
26807       "epeppho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,epeppho
26808
26809        epeppho=epeppho+evdwij+Fcav+ECL
26810 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
26811        enddo
26812        enddo
26813       end subroutine eprot_pep_phosphate
26814 !!!!!!!!!!!!!!!!-------------------------------------------------------------
26815       subroutine emomo(evdw)
26816       use calc_data
26817       use comm_momo
26818 !      implicit real(kind=8) (a-h,o-z)
26819 !      include 'DIMENSIONS'
26820 !      include 'COMMON.GEO'
26821 !      include 'COMMON.VAR'
26822 !      include 'COMMON.LOCAL'
26823 !      include 'COMMON.CHAIN'
26824 !      include 'COMMON.DERIV'
26825 !      include 'COMMON.NAMES'
26826 !      include 'COMMON.INTERACT'
26827 !      include 'COMMON.IOUNITS'
26828 !      include 'COMMON.CALC'
26829 !      include 'COMMON.CONTROL'
26830 !      include 'COMMON.SBRIDGE'
26831       logical :: lprn
26832 !el local variables
26833       integer :: iint,itypi1,subchap,isel,countss
26834       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
26835       real(kind=8) :: evdw,aa,bb
26836       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26837                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
26838                 sslipi,sslipj,faclip,alpha_sco
26839       integer :: ii,icont
26840       real(kind=8) :: fracinbuf
26841        real (kind=8) :: escpho
26842        real (kind=8),dimension(4):: ener
26843        real(kind=8) :: b1,b2,egb
26844        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
26845       Lambf,&
26846       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
26847       dFdOM2,dFdL,dFdOM12,&
26848       federmaus,&
26849       d1i,d1j
26850 !       real(kind=8),dimension(3,2)::erhead_tail
26851 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
26852        real(kind=8) ::  facd4, adler, Fgb, facd3
26853        integer troll,jj,istate
26854        real (kind=8) :: dcosom1(3),dcosom2(3)
26855        evdw=0.0d0
26856        eps_out=80.0d0
26857        sss_ele_cut=1.0d0
26858        countss=0
26859 !       print *,"EVDW KURW",evdw,nres
26860 !      do i=iatsc_s,iatsc_e
26861 !        print *,"I am in EVDW",i
26862       do icont=g_listscsc_start,g_listscsc_end
26863       i=newcontlisti(icont)
26864       j=newcontlistj(icont)
26865
26866       itypi=iabs(itype(i,1))
26867 !        if (i.ne.47) cycle
26868       if (itypi.eq.ntyp1) cycle
26869       itypi1=iabs(itype(i+1,1))
26870       xi=c(1,nres+i)
26871       yi=c(2,nres+i)
26872       zi=c(3,nres+i)
26873         call to_box(xi,yi,zi)
26874         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
26875 !       endif
26876 !       print *, sslipi,ssgradlipi
26877       dxi=dc_norm(1,nres+i)
26878       dyi=dc_norm(2,nres+i)
26879       dzi=dc_norm(3,nres+i)
26880 !        dsci_inv=dsc_inv(itypi)
26881       dsci_inv=vbld_inv(i+nres)
26882 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
26883 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
26884 !
26885 ! Calculate SC interaction energy.
26886 !
26887 !      do iint=1,nint_gr(i)
26888 !        do j=istart(i,iint),iend(i,iint)
26889 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
26890           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
26891             call dyn_ssbond_ene(i,j,evdwij,countss)
26892             evdw=evdw+evdwij
26893             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26894                         'evdw',i,j,evdwij,' ss'
26895 !              if (energy_dec) write (iout,*) &
26896 !                              'evdw',i,j,evdwij,' ss'
26897            do k=j+1,iend(i,iint)
26898 !C search over all next residues
26899             if (dyn_ss_mask(k)) then
26900 !C check if they are cysteins
26901 !C              write(iout,*) 'k=',k
26902
26903 !c              write(iout,*) "PRZED TRI", evdwij
26904 !               evdwij_przed_tri=evdwij
26905             call triple_ssbond_ene(i,j,k,evdwij)
26906 !c               if(evdwij_przed_tri.ne.evdwij) then
26907 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
26908 !c               endif
26909
26910 !c              write(iout,*) "PO TRI", evdwij
26911 !C call the energy function that removes the artifical triple disulfide
26912 !C bond the soubroutine is located in ssMD.F
26913             evdw=evdw+evdwij
26914             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26915                       'evdw',i,j,evdwij,'tss'
26916             endif!dyn_ss_mask(k)
26917            enddo! k
26918           ELSE
26919 !el            ind=ind+1
26920           itypj=iabs(itype(j,1))
26921           if (itypj.eq.ntyp1) cycle
26922            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26923
26924 !             if (j.ne.78) cycle
26925 !            dscj_inv=dsc_inv(itypj)
26926           dscj_inv=vbld_inv(j+nres)
26927          xj=c(1,j+nres)
26928          yj=c(2,j+nres)
26929          zj=c(3,j+nres)
26930      call to_box(xj,yj,zj)
26931      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
26932 !      write(iout,*) "KRUWA", i,j
26933       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26934       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26935       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26936       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26937       xj=boxshift(xj-xi,boxxsize)
26938       yj=boxshift(yj-yi,boxysize)
26939       zj=boxshift(zj-zi,boxzsize)
26940         dxj = dc_norm( 1, nres+j )
26941         dyj = dc_norm( 2, nres+j )
26942         dzj = dc_norm( 3, nres+j )
26943 !          print *,i,j,itypi,itypj
26944 !          d1i=0.0d0
26945 !          d1j=0.0d0
26946 !          BetaT = 1.0d0 / (298.0d0 * Rb)
26947 ! Gay-berne var's
26948 !1!          sig0ij = sigma_scsc( itypi,itypj )
26949 !          chi1=0.0d0
26950 !          chi2=0.0d0
26951 !          chip1=0.0d0
26952 !          chip2=0.0d0
26953 ! not used by momo potential, but needed by sc_angular which is shared
26954 ! by all energy_potential subroutines
26955         alf1   = 0.0d0
26956         alf2   = 0.0d0
26957         alf12  = 0.0d0
26958         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26959 !       a12sq = a12sq * a12sq
26960 ! charge of amino acid itypi is...
26961         chis1 = chis(itypi,itypj)
26962         chis2 = chis(itypj,itypi)
26963         chis12 = chis1 * chis2
26964         sig1 = sigmap1(itypi,itypj)
26965         sig2 = sigmap2(itypi,itypj)
26966 !       write (*,*) "sig1 = ", sig1
26967 !          chis1=0.0
26968 !          chis2=0.0
26969 !                    chis12 = chis1 * chis2
26970 !          sig1=0.0
26971 !          sig2=0.0
26972 !       write (*,*) "sig2 = ", sig2
26973 ! alpha factors from Fcav/Gcav
26974         b1cav = alphasur(1,itypi,itypj)
26975 !          b1cav=0.0d0
26976         b2cav = alphasur(2,itypi,itypj)
26977         b3cav = alphasur(3,itypi,itypj)
26978         b4cav = alphasur(4,itypi,itypj)
26979 ! used to determine whether we want to do quadrupole calculations
26980        eps_in = epsintab(itypi,itypj)
26981        if (eps_in.eq.0.0) eps_in=1.0
26982
26983        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26984        Rtail = 0.0d0
26985 !       dtail(1,itypi,itypj)=0.0
26986 !       dtail(2,itypi,itypj)=0.0
26987
26988        DO k = 1, 3
26989       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26990       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26991        END DO
26992        call to_box (ctail(1,1),ctail(2,1),ctail(3,1))
26993        call to_box (ctail(1,2),ctail(2,2),ctail(3,2))
26994
26995 !c! tail distances will be themselves usefull elswhere
26996 !c1 (in Gcav, for example)
26997        Rtail_distance(1)=boxshift(ctail( 1, 2 ) - ctail( 1,1 ),boxxsize)
26998        Rtail_distance(2)=boxshift(ctail( 2, 2 ) - ctail( 2,1 ),boxysize)
26999        Rtail_distance(3)=boxshift(ctail( 3, 2 ) - ctail( 3,1 ),boxzsize)
27000        Rtail = dsqrt( &
27001         (Rtail_distance(1)*Rtail_distance(1)) &
27002       + (Rtail_distance(2)*Rtail_distance(2)) &
27003       + (Rtail_distance(3)*Rtail_distance(3)))
27004
27005 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
27006 !-------------------------------------------------------------------
27007 ! tail location and distance calculations
27008        d1 = dhead(1, 1, itypi, itypj)
27009        d2 = dhead(2, 1, itypi, itypj)
27010
27011        DO k = 1,3
27012 ! location of polar head is computed by taking hydrophobic centre
27013 ! and moving by a d1 * dc_norm vector
27014 ! see unres publications for very informative images
27015       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27016       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27017 ! distance
27018       enddo
27019        if (energy_dec) write(iout,*) "before",chead(1,1),chead(2,1),chead(3,1)
27020        if (energy_dec) write(iout,*) "before",chead(1,2),chead(2,2),chead(3,2)
27021        call to_box (chead(1,1),chead(2,1),chead(3,1))
27022        call to_box (chead(1,2),chead(2,2),chead(3,2))
27023
27024 !c! head distances will be themselves usefull elswhere
27025 !c1 (in Gcav, for example)
27026        if (energy_dec) write(iout,*) "after",chead(1,1),chead(2,1),chead(3,1)
27027        if (energy_dec) write(iout,*) "after",chead(1,2),chead(2,2),chead(3,2)
27028
27029        Rhead_distance(1)=boxshift(chead( 1, 2 ) - chead( 1,1 ),boxxsize)
27030        Rhead_distance(2)=boxshift(chead( 2, 2 ) - chead( 2,1 ),boxysize)
27031        Rhead_distance(3)=boxshift(chead( 3, 2 ) - chead( 3,1 ),boxzsize)
27032        if (energy_dec) write(iout,*) "after,rdi",(Rhead_distance(k),k=1,3)
27033 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27034 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27035 !      Rhead_distance(k) = chead(k,2) - chead(k,1)
27036 !       END DO
27037 ! pitagoras (root of sum of squares)
27038        Rhead = dsqrt( &
27039         (Rhead_distance(1)*Rhead_distance(1)) &
27040       + (Rhead_distance(2)*Rhead_distance(2)) &
27041       + (Rhead_distance(3)*Rhead_distance(3)))
27042 !-------------------------------------------------------------------
27043 ! zero everything that should be zero'ed
27044        evdwij = 0.0d0
27045        ECL = 0.0d0
27046        Elj = 0.0d0
27047        Equad = 0.0d0
27048        Epol = 0.0d0
27049        Fcav=0.0d0
27050        eheadtail = 0.0d0
27051        dGCLdOM1 = 0.0d0
27052        dGCLdOM2 = 0.0d0
27053        dGCLdOM12 = 0.0d0
27054        dPOLdOM1 = 0.0d0
27055        dPOLdOM2 = 0.0d0
27056         Fcav = 0.0d0
27057         dFdR = 0.0d0
27058         dCAVdOM1  = 0.0d0
27059         dCAVdOM2  = 0.0d0
27060         dCAVdOM12 = 0.0d0
27061         dscj_inv = vbld_inv(j+nres)
27062 !          print *,i,j,dscj_inv,dsci_inv
27063 ! rij holds 1/(distance of Calpha atoms)
27064         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
27065         rij  = dsqrt(rrij)
27066             sss_ele_cut=sscale_ele(1.0d0/(rij))
27067             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
27068 !            print *,sss_ele_cut,sss_ele_grad,&
27069 !            1.0d0/(rij),r_cut_ele,rlamb_ele
27070             if (sss_ele_cut.le.0.0) cycle
27071
27072 !----------------------------
27073         CALL sc_angular
27074 ! this should be in elgrad_init but om's are calculated by sc_angular
27075 ! which in turn is used by older potentials
27076 ! om = omega, sqom = om^2
27077         sqom1  = om1 * om1
27078         sqom2  = om2 * om2
27079         sqom12 = om12 * om12
27080
27081 ! now we calculate EGB - Gey-Berne
27082 ! It will be summed up in evdwij and saved in evdw
27083         sigsq     = 1.0D0  / sigsq
27084         sig       = sig0ij * dsqrt(sigsq)
27085 !          rij_shift = 1.0D0  / rij - sig + sig0ij
27086         rij_shift = Rtail - sig + sig0ij
27087         IF (rij_shift.le.0.0D0) THEN
27088          evdw = 1.0D20
27089          RETURN
27090         END IF
27091         sigder = -sig * sigsq
27092         rij_shift = 1.0D0 / rij_shift
27093         fac       = rij_shift**expon
27094         c1        = fac  * fac * aa_aq(itypi,itypj)
27095 !          print *,"ADAM",aa_aq(itypi,itypj)
27096
27097 !          c1        = 0.0d0
27098         c2        = fac  * bb_aq(itypi,itypj)
27099 !          c2        = 0.0d0
27100         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
27101         eps2der   = eps3rt * evdwij
27102         eps3der   = eps2rt * evdwij
27103 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
27104         evdwij    = eps2rt * eps3rt * evdwij
27105 !#ifdef TSCSC
27106 !          IF (bb_aq(itypi,itypj).gt.0) THEN
27107 !           evdw_p = evdw_p + evdwij
27108 !          ELSE
27109 !           evdw_m = evdw_m + evdwij
27110 !          END IF
27111 !#else
27112         evdw = evdw  &
27113             + evdwij*sss_ele_cut
27114 !#endif
27115
27116         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
27117         fac    = -expon * (c1 + evdwij) * rij_shift
27118         sigder = fac * sigder
27119 !          fac    = rij * fac
27120 ! Calculate distance derivative
27121         gg(1) =  fac*sss_ele_cut+evdwij*sss_ele_grad
27122         gg(2) =  fac*sss_ele_cut+evdwij*sss_ele_grad
27123         gg(3) =  fac*sss_ele_cut+evdwij*sss_ele_grad
27124 !          if (b2.gt.0.0) then
27125         fac = chis1 * sqom1 + chis2 * sqom2 &
27126         - 2.0d0 * chis12 * om1 * om2 * om12
27127 ! we will use pom later in Gcav, so dont mess with it!
27128         pom = 1.0d0 - chis1 * chis2 * sqom12
27129         Lambf = (1.0d0 - (fac / pom))
27130 !          print *,"fac,pom",fac,pom,Lambf
27131         Lambf = dsqrt(Lambf)
27132         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
27133 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
27134 !       write (*,*) "sparrow = ", sparrow
27135         Chif = Rtail * sparrow
27136 !           print *,"rij,sparrow",rij , sparrow
27137         ChiLambf = Chif * Lambf
27138         eagle = dsqrt(ChiLambf)
27139         bat = ChiLambf ** 11.0d0
27140         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
27141         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
27142         botsq = bot * bot
27143 !          print *,top,bot,"bot,top",ChiLambf,Chif
27144         Fcav = top / bot
27145
27146        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
27147        dbot = 12.0d0 * b4cav * bat * Lambf
27148        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow*sss_ele_cut&
27149             +Fcav*sss_ele_grad
27150         Fcav=Fcav*sss
27151         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
27152         dbot = 12.0d0 * b4cav * bat * Chif
27153         eagle = Lambf * pom
27154         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
27155         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
27156         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
27157             * (chis2 * om2 * om12 - om1) / (eagle * pom)
27158
27159         dFdL = ((dtop * bot - top * dbot) / botsq)
27160 !       dFdL = 0.0d0
27161         dCAVdOM1  = dFdL * ( dFdOM1 )
27162         dCAVdOM2  = dFdL * ( dFdOM2 )
27163         dCAVdOM12 = dFdL * ( dFdOM12 )
27164
27165        DO k= 1, 3
27166       ertail(k) = Rtail_distance(k)/Rtail
27167        END DO
27168        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
27169        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
27170        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27171        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27172        DO k = 1, 3
27173 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
27174 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
27175       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
27176       gvdwx(k,i) = gvdwx(k,i) &
27177               - (( dFdR + gg(k) ) * pom)
27178 !c!     &             - ( dFdR * pom )
27179       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
27180       gvdwx(k,j) = gvdwx(k,j)   &
27181               + (( dFdR + gg(k) ) * pom)
27182 !c!     &             + ( dFdR * pom )
27183
27184       gvdwc(k,i) = gvdwc(k,i)  &
27185               - (( dFdR + gg(k) ) * ertail(k))
27186 !c!     &             - ( dFdR * ertail(k))
27187
27188       gvdwc(k,j) = gvdwc(k,j) &
27189               + (( dFdR + gg(k) ) * ertail(k))
27190 !c!     &             + ( dFdR * ertail(k))
27191
27192       gg(k) = 0.0d0
27193 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
27194 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
27195       END DO
27196
27197
27198 !c! Compute head-head and head-tail energies for each state
27199
27200         isel = iabs(Qi) + iabs(Qj)
27201 ! double charge for Phophorylated! itype - 25,27,27
27202 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
27203 !            Qi=Qi*2
27204 !            Qij=Qij*2
27205 !           endif
27206 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
27207 !            Qj=Qj*2
27208 !            Qij=Qij*2
27209 !           endif
27210
27211 !          isel=0
27212         IF (isel.eq.0) THEN
27213 !c! No charges - do nothing
27214          eheadtail = 0.0d0
27215
27216         ELSE IF (isel.eq.4) THEN
27217 !c! Calculate dipole-dipole interactions
27218          CALL edd(ecl)
27219          eheadtail = ECL
27220 !           eheadtail = 0.0d0
27221
27222         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
27223 !c! Charge-nonpolar interactions
27224         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27225           Qi=Qi*2
27226           Qij=Qij*2
27227          endif
27228         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27229           Qj=Qj*2
27230           Qij=Qij*2
27231          endif
27232
27233          CALL eqn(epol)
27234          eheadtail = epol
27235 !           eheadtail = 0.0d0
27236
27237         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
27238 !c! Nonpolar-charge interactions
27239         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27240           Qi=Qi*2
27241           Qij=Qij*2
27242          endif
27243         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27244           Qj=Qj*2
27245           Qij=Qij*2
27246          endif
27247
27248          CALL enq(epol)
27249          eheadtail = epol
27250 !           eheadtail = 0.0d0
27251
27252         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
27253 !c! Charge-dipole interactions
27254         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27255           Qi=Qi*2
27256           Qij=Qij*2
27257          endif
27258         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27259           Qj=Qj*2
27260           Qij=Qij*2
27261          endif
27262
27263          CALL eqd(ecl, elj, epol)
27264          eheadtail = ECL + elj + epol
27265 !           eheadtail = 0.0d0
27266
27267         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
27268 !c! Dipole-charge interactions
27269         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27270           Qi=Qi*2
27271           Qij=Qij*2
27272          endif
27273         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27274           Qj=Qj*2
27275           Qij=Qij*2
27276          endif
27277          CALL edq(ecl, elj, epol)
27278         eheadtail = ECL + elj + epol
27279 !           eheadtail = 0.0d0
27280
27281         ELSE IF ((isel.eq.2.and.   &
27282              iabs(Qi).eq.1).and.  &
27283              nstate(itypi,itypj).eq.1) THEN
27284 !c! Same charge-charge interaction ( +/+ or -/- )
27285         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27286           Qi=Qi*2
27287           Qij=Qij*2
27288          endif
27289         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27290           Qj=Qj*2
27291           Qij=Qij*2
27292          endif
27293
27294          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
27295          eheadtail = ECL + Egb + Epol + Fisocav + Elj
27296 !           eheadtail = 0.0d0
27297
27298         ELSE IF ((isel.eq.2.and.  &
27299              iabs(Qi).eq.1).and. &
27300              nstate(itypi,itypj).ne.1) THEN
27301 !c! Different charge-charge interaction ( +/- or -/+ )
27302         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27303           Qi=Qi*2
27304           Qij=Qij*2
27305          endif
27306         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27307           Qj=Qj*2
27308           Qij=Qij*2
27309          endif
27310
27311          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
27312         END IF
27313        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
27314       evdw = evdw  + Fcav + eheadtail
27315
27316        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
27317       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
27318       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
27319       Equad,evdwij+Fcav+eheadtail,evdw
27320 !       evdw = evdw  + Fcav  + eheadtail
27321
27322       iF (nstate(itypi,itypj).eq.1) THEN
27323       CALL sc_grad
27324        END IF
27325 !c!-------------------------------------------------------------------
27326 !c! NAPISY KONCOWE
27327       ! END DO   ! j
27328       !END DO    ! iint
27329        END DO     ! i
27330 !c      write (iout,*) "Number of loop steps in EGB:",ind
27331 !c      energy_dec=.false.
27332 !              print *,"EVDW KURW",evdw,nres
27333
27334        RETURN
27335       END SUBROUTINE emomo
27336 !C------------------------------------------------------------------------------------
27337       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
27338       use calc_data
27339       use comm_momo
27340        real (kind=8) ::  facd3, facd4, federmaus, adler,&
27341        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
27342 !       integer :: k
27343 !c! Epol and Gpol analytical parameters
27344        alphapol1 = alphapol(itypi,itypj)
27345        alphapol2 = alphapol(itypj,itypi)
27346 !c! Fisocav and Gisocav analytical parameters
27347        al1  = alphiso(1,itypi,itypj)
27348        al2  = alphiso(2,itypi,itypj)
27349        al3  = alphiso(3,itypi,itypj)
27350        al4  = alphiso(4,itypi,itypj)
27351        csig = (1.0d0  &
27352          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
27353          + sigiso2(itypi,itypj)**2.0d0))
27354 !c!
27355        pis  = sig0head(itypi,itypj)
27356        eps_head = epshead(itypi,itypj)
27357        Rhead_sq = Rhead * Rhead
27358 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27359 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27360        R1 = 0.0d0
27361        R2 = 0.0d0
27362        DO k = 1, 3
27363 !c! Calculate head-to-tail distances needed by Epol
27364       R1=R1+(ctail(k,2)-chead(k,1))**2
27365       R2=R2+(chead(k,2)-ctail(k,1))**2
27366        END DO
27367 !c! Pitagoras
27368        R1 = dsqrt(R1)
27369        R2 = dsqrt(R2)
27370
27371 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27372 !c!     &        +dhead(1,1,itypi,itypj))**2))
27373 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27374 !c!     &        +dhead(2,1,itypi,itypj))**2))
27375
27376 !c!-------------------------------------------------------------------
27377 !c! Coulomb electrostatic interaction
27378        Ecl = (332.0d0 * Qij) / Rhead
27379 !c! derivative of Ecl is Gcl...
27380        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq*sss_ele_cut+ECL*sss_ele_grad
27381        dGCLdOM1 = 0.0d0
27382        dGCLdOM2 = 0.0d0
27383        dGCLdOM12 = 0.0d0
27384        ECL=ECL*sss_ele_grad
27385        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27386        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27387        debkap=debaykap(itypi,itypj)
27388        Egb = -(332.0d0 * Qij *&
27389       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
27390 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
27391 !c! Derivative of Egb is Ggb...
27392        dGGBdFGB = -(-332.0d0 * Qij * &
27393        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
27394        -(332.0d0 * Qij *&
27395       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
27396        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
27397        dGGBdR = dGGBdFGB * dFGBdR*sss_ele_cut+Egb*sss_ele_grad
27398        Egb=Egb*sss_ele_cut
27399 !c!-------------------------------------------------------------------
27400 !c! Fisocav - isotropic cavity creation term
27401 !c! or "how much energy it costs to put charged head in water"
27402        pom = Rhead * csig
27403        top = al1 * (dsqrt(pom) + al2 * pom - al3)
27404        bot = (1.0d0 + al4 * pom**12.0d0)
27405        botsq = bot * bot
27406        FisoCav = top / bot
27407 !      write (*,*) "Rhead = ",Rhead
27408 !      write (*,*) "csig = ",csig
27409 !      write (*,*) "pom = ",pom
27410 !      write (*,*) "al1 = ",al1
27411 !      write (*,*) "al2 = ",al2
27412 !      write (*,*) "al3 = ",al3
27413 !      write (*,*) "al4 = ",al4
27414 !        write (*,*) "top = ",top
27415 !        write (*,*) "bot = ",bot
27416 !c! Derivative of Fisocav is GCV...
27417        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27418        dbot = 12.0d0 * al4 * pom ** 11.0d0
27419        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
27420 !c!-------------------------------------------------------------------
27421 !c! Epol
27422 !c! Polarization energy - charged heads polarize hydrophobic "neck"
27423        MomoFac1 = (1.0d0 - chi1 * sqom2)
27424        MomoFac2 = (1.0d0 - chi2 * sqom1)
27425        RR1  = ( R1 * R1 ) / MomoFac1
27426        RR2  = ( R2 * R2 ) / MomoFac2
27427        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27428        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27429        fgb1 = sqrt( RR1 + a12sq * ee1 )
27430        fgb2 = sqrt( RR2 + a12sq * ee2 )
27431        epol = 332.0d0 * eps_inout_fac * ( &
27432       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27433 !c!       epol = 0.0d0
27434        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27435              / (fgb1 ** 5.0d0)
27436        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27437              / (fgb2 ** 5.0d0)
27438        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
27439            / ( 2.0d0 * fgb1 )
27440        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
27441            / ( 2.0d0 * fgb2 )
27442        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
27443             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
27444        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
27445             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
27446        dPOLdR1 = dPOLdFGB1 * dFGBdR1*sss_ele_cut
27447 !c!       dPOLdR1 = 0.0d0
27448        dPOLdR2 = dPOLdFGB2 * dFGBdR2*sss_ele_cut
27449 !c!       dPOLdR2 = 0.0d0
27450        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27451 !c!       dPOLdOM1 = 0.0d0
27452        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27453 !c!       dPOLdOM2 = 0.0d0
27454 !c!-------------------------------------------------------------------
27455 !c! Elj
27456 !c! Lennard-Jones 6-12 interaction between heads
27457        pom = (pis / Rhead)**6.0d0
27458        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27459 !c! derivative of Elj is Glj
27460        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
27461            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))*sss_ele_cut+&
27462          (ELJ+epol)*sss_ele_grad
27463         epol=epol*sss_ele_cut
27464         Elj=Elj*sss_ele_cut
27465 !c!-------------------------------------------------------------------
27466 !c! Return the results
27467 !c! These things do the dRdX derivatives, that is
27468 !c! allow us to change what we see from function that changes with
27469 !c! distance to function that changes with LOCATION (of the interaction
27470 !c! site)
27471        DO k = 1, 3
27472       erhead(k) = Rhead_distance(k)/Rhead
27473       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27474       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27475        END DO
27476
27477        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27478        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27479        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27480        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27481        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27482        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27483        facd1 = d1 * vbld_inv(i+nres)
27484        facd2 = d2 * vbld_inv(j+nres)
27485        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27486        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27487
27488 !c! Now we add appropriate partial derivatives (one in each dimension)
27489        DO k = 1, 3
27490       hawk   = (erhead_tail(k,1) + &
27491       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
27492       condor = (erhead_tail(k,2) + &
27493       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27494
27495       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27496       gvdwx(k,i) = gvdwx(k,i) &
27497               - dGCLdR * pom&
27498               - dGGBdR * pom&
27499               - dGCVdR * pom&
27500               - dPOLdR1 * hawk&
27501               - dPOLdR2 * (erhead_tail(k,2)&
27502       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27503               - dGLJdR * pom
27504
27505       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27506       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
27507                + dGGBdR * pom+ dGCVdR * pom&
27508               + dPOLdR1 * (erhead_tail(k,1)&
27509       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
27510               + dPOLdR2 * condor + dGLJdR * pom
27511
27512       gvdwc(k,i) = gvdwc(k,i)  &
27513               - dGCLdR * erhead(k)&
27514               - dGGBdR * erhead(k)&
27515               - dGCVdR * erhead(k)&
27516               - dPOLdR1 * erhead_tail(k,1)&
27517               - dPOLdR2 * erhead_tail(k,2)&
27518               - dGLJdR * erhead(k)
27519
27520       gvdwc(k,j) = gvdwc(k,j)         &
27521               + dGCLdR * erhead(k) &
27522               + dGGBdR * erhead(k) &
27523               + dGCVdR * erhead(k) &
27524               + dPOLdR1 * erhead_tail(k,1) &
27525               + dPOLdR2 * erhead_tail(k,2)&
27526               + dGLJdR * erhead(k)
27527
27528        END DO
27529        RETURN
27530       END SUBROUTINE eqq
27531
27532       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
27533       use calc_data
27534       use comm_momo
27535        real (kind=8) ::  facd3, facd4, federmaus, adler,&
27536        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
27537 !       integer :: k
27538 !c! Epol and Gpol analytical parameters
27539        alphapol1 = alphapolcat(itypi,itypj)
27540        alphapol2 = alphapolcat2(itypj,itypi)
27541 !c! Fisocav and Gisocav analytical parameters
27542        al1  = alphisocat(1,itypi,itypj)
27543        al2  = alphisocat(2,itypi,itypj)
27544        al3  = alphisocat(3,itypi,itypj)
27545        al4  = alphisocat(4,itypi,itypj)
27546        csig = (1.0d0  &
27547          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
27548          + sigiso2cat(itypi,itypj)**2.0d0))
27549 !c!
27550        pis  = sig0headcat(itypi,itypj)
27551        eps_head = epsheadcat(itypi,itypj)
27552        Rhead_sq = Rhead * Rhead
27553 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27554 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27555        R1 = 0.0d0
27556        R2 = 0.0d0
27557        DO k = 1, 3
27558 !c! Calculate head-to-tail distances needed by Epol
27559       R1=R1+(ctail(k,2)-chead(k,1))**2
27560       R2=R2+(chead(k,2)-ctail(k,1))**2
27561        END DO
27562 !c! Pitagoras
27563        R1 = dsqrt(R1)
27564        R2 = dsqrt(R2)
27565
27566 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27567 !c!     &        +dhead(1,1,itypi,itypj))**2))
27568 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27569 !c!     &        +dhead(2,1,itypi,itypj))**2))
27570
27571 !c!-------------------------------------------------------------------
27572 !c! Coulomb electrostatic interaction
27573        Ecl = (332.0d0 * Qij) / Rhead
27574 !c! derivative of Ecl is Gcl...
27575        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq*sss_ele_cut+ECL*sss_ele_grad
27576        ECL=ECL*sss_ele_cut
27577        dGCLdOM1 = 0.0d0
27578        dGCLdOM2 = 0.0d0
27579        dGCLdOM12 = 0.0d0
27580
27581        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27582        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27583        debkap=debaykapcat(itypi,itypj)
27584        if (energy_dec) write(iout,*) "egb",Qij,debkap,Fgb,a12sq,ee0
27585        Egb = -(332.0d0 * Qij *&
27586       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
27587 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
27588 !c! Derivative of Egb is Ggb...
27589        dGGBdFGB = -(-332.0d0 * Qij * &
27590        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
27591        -(332.0d0 * Qij *&
27592       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
27593        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
27594        dGGBdR = dGGBdFGB * dFGBdR*sss_ele_cut+Egb*sss_ele_grad
27595        Egb=Egb*sss_ele_grad
27596 !c!-------------------------------------------------------------------
27597 !c! Fisocav - isotropic cavity creation term
27598 !c! or "how much energy it costs to put charged head in water"
27599        pom = Rhead * csig
27600        top = al1 * (dsqrt(pom) + al2 * pom - al3)
27601        bot = (1.0d0 + al4 * pom**12.0d0)
27602        botsq = bot * bot
27603        FisoCav = top / bot
27604 !      write (*,*) "Rhead = ",Rhead
27605 !      write (*,*) "csig = ",csig
27606 !      write (*,*) "pom = ",pom
27607 !      write (*,*) "al1 = ",al1
27608 !      write (*,*) "al2 = ",al2
27609 !      write (*,*) "al3 = ",al3
27610 !      write (*,*) "al4 = ",al4
27611 !        write (*,*) "top = ",top
27612 !        write (*,*) "bot = ",bot
27613 !c! Derivative of Fisocav is GCV...
27614        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27615        dbot = 12.0d0 * al4 * pom ** 11.0d0
27616        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig*sss_ele_cut&
27617                +FisoCav*sss_ele_grad
27618         FisoCav=FisoCav*sss_ele_cut
27619 !c!-------------------------------------------------------------------
27620 !c! Epol
27621 !c! Polarization energy - charged heads polarize hydrophobic "neck"
27622        MomoFac1 = (1.0d0 - chi1 * sqom2)
27623        MomoFac2 = (1.0d0 - chi2 * sqom1)
27624        RR1  = ( R1 * R1 ) / MomoFac1
27625        RR2  = ( R2 * R2 ) / MomoFac2
27626        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27627        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27628        fgb1 = sqrt( RR1 + a12sq * ee1 )
27629        fgb2 = sqrt( RR2 + a12sq * ee2 )
27630        epol = 332.0d0 * eps_inout_fac * ( &
27631       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27632 !c!       epol = 0.0d0
27633        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27634              / (fgb1 ** 5.0d0)
27635        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27636              / (fgb2 ** 5.0d0)
27637        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
27638            / ( 2.0d0 * fgb1 )
27639        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
27640            / ( 2.0d0 * fgb2 )
27641        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
27642             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
27643        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
27644             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
27645        dPOLdR1 = dPOLdFGB1 * dFGBdR1!*sss_ele_cut+epol*sss_ele_grad
27646 !c!       dPOLdR1 = 0.0d0
27647        dPOLdR2 = dPOLdFGB2 * dFGBdR2!*sss_ele_cut+epol*sss_ele_grad
27648 !c!       dPOLdR2 = 0.0d0
27649        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27650 !c!       dPOLdOM1 = 0.0d0
27651        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27652 !       epol=epol*sss_ele_cut
27653 !c!       dPOLdOM2 = 0.0d0
27654 !c!-------------------------------------------------------------------
27655 !c! Elj
27656 !c! Lennard-Jones 6-12 interaction between heads
27657        pom = (pis / Rhead)**6.0d0
27658        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27659 !c! derivative of Elj is Glj
27660        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
27661            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))*sss_ele_cut&
27662            +(Elj+epol)*sss_ele_grad
27663        Elj=Elj*sss_ele_cut
27664        epol=epol*sss_ele_cut
27665 !c!-------------------------------------------------------------------
27666 !c! Return the results
27667 !c! These things do the dRdX derivatives, that is
27668 !c! allow us to change what we see from function that changes with
27669 !c! distance to function that changes with LOCATION (of the interaction
27670 !c! site)
27671        DO k = 1, 3
27672       erhead(k) = Rhead_distance(k)/Rhead
27673       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27674       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27675        END DO
27676
27677        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27678        erdxj = scalar( erhead(1), dC_norm(1,j) )
27679        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27680        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
27681        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27682        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27683        facd1 = d1 * vbld_inv(i+nres)
27684        facd2 = d2 * vbld_inv(j)
27685        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27686        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
27687
27688 !c! Now we add appropriate partial derivatives (one in each dimension)
27689        DO k = 1, 3
27690       hawk   = (erhead_tail(k,1) + &
27691       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
27692       condor = (erhead_tail(k,2) + &
27693       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27694
27695       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27696       gradpepcatx(k,i) = gradpepcatx(k,i) &
27697               - dGCLdR * pom&
27698               - dGGBdR * pom&
27699               - dGCVdR * pom&
27700               - dPOLdR1 * hawk&
27701               - dPOLdR2 * (erhead_tail(k,2)&
27702       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27703               - dGLJdR * pom
27704
27705       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27706 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
27707 !                   + dGGBdR * pom+ dGCVdR * pom&
27708 !                  + dPOLdR1 * (erhead_tail(k,1)&
27709 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
27710 !                  + dPOLdR2 * condor + dGLJdR * pom
27711
27712       gradpepcat(k,i) = gradpepcat(k,i)  &
27713               - dGCLdR * erhead(k)&
27714               - dGGBdR * erhead(k)&
27715               - dGCVdR * erhead(k)&
27716               - dPOLdR1 * erhead_tail(k,1)&
27717               - dPOLdR2 * erhead_tail(k,2)&
27718               - dGLJdR * erhead(k)
27719
27720       gradpepcat(k,j) = gradpepcat(k,j)         &
27721               + dGCLdR * erhead(k) &
27722               + dGGBdR * erhead(k) &
27723               + dGCVdR * erhead(k) &
27724               + dPOLdR1 * erhead_tail(k,1) &
27725               + dPOLdR2 * erhead_tail(k,2)&
27726               + dGLJdR * erhead(k)
27727
27728        END DO
27729        RETURN
27730       END SUBROUTINE eqq_cat
27731 !c!-------------------------------------------------------------------
27732       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
27733       use comm_momo
27734       use calc_data
27735
27736        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
27737        double precision ener(4)
27738        double precision dcosom1(3),dcosom2(3)
27739 !c! used in Epol derivatives
27740        double precision facd3, facd4
27741        double precision federmaus, adler
27742        integer istate,ii,jj
27743        real (kind=8) :: Fgb
27744 !       print *,"CALLING EQUAD"
27745 !c! Epol and Gpol analytical parameters
27746        alphapol1 = alphapol(itypi,itypj)
27747        alphapol2 = alphapol(itypj,itypi)
27748 !c! Fisocav and Gisocav analytical parameters
27749        al1  = alphiso(1,itypi,itypj)
27750        al2  = alphiso(2,itypi,itypj)
27751        al3  = alphiso(3,itypi,itypj)
27752        al4  = alphiso(4,itypi,itypj)
27753        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
27754           + sigiso2(itypi,itypj)**2.0d0))
27755 !c!
27756        w1   = wqdip(1,itypi,itypj)
27757        w2   = wqdip(2,itypi,itypj)
27758        pis  = sig0head(itypi,itypj)
27759        eps_head = epshead(itypi,itypj)
27760 !c! First things first:
27761 !c! We need to do sc_grad's job with GB and Fcav
27762        eom1  = eps2der * eps2rt_om1 &
27763            - 2.0D0 * alf1 * eps3der&
27764            + sigder * sigsq_om1&
27765            + dCAVdOM1
27766        eom2  = eps2der * eps2rt_om2 &
27767            + 2.0D0 * alf2 * eps3der&
27768            + sigder * sigsq_om2&
27769            + dCAVdOM2
27770        eom12 =  evdwij  * eps1_om12 &
27771            + eps2der * eps2rt_om12 &
27772            - 2.0D0 * alf12 * eps3der&
27773            + sigder *sigsq_om12&
27774            + dCAVdOM12
27775 !c! now some magical transformations to project gradient into
27776 !c! three cartesian vectors
27777        DO k = 1, 3
27778       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
27779       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27780       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
27781 !c! this acts on hydrophobic center of interaction
27782       gvdwx(k,i)= gvdwx(k,i) - gg(k)*sss_ele_cut &
27783               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
27784               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss_ele_cut
27785       gvdwx(k,j)= gvdwx(k,j) + gg(k)*sss_ele_cut &
27786               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
27787               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss_ele_cut
27788 !c! this acts on Calpha
27789       gvdwc(k,i)=gvdwc(k,i)-gg(k)*sss_ele_cut
27790       gvdwc(k,j)=gvdwc(k,j)+gg(k)*sss_ele_cut
27791        END DO
27792 !c! sc_grad is done, now we will compute
27793        eheadtail = 0.0d0
27794        eom1 = 0.0d0
27795        eom2 = 0.0d0
27796        eom12 = 0.0d0
27797        DO istate = 1, nstate(itypi,itypj)
27798 !c*************************************************************
27799       IF (istate.ne.1) THEN
27800        IF (istate.lt.3) THEN
27801         ii = 1
27802        ELSE
27803         ii = 2
27804        END IF
27805       jj = istate/ii
27806       d1 = dhead(1,ii,itypi,itypj)
27807       d2 = dhead(2,jj,itypi,itypj)
27808       do k=1,3
27809       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27810       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27811 ! distance
27812       enddo
27813        call to_box (chead(1,1),chead(2,1),chead(3,1))
27814        call to_box (chead(1,2),chead(2,2),chead(3,2))
27815
27816 !c! head distances will be themselves usefull elswhere
27817 !c1 (in Gcav, for example)
27818
27819        Rhead_distance(1)=boxshift(chead( 1, 2 ) - chead( 1,1 ),boxxsize)
27820        Rhead_distance(2)=boxshift(chead( 2, 2 ) - chead( 2,1 ),boxysize)
27821        Rhead_distance(3)=boxshift(chead( 3, 2 ) - chead( 3,1 ),boxzsize)
27822 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27823 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27824 !      Rhead_distance(k) = chead(k,2) - chead(k,1)
27825 !       END DO
27826 ! pitagoras (root of sum of squares)
27827        Rhead = dsqrt( &
27828         (Rhead_distance(1)*Rhead_distance(1)) &
27829       + (Rhead_distance(2)*Rhead_distance(2)) &
27830       + (Rhead_distance(3)*Rhead_distance(3)))
27831
27832 !      DO k = 1,3
27833 !       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27834 !       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27835 !       Rhead_distance(k) = chead(k,2) - chead(k,1)
27836 !      END DO
27837 !c! pitagoras (root of sum of squares)
27838 !      Rhead = dsqrt( &
27839 !             (Rhead_distance(1)*Rhead_distance(1))  &
27840 !           + (Rhead_distance(2)*Rhead_distance(2))  &
27841 !           + (Rhead_distance(3)*Rhead_distance(3)))
27842       END IF
27843       Rhead_sq = Rhead * Rhead
27844
27845 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27846 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27847       R1 = 0.0d0
27848       R2 = 0.0d0
27849       DO k = 1, 3
27850 !c! Calculate head-to-tail distances
27851        R1=R1+(ctail(k,2)-chead(k,1))**2
27852        R2=R2+(chead(k,2)-ctail(k,1))**2
27853       END DO
27854 !c! Pitagoras
27855       R1 = dsqrt(R1)
27856       R2 = dsqrt(R2)
27857       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
27858 !c!        Ecl = 0.0d0
27859 !c!        write (*,*) "Ecl = ", Ecl
27860 !c! derivative of Ecl is Gcl...
27861       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)*sss_ele_cut+ECL*sss_ele_grad
27862        ECL=ecl*sss_ele_cut
27863 !c!        dGCLdR = 0.0d0
27864       dGCLdOM1 = 0.0d0
27865       dGCLdOM2 = 0.0d0
27866       dGCLdOM12 = 0.0d0
27867 !c!-------------------------------------------------------------------
27868 !c! Generalised Born Solvent Polarization
27869       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27870       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27871       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
27872 !c!        Egb = 0.0d0
27873 !c!      write (*,*) "a1*a2 = ", a12sq
27874 !c!      write (*,*) "Rhead = ", Rhead
27875 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
27876 !c!      write (*,*) "ee = ", ee
27877 !c!      write (*,*) "Fgb = ", Fgb
27878 !c!      write (*,*) "fac = ", eps_inout_fac
27879 !c!      write (*,*) "Qij = ", Qij
27880 !c!      write (*,*) "Egb = ", Egb
27881 !c! Derivative of Egb is Ggb...
27882 !c! dFGBdR is used by Quad's later...
27883       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
27884       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
27885              / ( 2.0d0 * Fgb )
27886       dGGBdR = dGGBdFGB * dFGBdR*sss_ele_cut+Egb*sss_ele_grad
27887       Egb=Egb*sss_ele_cut
27888 !c!        dGGBdR = 0.0d0
27889 !c!-------------------------------------------------------------------
27890 !c! Fisocav - isotropic cavity creation term
27891       pom = Rhead * csig
27892       top = al1 * (dsqrt(pom) + al2 * pom - al3)
27893       bot = (1.0d0 + al4 * pom**12.0d0)
27894       botsq = bot * bot
27895       FisoCav = top / bot
27896       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27897       dbot = 12.0d0 * al4 * pom ** 11.0d0
27898       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig*sss_ele_cut+FisoCav*sss_ele_grad
27899       FisoCav=FisoCav*sss_ele_cut
27900
27901 !c!        dGCVdR = 0.0d0
27902 !c!-------------------------------------------------------------------
27903 !c! Polarization energy
27904 !c! Epol
27905       MomoFac1 = (1.0d0 - chi1 * sqom2)
27906       MomoFac2 = (1.0d0 - chi2 * sqom1)
27907       RR1  = ( R1 * R1 ) / MomoFac1
27908       RR2  = ( R2 * R2 ) / MomoFac2
27909       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27910       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27911       fgb1 = sqrt( RR1 + a12sq * ee1 )
27912       fgb2 = sqrt( RR2 + a12sq * ee2 )
27913       epol = 332.0d0 * eps_inout_fac * (&
27914       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27915 !c!        epol = 0.0d0
27916 !c! derivative of Epol is Gpol...
27917       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27918               / (fgb1 ** 5.0d0)
27919       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27920               / (fgb2 ** 5.0d0)
27921       dFGBdR1 = ( (R1 / MomoFac1) &
27922             * ( 2.0d0 - (0.5d0 * ee1) ) )&
27923             / ( 2.0d0 * fgb1 )
27924       dFGBdR2 = ( (R2 / MomoFac2) &
27925             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27926             / ( 2.0d0 * fgb2 )
27927       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27928              * ( 2.0d0 - 0.5d0 * ee1) ) &
27929              / ( 2.0d0 * fgb1 )
27930       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27931              * ( 2.0d0 - 0.5d0 * ee2) ) &
27932              / ( 2.0d0 * fgb2 )
27933       dPOLdR1 = dPOLdFGB1 * dFGBdR1*sss_ele_cut
27934 !c!        dPOLdR1 = 0.0d0
27935       dPOLdR2 = dPOLdFGB2 * dFGBdR2*sss_ele_cut
27936 !c!        dPOLdR2 = 0.0d0
27937       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27938 !c!        dPOLdOM1 = 0.0d0
27939       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27940       pom = (pis / Rhead)**6.0d0
27941       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27942 !c!        Elj = 0.0d0
27943 !c! derivative of Elj is Glj
27944       dGLJdR = 4.0d0 * eps_head &
27945           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27946           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))*sss_ele_cut+&
27947           (epol+Elj)*sss_ele_grad
27948       Elj=Elj*sss_ele_cut
27949       epol=epol*sss_ele_cut
27950 !c!        dGLJdR = 0.0d0
27951 !c!-------------------------------------------------------------------
27952 !c! Equad
27953        IF (Wqd.ne.0.0d0) THEN
27954       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
27955            - 37.5d0  * ( sqom1 + sqom2 ) &
27956            + 157.5d0 * ( sqom1 * sqom2 ) &
27957            - 45.0d0  * om1*om2*om12
27958       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
27959       Equad = fac * Beta1
27960 !c!        Equad = 0.0d0
27961 !c! derivative of Equad...
27962       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR*sss_ele_cut&
27963           + Equad*sss_ele_grad
27964       Equad=Equad*sss_ele_cut
27965 !c!        dQUADdR = 0.0d0
27966       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
27967 !c!        dQUADdOM1 = 0.0d0
27968       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
27969 !c!        dQUADdOM2 = 0.0d0
27970       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
27971        ELSE
27972        Beta1 = 0.0d0
27973        Equad = 0.0d0
27974       END IF
27975 !c!-------------------------------------------------------------------
27976 !c! Return the results
27977 !c! Angular stuff
27978       eom1 = dPOLdOM1 + dQUADdOM1
27979       eom2 = dPOLdOM2 + dQUADdOM2
27980       eom12 = dQUADdOM12
27981 !c! now some magical transformations to project gradient into
27982 !c! three cartesian vectors
27983       DO k = 1, 3
27984        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
27985        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27986        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)*sss_ele_cut
27987       END DO
27988 !c! Radial stuff
27989       DO k = 1, 3
27990        erhead(k) = Rhead_distance(k)/Rhead
27991        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27992        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27993       END DO
27994       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27995       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27996       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27997       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27998       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27999       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28000       facd1 = d1 * vbld_inv(i+nres)
28001       facd2 = d2 * vbld_inv(j+nres)
28002       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
28003       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
28004       DO k = 1, 3
28005        hawk   = erhead_tail(k,1) + &
28006        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
28007        condor = erhead_tail(k,2) + &
28008        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
28009
28010        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28011 !c! this acts on hydrophobic center of interaction
28012        gheadtail(k,1,1) = gheadtail(k,1,1) &
28013                    - dGCLdR * pom &
28014                    - dGGBdR * pom &
28015                    - dGCVdR * pom &
28016                    - dPOLdR1 * hawk &
28017                    - dPOLdR2 * (erhead_tail(k,2) &
28018       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
28019                    - dGLJdR * pom &
28020                    - dQUADdR * pom&
28021                    - tuna(k) &
28022              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
28023              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss_ele_cut
28024
28025        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28026 !c! this acts on hydrophobic center of interaction
28027        gheadtail(k,2,1) = gheadtail(k,2,1)  &
28028                    + dGCLdR * pom      &
28029                    + dGGBdR * pom      &
28030                    + dGCVdR * pom      &
28031                    + dPOLdR1 * (erhead_tail(k,1) &
28032       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
28033                    + dPOLdR2 * condor &
28034                    + dGLJdR * pom &
28035                    + dQUADdR * pom &
28036                    + tuna(k) &
28037              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
28038              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss_ele_cut
28039
28040 !c! this acts on Calpha
28041        gheadtail(k,3,1) = gheadtail(k,3,1)  &
28042                    - dGCLdR * erhead(k)&
28043                    - dGGBdR * erhead(k)&
28044                    - dGCVdR * erhead(k)&
28045                    - dPOLdR1 * erhead_tail(k,1)&
28046                    - dPOLdR2 * erhead_tail(k,2)&
28047                    - dGLJdR * erhead(k) &
28048                    - dQUADdR * erhead(k)&
28049                    - tuna(k)
28050 !c! this acts on Calpha
28051        gheadtail(k,4,1) = gheadtail(k,4,1)   &
28052                     + dGCLdR * erhead(k) &
28053                     + dGGBdR * erhead(k) &
28054                     + dGCVdR * erhead(k) &
28055                     + dPOLdR1 * erhead_tail(k,1) &
28056                     + dPOLdR2 * erhead_tail(k,2) &
28057                     + dGLJdR * erhead(k) &
28058                     + dQUADdR * erhead(k)&
28059                     + tuna(k)
28060       END DO
28061       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
28062       eheadtail = eheadtail &
28063               + wstate(istate, itypi, itypj) &
28064               * dexp(-betaT * ener(istate))
28065 !c! foreach cartesian dimension
28066       DO k = 1, 3
28067 !c! foreach of two gvdwx and gvdwc
28068        DO l = 1, 4
28069         gheadtail(k,l,2) = gheadtail(k,l,2)  &
28070                      + wstate( istate, itypi, itypj ) &
28071                      * dexp(-betaT * ener(istate)) &
28072                      * gheadtail(k,l,1)
28073         gheadtail(k,l,1) = 0.0d0
28074        END DO
28075       END DO
28076        END DO
28077 !c! Here ended the gigantic DO istate = 1, 4, which starts
28078 !c! at the beggining of the subroutine
28079
28080        DO k = 1, 3
28081       DO l = 1, 4
28082        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
28083       END DO
28084       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
28085       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
28086       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
28087       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
28088       DO l = 1, 4
28089        gheadtail(k,l,1) = 0.0d0
28090        gheadtail(k,l,2) = 0.0d0
28091       END DO
28092        END DO
28093        eheadtail = (-dlog(eheadtail)) / betaT
28094        dPOLdOM1 = 0.0d0
28095        dPOLdOM2 = 0.0d0
28096        dQUADdOM1 = 0.0d0
28097        dQUADdOM2 = 0.0d0
28098        dQUADdOM12 = 0.0d0
28099        RETURN
28100       END SUBROUTINE energy_quad
28101 !!-----------------------------------------------------------
28102       SUBROUTINE eqn(Epol)
28103       use comm_momo
28104       use calc_data
28105
28106       double precision  facd4, federmaus,epol
28107       alphapol1 = alphapol(itypi,itypj)
28108 !c! R1 - distance between head of ith side chain and tail of jth sidechain
28109        R1 = 0.0d0
28110        DO k = 1, 3
28111 !c! Calculate head-to-tail distances
28112       R1=R1+(ctail(k,2)-chead(k,1))**2
28113        END DO
28114 !c! Pitagoras
28115        R1 = dsqrt(R1)
28116
28117 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28118 !c!     &        +dhead(1,1,itypi,itypj))**2))
28119 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28120 !c!     &        +dhead(2,1,itypi,itypj))**2))
28121 !c--------------------------------------------------------------------
28122 !c Polarization energy
28123 !c Epol
28124        MomoFac1 = (1.0d0 - chi1 * sqom2)
28125        RR1  = R1 * R1 / MomoFac1
28126        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
28127        fgb1 = sqrt( RR1 + a12sq * ee1)
28128        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
28129        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
28130              / (fgb1 ** 5.0d0)
28131        dFGBdR1 = ( (R1 / MomoFac1) &
28132             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
28133             / ( 2.0d0 * fgb1 )
28134        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
28135             * (2.0d0 - 0.5d0 * ee1) ) &
28136             / (2.0d0 * fgb1)
28137        dPOLdR1 = dPOLdFGB1 * dFGBdR1*sss_ele_cut+epol*sss_ele_grad
28138         epol=epol*sss_ele_cut
28139 !c!       dPOLdR1 = 0.0d0
28140        dPOLdOM1 = 0.0d0
28141        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
28142        DO k = 1, 3
28143       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
28144        END DO
28145        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
28146        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
28147        facd1 = d1 * vbld_inv(i+nres)
28148        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
28149
28150        DO k = 1, 3
28151       hawk = (erhead_tail(k,1) + &
28152       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
28153
28154       gvdwx(k,i) = gvdwx(k,i) &
28155                - dPOLdR1 * hawk
28156       gvdwx(k,j) = gvdwx(k,j) &
28157                + dPOLdR1 * (erhead_tail(k,1) &
28158        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
28159
28160       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
28161       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
28162
28163        END DO
28164        RETURN
28165       END SUBROUTINE eqn
28166       SUBROUTINE enq(Epol)
28167       use calc_data
28168       use comm_momo
28169        double precision facd3, adler,epol
28170        alphapol2 = alphapol(itypj,itypi)
28171 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28172        R2 = 0.0d0
28173        DO k = 1, 3
28174 !c! Calculate head-to-tail distances
28175       R2=R2+(chead(k,2)-ctail(k,1))**2
28176        END DO
28177 !c! Pitagoras
28178        R2 = dsqrt(R2)
28179
28180 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28181 !c!     &        +dhead(1,1,itypi,itypj))**2))
28182 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28183 !c!     &        +dhead(2,1,itypi,itypj))**2))
28184 !c------------------------------------------------------------------------
28185 !c Polarization energy
28186        MomoFac2 = (1.0d0 - chi2 * sqom1)
28187        RR2  = R2 * R2 / MomoFac2
28188        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28189        fgb2 = sqrt(RR2  + a12sq * ee2)
28190        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28191        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28192             / (fgb2 ** 5.0d0)
28193        dFGBdR2 = ( (R2 / MomoFac2)  &
28194             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28195             / (2.0d0 * fgb2)
28196        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28197             * (2.0d0 - 0.5d0 * ee2) ) &
28198             / (2.0d0 * fgb2)
28199        dPOLdR2 = dPOLdFGB2 * dFGBdR2*sss_ele_cut+epol*sss_ele_grad
28200        epol=epol*sss_ele_cut
28201 !c!       dPOLdR2 = 0.0d0
28202        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28203 !c!       dPOLdOM1 = 0.0d0
28204        dPOLdOM2 = 0.0d0
28205 !c!-------------------------------------------------------------------
28206 !c! Return the results
28207 !c! (See comments in Eqq)
28208        DO k = 1, 3
28209       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28210        END DO
28211        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
28212        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28213        facd2 = d2 * vbld_inv(j+nres)
28214        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
28215        DO k = 1, 3
28216       condor = (erhead_tail(k,2) &
28217        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
28218
28219       gvdwx(k,i) = gvdwx(k,i) &
28220                - dPOLdR2 * (erhead_tail(k,2) &
28221        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
28222       gvdwx(k,j) = gvdwx(k,j)   &
28223                + dPOLdR2 * condor
28224
28225       gvdwc(k,i) = gvdwc(k,i) &
28226                - dPOLdR2 * erhead_tail(k,2)
28227       gvdwc(k,j) = gvdwc(k,j) &
28228                + dPOLdR2 * erhead_tail(k,2)
28229
28230        END DO
28231       RETURN
28232       END SUBROUTINE enq
28233
28234       SUBROUTINE enq_cat(Epol)
28235       use calc_data
28236       use comm_momo
28237        double precision facd3, adler,epol
28238        alphapol2 = alphapolcat(itypi,itypj)
28239 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28240        R2 = 0.0d0
28241        DO k = 1, 3
28242 !c! Calculate head-to-tail distances
28243       R2=R2+(chead(k,2)-ctail(k,1))**2
28244        END DO
28245 !c! Pitagoras
28246        R2 = dsqrt(R2)
28247
28248 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28249 !c!     &        +dhead(1,1,itypi,itypj))**2))
28250 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28251 !c!     &        +dhead(2,1,itypi,itypj))**2))
28252 !c------------------------------------------------------------------------
28253 !c Polarization energy
28254        MomoFac2 = (1.0d0 - chi2 * sqom1)
28255        RR2  = R2 * R2 / MomoFac2
28256        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28257        fgb2 = sqrt(RR2  + a12sq * ee2)
28258        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28259        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28260             / (fgb2 ** 5.0d0)
28261        dFGBdR2 = ( (R2 / MomoFac2)  &
28262             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28263             / (2.0d0 * fgb2)
28264        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28265             * (2.0d0 - 0.5d0 * ee2) ) &
28266             / (2.0d0 * fgb2)
28267        dPOLdR2 = dPOLdFGB2 * dFGBdR2*sss_ele_cut+epol*sss_ele_grad
28268        epol=epol*sss_ele_cut
28269 !c!       dPOLdR2 = 0.0d0
28270        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28271 !c!       dPOLdOM1 = 0.0d0
28272        dPOLdOM2 = 0.0d0
28273
28274 !c!-------------------------------------------------------------------
28275 !c! Return the results
28276 !c! (See comments in Eqq)
28277        DO k = 1, 3
28278       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28279        END DO
28280        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
28281        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28282        facd2 = d2 * vbld_inv(j+nres)
28283        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
28284        DO k = 1, 3
28285       condor = (erhead_tail(k,2) &
28286        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
28287
28288       gradpepcatx(k,i) = gradpepcatx(k,i) &
28289                - dPOLdR2 * (erhead_tail(k,2) &
28290        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
28291 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
28292 !                   + dPOLdR2 * condor
28293
28294       gradpepcat(k,i) = gradpepcat(k,i) &
28295                - dPOLdR2 * erhead_tail(k,2)
28296       gradpepcat(k,j) = gradpepcat(k,j) &
28297                + dPOLdR2 * erhead_tail(k,2)
28298
28299        END DO
28300       RETURN
28301       END SUBROUTINE enq_cat
28302
28303       SUBROUTINE eqd(Ecl,Elj,Epol)
28304       use calc_data
28305       use comm_momo
28306        double precision  facd4, federmaus,ecl,elj,epol
28307        alphapol1 = alphapol(itypi,itypj)
28308        w1        = wqdip(1,itypi,itypj)
28309        w2        = wqdip(2,itypi,itypj)
28310        pis       = sig0head(itypi,itypj)
28311        eps_head   = epshead(itypi,itypj)
28312 !c!-------------------------------------------------------------------
28313 !c! R1 - distance between head of ith side chain and tail of jth sidechain
28314        R1 = 0.0d0
28315        DO k = 1, 3
28316 !c! Calculate head-to-tail distances
28317       R1=R1+(ctail(k,2)-chead(k,1))**2
28318        END DO
28319 !c! Pitagoras
28320        R1 = dsqrt(R1)
28321
28322 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28323 !c!     &        +dhead(1,1,itypi,itypj))**2))
28324 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28325 !c!     &        +dhead(2,1,itypi,itypj))**2))
28326
28327 !c!-------------------------------------------------------------------
28328 !c! ecl
28329        sparrow  = w1 * Qi * om1
28330        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
28331        Ecl = sparrow / Rhead**2.0d0 &
28332          - hawk    / Rhead**4.0d0
28333        dGCLdR  = (- 2.0d0 * sparrow / Rhead**3.0d0 &
28334              + 4.0d0 * hawk    / Rhead**5.0d0)*sss_ele_cut+Ecl*sss_ele_grad
28335        Ecl=Ecl*sss_ele_cut
28336 !c! dF/dom1
28337        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
28338 !c! dF/dom2
28339        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
28340 !c--------------------------------------------------------------------
28341 !c Polarization energy
28342 !c Epol
28343        MomoFac1 = (1.0d0 - chi1 * sqom2)
28344        RR1  = R1 * R1 / MomoFac1
28345        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
28346        fgb1 = sqrt( RR1 + a12sq * ee1)
28347        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
28348 !c!       epol = 0.0d0
28349 !c!------------------------------------------------------------------
28350 !c! derivative of Epol is Gpol...
28351        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
28352              / (fgb1 ** 5.0d0)
28353        dFGBdR1 = ( (R1 / MomoFac1)  &
28354            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
28355            / ( 2.0d0 * fgb1 )
28356        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
28357              * (2.0d0 - 0.5d0 * ee1) ) &
28358              / (2.0d0 * fgb1)
28359        dPOLdR1 = dPOLdFGB1 * dFGBdR1*sss_ele_cut+epol*sss_ele_grad
28360 !c!       dPOLdR1 = 0.0d0
28361        dPOLdOM1 = 0.0d0
28362        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
28363 !c!       dPOLdOM2 = 0.0d0
28364 !c!-------------------------------------------------------------------
28365 !c! Elj
28366        pom = (pis / Rhead)**6.0d0
28367        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28368 !c! derivative of Elj is Glj
28369        dGLJdR = 4.0d0 * eps_head &
28370         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28371         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))*sss_ele_cut+elj*sss_ele_grad
28372        Elj=Elj*sss_ele_cut
28373        DO k = 1, 3
28374       erhead(k) = Rhead_distance(k)/Rhead
28375       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
28376        END DO
28377
28378        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28379        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
28380        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
28381        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
28382        facd1 = d1 * vbld_inv(i+nres)
28383        facd2 = d2 * vbld_inv(j+nres)
28384        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
28385
28386        DO k = 1, 3
28387       hawk = (erhead_tail(k,1) +  &
28388       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
28389
28390       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28391       gvdwx(k,i) = gvdwx(k,i)  &
28392                - dGCLdR * pom&
28393                - dPOLdR1 * hawk &
28394                - dGLJdR * pom
28395
28396       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28397       gvdwx(k,j) = gvdwx(k,j)    &
28398                + dGCLdR * pom  &
28399                + dPOLdR1 * (erhead_tail(k,1) &
28400        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
28401                + dGLJdR * pom
28402
28403
28404       gvdwc(k,i) = gvdwc(k,i)          &
28405                - dGCLdR * erhead(k)  &
28406                - dPOLdR1 * erhead_tail(k,1) &
28407                - dGLJdR * erhead(k)
28408
28409       gvdwc(k,j) = gvdwc(k,j)          &
28410                + dGCLdR * erhead(k)  &
28411                + dPOLdR1 * erhead_tail(k,1) &
28412                + dGLJdR * erhead(k)
28413
28414        END DO
28415        RETURN
28416       END SUBROUTINE eqd
28417
28418       SUBROUTINE eqd_cat(Ecl,Elj,Epol)
28419       use calc_data
28420       use comm_momo
28421        double precision  facd4, federmaus,ecl,elj,epol
28422        alphapol1 = alphapolcat(itypi,itypj)
28423        w1        = wqdipcat(1,itypi,itypj)
28424        w2        = wqdipcat(2,itypi,itypj)
28425        pis       = sig0headcat(itypi,itypj)
28426        eps_head   = epsheadcat(itypi,itypj)
28427 !       eps_head=0.0d0
28428 !       w2=0.0d0
28429 !       alphapol1=0.0d0
28430 !c!-------------------------------------------------------------------
28431 !c! R1 - distance between head of ith side chain and tail of jth sidechain
28432        R1 = 0.0d0
28433        DO k = 1, 3
28434 !c! Calculate head-to-tail distances
28435       R1=R1+(ctail(k,2)-chead(k,1))**2
28436        END DO
28437 !c! Pitagoras
28438        R1 = dsqrt(R1)
28439
28440 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28441 !c!     &        +dhead(1,1,itypi,itypj))**2))
28442 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28443 !c!     &        +dhead(2,1,itypi,itypj))**2))
28444
28445 !c!-------------------------------------------------------------------
28446 !c! ecl
28447        sparrow  = w1 * Qi * om1
28448        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
28449        Ecl = sparrow / Rhead**2.0d0 &
28450          - hawk    / Rhead**4.0d0
28451        dGCLdR  =sss_ele_cut*(-2.0d0 * sparrow / Rhead**3.0d0 &
28452              + 4.0d0 * hawk    / Rhead**5.0d0)+sss_ele_grad*ECL
28453        ECL=ECL*sss_ele_cut
28454 !c! dF/dom1
28455        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
28456 !c! dF/dom2
28457        dGCLdOM2 = 0.0d0 !
28458
28459 !(2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
28460
28461 !c--------------------------------------------------------------------
28462 !c Polarization energy
28463 !c Epol
28464        MomoFac1 = (1.0d0 - chi1 * sqom2)
28465        RR1  = R1 * R1 / MomoFac1
28466        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
28467        fgb1 = sqrt( RR1 + a12sq * ee1)
28468        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
28469 !c!       epol = 0.0d0
28470 !c!------------------------------------------------------------------
28471 !c! derivative of Epol is Gpol...
28472        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
28473              / (fgb1 ** 5.0d0)
28474        dFGBdR1 = ( (R1 / MomoFac1)  &
28475            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
28476            / ( 2.0d0 * fgb1 )
28477        dFGBdOM2 = 0.0d0 ! as om2 is 0
28478 ! (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
28479 !             * (2.0d0 - 0.5d0 * ee1) ) &
28480 !             / (2.0d0 * fgb1)
28481        dPOLdR1 = dPOLdFGB1 * dFGBdR1*sss_ele_cut+epol*sss_ele_grad
28482 !c!       dPOLdR1 = 0.0d0
28483        dPOLdOM1 = 0.0d0
28484 !       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
28485        dPOLdOM2 = 0.0d0
28486        epol=epol*sss_ele_cut
28487 !c!-------------------------------------------------------------------
28488 !c! Elj
28489        pom = (pis / Rhead)**6.0d0
28490        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28491 !c! derivative of Elj is Glj
28492        dGLJdR = 4.0d0 * eps_head*sss_ele_cut &
28493         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28494         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))+Elj*sss_ele_grad
28495        Elj=Elj*sss_ele_cut
28496        DO k = 1, 3
28497       erhead(k) = Rhead_distance(k)/Rhead
28498       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
28499        END DO
28500
28501        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28502        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
28503        facd1 = d1 * vbld_inv(i+nres)
28504
28505        DO k = 1, 3
28506       hawk = (erhead_tail(k,1) +  &
28507       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
28508
28509       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28510       gradpepcatx(k,i) = gradpepcatx(k,i)  &
28511                - dGCLdR * pom&
28512                - dPOLdR1 * hawk &
28513                - dGLJdR * pom
28514
28515 !      pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28516 !      gradpepcatx(k,j) = gradpepcatx(k,j)    &
28517 !               + dGCLdR * pom  &
28518 !               + dPOLdR1 * (erhead_tail(k,1) &
28519 !       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
28520 !               + dGLJdR * pom
28521
28522
28523       gradpepcat(k,i) = gradpepcat(k,i)          &
28524                - dGCLdR * erhead(k)  &
28525                - dPOLdR1 * erhead_tail(k,1) &
28526                - dGLJdR * erhead(k)
28527
28528       gradpepcat(k,j) = gradpepcat(k,j)          &
28529                + dGCLdR * erhead(k)  &
28530                + dPOLdR1 * erhead_tail(k,1) &
28531                + dGLJdR * erhead(k)
28532
28533        END DO
28534        RETURN
28535       END SUBROUTINE eqd_cat
28536
28537       SUBROUTINE edq(Ecl,Elj,Epol)
28538 !       IMPLICIT NONE
28539        use comm_momo
28540       use calc_data
28541
28542       double precision  facd3, adler,ecl,elj,epol
28543        alphapol2 = alphapol(itypj,itypi)
28544        w1        = wqdip(1,itypi,itypj)
28545        w2        = wqdip(2,itypi,itypj)
28546        pis       = sig0head(itypi,itypj)
28547        eps_head  = epshead(itypi,itypj)
28548 !c!-------------------------------------------------------------------
28549 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28550        R2 = 0.0d0
28551        DO k = 1, 3
28552 !c! Calculate head-to-tail distances
28553       R2=R2+(chead(k,2)-ctail(k,1))**2
28554        END DO
28555 !c! Pitagoras
28556        R2 = dsqrt(R2)
28557
28558 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28559 !c!     &        +dhead(1,1,itypi,itypj))**2))
28560 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28561 !c!     &        +dhead(2,1,itypi,itypj))**2))
28562
28563
28564 !c!-------------------------------------------------------------------
28565 !c! ecl
28566        sparrow  = w1 * Qj * om1
28567        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
28568        ECL = sparrow / Rhead**2.0d0 &
28569          - hawk    / Rhead**4.0d0
28570 !c!-------------------------------------------------------------------
28571 !c! derivative of ecl is Gcl
28572 !c! dF/dr part
28573        dGCLdR  =sss_ele_cut*(- 2.0d0 * sparrow / Rhead**3.0d0 &
28574              + 4.0d0 * hawk    / Rhead**5.0d0)+Ecl*sss_ele_grad
28575 !c! dF/dom1
28576        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
28577 !c! dF/dom2
28578        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
28579 !c--------------------------------------------------------------------
28580 !c Polarization energy
28581 !c Epol
28582        MomoFac2 = (1.0d0 - chi2 * sqom1)
28583        RR2  = R2 * R2 / MomoFac2
28584        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28585        fgb2 = sqrt(RR2  + a12sq * ee2)
28586        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28587        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28588              / (fgb2 ** 5.0d0)
28589        dFGBdR2 = ( (R2 / MomoFac2)  &
28590              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28591              / (2.0d0 * fgb2)
28592        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28593             * (2.0d0 - 0.5d0 * ee2) ) &
28594             / (2.0d0 * fgb2)
28595        dPOLdR2 = dPOLdFGB2 * dFGBdR2*sss_ele_cut
28596         epol=epol*sss_ele_cut
28597 !c!       dPOLdR2 = 0.0d0
28598        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28599 !c!       dPOLdOM1 = 0.0d0
28600        dPOLdOM2 = 0.0d0
28601 !c!-------------------------------------------------------------------
28602 !c! Elj
28603        pom = (pis / Rhead)**6.0d0
28604        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28605 !c! derivative of Elj is Glj
28606        dGLJdR = 4.0d0 * eps_head &
28607          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28608          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))*sss_ele_cut+Elj*sss_ele_grad
28609         elj=elj*sss_ele_cut
28610 !c!-------------------------------------------------------------------
28611 !c! Return the results
28612 !c! (see comments in Eqq)
28613        DO k = 1, 3
28614       erhead(k) = Rhead_distance(k)/Rhead
28615       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28616        END DO
28617        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28618        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
28619        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
28620        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28621        facd1 = d1 * vbld_inv(i+nres)
28622        facd2 = d2 * vbld_inv(j+nres)
28623        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
28624        DO k = 1, 3
28625       condor = (erhead_tail(k,2) &
28626        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
28627
28628       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28629       gvdwx(k,i) = gvdwx(k,i) &
28630               - dGCLdR * pom &
28631               - dPOLdR2 * (erhead_tail(k,2) &
28632        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
28633               - dGLJdR * pom
28634
28635       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28636       gvdwx(k,j) = gvdwx(k,j) &
28637               + dGCLdR * pom &
28638               + dPOLdR2 * condor &
28639               + dGLJdR * pom
28640
28641
28642       gvdwc(k,i) = gvdwc(k,i) &
28643               - dGCLdR * erhead(k) &
28644               - dPOLdR2 * erhead_tail(k,2) &
28645               - dGLJdR * erhead(k)
28646
28647       gvdwc(k,j) = gvdwc(k,j) &
28648               + dGCLdR * erhead(k) &
28649               + dPOLdR2 * erhead_tail(k,2) &
28650               + dGLJdR * erhead(k)
28651
28652        END DO
28653        RETURN
28654       END SUBROUTINE edq
28655
28656       SUBROUTINE edq_cat(Ecl,Elj,Epol)
28657       use comm_momo
28658       use calc_data
28659
28660       double precision  facd3, adler,ecl,elj,epol
28661        alphapol2 = alphapolcat(itypi,itypj)
28662        w1        = wqdipcat(1,itypi,itypj)
28663        w2        = wqdipcat(2,itypi,itypj)
28664        pis       = sig0headcat(itypi,itypj)
28665        eps_head  = epsheadcat(itypi,itypj)
28666 !c!-------------------------------------------------------------------
28667 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28668        R2 = 0.0d0
28669        DO k = 1, 3
28670 !c! Calculate head-to-tail distances
28671       R2=R2+(chead(k,2)-ctail(k,1))**2
28672        END DO
28673 !c! Pitagoras
28674        R2 = dsqrt(R2)
28675
28676 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28677 !c!     &        +dhead(1,1,itypi,itypj))**2))
28678 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28679 !c!     &        +dhead(2,1,itypi,itypj))**2))
28680
28681
28682 !c!-------------------------------------------------------------------
28683 !c! ecl
28684 !       write(iout,*) "KURWA2",Rhead
28685        sparrow  = w1 * Qj * om1
28686        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
28687        ECL = sparrow / Rhead**2.0d0 &
28688          - hawk    / Rhead**4.0d0
28689 !c!-------------------------------------------------------------------
28690 !c! derivative of ecl is Gcl
28691 !c! dF/dr part
28692        dGCLdR  =( - 2.0d0 * sparrow / Rhead**3.0d0 &
28693              + 4.0d0 * hawk    / Rhead**5.0d0)*sss_ele_cut+ECL*sss_ele_grad
28694 !c! dF/dom1
28695        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
28696 !c! dF/dom2
28697        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
28698        ECL=ECL*sss_ele_cut
28699 !c--------------------------------------------------------------------
28700 !c--------------------------------------------------------------------
28701 !c Polarization energy
28702 !c Epol
28703        MomoFac2 = (1.0d0 - chi2 * sqom1)
28704        RR2  = R2 * R2 / MomoFac2
28705        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28706        fgb2 = sqrt(RR2  + a12sq * ee2)
28707        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28708        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28709              / (fgb2 ** 5.0d0)
28710        dFGBdR2 = ( (R2 / MomoFac2)  &
28711              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28712              / (2.0d0 * fgb2)
28713        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28714             * (2.0d0 - 0.5d0 * ee2) ) &
28715             / (2.0d0 * fgb2)
28716        dPOLdR2 = dPOLdFGB2 * dFGBdR2*sss_ele_cut+epol*sss_ele_grad
28717 !c!       dPOLdR2 = 0.0d0
28718        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28719 !c!       dPOLdOM1 = 0.0d0
28720        dPOLdOM2 = 0.0d0
28721        epol=epol*sss_ele_cut
28722 !c!-------------------------------------------------------------------
28723 !c! Elj
28724        pom = (pis / Rhead)**6.0d0
28725        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28726 !c! derivative of Elj is Glj
28727        dGLJdR = 4.0d0 * eps_head &
28728          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28729          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))*sss_ele_cut+&
28730            Elj*sss_ele_grad
28731        Elj=Elj*sss_ele_cut
28732 !c!-------------------------------------------------------------------
28733
28734 !c! Return the results
28735 !c! (see comments in Eqq)
28736        DO k = 1, 3
28737       erhead(k) = Rhead_distance(k)/Rhead
28738       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28739        END DO
28740        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28741        erdxj = scalar( erhead(1), dC_norm(1,j) )
28742        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
28743        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28744        facd1 = d1 * vbld_inv(i+nres)
28745        facd2 = d2 * vbld_inv(j)
28746        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
28747        DO k = 1, 3
28748       condor = (erhead_tail(k,2) &
28749        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
28750
28751       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28752       gradpepcatx(k,i) = gradpepcatx(k,i) &
28753               - dGCLdR * pom &
28754               - dPOLdR2 * (erhead_tail(k,2) &
28755        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
28756               - dGLJdR * pom
28757
28758       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
28759 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
28760 !                  + dGCLdR * pom &
28761 !                  + dPOLdR2 * condor &
28762 !                  + dGLJdR * pom
28763
28764
28765       gradpepcat(k,i) = gradpepcat(k,i) &
28766               - dGCLdR * erhead(k) &
28767               - dPOLdR2 * erhead_tail(k,2) &
28768               - dGLJdR * erhead(k)
28769
28770       gradpepcat(k,j) = gradpepcat(k,j) &
28771               + dGCLdR * erhead(k) &
28772               + dPOLdR2 * erhead_tail(k,2) &
28773               + dGLJdR * erhead(k)
28774
28775        END DO
28776        RETURN
28777       END SUBROUTINE edq_cat
28778
28779       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
28780       use comm_momo
28781       use calc_data
28782
28783       double precision  facd3, adler,ecl,elj,epol
28784        alphapol2 = alphapolcat(itypi,itypj)
28785        w1        = wqdipcat(1,itypi,itypj)
28786        w2        = wqdipcat(2,itypi,itypj)
28787        pis       = sig0headcat(itypi,itypj)
28788        eps_head  = epsheadcat(itypi,itypj)
28789 !c!-------------------------------------------------------------------
28790 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28791        R2 = 0.0d0
28792        DO k = 1, 3
28793 !c! Calculate head-to-tail distances
28794       R2=R2+(chead(k,2)-ctail(k,1))**2
28795        END DO
28796 !c! Pitagoras
28797        R2 = dsqrt(R2)
28798
28799 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28800 !c!     &        +dhead(1,1,itypi,itypj))**2))
28801 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28802 !c!     &        +dhead(2,1,itypi,itypj))**2))
28803
28804
28805 !c!-------------------------------------------------------------------
28806 !c! ecl
28807        sparrow  = w1 * Qj * om1
28808        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
28809 !       print *,"CO2", itypi,itypj
28810 !       print *,"CO?!.", w1,w2,Qj,om1
28811        ECL = sparrow / Rhead**2.0d0 &
28812          - hawk    / Rhead**4.0d0
28813 !c!-------------------------------------------------------------------
28814 !c! derivative of ecl is Gcl
28815 !c! dF/dr part
28816        dGCLdR  = (- 2.0d0 * sparrow / Rhead**3.0d0 &
28817              + 4.0d0 * hawk    / Rhead**5.0d0)*sss_ele_cut+&
28818              ECL*sss_ele_grad
28819        ECL=ECL*sss_ele_cut
28820 !c! dF/dom1
28821        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
28822 !c! dF/dom2
28823        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
28824 !c--------------------------------------------------------------------
28825 !c--------------------------------------------------------------------
28826 !c Polarization energy
28827 !c Epol
28828        MomoFac2 = (1.0d0 - chi2 * sqom1)
28829        RR2  = R2 * R2 / MomoFac2
28830        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28831        fgb2 = sqrt(RR2  + a12sq * ee2)
28832        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28833        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28834              / (fgb2 ** 5.0d0)
28835        dFGBdR2 = ( (R2 / MomoFac2)  &
28836              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28837              / (2.0d0 * fgb2)
28838        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28839             * (2.0d0 - 0.5d0 * ee2) ) &
28840             / (2.0d0 * fgb2)
28841        dPOLdR2 = dPOLdFGB2 * dFGBdR2*sss_ele_cut+epol*sss_ele_grad
28842        epol=epol*sss_ele_grad
28843 !c!       dPOLdR2 = 0.0d0
28844        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28845 !c!       dPOLdOM1 = 0.0d0
28846        dPOLdOM2 = 0.0d0
28847 !c!-------------------------------------------------------------------
28848 !c! Elj
28849        pom = (pis / Rhead)**6.0d0
28850        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28851 !c! derivative of Elj is Glj
28852        dGLJdR = 4.0d0 * eps_head*sss_ele_cut &
28853          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28854          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))+Elj*sss_ele_grad
28855        Elj=Elj*sss_ele_cut
28856 !c!-------------------------------------------------------------------
28857
28858 !c! Return the results
28859 !c! (see comments in Eqq)
28860        DO k = 1, 3
28861       erhead(k) = Rhead_distance(k)/Rhead
28862       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28863        END DO
28864        erdxi = scalar( erhead(1), dC_norm(1,i) )
28865        erdxj = scalar( erhead(1), dC_norm(1,j) )
28866        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
28867        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
28868        facd1 = d1 * vbld_inv(i+1)/2.0
28869        facd2 = d2 * vbld_inv(j)
28870        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
28871        DO k = 1, 3
28872       condor = (erhead_tail(k,2) &
28873        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
28874
28875       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
28876 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
28877 !                  - dGCLdR * pom &
28878 !                  - dPOLdR2 * (erhead_tail(k,2) &
28879 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
28880 !                  - dGLJdR * pom
28881
28882       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
28883 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
28884 !                  + dGCLdR * pom &
28885 !                  + dPOLdR2 * condor &
28886 !                  + dGLJdR * pom
28887
28888
28889       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
28890               - dGCLdR * erhead(k) &
28891               - dPOLdR2 * erhead_tail(k,2) &
28892               - dGLJdR * erhead(k))
28893       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
28894               - dGCLdR * erhead(k) &
28895               - dPOLdR2 * erhead_tail(k,2) &
28896               - dGLJdR * erhead(k))
28897
28898
28899       gradpepcat(k,j) = gradpepcat(k,j) &
28900               + dGCLdR * erhead(k) &
28901               + dPOLdR2 * erhead_tail(k,2) &
28902               + dGLJdR * erhead(k)
28903
28904        END DO
28905        RETURN
28906       END SUBROUTINE edq_cat_pep
28907
28908       SUBROUTINE edd(ECL)
28909 !       IMPLICIT NONE
28910        use comm_momo
28911       use calc_data
28912
28913        double precision ecl
28914 !c!       csig = sigiso(itypi,itypj)
28915        w1 = wqdip(1,itypi,itypj)
28916        w2 = wqdip(2,itypi,itypj)
28917 !c!-------------------------------------------------------------------
28918 !c! ECL
28919        fac = (om12 - 3.0d0 * om1 * om2)
28920        c1 = (w1 / (Rhead**3.0d0)) * fac
28921        c2 = (w2 / Rhead ** 6.0d0) &
28922         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
28923        ECL = c1 - c2
28924 !c!       write (*,*) "w1 = ", w1
28925 !c!       write (*,*) "w2 = ", w2
28926 !c!       write (*,*) "om1 = ", om1
28927 !c!       write (*,*) "om2 = ", om2
28928 !c!       write (*,*) "om12 = ", om12
28929 !c!       write (*,*) "fac = ", fac
28930 !c!       write (*,*) "c1 = ", c1
28931 !c!       write (*,*) "c2 = ", c2
28932 !c!       write (*,*) "Ecl = ", Ecl
28933 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
28934 !c!       write (*,*) "c2_2 = ",
28935 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
28936 !c!-------------------------------------------------------------------
28937 !c! dervative of ECL is GCL...
28938 !c! dECL/dr
28939        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
28940        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
28941         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
28942        dGCLdR = (c1 - c2)*sss_ele_cut+ECL*sss_ele_grad
28943        ECL=ECL*sss_ele_cut
28944 !c! dECL/dom1
28945        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
28946        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
28947         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
28948        dGCLdOM1 = c1 - c2
28949 !c! dECL/dom2
28950        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
28951        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
28952         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
28953        dGCLdOM2 = c1 - c2
28954 !c! dECL/dom12
28955        c1 = w1 / (Rhead ** 3.0d0)
28956        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
28957        dGCLdOM12 = c1 - c2
28958 !c!-------------------------------------------------------------------
28959 !c! Return the results
28960 !c! (see comments in Eqq)
28961        DO k= 1, 3
28962       erhead(k) = Rhead_distance(k)/Rhead
28963        END DO
28964        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28965        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
28966        facd1 = d1 * vbld_inv(i+nres)
28967        facd2 = d2 * vbld_inv(j+nres)
28968        DO k = 1, 3
28969
28970       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28971       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
28972       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28973       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
28974
28975       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
28976       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
28977        END DO
28978        RETURN
28979       END SUBROUTINE edd
28980       SUBROUTINE edd_cat(ECL)
28981 !       IMPLICIT NONE
28982        use comm_momo
28983       use calc_data
28984
28985        double precision ecl
28986 !c!       csig = sigiso(itypi,itypj)
28987        w1 = wqdipcat(1,itypi,itypj)
28988        w2 = wqdipcat(2,itypi,itypj)
28989 !       w2=0.0d0
28990 !c!-------------------------------------------------------------------
28991 !c! ECL
28992 !       print *,"om1",om1,om2,om12
28993        fac = - 3.0d0 * om1 !after integer and simplify
28994        c1 = (w1 / (Rhead**3.0d0)) * fac
28995        c2 = (w2 / Rhead ** 6.0d0) &
28996         * (4.0d0 + 6.0d0*sqom1 ) !after integration and simplification
28997        ECL = c1 - c2
28998 !c! dervative of ECL is GCL...
28999 !c! dECL/dr
29000        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
29001        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
29002         * (4.0d0 + 6.0d0*sqom1)
29003        dGCLdR = (c1 - c2)*sss_ele_cut+ECL*sss_ele_grad
29004 !c! dECL/dom1
29005        c1 = (-3.0d0 * w1) / (Rhead**3.0d0)
29006        c2 = (12.0d0 * w2*om1) / (Rhead**6.0d0)
29007        dGCLdOM1 = c1 - c2
29008 !c! dECL/dom2
29009 !       c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
29010        c1=0.0 ! this is because om2 is 0
29011 !       c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
29012 !        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
29013        c2=0.0 !om is 0
29014        dGCLdOM2 = c1 - c2
29015 !c! dECL/dom12
29016 !       c1 = w1 / (Rhead ** 3.0d0)
29017        c1=0.0d0 ! this is because om12 is 0
29018 !       c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
29019        c2=0.0d0 !om12 is 0
29020        dGCLdOM12 = c1 - c2
29021 !c!-------------------------------------------------------------------
29022 !c! Return the results
29023 !c! (see comments in Eqq)
29024        DO k= 1, 3
29025       erhead(k) = Rhead_distance(k)/Rhead
29026        END DO
29027        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
29028        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
29029        facd1 = d1 * vbld_inv(i+nres)
29030        facd2 = d2 * vbld_inv(j+nres)
29031        DO k = 1, 3
29032
29033       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
29034       gradpepcatx(k,i) = gradpepcatx(k,i)    - dGCLdR * pom
29035 !      pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
29036 !      gradpepcatx(k,j) = gradpepcatx(k,j)    + dGCLdR * pom
29037
29038       gradpepcat(k,i) = gradpepcat(k,i)    - dGCLdR * erhead(k)
29039       gradpepcat(k,j) = gradpepcat(k,j)    + dGCLdR * erhead(k)
29040        END DO
29041        RETURN
29042       END SUBROUTINE edd_cat
29043       SUBROUTINE edd_cat_pep(ECL)
29044 !       IMPLICIT NONE
29045        use comm_momo
29046       use calc_data
29047
29048        double precision ecl
29049 !c!       csig = sigiso(itypi,itypj)
29050        w1 = wqdipcat(1,itypi,itypj)
29051        w2 = wqdipcat(2,itypi,itypj)
29052 !c!-------------------------------------------------------------------
29053 !c! ECL
29054        fac = (om12 - 3.0d0 * om1 * om2)
29055        c1 = (w1 / (Rhead**3.0d0)) * fac
29056        c2 = (w2 / Rhead ** 6.0d0) &
29057         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
29058        ECL = c1 - c2
29059 !c! dECL/dr
29060        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
29061        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
29062         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
29063        dGCLdR = (c1 - c2)*sss_ele_cut+ECL*sss_ele_grad
29064        ECL=ECL*sss_ele_cut
29065 !c! dECL/dom1
29066        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
29067        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
29068         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
29069        dGCLdOM1 = c1 - c2
29070 !c! dECL/dom2
29071        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
29072        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
29073         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
29074        dGCLdOM2 = c1 - c2
29075        dGCLdOM2=0.0d0 ! this is because om2=0
29076 !c! dECL/dom12
29077        c1 = w1 / (Rhead ** 3.0d0)
29078        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
29079        dGCLdOM12 = c1 - c2
29080        dGCLdOM12=0.0d0 !this is because om12=0.0
29081 !c!-------------------------------------------------------------------
29082 !c! Return the results
29083 !c! (see comments in Eqq)
29084        DO k= 1, 3
29085       erhead(k) = Rhead_distance(k)/Rhead
29086        END DO
29087        erdxi = scalar( erhead(1), dC_norm(1,i) )
29088        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
29089        facd1 = d1 * vbld_inv(i)
29090        facd2 = d2 * vbld_inv(j+nres)
29091        DO k = 1, 3
29092
29093       pom = facd1*(erhead(k)-erdxi*dC_norm(k,i))
29094       gradpepcat(k,i) = gradpepcat(k,i)    + dGCLdR * pom
29095       gradpepcat(k,i+1) = gradpepcat(k,i+1) - dGCLdR * pom
29096 !      pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
29097 !      gradpepcatx(k,j) = gradpepcatx(k,j)    + dGCLdR * pom
29098
29099       gradpepcat(k,i) = gradpepcat(k,i)    - dGCLdR * erhead(k)*0.5d0
29100       gradpepcat(k,i+1) = gradpepcat(k,i+1)- dGCLdR * erhead(k)*0.5d0
29101       gradpepcat(k,j) = gradpepcat(k,j)    + dGCLdR * erhead(k)
29102        END DO
29103        RETURN
29104       END SUBROUTINE edd_cat_pep
29105
29106       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
29107 !       IMPLICIT NONE
29108        use comm_momo
29109       use calc_data
29110
29111        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
29112        eps_out=80.0d0
29113        itypi = itype(i,1)
29114        itypj = itype(j,1)
29115 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
29116 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
29117 !c!       t_bath = 300
29118 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
29119        Rb=0.001986d0
29120        BetaT = 1.0d0 / (298.0d0 * Rb)
29121 !c! Gay-berne var's
29122        sig0ij = sigma( itypi,itypj )
29123        chi1   = chi( itypi, itypj )
29124        chi2   = chi( itypj, itypi )
29125        chi12  = chi1 * chi2
29126        chip1  = chipp( itypi, itypj )
29127        chip2  = chipp( itypj, itypi )
29128        chip12 = chip1 * chip2
29129 !       chi1=0.0
29130 !       chi2=0.0
29131 !       chi12=0.0
29132 !       chip1=0.0
29133 !       chip2=0.0
29134 !       chip12=0.0
29135 !c! not used by momo potential, but needed by sc_angular which is shared
29136 !c! by all energy_potential subroutines
29137        alf1   = 0.0d0
29138        alf2   = 0.0d0
29139        alf12  = 0.0d0
29140 !c! location, location, location
29141 !       xj  = c( 1, nres+j ) - xi
29142 !       yj  = c( 2, nres+j ) - yi
29143 !       zj  = c( 3, nres+j ) - zi
29144        dxj = dc_norm( 1, nres+j )
29145        dyj = dc_norm( 2, nres+j )
29146        dzj = dc_norm( 3, nres+j )
29147 !c! distance from center of chain(?) to polar/charged head
29148 !c!       write (*,*) "istate = ", 1
29149 !c!       write (*,*) "ii = ", 1
29150 !c!       write (*,*) "jj = ", 1
29151        d1 = dhead(1, 1, itypi, itypj)
29152        d2 = dhead(2, 1, itypi, itypj)
29153 !c! ai*aj from Fgb
29154        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
29155 !c!       a12sq = a12sq * a12sq
29156 !c! charge of amino acid itypi is...
29157        Qi  = icharge(itypi)
29158        Qj  = icharge(itypj)
29159        Qij = Qi * Qj
29160 !c! chis1,2,12
29161        chis1 = chis(itypi,itypj)
29162        chis2 = chis(itypj,itypi)
29163        chis12 = chis1 * chis2
29164        sig1 = sigmap1(itypi,itypj)
29165        sig2 = sigmap2(itypi,itypj)
29166 !c!       write (*,*) "sig1 = ", sig1
29167 !c!       write (*,*) "sig2 = ", sig2
29168 !c! alpha factors from Fcav/Gcav
29169        b1cav = alphasur(1,itypi,itypj)
29170 !       b1cav=0.0
29171        b2cav = alphasur(2,itypi,itypj)
29172        b3cav = alphasur(3,itypi,itypj)
29173        b4cav = alphasur(4,itypi,itypj)
29174        wqd = wquad(itypi, itypj)
29175 !c! used by Fgb
29176        eps_in = epsintab(itypi,itypj)
29177        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
29178 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
29179 !c!-------------------------------------------------------------------
29180 !c! tail location and distance calculations
29181        Rtail = 0.0d0
29182        DO k = 1, 3
29183       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
29184       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
29185        END DO
29186 !c! tail distances will be themselves usefull elswhere
29187 !c1 (in Gcav, for example)
29188        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
29189        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
29190        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
29191        Rtail = dsqrt(  &
29192         (Rtail_distance(1)*Rtail_distance(1))  &
29193       + (Rtail_distance(2)*Rtail_distance(2))  &
29194       + (Rtail_distance(3)*Rtail_distance(3)))
29195 !c!-------------------------------------------------------------------
29196 !c! Calculate location and distance between polar heads
29197 !c! distance between heads
29198 !c! for each one of our three dimensional space...
29199        d1 = dhead(1, 1, itypi, itypj)
29200        d2 = dhead(2, 1, itypi, itypj)
29201
29202        DO k = 1,3
29203 !c! location of polar head is computed by taking hydrophobic centre
29204 !c! and moving by a d1 * dc_norm vector
29205 !c! see unres publications for very informative images
29206       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
29207       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
29208 !c! distance
29209 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
29210 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
29211       Rhead_distance(k) = chead(k,2) - chead(k,1)
29212        END DO
29213 !c! pitagoras (root of sum of squares)
29214        Rhead = dsqrt(   &
29215         (Rhead_distance(1)*Rhead_distance(1)) &
29216       + (Rhead_distance(2)*Rhead_distance(2)) &
29217       + (Rhead_distance(3)*Rhead_distance(3)))
29218 !c!-------------------------------------------------------------------
29219 !c! zero everything that should be zero'ed
29220        Egb = 0.0d0
29221        ECL = 0.0d0
29222        Elj = 0.0d0
29223        Equad = 0.0d0
29224        Epol = 0.0d0
29225        eheadtail = 0.0d0
29226        dGCLdOM1 = 0.0d0
29227        dGCLdOM2 = 0.0d0
29228        dGCLdOM12 = 0.0d0
29229        dPOLdOM1 = 0.0d0
29230        dPOLdOM2 = 0.0d0
29231        RETURN
29232       END SUBROUTINE elgrad_init
29233
29234
29235       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
29236       use comm_momo
29237       use calc_data
29238        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
29239        eps_out=80.0d0
29240        itypi = itype(i,1)
29241        itypj = itype(j,5)
29242 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
29243 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
29244 !c!       t_bath = 300
29245 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
29246        Rb=0.001986d0
29247        BetaT = 1.0d0 / (298.0d0 * Rb)
29248 !c! Gay-berne var's
29249        sig0ij = sigmacat( itypi,itypj )
29250        chi1   = chi1cat( itypi, itypj )
29251        chi2   = 0.0d0
29252        chi12  = 0.0d0
29253        chip1  = chipp1cat( itypi, itypj )
29254        chip2  = 0.0d0
29255        chip12 = 0.0d0
29256 !c! not used by momo potential, but needed by sc_angular which is shared
29257 !c! by all energy_potential subroutines
29258        alf1   = 0.0d0
29259        alf2   = 0.0d0
29260        alf12  = 0.0d0
29261        dxj = 0.0d0 !dc_norm( 1, nres+j )
29262        dyj = 0.0d0 !dc_norm( 2, nres+j )
29263        dzj = 0.0d0 !dc_norm( 3, nres+j )
29264 !c! distance from center of chain(?) to polar/charged head
29265        d1 = dheadcat(1, 1, itypi, itypj)
29266        d2 = dheadcat(2, 1, itypi, itypj)
29267 !c! ai*aj from Fgb
29268        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
29269 !c!       a12sq = a12sq * a12sq
29270 !c! charge of amino acid itypi is...
29271        Qi  = icharge(itypi)
29272        Qj  = ichargecat(itypj)
29273        Qij = Qi * Qj
29274 !c! chis1,2,12
29275        chis1 = chis1cat(itypi,itypj)
29276        chis2 = 0.0d0
29277        chis12 = 0.0d0
29278        sig1 = sigmap1cat(itypi,itypj)
29279        sig2 = sigmap2cat(itypi,itypj)
29280 !c! alpha factors from Fcav/Gcav
29281        b1cav = alphasurcat(1,itypi,itypj)
29282        b2cav = alphasurcat(2,itypi,itypj)
29283        b3cav = alphasurcat(3,itypi,itypj)
29284        b4cav = alphasurcat(4,itypi,itypj)
29285        wqd = wquadcat(itypi, itypj)
29286 !c! used by Fgb
29287        eps_in = epsintabcat(itypi,itypj)
29288        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
29289 !c!-------------------------------------------------------------------
29290 !c! tail location and distance calculations
29291        Rtail = 0.0d0
29292        DO k = 1, 3
29293       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
29294       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
29295        END DO
29296 !c! tail distances will be themselves usefull elswhere
29297 !c1 (in Gcav, for example)
29298        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
29299        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
29300        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
29301        Rtail = dsqrt(  &
29302         (Rtail_distance(1)*Rtail_distance(1))  &
29303       + (Rtail_distance(2)*Rtail_distance(2))  &
29304       + (Rtail_distance(3)*Rtail_distance(3)))
29305 !c!-------------------------------------------------------------------
29306 !c! Calculate location and distance between polar heads
29307 !c! distance between heads
29308 !c! for each one of our three dimensional space...
29309        d1 = dheadcat(1, 1, itypi, itypj)
29310        d2 = dheadcat(2, 1, itypi, itypj)
29311
29312        DO k = 1,3
29313 !c! location of polar head is computed by taking hydrophobic centre
29314 !c! and moving by a d1 * dc_norm vector
29315 !c! see unres publications for very informative images
29316       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
29317       chead(k,2) = c(k, j)
29318 !c! distance
29319 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
29320 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
29321       Rhead_distance(k) = chead(k,2) - chead(k,1)
29322        END DO
29323 !c! pitagoras (root of sum of squares)
29324        Rhead = dsqrt(   &
29325         (Rhead_distance(1)*Rhead_distance(1)) &
29326       + (Rhead_distance(2)*Rhead_distance(2)) &
29327       + (Rhead_distance(3)*Rhead_distance(3)))
29328 !c!-------------------------------------------------------------------
29329 !c! zero everything that should be zero'ed
29330        Egb = 0.0d0
29331        ECL = 0.0d0
29332        Elj = 0.0d0
29333        Equad = 0.0d0
29334        Epol = 0.0d0
29335        eheadtail = 0.0d0
29336        dGCLdOM1 = 0.0d0
29337        dGCLdOM2 = 0.0d0
29338        dGCLdOM12 = 0.0d0
29339        dPOLdOM1 = 0.0d0
29340        dPOLdOM2 = 0.0d0
29341        RETURN
29342       END SUBROUTINE elgrad_init_cat
29343
29344       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
29345       use comm_momo
29346       use calc_data
29347        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
29348        eps_out=80.0d0
29349        itypi = 10
29350        itypj = itype(j,5)
29351 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
29352 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
29353 !c!       t_bath = 300
29354 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
29355        Rb=0.001986d0
29356        BetaT = 1.0d0 / (298.0d0 * Rb)
29357 !c! Gay-berne var's
29358        sig0ij = sigmacat( itypi,itypj )
29359        chi1   = chi1cat( itypi, itypj )
29360        chi2   = 0.0d0
29361        chi12  = 0.0d0
29362        chip1  = chipp1cat( itypi, itypj )
29363        chip2  = 0.0d0
29364        chip12 = 0.0d0
29365 !c! not used by momo potential, but needed by sc_angular which is shared
29366 !c! by all energy_potential subroutines
29367        alf1   = 0.0d0
29368        alf2   = 0.0d0
29369        alf12  = 0.0d0
29370        dxj = 0.0d0 !dc_norm( 1, nres+j )
29371        dyj = 0.0d0 !dc_norm( 2, nres+j )
29372        dzj = 0.0d0 !dc_norm( 3, nres+j )
29373 !c! distance from center of chain(?) to polar/charged head
29374        d1 = dheadcat(1, 1, itypi, itypj)
29375        d2 = dheadcat(2, 1, itypi, itypj)
29376 !c! ai*aj from Fgb
29377        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
29378 !c!       a12sq = a12sq * a12sq
29379 !c! charge of amino acid itypi is...
29380        Qi  = 0
29381        Qj  = ichargecat(itypj)
29382 !       Qij = Qi * Qj
29383 !c! chis1,2,12
29384        chis1 = chis1cat(itypi,itypj)
29385        chis2 = 0.0d0
29386        chis12 = 0.0d0
29387        sig1 = sigmap1cat(itypi,itypj)
29388        sig2 = sigmap2cat(itypi,itypj)
29389 !c! alpha factors from Fcav/Gcav
29390        b1cav = alphasurcat(1,itypi,itypj)
29391        b2cav = alphasurcat(2,itypi,itypj)
29392        b3cav = alphasurcat(3,itypi,itypj)
29393        b4cav = alphasurcat(4,itypi,itypj)
29394        wqd = wquadcat(itypi, itypj)
29395 !c! used by Fgb
29396        eps_in = epsintabcat(itypi,itypj)
29397        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
29398 !c!-------------------------------------------------------------------
29399 !c! tail location and distance calculations
29400        Rtail = 0.0d0
29401        DO k = 1, 3
29402       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
29403       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
29404        END DO
29405 !c! tail distances will be themselves usefull elswhere
29406 !c1 (in Gcav, for example)
29407        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
29408        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
29409        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
29410        Rtail = dsqrt(  &
29411         (Rtail_distance(1)*Rtail_distance(1))  &
29412       + (Rtail_distance(2)*Rtail_distance(2))  &
29413       + (Rtail_distance(3)*Rtail_distance(3)))
29414 !c!-------------------------------------------------------------------
29415 !c! Calculate location and distance between polar heads
29416 !c! distance between heads
29417 !c! for each one of our three dimensional space...
29418        d1 = dheadcat(1, 1, itypi, itypj)
29419        d2 = dheadcat(2, 1, itypi, itypj)
29420
29421        DO k = 1,3
29422 !c! location of polar head is computed by taking hydrophobic centre
29423 !c! and moving by a d1 * dc_norm vector
29424 !c! see unres publications for very informative images
29425       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
29426       chead(k,2) = c(k, j)
29427 !c! distance
29428 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
29429 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
29430       Rhead_distance(k) = chead(k,2) - chead(k,1)
29431        END DO
29432 !c! pitagoras (root of sum of squares)
29433        Rhead = dsqrt(   &
29434         (Rhead_distance(1)*Rhead_distance(1)) &
29435       + (Rhead_distance(2)*Rhead_distance(2)) &
29436       + (Rhead_distance(3)*Rhead_distance(3)))
29437 !c!-------------------------------------------------------------------
29438 !c! zero everything that should be zero'ed
29439        Egb = 0.0d0
29440        ECL = 0.0d0
29441        Elj = 0.0d0
29442        Equad = 0.0d0
29443        Epol = 0.0d0
29444        eheadtail = 0.0d0
29445        dGCLdOM1 = 0.0d0
29446        dGCLdOM2 = 0.0d0
29447        dGCLdOM12 = 0.0d0
29448        dPOLdOM1 = 0.0d0
29449        dPOLdOM2 = 0.0d0
29450        RETURN
29451       END SUBROUTINE elgrad_init_cat_pep
29452
29453       double precision function tschebyshev(m,n,x,y)
29454       implicit none
29455       integer i,m,n
29456       double precision x(n),y,yy(0:maxvar),aux
29457 !c Tschebyshev polynomial. Note that the first term is omitted
29458 !c m=0: the constant term is included
29459 !c m=1: the constant term is not included
29460       yy(0)=1.0d0
29461       yy(1)=y
29462       do i=2,n
29463       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
29464       enddo
29465       aux=0.0d0
29466       do i=m,n
29467       aux=aux+x(i)*yy(i)
29468       enddo
29469       tschebyshev=aux
29470       return
29471       end function tschebyshev
29472 !C--------------------------------------------------------------------------
29473       double precision function gradtschebyshev(m,n,x,y)
29474       implicit none
29475       integer i,m,n
29476       double precision x(n+1),y,yy(0:maxvar),aux
29477 !c Tschebyshev polynomial. Note that the first term is omitted
29478 !c m=0: the constant term is included
29479 !c m=1: the constant term is not included
29480       yy(0)=1.0d0
29481       yy(1)=2.0d0*y
29482       do i=2,n
29483       yy(i)=2*y*yy(i-1)-yy(i-2)
29484       enddo
29485       aux=0.0d0
29486       do i=m,n
29487       aux=aux+x(i+1)*yy(i)*(i+1)
29488 !C        print *, x(i+1),yy(i),i
29489       enddo
29490       gradtschebyshev=aux
29491       return
29492       end function gradtschebyshev
29493 !!!!!!!!!--------------------------------------------------------------
29494       subroutine lipid_bond(elipbond)
29495       real(kind=8) :: elipbond,fac,dist_sub,sumdist
29496       real(kind=8), dimension(3):: dist
29497       integer(kind=8) :: i,j,k,ibra,ityp,jtyp,ityp1
29498       elipbond=0.0d0
29499 !      print *,"before",ilipbond_start,ilipbond_end
29500       do i=ilipbond_start,ilipbond_end
29501 !       print *,i,i+1,"i,i+1"
29502        ityp=itype(i,4)
29503        ityp1=itype(i+1,4)
29504 !       print *,ityp,ityp1,"itype"
29505        j=i+1
29506        if (ityp.eq.12) ibra=i
29507        if ((ityp.eq.ntyp1_molec(4)).or.(ityp1.ge.ntyp1_molec(4)-1)) cycle
29508        if (ityp.eq.(ntyp1_molec(4)-1)) then
29509        !cofniecie do ostatnie GL1
29510 !       i=ibra
29511        j=ibra
29512        else
29513        j=i
29514        endif
29515        jtyp=itype(j,4)
29516        do k=1,3
29517         dist(k)=c(k,j)-c(k,i+1)
29518        enddo
29519        sumdist=0.0d0
29520        do k=1,3
29521        sumdist=sumdist+dist(k)**2
29522        enddo
29523        dist_sub=sqrt(sumdist)
29524 !       print *,"before",i,j,ityp1,ityp,jtyp
29525        elipbond=elipbond+kbondlip*((dist_sub-lip_bond(jtyp,ityp1))**2)
29526        fac=kbondlip*(dist_sub-lip_bond(jtyp,ityp1))
29527        do k=1,3
29528         gradlipbond(k,i+1)= gradlipbond(k,i+1)-fac*dist(k)/dist_sub
29529         gradlipbond(k,j)=gradlipbond(k,j)+fac*dist(k)/dist_sub
29530        enddo
29531       if (energy_dec) write(iout,*) "lipbond",j,i+1,dist_sub,lip_bond(jtyp,ityp1),kbondlip,fac
29532       enddo
29533       elipbond=elipbond*0.5d0
29534       return
29535       end subroutine lipid_bond
29536 !---------------------------------------------------------------------------------------
29537       subroutine lipid_angle(elipang)
29538       real(kind=8) :: elipang,alfa,xa(3),xb(3),alfaact,alfa0,force,fac,&
29539       scalara,vnorm,wnorm,sss,sss_grad,eangle
29540       integer :: i,j,k,l,m,ibra,ityp1,itypm1,itypp1
29541       elipang=0.0d0
29542 !      print *,"ilipang_start,ilipang_end",ilipang_start,ilipang_end
29543       do i=ilipang_start,ilipang_end
29544 !       do i=4,4
29545
29546 ! the loop is centered on the central residue
29547       itypm1=itype(i-1,4)
29548       ityp1=itype(i,4)
29549       itypp1=itype(i+1,4)
29550 !         print *,i,i,j,"processor",fg_rank
29551       j=i-1
29552       k=i
29553       l=i+1
29554       if (ityp1.eq.12) ibra=i
29555       if ((itypm1.eq.ntyp1_molec(4)).or.(ityp1.eq.ntyp1_molec(4))&
29556          .or.(itypp1.eq.ntyp1_molec(4))) cycle !cycle if any of the angles is dummy
29557       if ((itypm1.eq.ntyp1_molec(4)-1).or.(itypp1.eq.ntyp1_molec(4)-1)) cycle
29558      ! branching is only to one angle
29559       if (ityp1.eq.ntyp1_molec(4)-1) then
29560       k=ibra
29561       j=ibra-1
29562       endif
29563       itypm1=itype(j,4)
29564       ityp1=itype(k,4)
29565       do m=1,3
29566       xa(m)=c(m,j)-c(m,k)
29567       xb(m)=c(m,l)-c(m,k)
29568 !      xb(m)=1.0d0
29569       enddo
29570       vnorm=dsqrt(xa(1)*xa(1)+xa(2)*xa(2)+xa(3)*xa(3))
29571       wnorm=dsqrt(xb(1)*xb(1)+xb(2)*xb(2)+xb(3)*xb(3))
29572       scalara=(xa(1)*xb(1)+xa(2)*xb(2)+xa(3)*xb(3))/(vnorm*wnorm)
29573 !      if (((scalar*scalar).gt.0.99999999d0).and.(alfa0.eq.180.0d0)) cycle
29574
29575       alfaact=scalara
29576 !      sss=sscale_martini_angle(alfaact)
29577 !      sss_grad=sscale_grad_martini_angle(alfaact)
29578 !      print *,sss_grad,"sss_grad",sss
29579 !      if (sss.le.0.0) cycle
29580 !      if (sss_grad.ne.0.0) print *,sss_grad,"sss_grad"
29581       force=lip_angle_force(itypm1,ityp1,itypp1)
29582       alfa0=lip_angle_angle(itypm1,ityp1,itypp1)
29583       eangle=force*(alfaact-dcos(alfa0))*(alfaact-dcos(alfa0))*0.5d0
29584       elipang=elipang+eangle!*(1001.0d0-1000.0d0*sss)
29585       fac=force*(alfaact-dcos(alfa0))!*(1001.0d0-1000.0d0*sss)-sss_grad*eangle*1000.0d0
29586       do m=1,3
29587       gradlipang(m,j)=gradlipang(m,j)+(fac &!/dsqrt(1.0d0-scalar*scalar)&
29588         *(xb(m)-scalara*wnorm*xa(m)/vnorm)&
29589        /(vnorm*wnorm))!-sss_grad*eangle*xa(m)/vnorm
29590
29591       gradlipang(m,l)=gradlipang(m,l)+(fac & !/dsqrt(1.0d0-scalar*scalar)&
29592        *(xa(m)-scalara*vnorm*xb(m)/wnorm)&
29593        /(vnorm*wnorm))!+sss_grad*eangle*xb(m)/wnorm
29594
29595       gradlipang(m,k)=gradlipang(m,k)-(fac)&  !/dsqrt(1.0d0-scalar*scalar)&
29596         *(xb(m)-scalara*wnorm*xa(m)/vnorm)&
29597        /((vnorm*wnorm))-(fac & !/dsqrt(1.0d0-scalar*scalar)&
29598        *(xa(m)-scalara*vnorm*xb(m)/wnorm)&
29599        /(vnorm*wnorm))!-sss_grad*eangle*xa(m)/vnorm&
29600                       !-sss_grad*eangle*xb(m)/wnorm
29601
29602
29603 !        *(xb(m)*vnorm*wnorm)&
29604
29605 !-xa(m)*xa(m)*xb(m)*wnorm/vnorm)&
29606       enddo
29607       if (energy_dec) write(iout,*) "elipang",j,k,l,force,alfa0,alfaact,elipang
29608       enddo
29609       return
29610       end subroutine lipid_angle
29611 !--------------------------------------------------------------------
29612       subroutine lipid_lj(eliplj)
29613       real(kind=8) :: eliplj,fac,sumdist,dist_sub,LJ1,LJ2,LJ,&
29614                       xj,yj,zj,xi,yi,zi,sss,sss_grad
29615       real(kind=8), dimension(3):: dist
29616       integer :: i,j,k,inum,ityp,jtyp
29617         eliplj=0.0d0
29618         do inum=iliplj_start,iliplj_end
29619         i=mlipljlisti(inum)
29620         j=mlipljlistj(inum)
29621 !         print *,inum,i,j,"processor",fg_rank
29622         ityp=itype(i,4)
29623         jtyp=itype(j,4)
29624         xi=c(1,i)
29625         yi=c(2,i)
29626         zi=c(3,i)
29627         call to_box(xi,yi,zi)
29628         xj=c(1,j)
29629         yj=c(2,j)
29630         zj=c(3,j)
29631       call to_box(xj,yj,zj)
29632       xj=boxshift(xj-xi,boxxsize)
29633       yj=boxshift(yj-yi,boxysize)
29634       zj=boxshift(zj-zi,boxzsize)
29635          dist(1)=xj
29636          dist(2)=yj
29637          dist(3)=zj
29638        !  do k=1,3
29639        !   dist(k)=c(k,j)-c(k,i)
29640        !  enddo
29641          sumdist=0.0d0
29642          do k=1,3
29643           sumdist=sumdist+dist(k)**2
29644          enddo
29645
29646          dist_sub=sqrt(sumdist)
29647          sss=sscale_martini(dist_sub)
29648          if (energy_dec) write(iout,*) "LJ LIP bef",i,j,ityp,jtyp,dist_sub
29649          if (sss.le.0.0) cycle
29650          sss_grad=sscale_grad_martini(dist_sub)
29651           LJ1 = (lip_sig(ityp,jtyp)/dist_sub)**6
29652           LJ2 = LJ1**2
29653           LJ = LJ2 - LJ1
29654           LJ = 4.0d0*lip_eps(ityp,jtyp)*LJ
29655           eliplj = eliplj + LJ*sss
29656           fac=4.0d0*lip_eps(ityp,jtyp)*(-6.0d0*LJ1/dist_sub+12.0d0*LJ2/dist_sub)
29657          do k=1,3
29658          gradliplj(k,i)=gradliplj(k,i)+fac*dist(k)/dist_sub*sss-sss_grad*LJ*dist(k)/dist_sub
29659          gradliplj(k,j)=gradliplj(k,j)-fac*dist(k)/dist_sub*sss+sss_grad*LJ*dist(k)/dist_sub
29660          enddo
29661          if (energy_dec) write(iout,'(a7,4i5,2f8.3)') "LJ LIP",i,j,ityp,jtyp,LJ,dist_sub
29662         enddo
29663       return
29664       end subroutine lipid_lj
29665 !--------------------------------------------------------------------------------------
29666       subroutine lipid_elec(elipelec)
29667       real(kind=8) :: elipelec,fac,sumdist,dist_sub,xj,yj,zj,xi,yi,zi,EQ,&
29668       sss,sss_grad
29669       real(kind=8), dimension(3):: dist
29670       integer :: i,j,k,inum,ityp,jtyp
29671         elipelec=0.0d0
29672 !        print *,"processor",fg_rank,ilip_elec_start,ilipelec_end
29673         do inum=ilip_elec_start,ilipelec_end
29674          i=mlipeleclisti(inum)
29675          j=mlipeleclistj(inum)
29676 !         print *,inum,i,j,"processor",fg_rank
29677          ityp=itype(i,4)
29678          jtyp=itype(j,4)
29679         xi=c(1,i)
29680         yi=c(2,i)
29681         zi=c(3,i)
29682         call to_box(xi,yi,zi)
29683         xj=c(1,j)
29684         yj=c(2,j)
29685         zj=c(3,j)
29686       call to_box(xj,yj,zj)
29687       xj=boxshift(xj-xi,boxxsize)
29688       yj=boxshift(yj-yi,boxysize)
29689       zj=boxshift(zj-zi,boxzsize)
29690          dist(1)=xj
29691          dist(2)=yj
29692          dist(3)=zj
29693 !         do k=1,3
29694 !          dist(k)=c(k,j)-c(k,i)
29695 !         enddo
29696          sumdist=0.0d0
29697          do k=1,3
29698           sumdist=sumdist+dist(k)**2
29699          enddo
29700          dist_sub=sqrt(sumdist)
29701          sss=sscale_martini(dist_sub)
29702 !         print *,sss,dist_sub
29703           if (energy_dec) write(iout,*) "EQ LIP",sss,dist_sub,i,j
29704          if (sss.le.0.0) cycle
29705          sss_grad=sscale_grad_martini(dist_sub)
29706 !         print *,"sss",sss,sss_grad
29707          EQ=k_coulomb_lip*(ichargelipid(ityp)*ichargelipid(jtyp)/dist_sub)
29708               elipelec=elipelec+EQ*sss
29709          fac=k_coulomb_lip*(ichargelipid(ityp)*ichargelipid(jtyp)/sumdist)*sss
29710          do k=1,3
29711          gradlipelec(k,i)=gradlipelec(k,i)+fac*dist(k)/dist_sub&
29712                                           -sss_grad*EQ*dist(k)/dist_sub
29713          gradlipelec(k,j)=gradlipelec(k,j)-fac*dist(k)/dist_sub&
29714                                           +sss_grad*EQ*dist(k)/dist_sub
29715          enddo
29716           if (energy_dec) write(iout,*) "EQ LIP",i,j,ityp,jtyp,EQ,dist_sub,elipelec
29717         enddo
29718       return
29719       end subroutine lipid_elec
29720 !-------------------------------------------------------------------------
29721       subroutine make_SCSC_inter_list
29722       include 'mpif.h'
29723       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29724       real(kind=8) :: dist_init, dist_temp,r_buff_list
29725       integer:: contlisti(250*nres),contlistj(250*nres)
29726 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
29727       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
29728       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
29729 !            print *,"START make_SC"
29730         r_buff_list=5.0
29731           ilist_sc=0
29732           do i=iatsc_s,iatsc_e
29733            itypi=iabs(itype(i,1))
29734            if (itypi.eq.ntyp1) cycle
29735            xi=c(1,nres+i)
29736            yi=c(2,nres+i)
29737            zi=c(3,nres+i)
29738           call to_box(xi,yi,zi)
29739            do iint=1,nint_gr(i)
29740 !           print *,"is it wrong", iint,i
29741             do j=istart(i,iint),iend(i,iint)
29742              itypj=iabs(itype(j,1))
29743              if (energy_dec) write(iout,*) "LISTA ZAKRES",istart(i,iint),iend(i,iint),iatsc_s,iatsc_e
29744              if (itypj.eq.ntyp1) cycle
29745              xj=c(1,nres+j)
29746              yj=c(2,nres+j)
29747              zj=c(3,nres+j)
29748              call to_box(xj,yj,zj)
29749 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
29750 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
29751           xj=boxshift(xj-xi,boxxsize)
29752           yj=boxshift(yj-yi,boxysize)
29753           zj=boxshift(zj-zi,boxzsize)
29754           dist_init=xj**2+yj**2+zj**2
29755 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
29756 ! r_buff_list is a read value for a buffer
29757              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29758 ! Here the list is created
29759              ilist_sc=ilist_sc+1
29760 ! this can be substituted by cantor and anti-cantor
29761              contlisti(ilist_sc)=i
29762              contlistj(ilist_sc)=j
29763
29764              endif
29765            enddo
29766            enddo
29767            enddo
29768 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
29769 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29770 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
29771 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
29772 #ifdef DEBUG
29773       write (iout,*) "before MPIREDUCE",ilist_sc
29774       do i=1,ilist_sc
29775       write (iout,*) i,contlisti(i),contlistj(i)
29776       enddo
29777 #endif
29778       if (nfgtasks.gt.1)then
29779
29780       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
29781         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29782 !        write(iout,*) "before bcast",g_ilist_sc
29783       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
29784                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
29785       displ(0)=0
29786       do i=1,nfgtasks-1,1
29787         displ(i)=i_ilist_sc(i-1)+displ(i-1)
29788       enddo
29789 !        write(iout,*) "before gather",displ(0),displ(1)
29790       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
29791                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
29792                    king,FG_COMM,IERR)
29793       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
29794                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
29795                    king,FG_COMM,IERR)
29796       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
29797 !        write(iout,*) "before bcast",g_ilist_sc
29798 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29799       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
29800       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
29801
29802 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29803
29804       else
29805       g_ilist_sc=ilist_sc
29806
29807       do i=1,ilist_sc
29808       newcontlisti(i)=contlisti(i)
29809       newcontlistj(i)=contlistj(i)
29810       enddo
29811       endif
29812
29813 #ifdef DEBUG
29814       write (iout,*) "after MPIREDUCE",g_ilist_sc
29815       do i=1,g_ilist_sc
29816       write (iout,*) i,newcontlisti(i),newcontlistj(i)
29817       enddo
29818 #endif
29819       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
29820       return
29821       end subroutine make_SCSC_inter_list
29822 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
29823
29824       subroutine make_SCp_inter_list
29825       use MD_data,  only: itime_mat
29826
29827       include 'mpif.h'
29828       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29829       real(kind=8) :: dist_init, dist_temp,r_buff_list
29830       integer:: contlistscpi(350*nres),contlistscpj(350*nres)
29831 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
29832       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
29833       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
29834 !            print *,"START make_SC"
29835       r_buff_list=5.0
29836           ilist_scp=0
29837       do i=iatscp_s,iatscp_e
29838       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
29839       xi=0.5D0*(c(1,i)+c(1,i+1))
29840       yi=0.5D0*(c(2,i)+c(2,i+1))
29841       zi=0.5D0*(c(3,i)+c(3,i+1))
29842         call to_box(xi,yi,zi)
29843       do iint=1,nscp_gr(i)
29844
29845       do j=iscpstart(i,iint),iscpend(i,iint)
29846         itypj=iabs(itype(j,1))
29847         if (itypj.eq.ntyp1) cycle
29848 ! Uncomment following three lines for SC-p interactions
29849 !         xj=c(1,nres+j)-xi
29850 !         yj=c(2,nres+j)-yi
29851 !         zj=c(3,nres+j)-zi
29852 ! Uncomment following three lines for Ca-p interactions
29853 !          xj=c(1,j)-xi
29854 !          yj=c(2,j)-yi
29855 !          zj=c(3,j)-zi
29856         xj=c(1,j)
29857         yj=c(2,j)
29858         zj=c(3,j)
29859         call to_box(xj,yj,zj)
29860       xj=boxshift(xj-xi,boxxsize)
29861       yj=boxshift(yj-yi,boxysize)
29862       zj=boxshift(zj-zi,boxzsize)
29863       dist_init=xj**2+yj**2+zj**2
29864 #ifdef DEBUG
29865             ! r_buff_list is a read value for a buffer
29866              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
29867 ! Here the list is created
29868              ilist_scp_first=ilist_scp_first+1
29869 ! this can be substituted by cantor and anti-cantor
29870              contlistscpi_f(ilist_scp_first)=i
29871              contlistscpj_f(ilist_scp_first)=j
29872             endif
29873 #endif
29874 ! r_buff_list is a read value for a buffer
29875              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29876 ! Here the list is created
29877              ilist_scp=ilist_scp+1
29878 ! this can be substituted by cantor and anti-cantor
29879              contlistscpi(ilist_scp)=i
29880              contlistscpj(ilist_scp)=j
29881             endif
29882            enddo
29883            enddo
29884            enddo
29885 #ifdef DEBUG
29886       write (iout,*) "before MPIREDUCE",ilist_scp
29887       do i=1,ilist_scp
29888       write (iout,*) i,contlistscpi(i),contlistscpj(i)
29889       enddo
29890 #endif
29891       if (nfgtasks.gt.1)then
29892
29893       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
29894         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29895 !        write(iout,*) "before bcast",g_ilist_sc
29896       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
29897                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
29898       displ(0)=0
29899       do i=1,nfgtasks-1,1
29900         displ(i)=i_ilist_scp(i-1)+displ(i-1)
29901       enddo
29902 !        write(iout,*) "before gather",displ(0),displ(1)
29903       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
29904                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
29905                    king,FG_COMM,IERR)
29906       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
29907                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
29908                    king,FG_COMM,IERR)
29909       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
29910 !        write(iout,*) "before bcast",g_ilist_sc
29911 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29912       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
29913       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
29914
29915 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29916
29917       else
29918       g_ilist_scp=ilist_scp
29919
29920       do i=1,ilist_scp
29921       newcontlistscpi(i)=contlistscpi(i)
29922       newcontlistscpj(i)=contlistscpj(i)
29923       enddo
29924       endif
29925
29926 #ifdef DEBUG
29927       write (iout,*) "after MPIREDUCE",g_ilist_scp
29928       do i=1,g_ilist_scp
29929       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
29930       enddo
29931
29932 !      if (ifirstrun.eq.0) ifirstrun=1
29933 !      do i=1,ilist_scp_first
29934 !       do j=1,g_ilist_scp
29935 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
29936 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
29937 !        enddo
29938 !       print *,itime_mat,"ERROR matrix needs updating"
29939 !       print *,contlistscpi_f(i),contlistscpj_f(i)
29940 !  126  continue
29941 !      enddo
29942 #endif
29943       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
29944
29945       return
29946       end subroutine make_SCp_inter_list
29947
29948 !-----------------------------------------------------------------------------
29949 !-----------------------------------------------------------------------------
29950
29951
29952       subroutine make_pp_inter_list
29953       include 'mpif.h'
29954       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29955       real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
29956       real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
29957       real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
29958       integer:: contlistppi(250*nres),contlistppj(250*nres)
29959 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
29960       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
29961       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
29962 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
29963             ilist_pp=0
29964       r_buff_list=5.0
29965       do i=iatel_s,iatel_e
29966         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
29967         dxi=dc(1,i)
29968         dyi=dc(2,i)
29969         dzi=dc(3,i)
29970         dx_normi=dc_norm(1,i)
29971         dy_normi=dc_norm(2,i)
29972         dz_normi=dc_norm(3,i)
29973         xmedi=c(1,i)+0.5d0*dxi
29974         ymedi=c(2,i)+0.5d0*dyi
29975         zmedi=c(3,i)+0.5d0*dzi
29976
29977         call to_box(xmedi,ymedi,zmedi)
29978         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
29979 !          write (iout,*) i,j,itype(i,1),itype(j,1)
29980 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
29981
29982 ! 1,j)
29983              do j=ielstart(i),ielend(i)
29984 !          write (iout,*) i,j,itype(i,1),itype(j,1)
29985           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
29986           dxj=dc(1,j)
29987           dyj=dc(2,j)
29988           dzj=dc(3,j)
29989           dx_normj=dc_norm(1,j)
29990           dy_normj=dc_norm(2,j)
29991           dz_normj=dc_norm(3,j)
29992 !          xj=c(1,j)+0.5D0*dxj-xmedi
29993 !          yj=c(2,j)+0.5D0*dyj-ymedi
29994 !          zj=c(3,j)+0.5D0*dzj-zmedi
29995           xj=c(1,j)+0.5D0*dxj
29996           yj=c(2,j)+0.5D0*dyj
29997           zj=c(3,j)+0.5D0*dzj
29998           call to_box(xj,yj,zj)
29999 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
30000 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
30001           xj=boxshift(xj-xmedi,boxxsize)
30002           yj=boxshift(yj-ymedi,boxysize)
30003           zj=boxshift(zj-zmedi,boxzsize)
30004           dist_init=xj**2+yj**2+zj**2
30005       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
30006 ! Here the list is created
30007                  ilist_pp=ilist_pp+1
30008 ! this can be substituted by cantor and anti-cantor
30009                  contlistppi(ilist_pp)=i
30010                  contlistppj(ilist_pp)=j
30011               endif
30012 !             enddo
30013              enddo
30014              enddo
30015 #ifdef DEBUG
30016       write (iout,*) "before MPIREDUCE",ilist_pp
30017       do i=1,ilist_pp
30018       write (iout,*) i,contlistppi(i),contlistppj(i)
30019       enddo
30020 #endif
30021       if (nfgtasks.gt.1)then
30022
30023         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
30024           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30025 !        write(iout,*) "before bcast",g_ilist_sc
30026         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
30027                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
30028         displ(0)=0
30029         do i=1,nfgtasks-1,1
30030           displ(i)=i_ilist_pp(i-1)+displ(i-1)
30031         enddo
30032 !        write(iout,*) "before gather",displ(0),displ(1)
30033         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
30034                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
30035                          king,FG_COMM,IERR)
30036         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
30037                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
30038                          king,FG_COMM,IERR)
30039         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
30040 !        write(iout,*) "before bcast",g_ilist_sc
30041 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30042         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
30043         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
30044
30045 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30046
30047         else
30048         g_ilist_pp=ilist_pp
30049
30050         do i=1,ilist_pp
30051         newcontlistppi(i)=contlistppi(i)
30052         newcontlistppj(i)=contlistppj(i)
30053         enddo
30054         endif
30055         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
30056 #ifdef DEBUG
30057       write (iout,*) "after MPIREDUCE",g_ilist_pp
30058       do i=1,g_ilist_pp
30059       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
30060       enddo
30061 #endif
30062       return
30063       end subroutine make_pp_inter_list
30064 !---------------------------------------------------------------------------
30065       subroutine make_cat_pep_list
30066       include 'mpif.h'
30067       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
30068       real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
30069       real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
30070       real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
30071       real(kind=8) :: xja,yja,zja
30072       integer:: contlistcatpnormi(300*nres),contlistcatpnormj(300*nres)
30073       integer:: contlistcatscnormi(250*nres),contlistcatscnormj(250*nres)
30074       integer:: contlistcatptrani(250*nres),contlistcatptranj(250*nres)
30075       integer:: contlistcatsctrani(250*nres),contlistcatsctranj(250*nres)
30076       integer:: contlistcatscangi(250*nres),contlistcatscangj(250*nres)
30077       integer:: contlistcatscangfi(250*nres),contlistcatscangfj(250*nres),&
30078                 contlistcatscangfk(250*nres)
30079       integer:: contlistcatscangti(250*nres),contlistcatscangtj(250*nres)
30080       integer:: contlistcatscangtk(250*nres),contlistcatscangtl(250*nres)
30081
30082
30083 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
30084       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_catscnorm,&
30085               ilist_catsctran,ilist_catpnorm,ilist_catptran,itmp,ilist_catscang,&
30086               ilist_catscangf,ilist_catscangt,k
30087       integer displ(0:nprocs),i_ilist_catscnorm(0:nprocs),ierr,&
30088              i_ilist_catpnorm(0:nprocs),i_ilist_catsctran(0:nprocs),&
30089              i_ilist_catptran(0:nprocs),i_ilist_catscang(0:nprocs),&
30090              i_ilist_catscangf(0:nprocs),i_ilist_catscangt(0:nprocs)
30091 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
30092             ilist_catpnorm=0
30093             ilist_catscnorm=0
30094             ilist_catptran=0
30095             ilist_catsctran=0
30096             ilist_catscang=0
30097
30098
30099       r_buff_list=6.0
30100       itmp=0
30101       do i=1,4
30102       itmp=itmp+nres_molec(i)
30103       enddo
30104 !        go to 17
30105 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
30106       do i=ibond_start,ibond_end
30107
30108 !        print *,"I am in EVDW",i
30109       itypi=iabs(itype(i,1))
30110
30111 !        if (i.ne.47) cycle
30112       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
30113 !      itypi1=iabs(itype(i+1,1))
30114       xi=c(1,nres+i)
30115       yi=c(2,nres+i)
30116       zi=c(3,nres+i)
30117       call to_box(xi,yi,zi)
30118       dxi=dc_norm(1,nres+i)
30119       dyi=dc_norm(2,nres+i)
30120       dzi=dc_norm(3,nres+i)
30121         xmedi=c(1,i)+0.5d0*dxi
30122         ymedi=c(2,i)+0.5d0*dyi
30123         zmedi=c(3,i)+0.5d0*dzi
30124         call to_box(xmedi,ymedi,zmedi)
30125
30126 !      dsci_inv=vbld_inv(i+nres)
30127        do j=itmp+1,itmp+nres_molec(5)
30128           dxj=dc(1,j)
30129           dyj=dc(2,j)
30130           dzj=dc(3,j)
30131           dx_normj=dc_norm(1,j)
30132           dy_normj=dc_norm(2,j)
30133           dz_normj=dc_norm(3,j)
30134           xj=c(1,j)
30135           yj=c(2,j)
30136           zj=c(3,j)
30137           call to_box(xj,yj,zj)
30138 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
30139 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
30140           xja=boxshift(xj-xmedi,boxxsize)
30141           yja=boxshift(yj-ymedi,boxysize)
30142           zja=boxshift(zj-zmedi,boxzsize)
30143           dist_init=xja**2+yja**2+zja**2
30144       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
30145 ! Here the list is created
30146               if (itype(j,5).le.5) then
30147                  ilist_catpnorm=ilist_catpnorm+1
30148 ! this can be substituted by cantor and anti-cantor
30149                  contlistcatpnormi(ilist_catpnorm)=i
30150                  contlistcatpnormj(ilist_catpnorm)=j
30151               else
30152                  ilist_catptran=ilist_catptran+1
30153 ! this can be substituted by cantor and anti-cantor
30154                  contlistcatptrani(ilist_catptran)=i
30155                  contlistcatptranj(ilist_catptran)=j
30156               endif
30157        endif
30158           xja=boxshift(xj-xi,boxxsize)
30159           yja=boxshift(yj-yi,boxysize)
30160           zja=boxshift(zj-zi,boxzsize)
30161           dist_init=xja**2+yja**2+zja**2
30162       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
30163 ! Here the list is created
30164               if (itype(j,5).le.5) then
30165                  ilist_catscnorm=ilist_catscnorm+1
30166 ! this can be substituted by cantor and anti-cantor
30167 !                 write(iout,*) "have contact",i,j,ilist_catscnorm
30168                  contlistcatscnormi(ilist_catscnorm)=i
30169                  contlistcatscnormj(ilist_catscnorm)=j
30170 !                 write(iout,*) "have contact2",i,j,ilist_catscnorm,&
30171 !               contlistcatscnormi(ilist_catscnorm),contlistcatscnormj(ilist_catscnorm)
30172
30173               else
30174                  ilist_catsctran=ilist_catsctran+1
30175 ! this can be substituted by cantor and anti-cantor
30176                  contlistcatsctrani(ilist_catsctran)=i
30177                  contlistcatsctranj(ilist_catsctran)=j
30178 !                 print *,"KUR**",i,j,itype(i,1)
30179                if (((itype(i,1).eq.1).or.(itype(i,1).eq.15).or.&
30180                    (itype(i,1).eq.16).or.(itype(i,1).eq.17)).and.&
30181                    ((sqrt(dist_init).le.(r_cut_ang+r_buff_list)))) then
30182 !                   print *,"KUR**2",i,j,itype(i,1),ilist_catscang+1
30183
30184                    ilist_catscang=ilist_catscang+1
30185                    contlistcatscangi(ilist_catscang)=i
30186                    contlistcatscangj(ilist_catscang)=j
30187                 endif
30188
30189               endif
30190       endif
30191 !             enddo
30192              enddo
30193              enddo
30194 #ifdef DEBUG
30195       write (iout,*) "before MPIREDUCE",ilist_catsctran,ilist_catptran,&
30196       ilist_catscnorm,ilist_catpnorm,ilist_catscang
30197
30198       do i=1,ilist_catsctran
30199       write (iout,*) i,contlistcatsctrani(i),contlistcatsctranj(i),&
30200       itype(j,contlistcatsctranj(i))
30201       enddo
30202       do i=1,ilist_catptran
30203       write (iout,*) i,contlistcatptrani(i),contlistcatsctranj(i)
30204       enddo
30205       do i=1,ilist_catscnorm
30206       write (iout,*) i,contlistcatscnormi(i),contlistcatscnormj(i)
30207       enddo
30208       do i=1,ilist_catpnorm
30209       write (iout,*) i,contlistcatpnormi(i),contlistcatscnormj(i)
30210       enddo
30211       do i=1,ilist_catscang
30212       write (iout,*) i,contlistcatscangi(i),contlistcatscangi(i)
30213       enddo
30214
30215
30216 #endif
30217       if (nfgtasks.gt.1)then
30218
30219         call MPI_Reduce(ilist_catsctran,g_ilist_catsctran,1,&
30220           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30221 !        write(iout,*) "before bcast",g_ilist_sc
30222         call MPI_Gather(ilist_catsctran,1,MPI_INTEGER,&
30223                         i_ilist_catsctran,1,MPI_INTEGER,king,FG_COMM,IERR)
30224         displ(0)=0
30225         do i=1,nfgtasks-1,1
30226           displ(i)=i_ilist_catsctran(i-1)+displ(i-1)
30227         enddo
30228 !        write(iout,*) "before gather",displ(0),displ(1)
30229         call MPI_Gatherv(contlistcatsctrani,ilist_catsctran,MPI_INTEGER,&
30230                          newcontlistcatsctrani,i_ilist_catsctran,displ,MPI_INTEGER,&
30231                          king,FG_COMM,IERR)
30232         call MPI_Gatherv(contlistcatsctranj,ilist_catsctran,MPI_INTEGER,&
30233                          newcontlistcatsctranj,i_ilist_catsctran,displ,MPI_INTEGER,&
30234                          king,FG_COMM,IERR)
30235         call MPI_Bcast(g_ilist_catsctran,1,MPI_INT,king,FG_COMM,IERR)
30236 !        write(iout,*) "before bcast",g_ilist_sc
30237 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30238         call MPI_Bcast(newcontlistcatsctrani,g_ilist_catsctran,MPI_INT,king,FG_COMM,IERR)
30239         call MPI_Bcast(newcontlistcatsctranj,g_ilist_catsctran,MPI_INT,king,FG_COMM,IERR)
30240
30241
30242         call MPI_Reduce(ilist_catptran,g_ilist_catptran,1,&
30243           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30244 !        write(iout,*) "before bcast",g_ilist_sc
30245         call MPI_Gather(ilist_catptran,1,MPI_INTEGER,&
30246                         i_ilist_catptran,1,MPI_INTEGER,king,FG_COMM,IERR)
30247         displ(0)=0
30248         do i=1,nfgtasks-1,1
30249           displ(i)=i_ilist_catptran(i-1)+displ(i-1)
30250         enddo
30251 !        write(iout,*) "before gather",displ(0),displ(1)
30252         call MPI_Gatherv(contlistcatptrani,ilist_catptran,MPI_INTEGER,&
30253                          newcontlistcatptrani,i_ilist_catptran,displ,MPI_INTEGER,&
30254                          king,FG_COMM,IERR)
30255         call MPI_Gatherv(contlistcatptranj,ilist_catptran,MPI_INTEGER,&
30256                          newcontlistcatptranj,i_ilist_catptran,displ,MPI_INTEGER,&
30257                          king,FG_COMM,IERR)
30258         call MPI_Bcast(g_ilist_catptran,1,MPI_INT,king,FG_COMM,IERR)
30259 !        write(iout,*) "before bcast",g_ilist_sc
30260 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30261         call MPI_Bcast(newcontlistcatptrani,g_ilist_catptran,MPI_INT,king,FG_COMM,IERR)
30262         call MPI_Bcast(newcontlistcatptranj,g_ilist_catptran,MPI_INT,king,FG_COMM,IERR)
30263
30264 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30265
30266         call MPI_Reduce(ilist_catscnorm,g_ilist_catscnorm,1,&
30267           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30268 !        write(iout,*) "before bcast",g_ilist_sc
30269         call MPI_Gather(ilist_catscnorm,1,MPI_INTEGER,&
30270                         i_ilist_catscnorm,1,MPI_INTEGER,king,FG_COMM,IERR)
30271         displ(0)=0
30272         do i=1,nfgtasks-1,1
30273           displ(i)=i_ilist_catscnorm(i-1)+displ(i-1)
30274         enddo
30275 !        write(iout,*) "before gather",displ(0),displ(1)
30276         call MPI_Gatherv(contlistcatscnormi,ilist_catscnorm,MPI_INTEGER,&
30277                          newcontlistcatscnormi,i_ilist_catscnorm,displ,MPI_INTEGER,&
30278                          king,FG_COMM,IERR)
30279         call MPI_Gatherv(contlistcatscnormj,ilist_catscnorm,MPI_INTEGER,&
30280                          newcontlistcatscnormj,i_ilist_catscnorm,displ,MPI_INTEGER,&
30281                          king,FG_COMM,IERR)
30282         call MPI_Bcast(g_ilist_catscnorm,1,MPI_INT,king,FG_COMM,IERR)
30283 !        write(iout,*) "before bcast",g_ilist_sc
30284 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30285         call MPI_Bcast(newcontlistcatscnormi,g_ilist_catscnorm,MPI_INT,king,FG_COMM,IERR)
30286         call MPI_Bcast(newcontlistcatscnormj,g_ilist_catscnorm,MPI_INT,king,FG_COMM,IERR)
30287
30288
30289
30290         call MPI_Reduce(ilist_catpnorm,g_ilist_catpnorm,1,&
30291           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30292 !        write(iout,*) "before bcast",g_ilist_sc
30293         call MPI_Gather(ilist_catpnorm,1,MPI_INTEGER,&
30294                         i_ilist_catpnorm,1,MPI_INTEGER,king,FG_COMM,IERR)
30295         displ(0)=0
30296         do i=1,nfgtasks-1,1
30297           displ(i)=i_ilist_catpnorm(i-1)+displ(i-1)
30298         enddo
30299 !        write(iout,*) "before gather",displ(0),displ(1)
30300         call MPI_Gatherv(contlistcatpnormi,ilist_catpnorm,MPI_INTEGER,&
30301                          newcontlistcatpnormi,i_ilist_catpnorm,displ,MPI_INTEGER,&
30302                          king,FG_COMM,IERR)
30303         call MPI_Gatherv(contlistcatpnormj,ilist_catpnorm,MPI_INTEGER,&
30304                          newcontlistcatpnormj,i_ilist_catpnorm,displ,MPI_INTEGER,&
30305                          king,FG_COMM,IERR)
30306         call MPI_Bcast(g_ilist_catpnorm,1,MPI_INT,king,FG_COMM,IERR)
30307 !        write(iout,*) "before bcast",g_ilist_sc
30308 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30309         call MPI_Bcast(newcontlistcatpnormi,g_ilist_catpnorm,MPI_INT,king,FG_COMM,IERR)
30310         call MPI_Bcast(newcontlistcatpnormj,g_ilist_catpnorm,MPI_INT,king,FG_COMM,IERR)
30311
30312
30313
30314         call MPI_Reduce(ilist_catscang,g_ilist_catscang,1,&
30315           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30316 !        write(iout,*) "before bcast",g_ilist_sc
30317         call MPI_Gather(ilist_catscang,1,MPI_INTEGER,&
30318                         i_ilist_catscang,1,MPI_INTEGER,king,FG_COMM,IERR)
30319         displ(0)=0
30320         do i=1,nfgtasks-1,1
30321           displ(i)=i_ilist_catscang(i-1)+displ(i-1)
30322         enddo
30323 !        write(iout,*) "before gather",displ(0),displ(1)
30324         call MPI_Gatherv(contlistcatscangi,ilist_catscang,MPI_INTEGER,&
30325                          newcontlistcatscangi,i_ilist_catscang,displ,MPI_INTEGER,&
30326                          king,FG_COMM,IERR)
30327         call MPI_Gatherv(contlistcatscangj,ilist_catscang,MPI_INTEGER,&
30328                          newcontlistcatscangj,i_ilist_catscang,displ,MPI_INTEGER,&
30329                          king,FG_COMM,IERR)
30330         call MPI_Bcast(g_ilist_catscang,1,MPI_INT,king,FG_COMM,IERR)
30331 !        write(iout,*) "before bcast",g_ilist_sc
30332 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30333         call MPI_Bcast(newcontlistcatscangi,g_ilist_catscang,MPI_INT,king,FG_COMM,IERR)
30334         call MPI_Bcast(newcontlistcatscangj,g_ilist_catscang,MPI_INT,king,FG_COMM,IERR)
30335
30336
30337         else
30338         g_ilist_catscnorm=ilist_catscnorm
30339         g_ilist_catsctran=ilist_catsctran
30340         g_ilist_catpnorm=ilist_catpnorm
30341         g_ilist_catptran=ilist_catptran
30342         g_ilist_catscang=ilist_catscang
30343
30344
30345         do i=1,ilist_catscnorm
30346         newcontlistcatscnormi(i)=contlistcatscnormi(i)
30347         newcontlistcatscnormj(i)=contlistcatscnormj(i)
30348         enddo
30349         do i=1,ilist_catpnorm
30350         newcontlistcatpnormi(i)=contlistcatpnormi(i)
30351         newcontlistcatpnormj(i)=contlistcatpnormj(i)
30352         enddo
30353         do i=1,ilist_catsctran
30354         newcontlistcatsctrani(i)=contlistcatsctrani(i)
30355         newcontlistcatsctranj(i)=contlistcatsctranj(i)
30356         enddo
30357         do i=1,ilist_catptran
30358         newcontlistcatptrani(i)=contlistcatptrani(i)
30359         newcontlistcatptranj(i)=contlistcatptranj(i)
30360         enddo
30361
30362         do i=1,ilist_catscang
30363         newcontlistcatscangi(i)=contlistcatscangi(i)
30364         newcontlistcatscangj(i)=contlistcatscangj(i)
30365         enddo
30366
30367
30368         endif
30369         call int_bounds(g_ilist_catsctran,g_listcatsctran_start,g_listcatsctran_end)
30370         call int_bounds(g_ilist_catptran,g_listcatptran_start,g_listcatptran_end)
30371         call int_bounds(g_ilist_catscnorm,g_listcatscnorm_start,g_listcatscnorm_end)
30372         call int_bounds(g_ilist_catpnorm,g_listcatpnorm_start,g_listcatpnorm_end)
30373         call int_bounds(g_ilist_catscang,g_listcatscang_start,g_listcatscang_end)
30374 ! make new ang list
30375         ilist_catscangf=0
30376         do i=g_listcatscang_start,g_listcatscang_end
30377          do j=2,g_ilist_catscang
30378 !          print *,"RWA",i,j,contlistcatscangj(i),contlistcatscangj(j)
30379           if (j.le.i) cycle
30380           if (newcontlistcatscangj(i).ne.newcontlistcatscangj(j)) cycle
30381                    ilist_catscangf=ilist_catscangf+1
30382                    contlistcatscangfi(ilist_catscangf)=newcontlistcatscangi(i)
30383                    contlistcatscangfj(ilist_catscangf)=newcontlistcatscangj(i)
30384                    contlistcatscangfk(ilist_catscangf)=newcontlistcatscangi(j)
30385 !          print *,"TUTU",g_listcatscang_start,g_listcatscang_end,i,j,g_ilist_catscangf,myrank
30386          enddo
30387         enddo
30388       if (nfgtasks.gt.1)then
30389
30390         call MPI_Reduce(ilist_catscangf,g_ilist_catscangf,1,&
30391           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30392 !        write(iout,*) "before bcast",g_ilist_sc
30393         call MPI_Gather(ilist_catscangf,1,MPI_INTEGER,&
30394                         i_ilist_catscangf,1,MPI_INTEGER,king,FG_COMM,IERR)
30395         displ(0)=0
30396         do i=1,nfgtasks-1,1
30397           displ(i)=i_ilist_catscangf(i-1)+displ(i-1)
30398         enddo
30399 !        write(iout,*) "before gather",displ(0),displ(1)
30400         call MPI_Gatherv(contlistcatscangfi,ilist_catscangf,MPI_INTEGER,&
30401                          newcontlistcatscangfi,i_ilist_catscangf,displ,MPI_INTEGER,&
30402                          king,FG_COMM,IERR)
30403         call MPI_Gatherv(contlistcatscangfj,ilist_catscangf,MPI_INTEGER,&
30404                          newcontlistcatscangfj,i_ilist_catscangf,displ,MPI_INTEGER,&
30405                          king,FG_COMM,IERR)
30406         call MPI_Gatherv(contlistcatscangfk,ilist_catscangf,MPI_INTEGER,&
30407                          newcontlistcatscangfk,i_ilist_catscangf,displ,MPI_INTEGER,&
30408                          king,FG_COMM,IERR)
30409
30410         call MPI_Bcast(g_ilist_catscangf,1,MPI_INT,king,FG_COMM,IERR)
30411 !        write(iout,*) "before bcast",g_ilist_sc
30412 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30413         call MPI_Bcast(newcontlistcatscangfi,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR)
30414         call MPI_Bcast(newcontlistcatscangfj,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR)
30415         call MPI_Bcast(newcontlistcatscangfk,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR)
30416         else
30417         g_ilist_catscangf=ilist_catscangf
30418         do i=1,ilist_catscangf
30419         newcontlistcatscangfi(i)=contlistcatscangfi(i)
30420         newcontlistcatscangfj(i)=contlistcatscangfj(i)
30421         newcontlistcatscangfk(i)=contlistcatscangfk(i)
30422         enddo
30423         endif
30424         call int_bounds(g_ilist_catscangf,g_listcatscangf_start,g_listcatscangf_end)
30425
30426
30427         ilist_catscangt=0
30428         do i=g_listcatscang_start,g_listcatscang_end
30429          do j=1,g_ilist_catscang
30430          do k=1,g_ilist_catscang
30431 !          print *,"TUTU1",g_listcatscang_start,g_listcatscang_end,i,j
30432
30433           if (newcontlistcatscangj(i).ne.newcontlistcatscangj(j)) cycle
30434           if (newcontlistcatscangj(i).ne.newcontlistcatscangj(k)) cycle
30435           if (newcontlistcatscangj(k).ne.newcontlistcatscangj(j)) cycle
30436           if (newcontlistcatscangi(i).eq.newcontlistcatscangi(j)) cycle
30437           if (newcontlistcatscangi(i).eq.newcontlistcatscangi(k)) cycle
30438           if (newcontlistcatscangi(k).eq.newcontlistcatscangi(j)) cycle
30439 !          print *,"TUTU2",g_listcatscang_start,g_listcatscang_end,i,j
30440
30441                    ilist_catscangt=ilist_catscangt+1
30442                    contlistcatscangti(ilist_catscangt)=newcontlistcatscangi(i)
30443                    contlistcatscangtj(ilist_catscangt)=newcontlistcatscangj(i)
30444                    contlistcatscangtk(ilist_catscangt)=newcontlistcatscangi(j)
30445                    contlistcatscangtl(ilist_catscangt)=newcontlistcatscangi(k)
30446
30447          enddo
30448         enddo
30449        enddo
30450       if (nfgtasks.gt.1)then
30451
30452         call MPI_Reduce(ilist_catscangt,g_ilist_catscangt,1,&
30453           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30454 !        write(iout,*) "before bcast",g_ilist_sc
30455         call MPI_Gather(ilist_catscangt,1,MPI_INTEGER,&
30456                         i_ilist_catscangt,1,MPI_INTEGER,king,FG_COMM,IERR)
30457         displ(0)=0
30458         do i=1,nfgtasks-1,1
30459           displ(i)=i_ilist_catscangt(i-1)+displ(i-1)
30460         enddo
30461 !        write(iout,*) "before gather",displ(0),displ(1)
30462         call MPI_Gatherv(contlistcatscangti,ilist_catscangt,MPI_INTEGER,&
30463                          newcontlistcatscangti,i_ilist_catscangt,displ,MPI_INTEGER,&
30464                          king,FG_COMM,IERR)
30465         call MPI_Gatherv(contlistcatscangtj,ilist_catscangt,MPI_INTEGER,&
30466                          newcontlistcatscangtj,i_ilist_catscangt,displ,MPI_INTEGER,&
30467                          king,FG_COMM,IERR)
30468         call MPI_Gatherv(contlistcatscangtk,ilist_catscangt,MPI_INTEGER,&
30469                          newcontlistcatscangtk,i_ilist_catscangt,displ,MPI_INTEGER,&
30470                          king,FG_COMM,IERR)
30471         call MPI_Gatherv(contlistcatscangtl,ilist_catscangt,MPI_INTEGER,&
30472                          newcontlistcatscangtl,i_ilist_catscangt,displ,MPI_INTEGER,&
30473                          king,FG_COMM,IERR)
30474
30475         call MPI_Bcast(g_ilist_catscangt,1,MPI_INT,king,FG_COMM,IERR)
30476 !        write(iout,*) "before bcast",g_ilist_sc
30477 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30478         call MPI_Bcast(newcontlistcatscangti,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30479         call MPI_Bcast(newcontlistcatscangtj,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30480         call MPI_Bcast(newcontlistcatscangtk,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30481         call MPI_Bcast(newcontlistcatscangtl,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30482
30483         else
30484         g_ilist_catscangt=ilist_catscangt
30485         do i=1,ilist_catscangt
30486         newcontlistcatscangti(i)=contlistcatscangti(i)
30487         newcontlistcatscangtj(i)=contlistcatscangtj(i)
30488         newcontlistcatscangtk(i)=contlistcatscangtk(i)
30489         newcontlistcatscangtl(i)=contlistcatscangtl(i)
30490         enddo
30491         endif
30492         call int_bounds(g_ilist_catscangt,g_listcatscangt_start,g_listcatscangt_end)
30493
30494
30495
30496
30497
30498 #ifdef DEBUG
30499       write (iout,*) "after MPIREDUCE",ilist_catsctran,ilist_catptran, &
30500       ilist_catscnorm,ilist_catpnorm
30501
30502       do i=1,g_ilist_catsctran
30503       write (iout,*) i,newcontlistcatsctrani(i),newcontlistcatsctranj(i)
30504       enddo
30505       do i=1,g_ilist_catptran
30506       write (iout,*) i,newcontlistcatptrani(i),newcontlistcatsctranj(i)
30507       enddo
30508       do i=1,g_ilist_catscnorm
30509       write (iout,*) i,newcontlistcatscnormi(i),newcontlistcatscnormj(i)
30510       enddo
30511       do i=1,g_ilist_catpnorm
30512       write (iout,*) i,newcontlistcatpnormi(i),newcontlistcatscnormj(i)
30513       enddo
30514       do i=1,g_ilist_catscang
30515       write (iout,*) i,newcontlistcatscangi(i),newcontlistcatscangj(i)
30516       enddo
30517 #endif
30518       return
30519       end subroutine make_cat_pep_list
30520
30521       subroutine make_cat_cat_list
30522       include 'mpif.h'
30523       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
30524       real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
30525       real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
30526       real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
30527       real(kind=8) :: xja,yja,zja
30528       integer,dimension(:),allocatable:: contlistcatpnormi,contlistcatpnormj
30529 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
30530       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_catscnorm,&
30531               ilist_catsctran,ilist_catpnorm,ilist_catptran,itmp,ilist_catscang,&
30532               ilist_catscangf,ilist_catscangt,k
30533       integer displ(0:nprocs),i_ilist_catscnorm(0:nprocs),ierr,&
30534              i_ilist_catpnorm(0:nprocs),i_ilist_catsctran(0:nprocs),&
30535              i_ilist_catptran(0:nprocs),i_ilist_catscang(0:nprocs),&
30536              i_ilist_catscangf(0:nprocs),i_ilist_catscangt(0:nprocs)
30537 !            write(iout,*),"START make_catcat"
30538             ilist_catpnorm=0
30539             ilist_catscnorm=0
30540             ilist_catptran=0
30541             ilist_catsctran=0
30542             ilist_catscang=0
30543
30544       if (.not.allocated(contlistcatpnormi)) then
30545        allocate(contlistcatpnormi(900*nres))
30546        allocate(contlistcatpnormj(900*nres))
30547       endif
30548       r_buff_list=3.0
30549       itmp=0
30550       do i=1,4
30551       itmp=itmp+nres_molec(i)
30552       enddo
30553 !        go to 17
30554 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
30555       do i=icatb_start,icatb_end
30556       xi=c(1,i)
30557       yi=c(2,i)
30558       zi=c(3,i)
30559       call to_box(xi,yi,zi)
30560       dxi=dc_norm(1,i)
30561       dyi=dc_norm(2,i)
30562       dzi=dc_norm(3,i)
30563 !      dsci_inv=vbld_inv(i+nres)
30564        do j=i+1,itmp+nres_molec(5)
30565           dxj=dc(1,j)
30566           dyj=dc(2,j)
30567           dzj=dc(3,j)
30568           dx_normj=dc_norm(1,j)
30569           dy_normj=dc_norm(2,j)
30570           dz_normj=dc_norm(3,j)
30571           xj=c(1,j)
30572           yj=c(2,j)
30573           zj=c(3,j)
30574           call to_box(xj,yj,zj)
30575 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
30576 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
30577           xja=boxshift(xj-xi,boxxsize)
30578           yja=boxshift(yj-yi,boxysize)
30579           zja=boxshift(zj-zi,boxzsize)
30580           dist_init=xja**2+yja**2+zja**2
30581       if (sqrt(dist_init).le.(10.0+r_buff_list)) then
30582 ! Here the list is created
30583 !                 if (i.eq.2) then
30584 !                 print *,i,j,dist_init,ilist_catpnorm
30585 !                 endif
30586                  ilist_catpnorm=ilist_catpnorm+1
30587
30588 ! this can be substituted by cantor and anti-cantor
30589                  contlistcatpnormi(ilist_catpnorm)=i
30590                  contlistcatpnormj(ilist_catpnorm)=j
30591        endif
30592 !             enddo
30593              enddo
30594              enddo
30595 #ifdef DEBUG
30596       write (iout,*) "before MPIREDUCE",ilist_catsctran,ilist_catptran,&
30597       ilist_catscnorm,ilist_catpnorm,ilist_catscang
30598
30599       do i=1,ilist_catpnorm
30600       write (iout,*) i,contlistcatpnormi(i)
30601       enddo
30602
30603
30604 #endif
30605       if (nfgtasks.gt.1)then
30606
30607         call MPI_Reduce(ilist_catpnorm,g_ilist_catcatnorm,1,&
30608           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
30609 !        write(iout,*) "before bcast",g_ilist_sc
30610         call MPI_Gather(ilist_catpnorm,1,MPI_INTEGER,&
30611                         i_ilist_catpnorm,1,MPI_INTEGER,king,FG_COMM,IERR)
30612         displ(0)=0
30613         do i=1,nfgtasks-1,1
30614           displ(i)=i_ilist_catpnorm(i-1)+displ(i-1)
30615         enddo
30616 !        write(iout,*) "before gather",displ(0),displ(1)
30617         call MPI_Gatherv(contlistcatpnormi,ilist_catpnorm,MPI_INTEGER,&
30618                          newcontlistcatcatnormi,i_ilist_catpnorm,displ,MPI_INTEGER,&
30619                          king,FG_COMM,IERR)
30620         call MPI_Gatherv(contlistcatpnormj,ilist_catpnorm,MPI_INTEGER,&
30621                          newcontlistcatcatnormj,i_ilist_catpnorm,displ,MPI_INTEGER,&
30622                          king,FG_COMM,IERR)
30623         call MPI_Bcast(g_ilist_catcatnorm,1,MPI_INT,king,FG_COMM,IERR)
30624 !        write(iout,*) "before bcast",g_ilist_sc
30625 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30626         call MPI_Bcast(newcontlistcatcatnormi,g_ilist_catcatnorm,MPI_INT,king,FG_COMM,IERR)
30627         call MPI_Bcast(newcontlistcatcatnormj,g_ilist_catcatnorm,MPI_INT,king,FG_COMM,IERR)
30628
30629
30630         else
30631         g_ilist_catcatnorm=ilist_catpnorm
30632         do i=1,ilist_catpnorm
30633         newcontlistcatcatnormi(i)=contlistcatpnormi(i)
30634         newcontlistcatcatnormj(i)=contlistcatpnormj(i)
30635         enddo
30636         endif
30637         call int_bounds(g_ilist_catcatnorm,g_listcatcatnorm_start,g_listcatcatnorm_end)
30638
30639 #ifdef DEBUG
30640       write (iout,*) "after MPIREDUCE",g_ilist_catcatnorm
30641
30642       do i=1,g_ilist_catcatnorm
30643       write (iout,*) i,newcontlistcatcatnormi(i),newcontlistcatcatnormj(i)
30644       enddo
30645 #endif
30646 !            write(iout,*),"END make_catcat"
30647       return
30648       end subroutine make_cat_cat_list
30649
30650
30651 !-----------------------------------------------------------------------------
30652       double precision function boxshift(x,boxsize)
30653       implicit none
30654       double precision x,boxsize
30655       double precision xtemp
30656       xtemp=dmod(x,boxsize)
30657       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
30658         boxshift=xtemp-boxsize
30659       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
30660         boxshift=xtemp+boxsize
30661       else
30662         boxshift=xtemp
30663       endif
30664       return
30665       end function boxshift
30666 !-----------------------------------------------------------------------------
30667       subroutine to_box(xi,yi,zi)
30668       implicit none
30669 !      include 'DIMENSIONS'
30670 !      include 'COMMON.CHAIN'
30671       double precision xi,yi,zi
30672       xi=dmod(xi,boxxsize)
30673       if (xi.lt.0.0d0) xi=xi+boxxsize
30674       yi=dmod(yi,boxysize)
30675       if (yi.lt.0.0d0) yi=yi+boxysize
30676       zi=dmod(zi,boxzsize)
30677       if (zi.lt.0.0d0) zi=zi+boxzsize
30678       return
30679       end subroutine to_box
30680 !--------------------------------------------------------------------------
30681       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
30682       implicit none
30683 !      include 'DIMENSIONS'
30684 !      include 'COMMON.IOUNITS'
30685 !      include 'COMMON.CHAIN'
30686       double precision xi,yi,zi,sslipi,ssgradlipi
30687       double precision fracinbuf
30688 !      double precision sscalelip,sscagradlip
30689 #ifdef DEBUG
30690       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
30691       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
30692       write (iout,*) "xi yi zi",xi,yi,zi
30693 #endif
30694       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
30695 ! the energy transfer exist
30696         if (zi.lt.buflipbot) then
30697 ! what fraction I am in
30698           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
30699 ! lipbufthick is thickenes of lipid buffore
30700           sslipi=sscalelip(fracinbuf)
30701           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
30702         elseif (zi.gt.bufliptop) then
30703           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
30704           sslipi=sscalelip(fracinbuf)
30705           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
30706         else
30707           sslipi=1.0d0
30708           ssgradlipi=0.0
30709         endif
30710       else
30711         sslipi=0.0d0
30712         ssgradlipi=0.0
30713       endif
30714 #ifdef DEBUG
30715       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
30716 #endif
30717       return
30718       end subroutine lipid_layer
30719 !-------------------------------------------------------------
30720       subroutine ecat_prot_transition(ecation_prottran)
30721       integer:: itypi,itypj,ityptrani,ityptranj,k,l,i,j
30722       real(kind=8),dimension(3):: cjtemp,citemp,diff,dsctemp,vecsc,&
30723                   diffnorm,boxx,r,dEvan1Cm,dEvan2Cm,dEtotalCm
30724       real(kind=8):: ecation_prottran,dista,sdist,De,ene,x0left,&
30725                     alphac,grad,sumvec,simplesum,pom,erdxi,facd1,&
30726                     sss_ele_cut,sss_ele_cut_grad,sss2min,sss2mingrad,&
30727                     ene1,ene2,grad1,grad2,evan1,evan2,rcal,r4,r7,r0p,&
30728                     r06,r012,epscalc,rocal,ract
30729       ecation_prottran=0.0d0
30730       boxx(1)=boxxsize
30731       boxx(2)=boxysize
30732       boxx(3)=boxzsize
30733       write(iout,*) "start ecattran",g_listcatsctran_start,g_listcatsctran_end
30734       do k=g_listcatsctran_start,g_listcatsctran_end
30735         i=newcontlistcatsctrani(k)
30736         j=newcontlistcatsctranj(k)
30737 !        print *,i,j,"in new tran"
30738         do  l=1,3
30739           citemp(l)=c(l,i+nres)
30740           cjtemp(l)=c(l,j)
30741          enddo
30742
30743          itypi=itype(i,1) !as the first is the protein part
30744          itypj=itype(j,5) !as the second part is always cation
30745 ! remapping to internal types
30746 !       read (iiontran,*,err=123,end=123) (agamacattran(k,j,i),k=1,3),&
30747 !       (athetacattran(k,j,i),k=1,6),acatshiftdsc(j,i),bcatshiftdsc(j,i),&
30748 !       demorsecat(j,i),alphamorsecat(j,i),x0catleft(j,i),x0catright(j,i),&
30749 !       x0cattrans(j,i)
30750
30751          if (itypj.eq.6) then
30752           ityptranj=1 !as now only Zn2+ is this needs to be modified for other ions
30753          endif
30754          if (itypi.eq.16) then
30755           ityptrani=1
30756          elseif (itypi.eq.1)  then
30757           ityptrani=2
30758          elseif (itypi.eq.15) then
30759           ityptrani=3
30760          elseif (itypi.eq.17) then
30761           ityptrani=4
30762          elseif (itypi.eq.2)  then
30763           ityptrani=5
30764          else
30765           ityptrani=6
30766          endif
30767
30768          if (ityptrani.gt.ntrantyp(ityptranj)) then
30769 !         do l=1,3
30770 !         write(iout,*),gradcattranc(l,j),gradcattranx(l,i)
30771 !         enddo
30772 !volume excluded
30773          call to_box(cjtemp(1),cjtemp(2),cjtemp(3))
30774          call to_box(citemp(1),citemp(2),citemp(3))
30775          rcal=0.0d0
30776          do l=1,3
30777          r(l)=boxshift(cjtemp(l)-citemp(l),boxx(l))
30778          rcal=rcal+r(l)*r(l)
30779          enddo
30780          ract=sqrt(rcal)
30781          if (ract.gt.r_cut_ele) cycle
30782          sss_ele_cut=sscale_ele(ract)
30783          sss_ele_cut_grad=sscagrad_ele(ract)
30784           rocal=1.5
30785           epscalc=0.2
30786           r0p=0.5*(rocal+sig0(itype(i,1)))
30787           r06 = r0p**6
30788           r012 = r06*r06
30789           Evan1=epscalc*(r012/rcal**6)
30790           Evan2=epscalc*2*(r06/rcal**3)
30791           r4 = rcal**4
30792           r7 = rcal**7
30793           do l=1,3
30794             dEvan1Cm(l) = 12*r(l)*epscalc*r012/r7
30795             dEvan2Cm(l) = 12*r(l)*epscalc*r06/r4
30796           enddo
30797           do l=1,3
30798             dEtotalCm(l)=(dEvan1Cm(l)+dEvan2Cm(l))*sss_ele_cut-&
30799                          (Evan1+Evan2)*sss_ele_cut_grad*r(l)/ract
30800           enddo
30801              ecation_prottran = ecation_prottran+&
30802              (Evan1+Evan2)*sss_ele_cut
30803           do  l=1,3
30804             gradcattranx(l,i)=gradcattranx(l,i)+dEtotalCm(l)
30805             gradcattranc(l,i)=gradcattranc(l,i)+dEtotalCm(l)
30806             gradcattranc(l,j)=gradcattranc(l,j)-dEtotalCm(l)
30807            enddo
30808
30809          ene=0.0d0
30810          else
30811 !         cycle
30812          sumvec=0.0d0
30813          simplesum=0.0d0
30814          do l=1,3
30815          vecsc(l)=citemp(l)-c(l,i)
30816          sumvec=sumvec+vecsc(l)**2
30817          simplesum=simplesum+vecsc(l)
30818          enddo
30819          sumvec=dsqrt(sumvec)
30820          call to_box(cjtemp(1),cjtemp(2),cjtemp(3))
30821          call to_box(citemp(1),citemp(2),citemp(3))
30822 !         sumvec=2.0d0
30823          do l=1,3
30824          dsctemp(l)=c(l,i+nres)&
30825                     +(acatshiftdsc(ityptrani,ityptranj)-1.0d0)*vecsc(l)&
30826                     +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec
30827          enddo
30828          call to_box(dsctemp(1),dsctemp(2),dsctemp(3))
30829          sdist=0.0d0
30830          do l=1,3
30831             diff(l)=boxshift(dsctemp(l)-cjtemp(l),boxx(l))
30832            sdist=sdist+diff(l)*diff(l)
30833          enddo
30834          dista=sqrt(sdist)
30835          if (dista.gt.r_cut_ele) cycle
30836
30837          sss_ele_cut=sscale_ele(dista)
30838          sss_ele_cut_grad=sscagrad_ele(dista)
30839          sss2min=sscale2(dista,x0cattrans(ityptrani,ityptranj)-0.1d0,0.2d0)
30840          De=demorsecat(ityptrani,ityptranj)
30841          alphac=alphamorsecat(ityptrani,ityptranj)
30842          if (sss2min.eq.1.0d0) then
30843 !         print *,"ityptrani",ityptrani,ityptranj
30844          x0left=x0catleft(ityptrani,ityptranj) ! to mn
30845          ene=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30846          grad=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30847               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30848               +ene/sss_ele_cut*sss_ele_cut_grad
30849           else if (sss2min.eq.0.0d0) then
30850          x0left=x0catright(ityptrani,ityptranj)
30851          ene=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30852          grad=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30853               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30854               +ene/sss_ele_cut*sss_ele_cut_grad
30855           else
30856          sss2mingrad=sscagrad2(dista,x0cattrans(ityptrani,ityptranj)-0.1d0,0.2d0)
30857          x0left=x0catleft(ityptrani,ityptranj)
30858          ene1=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30859          grad1=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30860               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30861               +ene/sss_ele_cut*sss_ele_cut_grad
30862          x0left=x0catright(ityptrani,ityptranj)
30863          ene2=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30864          grad2=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30865               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30866               +ene/sss_ele_cut*sss_ele_cut_grad
30867          ene=sss2min*ene1+(1.0d0-sss2min)*ene2
30868          grad=sss2min*grad1+(1.0d0-sss2min)*grad2+sss2mingrad*(ene1-ene2)
30869          endif
30870          do l=1,3
30871            diffnorm(l)= diff(l)/dista
30872           enddo
30873           erdxi=scalar(diffnorm(1),dc_norm(1,i+nres))
30874           facd1=bcatshiftdsc(ityptrani,ityptranj)/sumvec
30875
30876          do l=1,3
30877 !       DO k= 1, 3
30878 !      ertail(k) = Rtail_distance(k)/Rtail
30879 !       END DO
30880 !       erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
30881 !       erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
30882 !      facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
30883 !       facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
30884 !       DO k = 1, 3
30885 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
30886 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
30887 !      pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
30888 !      gvdwx(k,i) = gvdwx(k,i) &
30889 !              - (( dFdR + gg(k) ) * pom)
30890          pom=diffnorm(l)+facd1*(diffnorm(l)-erdxi*dc_norm(l,i+nres))
30891 !         write(iout,*),gradcattranc(l,j),gradcattranx(l,i),grad*diff(l)/dista
30892
30893          gradcattranx(l,i)=gradcattranx(l,i)+grad*pom&
30894          +grad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0)
30895 !         *( bcatshiftdsc(ityptrani,ityptranj)*&
30896 !          (1.0d0/sumvec-(vecsc(l)*simplesum)*(sumvec**(-3.0d0))))
30897          gradcattranc(l,i)=gradcattranc(l,i)+grad*diff(l)/dista
30898 !                          +sss_ele_cut_grad*ene*diff(l)/dista/sss_ele_cut
30899          gradcattranc(l,j)=gradcattranc(l,j)-grad*diff(l)/dista
30900 !         -sss_ele_cut_grad*ene*diff(l)/dista/sss_ele_cut
30901          enddo
30902          ecation_prottran=ecation_prottran+ene
30903          if (energy_dec) write(iout,*) "etrancat",i,j,ene,x0left,De,dista,&
30904          alphac
30905          endif
30906       enddo
30907 !      do k=g_listcatptran_start,g_listcatptran_end
30908 !      ene=0.0d0 this will be used if peptide group interaction is needed
30909 !      enddo
30910
30911
30912       return
30913       end subroutine
30914       subroutine ecat_prot_ang(ecation_protang)
30915       integer:: itypi,itypj,ityptrani,ityptranj,k,l,i,j,n,m,&
30916                 ityptrani1,ityptranj1,ityptrani2,ityptranj2,&
30917                 i1,i2,j1,j2,k1,k2,k3,i3,j3,ityptrani3,ityptranj3
30918
30919       real(kind=8),dimension(3):: cjtemp,citemp,diff,dsctemp,vecsc,&
30920                   diffnorm,boxx,dscvec,dscvecnorm,diffnorm2,&
30921                   dscvec2,dscvecnorm2,cjtemp2,citemp2,diff2,dsctemp2,&
30922                   vecsc2,diff1,diffnorm1,diff3,mindiffnorm2
30923       real(kind=8),dimension(3):: dscvec1,dscvecnorm1,cjtemp1,citemp1,vecsc1,dsctemp1,&
30924                   dscvec3,dscvecnorm3,cjtemp3,citemp3,vecsc3,dsctemp3,&
30925                   diffnorm3,diff4,diffnorm4
30926
30927       real(kind=8):: ecation_protang,dista,sdist,De,ene,x0left,&
30928                     alphac,grad,sumvec,sumdscvec,pom,erdxi,facd1,&
30929                     sss_ele_cut,sss_ele_cut_grad,sss2min,sss2mingrad,&
30930                     simplesum,cosval,part1,part2a,part2,part2b,part3,&
30931                     part4a,part4b,part4,bottom,dista2,sdist2,sumvec2,&
30932                     sumdscvec2,simplesum2,dista1,sdist1,sumvec1,simplesum1,&
30933                     sumdscvec1,facd2,scal1a,scal1b,scal2a,scal2b,&
30934                     sss2mingrad1,sss2mingrad2,sss2min1,sss2min2,pom1,pom2,&
30935                     det1ij,det2ij,cosom1,cosom2,cosom12,cosphij,dista3,&
30936                     sumvec3
30937       real(kind=8):: sinom1,sinom2,sinaux,dephiij,sumdscvec3,sumscvec3,&
30938                      cosphi,sdist3,simplesum3,det1t2ij,sss2mingrad3,sss2min3,&
30939                      scal1c,scal2c,scal3a,scal3b,scal3c,facd3,facd2b,scal3d,&
30940                      scal3e,dista4,sdist4,pom3,sssmintot
30941
30942       ecation_protang=0.0d0
30943       boxx(1)=boxxsize
30944       boxx(2)=boxysize
30945       boxx(3)=boxzsize
30946 !      print *,"KUR**3",g_listcatscang_start,g_listcatscang_end
30947 !      go to 19
30948 !      go to 21
30949       do k=g_listcatscang_start,g_listcatscang_end
30950         ene=0.0d0
30951         i=newcontlistcatscangi(k)
30952         j=newcontlistcatscangj(k)
30953          itypi=itype(i,1) !as the first is the protein part
30954          itypj=itype(j,5) !as the second part is always cation
30955 !         print *,"KUR**4",i,j,itypi,itypj
30956 ! remapping to internal types
30957 !       read (iiontran,*,err=123,end=123) (agamacattran(k,j,i),k=1,3),&
30958 !       (athetacattran(k,j,i),k=1,6),acatshiftdsc(j,i),bcatshiftdsc(j,i),&
30959 !       demorsecat(j,i),alphamorsecat(j,i),x0catleft(j,i),x0catright(j,i),&
30960 !       x0cattrans(j,i)
30961          if (itypj.eq.6) then
30962           ityptranj=1 !as now only Zn2+ is this needs to be modified for other ions
30963          endif
30964          if (itypi.eq.16) then
30965           ityptrani=1
30966          elseif (itypi.eq.1)  then
30967           ityptrani=2
30968          elseif (itypi.eq.15) then
30969           ityptrani=3
30970          elseif (itypi.eq.17) then
30971           ityptrani=4
30972          elseif (itypi.eq.2)  then
30973           ityptrani=5
30974          else
30975           ityptrani=6
30976          endif
30977          if (ityptrani.gt.ntrantyp(ityptranj)) cycle
30978          do  l=1,3
30979           citemp(l)=c(l,i+nres)
30980           cjtemp(l)=c(l,j)
30981          enddo
30982          sumvec=0.0d0
30983          simplesum=0.0d0
30984          do l=1,3
30985          vecsc(l)=citemp(l)-c(l,i)
30986          sumvec=sumvec+vecsc(l)**2
30987          simplesum=simplesum+vecsc(l)
30988          enddo
30989          sumvec=dsqrt(sumvec)
30990          sumdscvec=0.0d0
30991         do l=1,3
30992           dsctemp(l)=c(l,i)&
30993 !                     +1.0d0
30994                     +(acatshiftdsc(ityptrani,ityptranj))*vecsc(l)&
30995                     +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec
30996           dscvec(l)= &
30997 !1.0d0
30998                      (acatshiftdsc(ityptrani,ityptranj))*vecsc(l)&
30999                     +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec
31000           sumdscvec=sumdscvec+dscvec(l)**2
31001          enddo
31002          sumdscvec=dsqrt(sumdscvec)
31003          do l=1,3
31004          dscvecnorm(l)=dscvec(l)/sumdscvec
31005          enddo
31006          call to_box(dsctemp(1),dsctemp(2),dsctemp(3))
31007          call to_box(cjtemp(1),cjtemp(2),cjtemp(3))
31008          sdist=0.0d0
31009           do l=1,3
31010             diff(l)=boxshift(dsctemp(l)-cjtemp(l),boxx(l))
31011             sdist=sdist+diff(l)*diff(l)
31012          enddo
31013          dista=sqrt(sdist)
31014          do l=1,3
31015          diffnorm(l)= diff(l)/dista
31016          enddo
31017          cosval=scalar(diffnorm(1),dc_norm(1,i+nres))
31018          grad=0.0d0
31019          sss2min=sscale2(dista,r_cut_ang,1.0d0)
31020          sss2mingrad=sscagrad2(dista,r_cut_ang,1.0d0)
31021          ene=ene&
31022          +tschebyshev(1,6,athetacattran(1,ityptrani,ityptranj),cosval)
31023          grad=gradtschebyshev(0,5,athetacattran(1,ityptrani,ityptranj),cosval)*sss2min
31024
31025          facd1=bcatshiftdsc(ityptrani,ityptranj)/sumvec
31026          erdxi=scalar(diffnorm(1),dc_norm(1,i+nres))
31027          part1=0.0d0
31028          part2=0.0d0
31029          part3=0.0d0
31030          part4=0.0d0
31031          do l=1,3
31032          bottom=sumvec**2*sdist
31033          part1=diff(l)*sumvec*dista
31034          part2a=(acatshiftdsc(ityptrani,ityptranj))*vecsc(l)
31035          part2b=0.0d0
31036          !bcatshiftdsc(ityptrani,ityptranj)/sumvec*&
31037          !(vecsc(l)-cosval*dista*dc_norm(l,i+nres))
31038          part2=(part2a+part2b)*sumvec*dista
31039          part3=cosval*sumvec*dista*dc_norm(l,i+nres)*dista
31040          part4a=diff(l)*acatshiftdsc(ityptrani,ityptranj)
31041          part4b=bcatshiftdsc(ityptrani,ityptranj)/sumvec*&
31042          (diff(l)-cosval*dista*dc_norm(l,i+nres))
31043          part4=cosval*sumvec*(part4a+part4b)*sumvec
31044 !      gradlipang(m,l)=gradlipang(m,l)+(fac &
31045 !       *(xa(m)-scalar*vnorm*xb(m)/wnorm)&
31046 !       /(vnorm*wnorm))
31047
31048 !       DO k= 1, 3
31049 !      ertail(k) = Rtail_distance(k)/Rtail
31050 !       END DO
31051 !       erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
31052 !       erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
31053 !      facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
31054 !       facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
31055 !       DO k = 1, 3
31056 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
31057 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
31058 !      pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
31059 !      gvdwx(k,i) = gvdwx(k,i) &
31060 !              - (( dFdR + gg(k) ) * pom)
31061          pom=diffnorm(l)+facd1*(diffnorm(l)-erdxi*dc_norm(l,i+nres))
31062
31063          gradcatangc(l,j)=gradcatangc(l,j)-grad*&
31064          (dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)-&
31065          ene*sss2mingrad*diffnorm(l)
31066
31067          gradcatangc(l,i)=gradcatangc(l,i)+grad*&
31068          (dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)+&
31069          ene*sss2mingrad*diffnorm(l)
31070
31071          gradcatangx(l,i)=gradcatangx(l,i)+grad*&
31072          (part1+part2-part3-part4)/bottom+&
31073          ene*sss2mingrad*pom+&
31074          ene*sss2mingrad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0)
31075 !         +grad*(dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)&
31076 !         +grad*pom+grad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0)
31077 !&
31078 !         (diff(l)-cosval*dscvecnorm(l)*dista)/(sumdscvec*dista)
31079
31080
31081
31082
31083
31084         enddo
31085 !       print *,i,j,cosval,tschebyshev(1,3,aomicattr(1,ityptranj),cosval)&
31086 !              ,aomicattr(0,ityptranj),ene
31087        if (energy_dec) write(iout,*) i,j,ityptrani,ityptranj,ene,cosval
31088        ecation_protang=ecation_protang+ene*sss2min
31089       enddo
31090  19   continue
31091 !         print *,"KUR**",g_listcatscangf_start,g_listcatscangf_end
31092             do k=g_listcatscangf_start,g_listcatscangf_end
31093         ene=0.0d0
31094         i1=newcontlistcatscangfi(k)
31095         j1=newcontlistcatscangfj(k)
31096          itypi=itype(i1,1) !as the first is the protein part
31097          itypj=itype(j1,5) !as the second part is always cation
31098          if (itypj.eq.6) then
31099           ityptranj1=1 !as now only Zn2+ is this needs to be modified for other ions
31100          endif
31101          if (itypi.eq.16) then
31102           ityptrani1=1
31103          elseif (itypi.eq.1)  then
31104           ityptrani1=2
31105          elseif (itypi.eq.15) then
31106           ityptrani1=3
31107          elseif (itypi.eq.17) then
31108           ityptrani1=4
31109          elseif (itypi.eq.2)  then
31110           ityptrani1=5
31111          else
31112           ityptrani1=6
31113          endif
31114          do  l=1,3
31115           citemp1(l)=c(l,i1+nres)
31116           cjtemp1(l)=c(l,j1)
31117          enddo
31118          sumvec1=0.0d0
31119          simplesum1=0.0d0
31120          do l=1,3
31121          vecsc1(l)=citemp1(l)-c(l,i1)
31122          sumvec1=sumvec1+vecsc1(l)**2
31123          simplesum1=simplesum1+vecsc1(l)
31124          enddo
31125          sumvec1=dsqrt(sumvec1)
31126          sumdscvec1=0.0d0
31127         do l=1,3
31128           dsctemp1(l)=c(l,i1)&
31129 !                     +1.0d0
31130                     +(acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
31131                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
31132           dscvec1(l)= &
31133 !1.0d0
31134                      (acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
31135                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
31136           sumdscvec1=sumdscvec1+dscvec1(l)**2
31137          enddo
31138          sumdscvec1=dsqrt(sumdscvec1)
31139          do l=1,3
31140          dscvecnorm1(l)=dscvec1(l)/sumdscvec1
31141          enddo
31142          call to_box(dsctemp1(1),dsctemp1(2),dsctemp1(3))
31143          call to_box(cjtemp1(1),cjtemp1(2),cjtemp1(3))
31144          sdist1=0.0d0
31145           do l=1,3
31146             diff1(l)=boxshift(dsctemp1(l)-cjtemp1(l),boxx(l))
31147             sdist1=sdist1+diff1(l)*diff1(l)
31148          enddo
31149          dista1=sqrt(sdist1)
31150          do l=1,3
31151          diffnorm1(l)= diff1(l)/dista1
31152          enddo
31153          sss2min1=sscale2(dista1,r_cut_ang,1.0d0)
31154          sss2mingrad1=sscagrad2(dista1,r_cut_ang,1.0d0)
31155          if (ityptrani1.gt.ntrantyp(ityptranj1)) cycle
31156
31157 !-----------------------------------------------------------------
31158 !             do m=k+1,g_listcatscang_end
31159              ene=0.0d0
31160              i2=newcontlistcatscangfk(k)
31161              j2=j1
31162               if (j1.ne.j2) cycle
31163                itypi=itype(i2,1) !as the first is the protein part
31164                itypj=itype(j2,5) !as the second part is always cation
31165               if (itypj.eq.6) then
31166               ityptranj2=1 !as now only Zn2+ is this needs to be modified for other ions
31167               endif
31168              if (itypi.eq.16) then
31169               ityptrani2=1
31170              elseif (itypi.eq.1)  then
31171               ityptrani2=2
31172              elseif (itypi.eq.15) then
31173               ityptrani2=3
31174              elseif (itypi.eq.17) then
31175               ityptrani2=4
31176              elseif (itypi.eq.2)  then
31177               ityptrani2=5
31178              else
31179               ityptrani2=6
31180              endif
31181          if (ityptrani2.gt.ntrantyp(ityptranj2)) cycle
31182
31183            do  l=1,3
31184           citemp2(l)=c(l,i2+nres)
31185           cjtemp2(l)=c(l,j2)
31186          enddo
31187          sumvec2=0.0d0
31188          simplesum2=0.0d0
31189          do l=1,3
31190          vecsc2(l)=citemp2(l)-c(l,i2)
31191          sumvec2=sumvec2+vecsc2(l)**2
31192          simplesum2=simplesum2+vecsc2(l)
31193          enddo
31194          sumvec2=dsqrt(sumvec2)
31195          sumdscvec2=0.0d0
31196         do l=1,3
31197           dsctemp2(l)=c(l,i2)&
31198 !                     +1.0d0
31199                     +(acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
31200                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
31201           dscvec2(l)= &
31202 !1.0d0
31203                      (acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
31204                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
31205           sumdscvec2=sumdscvec2+dscvec2(l)**2
31206          enddo
31207          sumdscvec2=dsqrt(sumdscvec2)
31208          do l=1,3
31209          dscvecnorm2(l)=dscvec2(l)/sumdscvec2
31210          enddo
31211          call to_box(dsctemp2(1),dsctemp2(2),dsctemp2(3))
31212          call to_box(cjtemp2(1),cjtemp2(2),cjtemp2(3))
31213          sdist2=0.0d0
31214           do l=1,3
31215             diff2(l)=boxshift(dsctemp2(l)-cjtemp2(l),boxx(l))
31216 !            diff2(l)=1.0d0
31217             sdist2=sdist2+diff2(l)*diff2(l)
31218          enddo
31219          dista2=sqrt(sdist2)
31220          do l=1,3
31221          diffnorm2(l)= diff2(l)/dista2
31222          enddo
31223 !         print *,i1,i2,diffnorm2(1)
31224          cosval=scalar(diffnorm1(1),diffnorm2(1))
31225          grad=0.0d0
31226          sss2min2=sscale2(dista2,r_cut_ang,1.0d0)
31227          sss2mingrad2=sscagrad2(dista2,r_cut_ang,1.0d0)
31228          ene=ene+tschebyshev(1,3,aomicattr(1,ityptranj1),cosval)
31229          grad=gradtschebyshev(0,2,aomicattr(1,ityptranj1),cosval)*sss2min2*sss2min1
31230          part1=0.0d0
31231          part2=0.0d0
31232          part3=0.0d0
31233          part4=0.0d0
31234          ecation_protang=ecation_protang+ene*sss2min2*sss2min1
31235          facd1=bcatshiftdsc(ityptrani1,ityptranj1)/sumvec1
31236          facd2=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec2
31237          scal1a=scalar(diffnorm1(1),dc_norm(1,i1+nres))
31238          scal1b=scalar(diffnorm2(1),dc_norm(1,i1+nres))
31239          scal2a=scalar(diffnorm1(1),dc_norm(1,i2+nres))
31240          scal2b=scalar(diffnorm2(1),dc_norm(1,i2+nres))
31241
31242        if (energy_dec) write(iout,*) "omi", i,j,ityptrani,ityptranj,ene,cosval,aomicattr(1,ityptranj1),&
31243              aomicattr(2,ityptranj1),aomicattr(3,ityptranj1),tschebyshev(1,3,aomicattr(1,ityptranj1),cosval)
31244
31245 !*sss2min
31246          do l=1,3
31247          pom1=diffnorm1(l)+facd1*(diffnorm1(l)-scal1a*dc_norm(l,i1+nres))
31248          pom2=diffnorm2(l)+facd2*(diffnorm2(l)-scal2b*dc_norm(l,i2+nres))
31249
31250
31251          gradcatangc(l,i1)=gradcatangc(l,i1)+grad*(diff2(l)-&
31252          cosval*diffnorm1(l)*dista2)/(dista2*dista1)+&
31253           ene*sss2mingrad1*diffnorm1(l)*sss2min2
31254
31255
31256          gradcatangx(l,i1)=gradcatangx(l,i1)+grad/(dista2*dista1)*&
31257          (acatshiftdsc(ityptrani1,ityptranj1)*diff2(l)+&
31258          facd1*(diff2(l)-scal1b*dc_norm(l,i1+nres)*dista2)-&
31259          cosval*dista2/dista1*&
31260          (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+&
31261          facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1)))+&
31262          ene*sss2mingrad1*sss2min2*(pom1+&
31263          diffnorm1(l)*(acatshiftdsc(ityptrani1,ityptranj1)-1.0d0))
31264
31265
31266          gradcatangx(l,i2)=gradcatangx(l,i2)+grad/(dista2*dista1)*&
31267          (acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)+&
31268          facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1)-&
31269          cosval*dista1/dista2*&
31270          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&
31271          facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)))+&
31272          ene*sss2mingrad2*sss2min1*(pom2+&
31273          diffnorm2(l)*(acatshiftdsc(ityptrani2,ityptranj2)-1.0d0))
31274
31275
31276          gradcatangx(l,i2)=gradcatangx(l,i2)
31277          gradcatangc(l,i2)=gradcatangc(l,i2)+grad*(diff1(l)-&
31278          cosval*diffnorm2(l)*dista1)/(dista2*dista1)+&
31279           ene*sss2mingrad2*diffnorm2(l)*sss2min1
31280
31281          gradcatangc(l,j2)=gradcatangc(l,j2)-grad*(diff2(l)/dista2/dista1-&
31282          cosval*diff1(l)/dista1/dista1+diff1(l)/dista2/dista1-&
31283          cosval*diff2(l)/dista2/dista2)-&
31284          ene*sss2mingrad1*diffnorm1(l)*sss2min2-&
31285          ene*sss2mingrad2*diffnorm2(l)*sss2min1
31286
31287
31288          enddo
31289
31290               enddo
31291 !            enddo
31292 !#ifdef DUBUG
31293   21  continue
31294 !       do k1=g_listcatscang_start,g_listcatscang_end
31295 !        print *,"KURNA",g_listcatscangt_start,g_listcatscangt_end
31296         do k1=g_listcatscangt_start,g_listcatscangt_end
31297         i1=newcontlistcatscangti(k1)
31298         j1=newcontlistcatscangtj(k1)
31299         itypi=itype(i1,1) !as the first is the protein part
31300         itypj=itype(j1,5) !as the second part is always cation
31301         if (itypj.eq.6) then
31302          ityptranj1=1 !as now only Zn2+ is this needs to be modified for other ions
31303         endif
31304         if (itypi.eq.16) then
31305          ityptrani1=1
31306         elseif (itypi.eq.1)  then
31307          ityptrani1=2
31308         elseif (itypi.eq.15) then
31309          ityptrani1=3
31310         elseif (itypi.eq.17) then
31311          ityptrani1=4
31312         elseif (itypi.eq.2)  then
31313          ityptrani1=5
31314         else
31315          ityptrani1=6
31316         endif
31317         do  l=1,3
31318           citemp1(l)=c(l,i1+nres)
31319           cjtemp1(l)=c(l,j1)
31320         enddo
31321         sumvec1=0.0d0
31322         simplesum1=0.0d0
31323         do l=1,3
31324          vecsc1(l)=citemp1(l)-c(l,i1)
31325          sumvec1=sumvec1+vecsc1(l)**2
31326          simplesum1=simplesum1+vecsc1(l)
31327         enddo
31328         sumvec1=dsqrt(sumvec1)
31329         sumdscvec1=0.0d0
31330         do l=1,3
31331           dsctemp1(l)=c(l,i1)&
31332                     +(acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
31333                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
31334           dscvec1(l)= &
31335                      (acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
31336                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
31337           sumdscvec1=sumdscvec1+dscvec1(l)**2
31338         enddo
31339         sumdscvec1=dsqrt(sumdscvec1)
31340         do l=1,3
31341         dscvecnorm1(l)=dscvec1(l)/sumdscvec1
31342         enddo
31343         call to_box(dsctemp1(1),dsctemp1(2),dsctemp1(3))
31344         call to_box(cjtemp1(1),cjtemp1(2),cjtemp1(3))
31345         sdist1=0.0d0
31346           do l=1,3
31347             diff1(l)=boxshift(dsctemp1(l)-cjtemp1(l),boxx(l))
31348             sdist1=sdist1+diff1(l)*diff1(l)
31349          enddo
31350          dista1=sqrt(sdist1)
31351          do l=1,3
31352          diffnorm1(l)= diff1(l)/dista1
31353          enddo
31354          sss2min1=sscale2(dista1,r_cut_ang,1.0d0)
31355          sss2mingrad1=sscagrad2(dista1,r_cut_ang,1.0d0)
31356          if (ityptrani1.gt.ntrantyp(ityptranj1)) cycle
31357 !---------------before second loop
31358 !        do k2=k1+1,g_listcatscang_end
31359          i2=newcontlistcatscangtk(k1)
31360          j2=j1
31361 !         print *,"TUTU3",i1,i2,j1,j2
31362          if (i2.eq.i1) cycle
31363          if (j2.ne.j1) cycle
31364          itypi=itype(i2,1) !as the first is the protein part
31365          itypj=itype(j2,5) !as the second part is always cation
31366          if (itypj.eq.6) then
31367            ityptranj2=1 !as now only Zn2+ is this needs to be modified for other ions
31368           endif
31369           if (itypi.eq.16) then
31370            ityptrani2=1
31371           elseif (itypi.eq.1)  then
31372            ityptrani2=2
31373           elseif (itypi.eq.15) then
31374            ityptrani2=3
31375           elseif (itypi.eq.17) then
31376            ityptrani2=4
31377           elseif (itypi.eq.2)  then
31378            ityptrani2=5
31379           else
31380            ityptrani2=6
31381           endif
31382           if (ityptrani2.gt.ntrantyp(ityptranj2)) cycle
31383           do  l=1,3
31384            citemp2(l)=c(l,i2+nres)
31385            cjtemp2(l)=c(l,j2)
31386           enddo
31387           sumvec2=0.0d0
31388           simplesum2=0.0d0
31389           do l=1,3
31390            vecsc2(l)=citemp2(l)-c(l,i2)
31391            sumvec2=sumvec2+vecsc2(l)**2
31392            simplesum2=simplesum2+vecsc2(l)
31393           enddo
31394           sumvec2=dsqrt(sumvec2)
31395           sumdscvec2=0.0d0
31396           do l=1,3
31397            dsctemp2(l)=c(l,i2)&
31398                     +(acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
31399                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
31400            dscvec2(l)= &
31401                      (acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
31402                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
31403            sumdscvec2=sumdscvec2+dscvec2(l)**2
31404           enddo
31405           sumdscvec2=dsqrt(sumdscvec2)
31406           do l=1,3
31407            dscvecnorm2(l)=dscvec2(l)/sumdscvec2
31408           enddo
31409           call to_box(dsctemp2(1),dsctemp2(2),dsctemp2(3))
31410           call to_box(cjtemp2(1),cjtemp2(2),cjtemp2(3))
31411          sdist2=0.0d0
31412           do l=1,3
31413             diff2(l)=boxshift(dsctemp2(l)-cjtemp2(l),boxx(l))
31414 !            diff2(l)=1.0d0
31415             sdist2=sdist2+diff2(l)*diff2(l)
31416          enddo
31417          dista2=sqrt(sdist2)
31418          do l=1,3
31419          diffnorm2(l)= diff2(l)/dista2
31420          mindiffnorm2(l)=-diffnorm2(l)
31421          enddo
31422 !         print *,i1,i2,diffnorm2(1)
31423          cosom1=scalar(diffnorm1(1),diffnorm2(1))
31424          sss2min2=sscale2(dista2,r_cut_ang,1.0d0)
31425          sss2mingrad2=sscagrad2(dista2,r_cut_ang,1.0d0)
31426
31427 !---------------- before third loop
31428 !          do k3=g_listcatscang_start,g_listcatscang_end
31429            ene=0.0d0
31430            i3=newcontlistcatscangtl(k1)
31431            j3=j1
31432 !            print *,"TUTU4",i1,i2,i3,j1,j2,j3
31433
31434            if (i3.eq.i2) cycle
31435            if (i3.eq.i1) cycle
31436            if (j3.ne.j1) cycle
31437            itypi=itype(i3,1) !as the first is the protein part
31438            itypj=itype(j3,5) !as the second part is always cation
31439            if (itypj.eq.6) then
31440             ityptranj3=1 !as now only Zn2+ is this needs to be modified for other ions
31441            endif
31442            if (itypi.eq.16) then
31443             ityptrani3=1
31444            elseif (itypi.eq.1)  then
31445             ityptrani3=2
31446            elseif (itypi.eq.15) then
31447             ityptrani3=3
31448            elseif (itypi.eq.17) then
31449             ityptrani3=4
31450            elseif (itypi.eq.2)  then
31451             ityptrani3=5
31452            else
31453             ityptrani3=6
31454            endif
31455            if (ityptrani3.gt.ntrantyp(ityptranj3)) cycle
31456            do  l=1,3
31457             citemp3(l)=c(l,i3+nres)
31458             cjtemp3(l)=c(l,j3)
31459           enddo
31460           sumvec3=0.0d0
31461           simplesum3=0.0d0
31462           do l=1,3
31463            vecsc3(l)=citemp3(l)-c(l,i3)
31464            sumvec3=sumvec3+vecsc3(l)**2
31465            simplesum3=simplesum3+vecsc3(l)
31466           enddo
31467           sumvec3=dsqrt(sumvec3)
31468           sumdscvec3=0.0d0
31469           do l=1,3
31470            dsctemp3(l)=c(l,i3)&
31471                     +(acatshiftdsc(ityptrani3,ityptranj3))*vecsc3(l)&
31472                     +bcatshiftdsc(ityptrani3,ityptranj3)*vecsc3(l)/sumvec3
31473            dscvec3(l)= &
31474                      (acatshiftdsc(ityptrani3,ityptranj3))*vecsc3(l)&
31475                     +bcatshiftdsc(ityptrani3,ityptranj3)*vecsc3(l)/sumvec3
31476            sumdscvec3=sumdscvec3+dscvec3(l)**2
31477           enddo
31478           sumdscvec3=dsqrt(sumdscvec3)
31479           do l=1,3
31480            dscvecnorm3(l)=dscvec3(l)/sumdscvec3
31481           enddo
31482           call to_box(dsctemp3(1),dsctemp3(2),dsctemp3(3))
31483           call to_box(cjtemp3(1),cjtemp3(2),cjtemp3(3))
31484           sdist3=0.0d0
31485           do l=1,3
31486             diff3(l)=boxshift(dsctemp3(l)-dsctemp2(l),boxx(l))
31487             sdist3=sdist3+diff3(l)*diff3(l)
31488          enddo
31489          dista3=sqrt(sdist3)
31490          do l=1,3
31491          diffnorm3(l)= diff3(l)/dista3
31492          enddo
31493          sdist4=0.0d0
31494           do l=1,3
31495             diff4(l)=boxshift(dsctemp3(l)-cjtemp2(l),boxx(l))
31496 !            diff2(l)=1.0d0
31497             sdist4=sdist4+diff4(l)*diff4(l)
31498          enddo
31499          dista4=sqrt(sdist4)
31500          do l=1,3
31501          diffnorm4(l)= diff4(l)/dista4
31502          enddo
31503
31504          sss2min3=sscale2(dista4,r_cut_ang,1.0d0)
31505          sss2mingrad3=sscagrad2(dista4,r_cut_ang,1.0d0)
31506          sssmintot=sss2min3*sss2min2*sss2min1
31507          if (ityptrani3.gt.ntrantyp(ityptranj3)) cycle
31508          cosom12=scalar(diffnorm3(1),diffnorm1(1))
31509          cosom2=scalar(diffnorm3(1),mindiffnorm2(1))
31510          sinom1=dsqrt(1.0d0-cosom1*cosom1)
31511          sinom2=dsqrt(1.0d0-cosom2*cosom2)
31512          cosphi=cosom12-cosom1*cosom2
31513          sinaux=sinom1*sinom2
31514          ene=ene+mytschebyshev(1,3,agamacattran(1,ityptrani2,ityptranj2),cosphi,sinaux)
31515          call mygradtschebyshev(1,3,agamacattran(1,ityptrani2,ityptranj2)&
31516           ,cosphi,sinaux,dephiij,det1t2ij)
31517
31518           det1ij=-det1t2ij*sinom2*cosom1/sinom1-dephiij*cosom2
31519           det2ij=-det1t2ij*sinom1*cosom2/sinom2-dephiij*cosom1
31520           facd1=bcatshiftdsc(ityptrani1,ityptranj1)/sumvec1
31521           facd2=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec2
31522 !          facd2b=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec3
31523           facd3=bcatshiftdsc(ityptrani3,ityptranj3)/sumvec3
31524           scal1a=scalar(diffnorm1(1),dc_norm(1,i1+nres))
31525           scal1b=scalar(diffnorm2(1),dc_norm(1,i1+nres))
31526           scal1c=scalar(diffnorm3(1),dc_norm(1,i1+nres))
31527           scal2a=scalar(diffnorm1(1),dc_norm(1,i2+nres))
31528           scal2b=scalar(diffnorm2(1),dc_norm(1,i2+nres))
31529           scal2c=scalar(diffnorm3(1),dc_norm(1,i2+nres))
31530           scal3a=scalar(diffnorm1(1),dc_norm(1,i3+nres))
31531           scal3b=scalar(mindiffnorm2(1),dc_norm(1,i3+nres))
31532           scal3d=scalar(diffnorm2(1),dc_norm(1,i3+nres))
31533           scal3c=scalar(diffnorm3(1),dc_norm(1,i3+nres))
31534           scal3e=scalar(diffnorm4(1),dc_norm(1,i3+nres))
31535
31536
31537           do l=1,3
31538          pom1=diffnorm1(l)+facd1*(diffnorm1(l)-scal1a*dc_norm(l,i1+nres))
31539          pom2=diffnorm2(l)+facd2*(diffnorm2(l)-scal2b*dc_norm(l,i2+nres))
31540          pom3=diffnorm4(l)+facd3*(diffnorm4(l)-scal3e*dc_norm(l,i3+nres))
31541
31542           gradcatangc(l,i1)=gradcatangc(l,i1)&
31543           +det1ij*sssmintot*(diff2(l)-diffnorm1(l)*cosom1*dista2)/(dista2*dista1)+&
31544           dephiij*sssmintot*(diff3(l)-diffnorm1(l)*cosom12*dista3)/(dista3*dista1)&
31545          +ene*sss2mingrad1*diffnorm1(l)*sss2min2*sss2min3
31546
31547
31548           gradcatangc(l,i2)=gradcatangc(l,i2)+(&
31549           det1ij*(diff1(l)-diffnorm2(l)*cosom1*dista1)/(dista2*dista1)+&
31550           det2ij*(-diff3(l)+mindiffnorm2(l)*cosom2*dista3)/(dista3*dista2)&
31551           -det2ij*(-diff2(l)-diffnorm3(l)*cosom2*dista2)/(dista3*dista2)&
31552           -dephiij*(diff1(l)-diffnorm3(l)*cosom12*dista1)/(dista3*dista1))*sssmintot&
31553          +ene*sss2mingrad2*diffnorm2(l)*sss2min1*sss2min3
31554
31555
31556
31557           gradcatangc(l,i3)=gradcatangc(l,i3)&
31558           +det2ij*(-diff2(l)-diffnorm3(l)*cosom2*dista2)/(dista3*dista2)*sssmintot&
31559           +dephiij*(diff1(l)-diffnorm3(l)*cosom12*dista1)/(dista3*dista1)*sssmintot&
31560          +ene*sss2mingrad3*diffnorm4(l)*sss2min1*sss2min2
31561
31562
31563           gradcatangc(l,j1)=gradcatangc(l,j1)-&
31564           sssmintot*(det1ij*(diff2(l)-diffnorm1(l)*cosom1*dista2)/(dista2*dista1)+&
31565           dephiij*(diff3(l)-diffnorm1(l)*cosom12*dista3)/(dista3*dista1))&
31566           -(det1ij*(diff1(l)-diffnorm2(l)*cosom1*dista1)/(dista1*dista2)+&
31567           det2ij*(-diff3(l)+mindiffnorm2(l)*cosom2*dista3)/(dista3*dista2))*sssmintot&
31568          -ene*sss2mingrad1*diffnorm1(l)*sss2min2*sss2min3&
31569          -ene*sss2mingrad2*diffnorm2(l)*sss2min1*sss2min3&
31570          -ene*sss2mingrad3*diffnorm4(l)*sss2min1*sss2min2
31571
31572
31573          gradcatangx(l,i1)=gradcatangx(l,i1)+(det1ij/(dista2*dista1)*&
31574          (acatshiftdsc(ityptrani1,ityptranj1)*diff2(l)+&
31575          facd1*(diff2(l)-scal1b*dc_norm(l,i1+nres)*dista2)-&
31576          cosom1*dista2/dista1*&
31577          (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+&
31578          facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1)))&
31579          +dephiij/(dista3*dista1)*&
31580          (acatshiftdsc(ityptrani1,ityptranj1)*diff3(l)+&
31581          facd1*(diff3(l)-scal1c*dc_norm(l,i1+nres)*dista3)-&
31582          cosom12*dista3/dista1*&
31583          (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+&
31584          facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1))))*sssmintot&
31585          +ene*sss2mingrad1*sss2min2*sss2min3*(pom1+&
31586           diffnorm1(l)*(acatshiftdsc(ityptrani1,ityptranj1)-1.0d0))
31587
31588
31589          gradcatangx(l,i3)=gradcatangx(l,i3)+(&
31590          det2ij/(dista3*dista2)*&
31591          (acatshiftdsc(ityptrani3,ityptranj3)*(-diff2(l))+&
31592          facd3*(-diff2(l)-scal3b*dc_norm(l,i3+nres)*dista2)-&
31593          cosom2*dista2/dista3*&
31594          (acatshiftdsc(ityptrani3,ityptranj3)*diff3(l)+&
31595          facd3*(diff3(l)-scal3c*dc_norm(l,i3+nres)*dista3)))&
31596          +dephiij/(dista3*dista1)*&
31597          (acatshiftdsc(ityptrani3,ityptranj3)*diff1(l)+&
31598          facd3*(diff1(l)-scal3a*dc_norm(l,i3+nres)*dista1)-&
31599          cosom12*dista1/dista3*&
31600          (acatshiftdsc(ityptrani3,ityptranj3)*diff3(l)+&
31601          facd3*(diff3(l)-scal3c*dc_norm(l,i3+nres)*dista3))))*sssmintot&
31602          +ene*sss2mingrad3*sss2min2*sss2min1*(pom3+&
31603           diffnorm4(l)*(acatshiftdsc(ityptrani3,ityptranj3)-1.0d0))
31604
31605
31606          gradcatangx(l,i2)=gradcatangx(l,i2)+(&!
31607          det1ij/(dista2*dista1)*&!
31608          (acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)&!
31609          +facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1)&
31610          -cosom1*dista1/dista2*&!
31611          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&!
31612          facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)))+&
31613          det2ij/(dista3*dista2)*&!
31614          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&!
31615          facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)&
31616          -(acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&!
31617           facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3))&
31618          -cosom2*dista3/dista2*&!
31619          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&!
31620           facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2))&
31621          +cosom2*dista2/dista3*&!
31622          (acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&!
31623          facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3)))&
31624          +dephiij/(dista3*dista1)*&!
31625          (-(acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)+&!
31626          facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1))+&
31627          cosom12*dista1/dista3*&!
31628          (acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&!
31629           facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3))))*sssmintot&
31630          +ene*sss2mingrad2*sss2min3*sss2min1*(pom2+&
31631           diffnorm2(l)*(acatshiftdsc(ityptrani2,ityptranj2)-1.0d0))
31632
31633
31634           enddo
31635 !          print *,i1,i2,i3,j1,j2,j3,"tors",ene,sinaux,cosphi
31636 !          print *,"param",agamacattran(1,ityptrani2,ityptranj2),ityptranj2,ityptrani2
31637           ecation_protang=ecation_protang+ene*sssmintot
31638          enddo
31639 !        enddo
31640 !       enddo
31641 !#endif
31642       return
31643       end subroutine
31644 !--------------------------------------------------------------------------
31645 !c------------------------------------------------------------------------------
31646       double precision function mytschebyshev(m,n,x,y,yt)
31647       implicit none
31648       integer i,m,n
31649       double precision x(n),y,yt,yy(0:100),aux
31650 !c Tschebyshev polynomial in y multiplied by sin(t1)sin(t2) (yt).
31651 !c Note that the first term is omitted
31652 !c m=0: the constant term is included
31653 !c m=1: the constant term is not included
31654       yy(0)=1.0d0
31655       yy(1)=y
31656       do i=2,n
31657         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)*yt*yt
31658       enddo
31659       aux=0.0d0
31660       do i=m,n
31661         aux=aux+x(i)*yy(i)
31662       enddo
31663 !c      print *,(yy(i),i=1,n)
31664       mytschebyshev=aux
31665       return
31666       end function
31667 !C--------------------------------------------------------------------------
31668 !C--------------------------------------------------------------------------
31669       subroutine mygradtschebyshev(m,n,x,y,yt,fy,fyt)
31670       implicit none
31671       integer i,m,n
31672       double precision x(n+1),y,yt,fy,fyt,yy(0:100),yb(0:100), &
31673       ybt(0:100)
31674 !c Derivative of Tschebyshev polynomial in y multiplied by sin(t1)sin(t2) (yt).
31675 !c Note that the first term is omitted
31676 !c m=0: the constant term is included
31677 !c m=1: the constant term is not included
31678       yy(0)=1.0d0
31679       yy(1)=y
31680       yb(0)=0.0d0
31681       yb(1)=1.0d0
31682       ybt(0)=0.0d0
31683       ybt(1)=0.0d0
31684       do i=2,n
31685         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)*yt*yt
31686         yb(i)=2*yy(i-1)+2*yy(1)*yb(i-1)-yb(i-2)*yt*yt
31687         ybt(i)=2*yy(1)*ybt(i-1)-ybt(i-2)*yt*yt-2*yy(i-2)*yt
31688       enddo
31689       fy=0.0d0
31690       fyt=0.0d0
31691       do i=m,n
31692         fy=fy+x(i)*yb(i)
31693         fyt=fyt+x(i)*ybt(i)
31694       enddo
31695       return
31696       end subroutine
31697        subroutine fodstep(nsteps)
31698        use geometry_data, only: c, nres, theta, alph
31699        use geometry, only:alpha,beta,dist
31700        integer, intent(in) :: nsteps
31701        integer idxtomod, j, i
31702       double precision RD0, RD1, fi
31703 !      double precision alpha
31704 !      double precision beta
31705 !      double precision dist
31706 !      double precision compute_RD
31707       double precision TT
31708       real :: r21(5)
31709 !c    ! Założenia: dla łańcucha zapisanego w tablicy c zawierającego
31710 !c    ! nres elementów CA i CB da się wyznaczyć kąty płaskie
31711 !c    ! theta (procedura Alpha) i kąty torsyjne (procedura beta),
31712 !c    ! zapisywane w tablicach theta i alph.
31713 !c    ! Na podstawie danych z tych tablic da się odtworzyć
31714 !c    ! strukturę 3D łańcucha procedurą chainbuild.
31715 !c    !
31716 !      print *,"fodstep: nres=",nres
31717       RD0 = compute_RD()
31718 !      print *, "RD0before step: ",RD0
31719       do j=1,nsteps
31720 !c      ! Wyznaczenie kątów theta na podstawie struktury
31721 !c      ! zapisanej w tablicy c
31722       do i=3,nres
31723         TT=alpha(i-2,i-1,i)
31724         theta(i)=TT
31725 !c       print *,"TT=",TT
31726       end do
31727 !c      ! Wyznaczenie kątów phi na podstawie struktury
31728 !c      ! zapisanej w tablicy c
31729       do i=4,nres
31730         phi(i)=beta(i-3,i-2,i-1,i)
31731       end do
31732 !c      ! Wyznaczenie odległości między atomami
31733 !c      ! vbld(i)=dist(i-1,i)
31734       do i=2,nres
31735         vbld(i)=dist(i-1,i)
31736       end do
31737 !c      ! losujemy kilka liczb
31738       call random_number(r21)
31739 !c          ! r21(1): indeks pozycji do zmiany
31740 !c          ! r21(2): kąt (r21(2)/20.0-1/40.0)
31741 !c          ! r21(3): wybór tablicy
31742       RD0 = compute_RD()
31743 !c     print *, "RD before step: ",RD0
31744       fi = (r21(2)/20.0-1.0/40.0) ! o tyle radianów zmienimy losowy kąt
31745       if (r21(3) .le. 0.5) then
31746           idxtomod = 3+r21(1)*(nres - 2)
31747           theta(idxtomod) = theta(idxtomod)+fi
31748 !          print *,"Zmiana kąta theta(",&
31749 !         idxtomod,") o fi = ",fi
31750       else
31751           idxtomod = 4+r21(1)*(nres - 3)
31752           phi(idxtomod) = phi(idxtomod)+fi
31753 !          print *,"Zmiana kąta phi(",&
31754 !         idxtomod,") o fi = ",fi
31755       end if
31756 !c     ! odtwarzamy łańcuch
31757       call chainbuild
31758 !c     ! czy coś się polepszyło?
31759       RD1 = compute_RD()
31760       if (RD1 .gt. RD0) then  ! nie, wycofujemy zmianę
31761 !           print *, "RD  after step: ",RD1," rejected"
31762            if (r21(3) .le. 0.5) then
31763                theta(idxtomod) = theta(idxtomod)-fi
31764            else
31765                phi(idxtomod) = phi(idxtomod)-fi
31766            end if
31767            call chainbuild    ! odtworzenie pierwotnej wersji (bez zmienionego kąta)
31768       else
31769 !           print *, "RD  after step: ",RD1," accepted"
31770       continue
31771       end if
31772       end do
31773       end subroutine
31774 !c-----------------------------------------------------------------------------------------
31775       subroutine orientation_matrix(res) ! obliczenie macierzy oraz przygotowanie ea z tymi przeksztalceniami
31776       use geometry_data, only: c, nres
31777       use energy_data, only: itype
31778       double precision, intent(out) :: res(4,4)
31779       double precision resM(4,4)
31780       double precision M(4,4)
31781       double precision M2(4,4)
31782       integer i, j, maxi, maxj
31783 !      double precision sq
31784       double precision maxd, dd
31785       double precision v1(3)
31786       double precision v2(3)
31787       double precision vecnea(3)
31788       double precision mean_ea(3)
31789       double precision fi
31790 !c    ! liczymy atomy efektywne i zapisujemy w tablicy ea
31791       do i=1,nres
31792 !c         if (itype(i,1) .ne. 10) then
31793           if (itype(i,1) .ne. 10) then
31794               ea(1,i) =  c(1,i+nres)
31795               ea(2,i) =  c(2,i+nres)
31796               ea(3,i) =  c(3,i+nres)
31797           else
31798               ea(1,i) = c(1,i)
31799               ea(2,i) = c(2,i)
31800               ea(3,i) = c(3,i)
31801           end if
31802       end do
31803       call IdentityM(resM)
31804       if (nres .le. 2) then
31805           print *, "nres too small (should be at least 2), stopping"
31806           stop
31807       end if
31808       do i=1,3
31809           v1(i)=ea(i,1)
31810           v2(i)=ea(i,2)
31811       end do
31812 !c     ! szukamy najwiekszej odleglosci miedzy atomami efektywnymi ea
31813       call Dist3d(maxd,v1,v2)
31814 !c       ! odleglosc miedzy pierwsza para atomow efektywnych
31815       maxi = 1
31816       maxj = 2
31817       do i=1,nres-1
31818           do j=i+1,nres
31819               v1(1)=ea(1,i)
31820               v1(2)=ea(2,i)
31821               v1(3)=ea(3,i)
31822               v2(1)=ea(1,j)
31823               v2(2)=ea(2,j)
31824               v2(3)=ea(3,j)
31825               call Dist3d(dd,v1,v2)
31826               if (dd .gt. maxd) then
31827                   maxd = dd
31828                   maxi = i
31829                   maxj = j
31830               end if
31831           end do
31832       end do
31833       vecnea(1)=ea(1,maxi)-ea(1,maxj)
31834       vecnea(2)=ea(2,maxi)-ea(2,maxj)
31835       vecnea(3)=ea(3,maxi)-ea(3,maxj)
31836       if (vecnea(1) .lt. 0) then
31837           vecnea(1) = -vecnea(1)
31838           vecnea(2) = -vecnea(2)
31839           vecnea(3) = -vecnea(3)
31840       end if
31841 !c     ! obliczenie kata obrotu wokol osi Z
31842       fi = -atan2(vecnea(2),vecnea(1))
31843       call RotateZ(M,fi)
31844 !c     ! obliczenie kata obrotu wokol osi Y
31845       fi = atan2(vecnea(3), sqrt(sq(vecnea(1))+sq(vecnea(2))))
31846       call RotateY(M2,fi)
31847       M = matmul(M2,M)
31848 !c    ! Przeksztalcamy wszystkie atomy efektywne
31849 !c    ! uzyskujac najwieksza odleglosc ulożona wzdluz OX
31850 !c    ! ea = transform_eatoms(ea,M)
31851       do i=1,nres
31852           v1(1)=ea(1,i)
31853           v1(2)=ea(2,i)
31854           v1(3)=ea(3,i)
31855           call tranform_point(v2,v1,M)
31856           ea(1,i)=v2(1)
31857           ea(2,i)=v2(2)
31858           ea(3,i)=v2(3)
31859       end do
31860       resM = M
31861 !c      ! Teraz szukamy najdluzszego rzutu na plaszczyzne YZ
31862 !c      ! (czyli w liczeniu odleglosci bierzemy pod uwage tylko wsp. y, z)
31863       maxd = sqrt( sq(ea(2,1)-ea(2,2)) + sq(ea(3,1)-ea(3,2))) ! aktualnie max odl
31864       maxi = 1  ! indeksy atomow
31865       maxj = 2  ! miedzy ktorymi jest max odl (chwilowe)
31866       do i=1,nres-1
31867         do j=i+1,nres
31868             dd = sqrt( (ea(2,i)-ea(2,j))**2 + (ea(3,i)-ea(3,j))**2)
31869             if (dd .gt. maxd) then
31870                 maxd = dd
31871                 maxi = i
31872                 maxj = j
31873             end if
31874         end do
31875       end do
31876 !c   ! Teraz obrocimy wszystko wokol OX tak, zeby znaleziony rzut
31877 !c   ! byl rownolegly do OY
31878       vecnea(1) = ea(1,maxi)-ea(1,maxj)
31879       vecnea(2) = ea(2,maxi)-ea(2,maxj)
31880       vecnea(3) = ea(3,maxi)-ea(3,maxj)
31881 !c   ! jeśli współrzędna vecnea.y < 0, to robimy odwrotnie
31882       if (vecnea(2) .lt. 0) then
31883          vecnea(1) = -vecnea(1)
31884          vecnea(2) = -vecnea(2)
31885          vecnea(3) = -vecnea(3)
31886       end if
31887 !c     ! obliczenie kąta obrotu wokół osi X
31888       fi = -atan2(vecnea(3),vecnea(2))
31889       call RotateX(M,fi)
31890 !c    ! Przeksztalcamy wszystkie atomy efektywne
31891       do i=1,nres
31892          v1(1)=ea(1,i)
31893          v1(2)=ea(2,i)
31894          v1(3)=ea(3,i)
31895          call tranform_point(v2,v1,M)
31896          ea(1,i)=v2(1)
31897          ea(2,i)=v2(2)
31898          ea(3,i)=v2(3)
31899       end do
31900       resM = matmul(M,resM)  ! zbieramy wynik (sprawdzic kolejnosc M,resM)
31901 !c     ! centrujemy
31902       mean_ea(1) = 0
31903       mean_ea(2) = 0
31904       mean_ea(3) = 0
31905       do i=1,nres
31906          mean_ea(1) = mean_ea(1) + ea(1,i)
31907          mean_ea(2) = mean_ea(2) + ea(2,i)
31908          mean_ea(3) = mean_ea(3) + ea(3,i)
31909       end do
31910       v1(1) = -mean_ea(1)/nres
31911       v1(2) = -mean_ea(2)/nres
31912       v1(3) = -mean_ea(3)/nres
31913       call TranslateV(M,v1)
31914       resM = matmul(M,resM)
31915 !c     ! przesuwamy
31916       do i=1,nres
31917          ea(1,i) = ea(1,i) + v1(1)
31918          ea(2,i) = ea(2,i) + v1(2)
31919          ea(3,i) = ea(3,i) + v1(3)
31920       end do
31921       res = resM
31922 !c     ! wynikowa macierz przeksztalcenia lancucha
31923 !c     ! (ale lancuch w ea juz mamy przeksztalcony)
31924       return
31925       end subroutine
31926       double precision function compute_rd
31927       use geometry_data, only: nres
31928       use energy_data, only: itype
31929       implicit none
31930       double precision or_mat(4,4)
31931 !      double precision hydrophobicity
31932       integer neatoms
31933       double precision cutoff
31934       double precision ho(70000)
31935       double precision ht(70000)
31936       double precision hosum, htsum
31937       double precision marg, sigmax, sigmay, sigmaz
31938       integer i, j
31939       double precision v1(3)
31940       double precision v2(3)
31941       double precision rijdivc, coll, tmpkwadrat, tmppotega, dist
31942       double precision OdivT, OdivR, ot_one, or_one, RD_classic
31943       call orientation_matrix(or_mat)
31944 !c     ! tam juz liczy sie tablica ea
31945       neatoms = nres
31946       cutoff = 8.99d0
31947 !c     ! granica oddzialywania w A (powyzej ignorujemy oddzialywanie)
31948 !c     ! Najpierw liczymy "obserwowana hydrofobowosc"
31949       hosum = 0.0d0  ! na sume pol ho, do celow pozniejszej normalizacji
31950       do j=1,neatoms
31951         ho(j)=0.0d0
31952         do i=1,neatoms
31953           if (j .eq. i) then ! nie uwzgledniamy oddzialywania atomu z samym soba
31954              cycle
31955           end if
31956           v1(1)=ea(1,i)
31957           v1(2)=ea(2,i)
31958           v1(3)=ea(3,i)
31959           v2(1)=ea(1,j)
31960           v2(2)=ea(2,j)
31961           v2(3)=ea(3,j)
31962           call Dist3d(dist,v1,v2) ! odleglosc miedzy atomami
31963           if (dist .gt. cutoff) then  ! za daleko, nie uwzgledniamy
31964             cycle
31965           end if
31966           rijdivc = dist / cutoff
31967           coll = 0.0d0
31968           tmppotega = rijdivc*rijdivc
31969           tmpkwadrat = tmppotega
31970           coll = coll + 7*tmpkwadrat
31971           tmppotega = tmppotega * tmpkwadrat  ! do potęgi 4
31972           coll = coll - 9*tmppotega
31973           tmppotega = tmppotega * tmpkwadrat  ! do potęgi 6
31974           coll = coll + 5*tmppotega
31975           tmppotega = tmppotega * tmpkwadrat  ! do potęgi 8
31976           coll = coll - tmppotega
31977 !c        ! Wersja: Bryliński 2007
31978 !c        ! EAtoms[j].collectedhp += EAtoms[i].hyphob*(1 - 0.5 * coll);
31979 !c        ! ea$ho[j] = ea$ho[j] + hydrophobicity(ea$resid[i])*(1-0.5*coll)
31980 !c        ! Wersja: Banach Konieczny Roterman 2014
31981 !c        ! EAtoms[j].collectedhp += (EAtoms[i].hyphob+EAtoms[j].hyphob)*(1 - 0.5 * coll);
31982 !c        ponizej bylo itype(i,1) w miejscu itype(i)  oraz itype(j,1) w miejscu itype(j)
31983          ho(j) = ho(j) + (hydrophobicity(itype(i,1))+&
31984         hydrophobicity(itype(j,1)))*(1.0d0-0.5_8*coll)
31985       end do
31986       hosum = hosum + ho(j)
31987       end do
31988 !c     ! Normalizujemy
31989       do i=1,neatoms
31990       ho(i) = ho(i) / hosum
31991       end do
31992 !c     ! Koniec liczenia hydrofobowosci obserwowanej (profil ho)
31993 !c     ! Teraz liczymy "teoretyczna hydrofobowosc", wedlug kropli i rozkladu Gaussa
31994       htsum = 0.0d0
31995 !c     ! tu zbieramy sume ht, uzyjemy potem do normalizacji
31996 !c  ! Ustalimy teraz parametry rozkladu Gaussa, czyli sigmy (srodek jest w (0,0,0)).
31997 !c  ! To bedzie (max odl od srodka + margines) / 3, oddzielnie dla kazdej wspolrzednej.
31998       marg  = 9.0d0
31999       htsum = 0.0d0
32000 !c  ! jeszcze raz zerujemy
32001 !c  ! szukamy ekstremalnej wartosci wspolrzednej x (max wart bezwzgl)
32002       sigmax = ea(1,1)
32003       do i=2,neatoms
32004       if (abs(ea(1,i))>sigmax) then
32005           sigmax = abs(ea(1,i))
32006       end if
32007       end do
32008       sigmax = (marg + sigmax) / 3.0d0
32009 !c  ! szukamy ekstremalnej wartosci wspolrzednej y (max wart bezwzgl)
32010       sigmay = ea(2,1)
32011       do i=2,neatoms
32012       if (abs(ea(2,i))>sigmay) then
32013          sigmay = abs(ea(2,i))
32014       end if
32015       end do
32016       sigmay = (marg + sigmay) / 3.0d0
32017 !c  ! szukamy ekstremalnej wartosci wspolrzednej z (max wart bezwzgl)
32018       sigmaz = ea(3,1)
32019       do i=2,neatoms
32020       if (abs(ea(3,i))>sigmaz) then
32021         sigmaz = abs(ea(3,i))
32022       end if
32023       end do
32024       sigmaz = (marg + sigmaz) / 3.0d0
32025 !c  !sigmax = (marg + max(abs(max(ea$acoor[,1])), abs(min(ea$acoor[,1]))))/3.0
32026 !c  !sigmay = (marg + max(abs(max(ea$acoor[,2])), abs(min(ea$acoor[,2]))))/3.0
32027 !c  !sigmaz = (marg + max(abs(max(ea$acoor[,3])), abs(min(ea$acoor[,3]))))/3.0
32028 !c  ! print *,"sigmax =",sigmax,"  sigmay =",sigmay," sigmaz = ",sigmaz
32029       do j=1,neatoms
32030       ht(j)= exp(-(ea(1,j))**2/(2*sigmax**2))&
32031       * exp(-(ea(2,j))**2/(2*sigmay**2)) &
32032       * exp(-(ea(3,j))**2/(2*sigmaz**2))
32033       htsum = htsum + ht(j)
32034       end do
32035 !c  ! Normalizujemy
32036       do i=1, neatoms
32037         ht(i) = ht(i) / htsum
32038       end do
32039 !c  ! Teraz liczymy RD
32040       OdivT = 0.0d0
32041       OdivR = 0.0d0
32042       do j=1,neatoms
32043         if (ho(j) .ne. 0) then
32044            ot_one = ho(j) * log(ho(j)/ht(j)) / log(2.0d0)
32045            OdivT  = OdivT + ot_one
32046            or_one = ho(j) * log(ho(j)/ (1.0d0/neatoms)) / log(2.0_8)
32047            OdivR  = OdivR + or_one
32048         endif
32049       end do
32050       RD_classic = OdivT / (OdivT+OdivR)
32051       compute_rd = RD_classic
32052       return
32053       end function
32054       function hydrophobicity(id)  ! do przepisania (bylo: identyfikowanie aa po nazwach)
32055       integer id
32056       double precision hydrophobicity
32057       hydrophobicity = 0.0d0
32058       if (id .eq. 1) then
32059          hydrophobicity = 1.000d0  ! CYS
32060          return
32061       endif
32062       if (id .eq. 2) then
32063          hydrophobicity = 0.828d0  ! MET
32064          return
32065       endif
32066       if (id .eq. 3) then
32067          hydrophobicity = 0.906d0  ! PHE
32068          return
32069       endif
32070       if (id .eq. 4) then
32071          hydrophobicity = 0.883d0  ! ILE
32072          return
32073       endif
32074       if (id .eq. 5) then
32075          hydrophobicity = 0.783d0  ! LEU
32076          return
32077       endif
32078       if (id .eq. 6) then
32079          hydrophobicity = 0.811d0  ! VAL
32080          return
32081       endif
32082       if (id .eq. 7) then
32083          hydrophobicity = 0.856d0  ! TRP
32084          return
32085       endif
32086       if (id .eq. 8) then
32087          hydrophobicity = 0.700d0  ! TYR
32088          return
32089       endif
32090       if (id .eq. 9) then
32091          hydrophobicity = 0.572d0  ! ALA
32092          return
32093       endif
32094       if (id .eq. 10) then
32095          hydrophobicity = 0.550d0  ! GLY
32096          return
32097       endif
32098       if (id .eq. 11) then
32099          hydrophobicity = 0.478d0  ! THR
32100          return
32101       endif
32102       if (id .eq. 12) then
32103          hydrophobicity = 0.422d0  ! SER
32104          return
32105       endif
32106       if (id .eq. 13) then
32107          hydrophobicity = 0.250d0  ! GLN
32108          return
32109       endif
32110       if (id .eq. 14) then
32111          hydrophobicity = 0.278d0  ! ASN
32112          return
32113       endif
32114       if (id .eq. 15) then
32115          hydrophobicity = 0.083d0  ! GLU
32116          return
32117       endif
32118       if (id .eq. 16) then
32119          hydrophobicity = 0.167d0  ! ASP
32120          return
32121       endif
32122       if (id .eq. 17) then
32123          hydrophobicity = 0.628d0  ! HIS
32124          return
32125       endif
32126       if (id .eq. 18) then
32127          hydrophobicity = 0.272d0  ! ARG
32128          return
32129       endif
32130       if (id .eq. 19) then
32131          hydrophobicity = 0.000d0  ! LYS
32132          return
32133       endif
32134       if (id .eq. 20) then
32135          hydrophobicity = 0.300d0  ! PRO
32136          return
32137       endif
32138       return
32139       end function hydrophobicity
32140       subroutine mycrossprod(res,b,c)
32141         implicit none
32142         double precision, intent(out) ::  res(3)
32143         double precision, intent(in)  ::  b(3)
32144         double precision, intent(in)  ::  c(3)
32145 !c       ! Tylko dla wektorów trójwymiarowych, ale nie sprawdzamy tego tutaj
32146         res(1) = b(2)*c(3)-b(3)*c(2)
32147         res(2) = b(3)*c(1)-b(1)*c(3)
32148         res(3) = b(1)*c(2)-b(2)*c(1)
32149       return
32150       end subroutine
32151       subroutine mydotprod(res,b,c)
32152         implicit none
32153         double precision, intent(out) ::  res
32154         double precision, intent(in)  ::  b(3)
32155         double precision, intent(in)  ::  c(3)
32156 !c    ! Tylko dla wektorów trójwymiarowych, ale nie sprawdzamy tego tutaj
32157         res = b(1)*c(1)+b(2)*c(2)+b(3)*c(3)
32158        return
32159       end subroutine
32160 !c ! cosinus k¹ta miêdzy wektorami trójwymiarowymi
32161       subroutine cosfi(res, x, y)
32162         implicit none
32163         double precision, intent(out) ::  res
32164         double precision, intent(in)  ::  x(3)
32165         double precision, intent(in)  ::  y(3)
32166         double precision LxLy
32167         LxLy=sqrt(x(1)*x(1)+x(2)*x(2)+x(3)*x(3)) *&
32168             sqrt(y(1)*y(1)+y(2)*y(2)+y(3)*y(3))
32169         if (LxLy==0.0) then
32170           res = 0.0d0
32171         else
32172           call mydotprod(res,x,y)
32173           res = res / LxLy
32174         end if
32175       return
32176       end subroutine
32177
32178
32179       subroutine Dist3d(res,v1,v2)
32180         implicit none
32181         double precision, intent(out) ::  res
32182         double precision, intent(in)  ::  v1(3)
32183         double precision, intent(in)  ::  v2(3)
32184 !        double precision sq
32185         res = sqrt( sq(v1(1)-v2(1)) + sq(v1(2)-v2(2)) + sq(v1(3)-v2(3)))
32186       return
32187       end subroutine
32188 !c ! Przeksztalca wsp. 3d uzywajac macierzy przeksztalcenia M (4x4)
32189       subroutine tranform_point(res,v3d,M)
32190         implicit none
32191         double precision, intent(out) ::  res(3)
32192         double precision, intent(in)  ::  v3d(3)
32193         double precision, intent(in)  ::  M(4,4)
32194
32195         res(1) = M(1,1)*v3d(1) + M(1,2)*v3d(2) + M(1,3)*v3d(3) + M(1,4)
32196         res(2) = M(2,1)*v3d(1) + M(2,2)*v3d(2) + M(2,3)*v3d(3) + M(2,4)
32197         res(3) = M(3,1)*v3d(1) + M(3,2)*v3d(2) + M(3,3)*v3d(3) + M(3,4)
32198       return
32199       end subroutine
32200 !c ! TranslateV: macierz translacji o wektor V
32201       subroutine TranslateV(res,V)
32202         implicit none
32203         double precision, intent(out) ::  res(4,4)
32204         double precision, intent(in)  ::  v(3)
32205         res(1,1) = 1.0d0
32206         res(1,2) = 0
32207         res(1,3) = 0
32208         res(1,4) = v(1)
32209         res(2,1) = 0
32210         res(2,2) = 1.0d0
32211         res(2,3) = 0
32212         res(2,4) = v(2)
32213         res(3,1) = 0
32214         res(3,2) = 0
32215         res(3,3) = 1.0d0
32216         res(3,4) = v(3)
32217         res(4,1) = 0
32218         res(4,2) = 0
32219         res(4,3) = 0
32220         res(4,4) = 1.0d0
32221       return
32222       end subroutine
32223 !c ! RotateX: macierz obrotu wokol osi OX o kat fi
32224       subroutine RotateX(res,fi)
32225         implicit none
32226         double precision, intent(out) ::  res(4,4)
32227         double precision, intent(in)  ::  fi
32228         res(1,1) = 1.0d0
32229         res(1,2) = 0
32230         res(1,3) = 0
32231         res(1,4) = 0
32232         res(2,1) = 0
32233         res(2,2) = cos(fi)
32234         res(2,3) = -sin(fi)
32235         res(2,4) = 0
32236         res(3,1) = 0
32237         res(3,2) = sin(fi)
32238         res(3,3) = cos(fi)
32239         res(3,4) = 0
32240         res(4,1) = 0
32241         res(4,2) = 0
32242         res(4,3) = 0
32243         res(4,4) = 1.0d0
32244       return
32245       end subroutine
32246 !c ! RotateY: macierz obrotu wokol osi OY o kat fi
32247       subroutine RotateY(res,fi)
32248         implicit none
32249         double precision, intent(out) ::  res(4,4)
32250         double precision, intent(in)  ::  fi
32251         res(1,1) = cos(fi)
32252         res(1,2) = 0
32253         res(1,3) = sin(fi)
32254         res(1,4) = 0
32255         res(2,1) = 0
32256         res(2,2) = 1.0d0
32257         res(2,3) = 0
32258         res(2,4) = 0
32259         res(3,1) = -sin(fi)
32260         res(3,2) = 0
32261         res(3,3) = cos(fi)
32262         res(3,4) = 0
32263         res(4,1) = 0
32264         res(4,2) = 0
32265         res(4,3) = 0
32266         res(4,4) = 1.0d0
32267       return
32268       end subroutine
32269 !c ! RotateZ: macierz obrotu wokol osi OZ o kat fi
32270       subroutine RotateZ(res,fi)
32271         implicit none
32272         double precision, intent(out) ::  res(4,4)
32273         double precision, intent(in)  ::  fi
32274         res(1,1) = cos(fi)
32275         res(1,2) = -sin(fi)
32276         res(1,3) = 0
32277         res(1,4) = 0
32278         res(2,1) = sin(fi)
32279         res(2,2) = cos(fi)
32280         res(2,3) = 0
32281         res(2,4) = 0
32282         res(3,1) = 0
32283         res(3,2) = 0
32284         res(3,3) = 1.0d0
32285         res(3,4) = 0
32286         res(4,1) = 0
32287         res(4,2) = 0
32288         res(4,3) = 0
32289         res(4,4) = 1.0d0
32290       return
32291       end subroutine
32292 !c ! IdentityM
32293       subroutine IdentityM(res)
32294         implicit none
32295         double precision, intent(out) ::  res(4,4)
32296         res(1,1) = 1.0d0
32297         res(1,2) = 0
32298         res(1,3) = 0
32299         res(1,4) = 0
32300         res(2,1) = 0
32301         res(2,2) = 1.0d0
32302         res(2,3) = 0
32303         res(2,4) = 0
32304         res(3,1) = 0
32305         res(3,2) = 0
32306         res(3,3) = 1.0d0
32307         res(3,4) = 0
32308         res(4,1) = 0
32309         res(4,2) = 0
32310         res(4,3) = 0
32311         res(4,4) = 1.0d0
32312       return
32313       end subroutine
32314       double precision function sq(x)
32315         double precision x
32316         sq = x*x
32317       return
32318       end function sq
32319
32320 #ifdef LBFGS
32321       double precision function funcgrad(x,g)
32322       use MD_data, only: totT,usampl
32323       implicit none
32324       double precision energia(0:n_ene)
32325       double precision x(nvar),g(nvar)
32326       integer i
32327       call var_to_geom(nvar,x)
32328       call zerograd
32329       call chainbuild
32330       call etotal(energia(0))
32331       call sum_gradient
32332       funcgrad=energia(0)
32333       call cart2intgrad(nvar,g)
32334       if (usampl) then
32335          do i=1,nres-3
32336            gloc(i,icg)=gloc(i,icg)+dugamma(i)
32337          enddo
32338          do i=1,nres-2
32339            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
32340          enddo
32341       endif
32342       do i=1,nvar
32343         g(i)=g(i)+gloc(i,icg)
32344       enddo
32345       return
32346       end function funcgrad
32347       subroutine cart2intgrad(n,g)
32348       integer n
32349       double precision g(n)
32350       double precision drt(3,3,nres),rdt(3,3,nres),dp(3,3),&
32351       temp(3,3),prordt(3,3,nres),prodrt(3,3,nres)
32352       double precision xx(3),xx1(3),alphi,omegi,xj,dpjk,yp,xp,xxp,yyp
32353       double precision cosalphi,sinalphi,cosomegi,sinomegi,theta2,&
32354        cost2,sint2,rj,dxoiij,tempkl,dxoijk,dsci,zzp,dj,dpkl
32355       double precision fromto(3,3),aux(6)
32356       integer i,ii,j,jjj,k,l,m,indi,ind,ind1
32357        logical sideonly
32358       sideonly=.false.
32359       g=0.0d0
32360       if (sideonly) goto 10
32361       do i=1,nres-2
32362         rdt(1,1,i)=-rt(1,2,i)
32363         rdt(1,2,i)= rt(1,1,i)
32364         rdt(1,3,i)= 0.0d0
32365         rdt(2,1,i)=-rt(2,2,i)
32366         rdt(2,2,i)= rt(2,1,i)
32367         rdt(2,3,i)= 0.0d0
32368         rdt(3,1,i)=-rt(3,2,i)
32369         rdt(3,2,i)= rt(3,1,i)
32370         rdt(3,3,i)= 0.0d0
32371       enddo
32372       do i=2,nres-2
32373         drt(1,1,i)= 0.0d0
32374         drt(1,2,i)= 0.0d0
32375         drt(1,3,i)= 0.0d0
32376         drt(2,1,i)= rt(3,1,i)
32377         drt(2,2,i)= rt(3,2,i)
32378         drt(2,3,i)= rt(3,3,i)
32379         drt(3,1,i)=-rt(2,1,i)
32380         drt(3,2,i)=-rt(2,2,i)
32381         drt(3,3,i)=-rt(2,3,i)
32382       enddo
32383       ind1=0
32384       do i=1,nres-2
32385         ind1=ind1+1
32386         if (n.gt.nphi) then
32387
32388         do j=1,3
32389           do k=1,2
32390             dpjk=0.0D0
32391             do l=1,3
32392               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
32393             enddo
32394             dp(j,k)=dpjk
32395             prordt(j,k,i)=dp(j,k)
32396           enddo
32397           dp(j,3)=0.0D0
32398           g(nphi+i)=g(nphi+i)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg)
32399         enddo
32400         xx1(1)=-0.5D0*xloc(2,i+1)
32401         xx1(2)= 0.5D0*xloc(1,i+1)
32402         do j=1,3
32403           xj=0.0D0
32404           do k=1,2
32405             xj=xj+r(j,k,i)*xx1(k)
32406           enddo
32407           xx(j)=xj
32408         enddo
32409         do j=1,3
32410           rj=0.0D0
32411           do k=1,3
32412             rj=rj+prod(j,k,i)*xx(k)
32413           enddo
32414           g(nphi+i)=g(nphi+i)+rj*gradx(j,i+1,icg)
32415         enddo
32416         if (i.lt.nres-2) then
32417         do j=1,3
32418           dxoiij=0.0D0
32419           do k=1,3
32420             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
32421           enddo
32422           g(nphi+i)=g(nphi+i)+dxoiij*gradx(j,i+2,icg)
32423         enddo
32424         endif
32425
32426         endif
32427
32428
32429         if (i.gt.1) then
32430         do j=1,3
32431           do k=1,3
32432             dpjk=0.0
32433             do l=2,3
32434               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
32435             enddo
32436             dp(j,k)=dpjk
32437             prodrt(j,k,i)=dp(j,k)
32438           enddo
32439           g(i-1)=g(i-1)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg)
32440         enddo
32441         endif
32442         xx(1)= 0.0D0
32443         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
32444         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
32445         if (i.gt.1) then
32446         do j=1,3
32447           rj=0.0D0
32448           do k=2,3
32449             rj=rj+prod(j,k,i)*xx(k)
32450           enddo
32451           g(i-1)=g(i-1)-rj*gradx(j,i+1,icg)
32452         enddo
32453         endif
32454         if (i.gt.1) then
32455         do j=1,3
32456           dxoiij=0.0D0
32457           do k=1,3
32458             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
32459           enddo
32460           g(i-1)=g(i-1)+dxoiij*gradx(j,i+2,icg)
32461         enddo
32462         endif
32463         do j=i+1,nres-2
32464           ind1=ind1+1
32465           call build_fromto(i+1,j+1,fromto)
32466           do k=1,3
32467             do l=1,3
32468               tempkl=0.0D0
32469               do m=1,2
32470                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l)
32471               enddo
32472               temp(k,l)=tempkl
32473             enddo
32474           enddo
32475           if (n.gt.nphi) then
32476           do k=1,3
32477             g(nphi+i)=g(nphi+i)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg)
32478           enddo
32479           do k=1,3
32480             dxoijk=0.0D0
32481             do l=1,3
32482               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
32483             enddo
32484             g(nphi+i)=g(nphi+i)+dxoijk*gradx(k,j+2,icg)
32485           enddo
32486           endif
32487           do k=1,3
32488             do l=1,3
32489               tempkl=0.0D0
32490               do m=1,3
32491                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l)
32492               enddo
32493               temp(k,l)=tempkl
32494             enddo
32495           enddo
32496           if (i.gt.1) then
32497           do k=1,3
32498             g(i-1)=g(i-1)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg)
32499           enddo
32500           do k=1,3
32501             dxoijk=0.0D0
32502             do l=1,3
32503               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
32504             enddo
32505             g(i-1)=g(i-1)+dxoijk*gradx(k,j+2,icg)
32506           enddo
32507           endif
32508         enddo
32509       enddo
32510
32511       if (nvar.le.nphi+ntheta) return
32512
32513    10 continue
32514       do i=2,nres-1
32515         if (iabs(itype(i,1)).eq.10 .or. itype(i,1).eq.ntyp1& !) cycle
32516          .or. mask_side(i).eq.0 ) cycle
32517         ii=ialph(i,1)
32518         dsci=vbld(i+nres)
32519 #ifdef OSF
32520         alphi=alph(i)
32521         omegi=omeg(i)
32522         if(alphi.ne.alphi) alphi=100.0
32523         if(omegi.ne.omegi) omegi=-100.0
32524 #else
32525         alphi=alph(i)
32526         omegi=omeg(i)
32527 #endif
32528         cosalphi=dcos(alphi)
32529         sinalphi=dsin(alphi)
32530         cosomegi=dcos(omegi)
32531         sinomegi=dsin(omegi)
32532         temp(1,1)=-dsci*sinalphi
32533         temp(2,1)= dsci*cosalphi*cosomegi
32534         temp(3,1)=-dsci*cosalphi*sinomegi
32535         temp(1,2)=0.0D0
32536         temp(2,2)=-dsci*sinalphi*sinomegi
32537         temp(3,2)=-dsci*sinalphi*cosomegi
32538         theta2=pi-0.5D0*theta(i+1)
32539         cost2=dcos(theta2)
32540         sint2=dsin(theta2)
32541         jjj=0
32542         do j=1,2
32543           xp=temp(1,j)
32544           yp=temp(2,j)
32545           xxp= xp*cost2+yp*sint2
32546           yyp=-xp*sint2+yp*cost2
32547           zzp=temp(3,j)
32548           xx(1)=xxp
32549           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
32550           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
32551           do k=1,3
32552             dj=0.0D0
32553             do l=1,3
32554               dj=dj+prod(k,l,i-1)*xx(l)
32555             enddo
32556             aux(jjj+k)=dj
32557           enddo
32558           jjj=jjj+3
32559         enddo
32560         do k=1,3
32561           g(ii)=g(ii)+aux(k)*gradx(k,i,icg)
32562           g(ii+nside)=g(ii+nside)+aux(k+3)*gradx(k,i,icg)
32563         enddo
32564       enddo
32565       return
32566       end subroutine cart2intgrad
32567
32568
32569 #endif
32570 !--------------------------------------------------------------------------
32571       end module energy