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), &
 268       grad_shield_locbuf1(3*maxcontsshi*nres), &
 269       grad_shield_sidebuf1(3*maxcontsshi*nres), &
 270       grad_shield_locbuf2(3*maxcontsshi*nres), &
 271       grad_shield_sidebuf2(3*maxcontsshi*nres), &
 272       grad_shieldbuf1(3*nres), &
 273       grad_shieldbuf2(3*nres)
 274
 275        integer ishield_listbuf(-1:nres), &
 276        shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj
 277 !       print *,"I START ENERGY"
 278        imatupdate=100
 279 !       if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 280 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 281 !      real(kind=8), dimension(:,:,:),allocatable:: &
 282 !       grad_shield_locbuf,grad_shield_sidebuf
 283 !      real(kind=8), dimension(:,:),allocatable:: &
 284 !        grad_shieldbuf
 285 !       integer, dimension(:),allocatable:: &
 286 !       ishield_listbuf
 287 !       integer, dimension(:,:),allocatable::  shield_listbuf
 288 !       integer :: k,j,i
 289 !      if (.not.allocated(fac_shieldbuf)) then
 290 !          allocate(fac_shieldbuf(nres))
 291 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 292 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 293 !          allocate(grad_shieldbuf(3,-1:nres))
 294 !          allocate(ishield_listbuf(nres))
 295 !          allocate(shield_listbuf(maxcontsshi,nres))
 296 !       endif
 297 !       print *,"wstrain check", wstrain
 298 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 299 !     & " nfgtasks",nfgtasks
 300       if (nfgtasks.gt.1) then
 301         time00=MPI_Wtime()
 302 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 303         if (fg_rank.eq.0) then
 304           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 305 !          print *,"Processor",myrank," BROADCAST iorder"
 306 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 307 ! FG slaves as WEIGHTS array.
 308           weights_(1)=wsc
 309           weights_(2)=wscp
 310           weights_(3)=welec
 311           weights_(4)=wcorr
 312           weights_(5)=wcorr5
 313           weights_(6)=wcorr6
 314           weights_(7)=wel_loc
 315           weights_(8)=wturn3
 316           weights_(9)=wturn4
 317           weights_(10)=wturn6
 318           weights_(11)=wang
 319           weights_(12)=wscloc
 320           weights_(13)=wtor
 321           weights_(14)=wtor_d
 322           weights_(15)=wstrain
 323           weights_(16)=wvdwpp
 324           weights_(17)=wbond
 325           weights_(18)=scal14
 326           weights_(21)=wsccor
 327           weights_(26)=wvdwpp_nucl
 328           weights_(27)=welpp
 329           weights_(28)=wvdwpsb
 330           weights_(29)=welpsb
 331           weights_(30)=wvdwsb
 332           weights_(31)=welsb
 333           weights_(32)=wbond_nucl
 334           weights_(33)=wang_nucl
 335           weights_(34)=wsbloc
 336           weights_(35)=wtor_nucl
 337           weights_(36)=wtor_d_nucl
 338           weights_(37)=wcorr_nucl
 339           weights_(38)=wcorr3_nucl
 340           weights_(41)=wcatcat
 341           weights_(42)=wcatprot
 342           weights_(46)=wscbase
 343           weights_(47)=wpepbase
 344           weights_(48)=wscpho
 345           weights_(49)=wpeppho
 346           weights_(50)=wcatnucl
 347           weights_(56)=wcat_tran
 348
 349 !          wcatcat= weights(41)
 350 !          wcatprot=weights(42)
 351
 352 ! FG Master broadcasts the WEIGHTS_ array
 353           call MPI_Bcast(weights_(1),n_ene,&
 354              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 355         else
 356 ! FG slaves receive the WEIGHTS array
 357           call MPI_Bcast(weights(1),n_ene,&
 358               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 359           wsc=weights(1)
 360           wscp=weights(2)
 361           welec=weights(3)
 362           wcorr=weights(4)
 363           wcorr5=weights(5)
 364           wcorr6=weights(6)
 365           wel_loc=weights(7)
 366           wturn3=weights(8)
 367           wturn4=weights(9)
 368           wturn6=weights(10)
 369           wang=weights(11)
 370           wscloc=weights(12)
 371           wtor=weights(13)
 372           wtor_d=weights(14)
 373           wstrain=weights(15)
 374           wvdwpp=weights(16)
 375           wbond=weights(17)
 376           scal14=weights(18)
 377           wsccor=weights(21)
 378           wvdwpp_nucl =weights(26)
 379           welpp  =weights(27)
 380           wvdwpsb=weights(28)
 381           welpsb =weights(29)
 382           wvdwsb =weights(30)
 383           welsb  =weights(31)
 384           wbond_nucl  =weights(32)
 385           wang_nucl   =weights(33)
 386           wsbloc =weights(34)
 387           wtor_nucl   =weights(35)
 388           wtor_d_nucl =weights(36)
 389           wcorr_nucl  =weights(37)
 390           wcorr3_nucl =weights(38)
 391           wcatcat= weights(41)
 392           wcatprot=weights(42)
 393           wscbase=weights(46)
 394           wpepbase=weights(47)
 395           wscpho=weights(48)
 396           wpeppho=weights(49)
 397           wcatnucl=weights(50)
 398           wcat_tran=weights(56)
 399
 400 !      welpsb=weights(28)*fact(1)
 401 !
 402 !      wcorr_nucl= weights(37)*fact(1)
 403 !     wcorr3_nucl=weights(38)*fact(2)
 404 !     wtor_nucl=  weights(35)*fact(1)
 405 !     wtor_d_nucl=weights(36)*fact(2)
 406
 407         endif
 408         time_Bcast=time_Bcast+MPI_Wtime()-time00
 409         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 410 !        call chainbuild_cart
 411       endif
 412 !       print *,"itime_mat",itime_mat,imatupdate
 413         if (nfgtasks.gt.1) then
 414         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 415         endif
 416        if (nres_molec(1).gt.0) then
 417        if (mod(itime_mat,imatupdate).eq.0) call make_SCp_inter_list
 418 !       write (iout,*) "after make_SCp_inter_list"
 419        if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 420 !       write (iout,*) "after make_SCSC_inter_list"
 421
 422        if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list
 423        if (nres_molec(5).gt.0) then
 424        if (mod(itime_mat,imatupdate).eq.0) then
 425 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 426         call  make_cat_pep_list
 427        endif
 428        endif
 429        endif
 430 !       write (iout,*) "after make_pp_inter_list"
 431
 432 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 433 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 434 #else
 435 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 436 !        call int_from_cart1(.false.)
 437 !      endif
 438 #endif
 439 #ifdef TIMING
 440       time00=MPI_Wtime()
 441 #endif
 442 !
 443 ! Compute the side-chain and electrostatic interaction energy
 444 !        print *, "Before EVDW"
 445 !      goto (101,102,103,104,105,106) ipot
 446       if (nres_molec(1).gt.0) then
 447       select case(ipot)
 448 ! Lennard-Jones potential.
 449 !  101 call elj(evdw)
 450        case (1)
 451          call elj(evdw)
 452 !d    print '(a)','Exit ELJcall el'
 453 !      goto 107
 454 ! Lennard-Jones-Kihara potential (shifted).
 455 !  102 call eljk(evdw)
 456        case (2)
 457          call eljk(evdw)
 458 !      goto 107
 459 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 460 !  103 call ebp(evdw)
 461        case (3)
 462          call ebp(evdw)
 463 !      goto 107
 464 ! Gay-Berne potential (shifted LJ, angular dependence).
 465 !  104 call egb(evdw)
 466        case (4)
 467 !       print *,"MOMO",scelemode
 468         if (scelemode.eq.0) then
 469          call egb(evdw)
 470         else
 471          call emomo(evdw)
 472         endif
 473 !      goto 107
 474 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 475 !  105 call egbv(evdw)
 476        case (5)
 477          call egbv(evdw)
 478 !      goto 107
 479 ! Soft-sphere potential
 480 !  106 call e_softsphere(evdw)
 481        case (6)
 482          call e_softsphere(evdw)
 483 !
 484 ! Calculate electrostatic (H-bonding) energy of the main chain.
 485 !
 486 !  107 continue
 487        case default
 488          write(iout,*)"Wrong ipot"
 489 !         return
 490 !   50 continue
 491       end select
 492 !      continue
 493 !        print *,"after EGB"
 494 ! shielding effect
 495        if (shield_mode.eq.2) then
 496                  call set_shield_fac2
 497
 498       if (nfgtasks.gt.1) then
 499       grad_shield_sidebuf1(:)=0.0d0
 500       grad_shield_locbuf1(:)=0.0d0
 501       grad_shield_sidebuf2(:)=0.0d0
 502       grad_shield_locbuf2(:)=0.0d0
 503       grad_shieldbuf1(:)=0.0d0
 504       grad_shieldbuf2(:)=0.0d0
 505 !#define DEBUG
 506 #ifdef DEBUG
 507        write(iout,*) "befor reduce fac_shield reduce"
 508        do i=1,nres
 509         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 510         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 511        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 512        enddo
 513 #endif
 514         iii=0
 515         jjj=0
 516         do i=1,nres
 517         ishield_listbuf(i)=0
 518         do k=1,3
 519         iii=iii+1
 520         grad_shieldbuf1(iii)=grad_shield(k,i)
 521         enddo
 522         enddo
 523         do i=1,nres
 524          do j=1,maxcontsshi
 525           do k=1,3
 526               jjj=jjj+1
 527               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 528               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 529            enddo
 530           enddo
 531          enddo
 532         call MPI_Allgatherv(fac_shield(ivec_start), &
 533         ivec_count(fg_rank1), &
 534         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 535         ivec_displ(0), &
 536         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 537         call MPI_Allgatherv(shield_list(1,ivec_start), &
 538         ivec_count(fg_rank1), &
 539         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 540         ivec_displ(0), &
 541         MPI_I50,FG_COMM,IERROR)
 542 !        write(2,*) "After I50"
 543 !        call flush(iout)
 544         call MPI_Allgatherv(ishield_list(ivec_start), &
 545         ivec_count(fg_rank1), &
 546         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 547         ivec_displ(0), &
 548         MPI_INTEGER,FG_COMM,IERROR)
 549 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 550
 551 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 552 !        write (2,*) "before"
 553 !        write(2,*) grad_shieldbuf1
 554 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 555 !        ivec_count(fg_rank1)*3, &
 556 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 557 !        ivec_count(0), &
 558 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 559         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 560         nres*3, &
 561         MPI_DOUBLE_PRECISION, &
 562         MPI_SUM, &
 563         FG_COMM,IERROR)
 564         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 565         nres*3*maxcontsshi, &
 566         MPI_DOUBLE_PRECISION, &
 567         MPI_SUM, &
 568         FG_COMM,IERROR)
 569
 570         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 571         nres*3*maxcontsshi, &
 572         MPI_DOUBLE_PRECISION, &
 573         MPI_SUM, &
 574         FG_COMM,IERROR)
 575
 576 !        write(2,*) "after"
 577 !        write(2,*) grad_shieldbuf2
 578
 579 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 580 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 581 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 582 !        ivec_displ(0)*3*maxcontsshi, &
 583 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 584 !        write(2,*) "After grad_shield_side"
 585 !        call flush(iout)
 586 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 587 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 588 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 589 !        ivec_displ(0)*3*maxcontsshi, &
 590 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 591 !        write(2,*) "After MPI_SHI"
 592 !        call flush(iout)
 593         iii=0
 594         jjj=0
 595         do i=1,nres
 596          fac_shield(i)=fac_shieldbuf(i)
 597          ishield_list(i)=ishield_listbuf(i)
 598 !         write(iout,*) i,fac_shield(i)
 599          do j=1,3
 600          iii=iii+1
 601          grad_shield(j,i)=grad_shieldbuf2(iii)
 602          enddo !j
 603          do j=1,ishield_list(i)
 604 !          write (iout,*) "ishild", ishield_list(i),i
 605            shield_list(j,i)=shield_listbuf(j,i)
 606           enddo
 607           do j=1,maxcontsshi
 608           do k=1,3
 609            jjj=jjj+1
 610           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 611           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 612           enddo !k
 613         enddo !j
 614        enddo !i
 615        endif
 616 #ifdef DEBUG
 617        write(iout,*) "after reduce fac_shield reduce"
 618        do i=1,nres
 619         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 620         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 621         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 622        enddo
 623 #endif
 624 #undef DEBUG
 625        endif
 626
 627
 628
 629 !       print *,"AFTER EGB",ipot,evdw
 630 !mc
 631 !mc Sep-06: egb takes care of dynamic ss bonds too
 632 !mc
 633 !      if (dyn_ss) call dyn_set_nss
 634 !      print *,"Processor",myrank," computed USCSC"
 635 #ifdef TIMING
 636       time01=MPI_Wtime()
 637 #endif
 638       call vec_and_deriv
 639 #ifdef TIMING
 640       time_vec=time_vec+MPI_Wtime()-time01
 641 #endif
 642
 643
 644
 645
 646 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 647       if (ipot.lt.6) then
 648 #ifdef SPLITELE
 649 !         print *,"after ipot if", ipot
 650          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 651              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 652              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 653              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 654 #else
 655          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 656              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 657              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 658              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 659 #endif
 660 !            print *,"just befor eelec call"
 661             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 662 !            print *, "ELEC calc"
 663          else
 664             ees=0.0d0
 665             evdw1=0.0d0
 666             eel_loc=0.0d0
 667             eello_turn3=0.0d0
 668             eello_turn4=0.0d0
 669          endif
 670       else
 671 !        write (iout,*) "Soft-spheer ELEC potential"
 672         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 673          eello_turn4)
 674       endif
 675 !      print *,"Processor",myrank," computed UELEC"
 676 !
 677 ! Calculate excluded-volume interaction energy between peptide groups
 678 ! and side chains.
 679 !
 680 !       write(iout,*) "in etotal calc exc;luded",ipot
 681
 682       if (ipot.lt.6) then
 683        if(wscp.gt.0d0) then
 684         call escp(evdw2,evdw2_14)
 685        else
 686         evdw2=0
 687         evdw2_14=0
 688        endif
 689       else
 690 !        write (iout,*) "Soft-sphere SCP potential"
 691         call escp_soft_sphere(evdw2,evdw2_14)
 692       endif
 693 !        write(iout,*) "in etotal before ebond",ipot
 694 !      print *,"after escp"
 695 !
 696 ! Calculate the bond-stretching energy
 697 !
 698       call ebond(estr)
 699 !       print *,"EBOND",estr
 700 !       write(iout,*) "in etotal afer ebond",ipot
 701
 702 !
 703 ! Calculate the disulfide-bridge and other energy and the contributions
 704 ! from other distance constraints.
 705 !      print *,'Calling EHPB'
 706 !      call edis(ehpb)
 707 !elwrite(iout,*) "in etotal afer edis",ipot
 708 !      print *,'EHPB exitted succesfully.'
 709 !
 710 ! Calculate the virtual-bond-angle energy.
 711 !       write(iout,*) "in etotal afer edis",ipot
 712
 713 !      if (wang.gt.0.0d0) then
 714 !        call ebend(ebe,ethetacnstr)
 715 !      else
 716 !        ebe=0
 717 !        ethetacnstr=0
 718 !      endif
 719       if (wang.gt.0d0) then
 720        if (tor_mode.eq.0) then
 721          call ebend(ebe)
 722        else
 723 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 724 !C energy function
 725          call ebend_kcc(ebe)
 726        endif
 727       else
 728         ebe=0.0d0
 729       endif
 730       ethetacnstr=0.0d0
 731 !      write(iout,*) with_theta_constr,"with_theta_constr"
 732       if (with_theta_constr) call etheta_constr(ethetacnstr)
 733
 734 !       write(iout,*) "in etotal afer ebe",ipot
 735
 736 !      print *,"Processor",myrank," computed UB"
 737 !
 738 ! Calculate the SC local energy.
 739 !
 740       call esc(escloc)
 741 !      print *, "in etotal afer esc",wtor
 742 !      print *,"Processor",myrank," computed USC"
 743 !
 744 ! Calculate the virtual-bond torsional energy.
 745 !
 746 !d    print *,'nterm=',nterm
 747 !      if (wtor.gt.0) then
 748 !       call etor(etors,edihcnstr)
 749 !      else
 750 !       etors=0
 751 !       edihcnstr=0
 752 !      endif
 753       if (wtor.gt.0.0d0) then
 754 !         print *,"WTOR",wtor,tor_mode
 755          if (tor_mode.eq.0) then
 756            call etor(etors)
 757          else
 758 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 759 !C energy function
 760            call etor_kcc(etors)
 761          endif
 762       else
 763         etors=0.0d0
 764       endif
 765       edihcnstr=0.0d0
 766       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 767 !c      print *,"Processor",myrank," computed Utor"
 768
 769 !       print *, "constr_homol",constr_homology
 770 !      print *,"Processor",myrank," computed Utor"
 771       if (constr_homology.ge.1) then
 772         call e_modeller(ehomology_constr)
 773 !        print *,'iset=',iset,'me=',me,ehomology_constr,
 774 !     &  'Processor',fg_rank,' CG group',kolor,
 775 !     &  ' absolute rank',MyRank
 776 !       print *,"tu"
 777       else
 778         ehomology_constr=0.0d0
 779       endif
 780
 781 !
 782 ! 6/23/01 Calculate double-torsional energy
 783 !
 784 !      print *, "before etor_d",wtor_d
 785       if (wtor_d.gt.0) then
 786        call etor_d(etors_d)
 787       else
 788        etors_d=0
 789       endif
 790 !      print *,"Processor",myrank," computed Utord"
 791 !
 792 ! 21/5/07 Calculate local sicdechain correlation energy
 793 !
 794       if (wsccor.gt.0.0d0) then
 795         call eback_sc_corr(esccor)
 796       else
 797         esccor=0.0d0
 798       endif
 799
 800 !      write(iout,*) "before multibody"
 801       call flush(iout)
 802 !      print *,"Processor",myrank," computed Usccorr"
 803 !
 804 ! 12/1/95 Multi-body terms
 805 !
 806       n_corr=0
 807       n_corr1=0
 808       call flush(iout)
 809       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 810           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 811          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 812 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 813 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 814       else
 815          ecorr=0.0d0
 816          ecorr5=0.0d0
 817          ecorr6=0.0d0
 818          eturn6=0.0d0
 819       endif
 820 !elwrite(iout,*) "in etotal",ipot
 821       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 822          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 823 !d         write (iout,*) "multibody_hb ecorr",ecorr
 824       endif
 825 !      write(iout,*) "afeter  multibody hb"
 826
 827 !      print *,"Processor",myrank," computed Ucorr"
 828 !
 829 ! If performing constraint dynamics, call the constraint energy
 830 !  after the equilibration time
 831       if((usampl).and.(totT.gt.eq_time)) then
 832         write(iout,*) "usampl",usampl
 833          call EconstrQ
 834 !elwrite(iout,*) "afeter  multibody hb"
 835          call Econstr_back
 836 !elwrite(iout,*) "afeter  multibody hb"
 837       else
 838          Uconst=0.0d0
 839          Uconst_back=0.0d0
 840       endif
 841       call flush(iout)
 842 !         write(iout,*) "after Econstr"
 843
 844       if (wliptran.gt.0) then
 845 !        print *,"PRZED WYWOLANIEM"
 846         call Eliptransfer(eliptran)
 847       else
 848        eliptran=0.0d0
 849       endif
 850       else
 851       eliptran=0.0d0
 852       evdw=0.0d0
 853 #ifdef SCP14
 854       evdw2=0.0d0
 855       evdw2_14=0.0d0
 856 #else
 857       evdw2=0.0d0
 858 #endif
 859 #ifdef SPLITELE
 860       ees=0.0d0
 861       evdw1=0.0d0
 862 #else
 863       ees=0.0d0
 864       evdw1=0.0d0
 865 #endif
 866       ecorr=0.0d0
 867       ecorr5=0.0d0
 868       ecorr6=0.0d0
 869       eel_loc=0.0d0
 870       eello_turn3=0.0d0
 871       eello_turn4=0.0d0
 872       eturn6=0.0d0
 873       ebe=0.0d0
 874       escloc=0.0d0
 875       etors=0.0d0
 876       etors_d=0.0d0
 877       ehpb=0.0d0
 878       edihcnstr=0.0d0
 879       estr=0.0d0
 880       Uconst=0.0d0
 881       esccor=0.0d0
 882       ehomology_constr=0.0d0
 883       ethetacnstr=0.0d0
 884       endif !nres_molec(1)
 885 !      write(iout,*) "TU JEST PRZED EHPB"
 886 !      call edis(ehpb)
 887       if (fg_rank.eq.0) then
 888       if (AFMlog.gt.0) then
 889         call AFMforce(Eafmforce)
 890       else if (selfguide.gt.0) then
 891         call AFMvel(Eafmforce)
 892       else
 893         Eafmforce=0.0d0
 894       endif
 895       endif
 896 !      print *,"before tubemode",tubemode
 897       if (tubemode.eq.1) then
 898        call calctube(etube)
 899       else if (tubemode.eq.2) then
 900        call calctube2(etube)
 901       elseif (tubemode.eq.3) then
 902        call calcnano(etube)
 903       else
 904        etube=0.0d0
 905       endif
 906 !      print *, "TU JEST PRZED EHPB"
 907       call edis(ehpb)
 908
 909 !--------------------------------------------------------
 910 !       print *, "NRES_MOLEC(2),",nres_molec(2)
 911 !      print *,"before",ees,evdw1,ecorr
 912 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 913       if (nres_molec(2).gt.0) then
 914       call ebond_nucl(estr_nucl)
 915       call ebend_nucl(ebe_nucl)
 916       call etor_nucl(etors_nucl)
 917       call esb_gb(evdwsb,eelsb)
 918       call epp_nucl_sub(evdwpp,eespp)
 919       call epsb(evdwpsb,eelpsb)
 920       call esb(esbloc)
 921       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 922             call ecat_nucl(ecation_nucl)
 923       else
 924        etors_nucl=0.0d0
 925        estr_nucl=0.0d0
 926        ecorr3_nucl=0.0d0
 927        ecorr_nucl=0.0d0
 928        ebe_nucl=0.0d0
 929        evdwsb=0.0d0
 930        eelsb=0.0d0
 931        esbloc=0.0d0
 932        evdwpsb=0.0d0
 933        eelpsb=0.0d0
 934        evdwpp=0.0d0
 935        eespp=0.0d0
 936        etors_d_nucl=0.0d0
 937        ecation_nucl=0.0d0
 938       endif
 939 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 940 !      print *,"before ecatcat",wcatcat
 941       if (nres_molec(5).gt.0) then
 942        if (g_ilist_catsctran.gt.0) then
 943         call ecat_prot_transition(ecat_prottran)
 944        else
 945         ecat_prottran=0.0d0
 946        endif
 947        if (g_ilist_catscang.gt.0) then
 948          call ecat_prot_ang(ecation_protang)
 949        else
 950          ecation_protang=0.0d0
 951        endif
 952        if (nfgtasks.gt.1) then
 953        if (fg_rank.eq.0) then
 954         if (nres_molec(5).gt.1)  call ecatcat(ecationcation)
 955        endif
 956        else
 957         if (nres_molec(5).gt.1) call ecatcat(ecationcation)
 958        endif
 959        if (oldion.gt.0) then
 960        if (g_ilist_catpnorm.gt.0) call ecat_prot(ecation_prot)
 961         else
 962        if (g_ilist_catpnorm.gt.0) call ecats_prot_amber(ecation_prot)
 963         endif
 964       else
 965       ecationcation=0.0d0
 966       ecation_prot=0.0d0
 967       ecation_protang=0.0d0
 968       ecat_prottran=0.0d0
 969       endif
 970       if (g_ilist_catscnorm.eq.0) ecation_prot=0.0d0
 971       if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then
 972       call eprot_sc_base(escbase)
 973       call epep_sc_base(epepbase)
 974       call eprot_sc_phosphate(escpho)
 975       call eprot_pep_phosphate(epeppho)
 976       else
 977       epepbase=0.0
 978       escbase=0.0
 979       escpho=0.0
 980       epeppho=0.0
 981       endif
 982 ! MARTINI FORCE FIELD ENERGY TERMS
 983       if (nres_molec(4).gt.0) then
 984       if (nfgtasks.gt.1) then
 985       if (fg_rank.eq.0) then
 986         call lipid_bond(elipbond)
 987         call lipid_angle(elipang)
 988       endif
 989       else
 990         call lipid_bond(elipbond)
 991         call lipid_angle(elipang)
 992       endif
 993         call lipid_LJ(eliplj)
 994         call lipid_elec(elipelec)
 995       else
 996         elipbond=0.0d0
 997         elipang=0.0d0
 998         eliplj=0.0d0
 999         elipelec=0.0d0
1000        endif
1001 !      call ecatcat(ecationcation)
1002 !      print *,"after ebend", wtor_nucl
1003 #ifdef TIMING
1004       time_enecalc=time_enecalc+MPI_Wtime()-time00
1005 #endif
1006 !      print *,"Processor",myrank," computed Uconstr"
1007 #ifdef TIMING
1008       time00=MPI_Wtime()
1009 #endif
1010 !
1011 ! Sum the energies
1012 !
1013       energia(1)=evdw
1014 #ifdef SCP14
1015       energia(2)=evdw2-evdw2_14
1016       energia(18)=evdw2_14
1017 #else
1018       energia(2)=evdw2
1019       energia(18)=0.0d0
1020 #endif
1021 #ifdef SPLITELE
1022       energia(3)=ees
1023       energia(16)=evdw1
1024 #else
1025       energia(3)=ees+evdw1
1026       energia(16)=0.0d0
1027 #endif
1028       energia(4)=ecorr
1029       energia(5)=ecorr5
1030       energia(6)=ecorr6
1031       energia(7)=eel_loc
1032       energia(8)=eello_turn3
1033       energia(9)=eello_turn4
1034       energia(10)=eturn6
1035       energia(11)=ebe
1036       energia(12)=escloc
1037       energia(13)=etors
1038       energia(14)=etors_d
1039       energia(15)=ehpb
1040       energia(19)=edihcnstr
1041       energia(17)=estr
1042       energia(20)=Uconst+Uconst_back
1043       energia(21)=esccor
1044       energia(22)=eliptran
1045       energia(23)=Eafmforce
1046       energia(24)=ethetacnstr
1047       energia(25)=etube
1048 !---------------------------------------------------------------
1049       energia(26)=evdwpp
1050       energia(27)=eespp
1051       energia(28)=evdwpsb
1052       energia(29)=eelpsb
1053       energia(30)=evdwsb
1054       energia(31)=eelsb
1055       energia(32)=estr_nucl
1056       energia(33)=ebe_nucl
1057       energia(34)=esbloc
1058       energia(35)=etors_nucl
1059       energia(36)=etors_d_nucl
1060       energia(37)=ecorr_nucl
1061       energia(38)=ecorr3_nucl
1062 !----------------------------------------------------------------------
1063 !    Here are the energies showed per procesor if the are more processors
1064 !    per molecule then we sum it up in sum_energy subroutine
1065 !      print *," Processor",myrank," calls SUM_ENERGY"
1066       energia(42)=ecation_prot
1067       energia(41)=ecationcation
1068       energia(46)=escbase
1069       energia(47)=epepbase
1070       energia(48)=escpho
1071       energia(49)=epeppho
1072 !      energia(50)=ecations_prot_amber
1073       energia(50)=ecation_nucl
1074       energia(51)=ehomology_constr
1075 !     energia(51)=homology
1076       energia(52)=elipbond
1077       energia(53)=elipang
1078       energia(54)=eliplj
1079       energia(55)=elipelec
1080       energia(56)=ecat_prottran
1081       energia(57)=ecation_protang
1082 !      write(iout,*) elipelec,"elipelec"
1083 !      write(iout,*) elipang,"elipang"
1084 !      write(iout,*) eliplj,"eliplj"
1085       call sum_energy(energia,.true.)
1086       if (dyn_ss) call dyn_set_nss
1087 !      print *," Processor",myrank," left SUM_ENERGY"
1088 #ifdef TIMING
1089       time_sumene=time_sumene+MPI_Wtime()-time00
1090 #endif
1091 !        call enerprint(energia)
1092 !elwrite(iout,*)"finish etotal"
1093       return
1094       end subroutine etotal
1095 !-----------------------------------------------------------------------------
1096       subroutine sum_energy(energia,reduce)
1097 !      implicit real(kind=8) (a-h,o-z)
1098 !      include 'DIMENSIONS'
1099 #ifndef ISNAN
1100       external proc_proc
1101 #ifdef WINPGI
1102 !MS$ATTRIBUTES C ::  proc_proc
1103 #endif
1104 #endif
1105 #ifdef MPI
1106       include "mpif.h"
1107 #endif
1108 !      include 'COMMON.SETUP'
1109 !      include 'COMMON.IOUNITS'
1110       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
1111 !      include 'COMMON.FFIELD'
1112 !      include 'COMMON.DERIV'
1113 !      include 'COMMON.INTERACT'
1114 !      include 'COMMON.SBRIDGE'
1115 !      include 'COMMON.CHAIN'
1116 !      include 'COMMON.VAR'
1117 !      include 'COMMON.CONTROL'
1118 !      include 'COMMON.TIME1'
1119       logical :: reduce
1120       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
1121       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
1122       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
1123         eliptran,etube, Eafmforce,ethetacnstr
1124       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1125                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1126                       ecorr3_nucl,ehomology_constr
1127       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1128                       ecation_nucl,ecat_prottran,ecation_protang
1129       real(kind=8) :: escbase,epepbase,escpho,epeppho
1130       integer :: i
1131       real(kind=8) :: elipbond,elipang,eliplj,elipelec
1132 #ifdef MPI
1133       integer :: ierr
1134       real(kind=8) :: time00
1135       if (nfgtasks.gt.1 .and. reduce) then
1136
1137 #ifdef DEBUG
1138         write (iout,*) "energies before REDUCE"
1139         call enerprint(energia)
1140         call flush(iout)
1141 #endif
1142         do i=0,n_ene
1143           enebuff(i)=energia(i)
1144         enddo
1145         time00=MPI_Wtime()
1146         call MPI_Barrier(FG_COMM,IERR)
1147         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1148         time00=MPI_Wtime()
1149         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1150           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1151 #ifdef DEBUG
1152         write (iout,*) "energies after REDUCE"
1153         call enerprint(energia)
1154         call flush(iout)
1155 #endif
1156         time_Reduce=time_Reduce+MPI_Wtime()-time00
1157       endif
1158       if (fg_rank.eq.0) then
1159 #endif
1160       evdw=energia(1)
1161 #ifdef SCP14
1162       evdw2=energia(2)+energia(18)
1163       evdw2_14=energia(18)
1164 #else
1165       evdw2=energia(2)
1166 #endif
1167 #ifdef SPLITELE
1168       ees=energia(3)
1169       evdw1=energia(16)
1170 #else
1171       ees=energia(3)
1172       evdw1=0.0d0
1173 #endif
1174       ecorr=energia(4)
1175       ecorr5=energia(5)
1176       ecorr6=energia(6)
1177       eel_loc=energia(7)
1178       eello_turn3=energia(8)
1179       eello_turn4=energia(9)
1180       eturn6=energia(10)
1181       ebe=energia(11)
1182       escloc=energia(12)
1183       etors=energia(13)
1184       etors_d=energia(14)
1185       ehpb=energia(15)
1186       edihcnstr=energia(19)
1187       estr=energia(17)
1188       Uconst=energia(20)
1189       esccor=energia(21)
1190       eliptran=energia(22)
1191       Eafmforce=energia(23)
1192       ethetacnstr=energia(24)
1193       etube=energia(25)
1194       evdwpp=energia(26)
1195       eespp=energia(27)
1196       evdwpsb=energia(28)
1197       eelpsb=energia(29)
1198       evdwsb=energia(30)
1199       eelsb=energia(31)
1200       estr_nucl=energia(32)
1201       ebe_nucl=energia(33)
1202       esbloc=energia(34)
1203       etors_nucl=energia(35)
1204       etors_d_nucl=energia(36)
1205       ecorr_nucl=energia(37)
1206       ecorr3_nucl=energia(38)
1207       ecation_prot=energia(42)
1208       ecationcation=energia(41)
1209       escbase=energia(46)
1210       epepbase=energia(47)
1211       escpho=energia(48)
1212       epeppho=energia(49)
1213       ecation_nucl=energia(50)
1214       ehomology_constr=energia(51)
1215       elipbond=energia(52)
1216       elipang=energia(53)
1217       eliplj=energia(54)
1218       elipelec=energia(55)
1219       ecat_prottran=energia(56)
1220       ecation_protang=energia(57)
1221 !      ecations_prot_amber=energia(50)
1222
1223 !      energia(41)=ecation_prot
1224 !      energia(42)=ecationcation
1225
1226
1227 #ifdef SPLITELE
1228       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1229        +wang*ebe+wtor*etors+wscloc*escloc &
1230        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1231        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1232        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1233        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1234        +Eafmforce+ethetacnstr  &
1235        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1236        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1237        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1238        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1239        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1240        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl&
1241        +elipbond+elipang+eliplj+elipelec+wcat_tran*ecat_prottran+ecation_protang&
1242 #ifdef WHAM_RUN
1243        +0.0d0
1244 #else
1245        +ehomology_constr
1246 #endif
1247 #else
1248       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1249        +wang*ebe+wtor*etors+wscloc*escloc &
1250        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1251        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1252        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1253        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1254        +Eafmforce+ethetacnstr &
1255        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1256        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1257        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1258        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1259        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1260        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl&
1261        +elipbond+elipang+eliplj+elipelec+wcat_tran*ecat_prottran+ecation_protang&
1262 #ifdef WHAM_RUN
1263        +0.0d0
1264 #else
1265        +ehomology_constr
1266 #endif
1267 #endif
1268       energia(0)=etot
1269 ! detecting NaNQ
1270 #ifdef ISNAN
1271 #ifdef AIX
1272       if (isnan(etot).ne.0) energia(0)=1.0d+99
1273 #else
1274       if (isnan(etot)) energia(0)=1.0d+99
1275 #endif
1276 #else
1277       i=0
1278 #ifdef WINPGI
1279       idumm=proc_proc(etot,i)
1280 #else
1281       call proc_proc(etot,i)
1282 #endif
1283       if(i.eq.1)energia(0)=1.0d+99
1284 #endif
1285 #ifdef MPI
1286       endif
1287 #endif
1288 !      call enerprint(energia)
1289       call flush(iout)
1290       return
1291       end subroutine sum_energy
1292 !-----------------------------------------------------------------------------
1293       subroutine rescale_weights(t_bath)
1294 !      implicit real(kind=8) (a-h,o-z)
1295 #ifdef MPI
1296       include 'mpif.h'
1297 #endif
1298 !      include 'DIMENSIONS'
1299 !      include 'COMMON.IOUNITS'
1300 !      include 'COMMON.FFIELD'
1301 !      include 'COMMON.SBRIDGE'
1302       real(kind=8) :: kfac=2.4d0
1303       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1304 !el local variables
1305       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1306       real(kind=8) :: T0=3.0d2
1307       integer :: ierror
1308 !      facT=temp0/t_bath
1309 !      facT=2*temp0/(t_bath+temp0)
1310       if (rescale_mode.eq.0) then
1311         facT(1)=1.0d0
1312         facT(2)=1.0d0
1313         facT(3)=1.0d0
1314         facT(4)=1.0d0
1315         facT(5)=1.0d0
1316         facT(6)=1.0d0
1317       else if (rescale_mode.eq.1) then
1318         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1319         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1320         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1321         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1322         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1323 #ifdef WHAM_RUN
1324 !#if defined(WHAM_RUN) || defined(CLUSTER)
1325 #if defined(FUNCTH)
1326 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1327         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1328 #elif defined(FUNCT)
1329         facT(6)=t_bath/T0
1330 #else
1331         facT(6)=1.0d0
1332 #endif
1333 #endif
1334       else if (rescale_mode.eq.2) then
1335         x=t_bath/temp0
1336         x2=x*x
1337         x3=x2*x
1338         x4=x3*x
1339         x5=x4*x
1340         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1341         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1342         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1343         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1344         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1345 #ifdef WHAM_RUN
1346 !#if defined(WHAM_RUN) || defined(CLUSTER)
1347 #if defined(FUNCTH)
1348         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1349 #elif defined(FUNCT)
1350         facT(6)=t_bath/T0
1351 #else
1352         facT(6)=1.0d0
1353 #endif
1354 #endif
1355       else
1356         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1357         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1358 #ifdef MPI
1359        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1360 #endif
1361        stop 555
1362       endif
1363       welec=weights(3)*fact(1)
1364       wcorr=weights(4)*fact(3)
1365       wcorr5=weights(5)*fact(4)
1366       wcorr6=weights(6)*fact(5)
1367       wel_loc=weights(7)*fact(2)
1368       wturn3=weights(8)*fact(2)
1369       wturn4=weights(9)*fact(3)
1370       wturn6=weights(10)*fact(5)
1371       wtor=weights(13)*fact(1)
1372       wtor_d=weights(14)*fact(2)
1373       wsccor=weights(21)*fact(1)
1374       welpsb=weights(28)*fact(1)
1375       wcorr_nucl= weights(37)*fact(1)
1376       wcorr3_nucl=weights(38)*fact(2)
1377       wtor_nucl=  weights(35)*fact(1)
1378       wtor_d_nucl=weights(36)*fact(2)
1379       wpepbase=weights(47)*fact(1)
1380       return
1381       end subroutine rescale_weights
1382 !-----------------------------------------------------------------------------
1383       subroutine enerprint(energia)
1384 !      implicit real(kind=8) (a-h,o-z)
1385 !      include 'DIMENSIONS'
1386 !      include 'COMMON.IOUNITS'
1387 !      include 'COMMON.FFIELD'
1388 !      include 'COMMON.SBRIDGE'
1389 !      include 'COMMON.MD'
1390       real(kind=8) :: energia(0:n_ene)
1391 !el local variables
1392       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1393       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1394       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1395        etube,ethetacnstr,Eafmforce
1396       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1397                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1398                       ecorr3_nucl,ehomology_constr
1399       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1400                       ecation_nucl,ecat_prottran,ecation_protang
1401       real(kind=8) :: escbase,epepbase,escpho,epeppho
1402       real(kind=8) :: elipbond,elipang,eliplj,elipelec
1403       etot=energia(0)
1404       evdw=energia(1)
1405       evdw2=energia(2)
1406 #ifdef SCP14
1407       evdw2=energia(2)+energia(18)
1408 #else
1409       evdw2=energia(2)
1410 #endif
1411       ees=energia(3)
1412 #ifdef SPLITELE
1413       evdw1=energia(16)
1414 #endif
1415       ecorr=energia(4)
1416       ecorr5=energia(5)
1417       ecorr6=energia(6)
1418       eel_loc=energia(7)
1419       eello_turn3=energia(8)
1420       eello_turn4=energia(9)
1421       eello_turn6=energia(10)
1422       ebe=energia(11)
1423       escloc=energia(12)
1424       etors=energia(13)
1425       etors_d=energia(14)
1426       ehpb=energia(15)
1427       edihcnstr=energia(19)
1428       estr=energia(17)
1429       Uconst=energia(20)
1430       esccor=energia(21)
1431       eliptran=energia(22)
1432       Eafmforce=energia(23)
1433       ethetacnstr=energia(24)
1434       etube=energia(25)
1435       evdwpp=energia(26)
1436       eespp=energia(27)
1437       evdwpsb=energia(28)
1438       eelpsb=energia(29)
1439       evdwsb=energia(30)
1440       eelsb=energia(31)
1441       estr_nucl=energia(32)
1442       ebe_nucl=energia(33)
1443       esbloc=energia(34)
1444       etors_nucl=energia(35)
1445       etors_d_nucl=energia(36)
1446       ecorr_nucl=energia(37)
1447       ecorr3_nucl=energia(38)
1448       ecation_prot=energia(42)
1449       ecationcation=energia(41)
1450       escbase=energia(46)
1451       epepbase=energia(47)
1452       escpho=energia(48)
1453       epeppho=energia(49)
1454       ecation_nucl=energia(50)
1455       elipbond=energia(52)
1456       elipang=energia(53)
1457       eliplj=energia(54)
1458       elipelec=energia(55)
1459       ecat_prottran=energia(56)
1460       ecation_protang=energia(57)
1461       ehomology_constr=energia(51)
1462
1463 !      ecations_prot_amber=energia(50)
1464 #ifdef SPLITELE
1465       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1466         estr,wbond,ebe,wang,&
1467         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1468         ecorr,wcorr,&
1469         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1470         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1471         edihcnstr,ethetacnstr,ebr*nss,&
1472         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1473         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1474         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1475         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1476         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1477         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,&
1478         ecat_prottran,wcat_tran,ecation_protang,wcat_ang,&
1479         ecationcation,wcatcat, &
1480         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1481         ecation_nucl,wcatnucl,ehomology_constr,&
1482         elipbond,elipang,eliplj,elipelec,etot
1483    10 format (/'Virtual-chain energies:'// &
1484        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1485        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1486        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1487        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1488        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1489        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1490        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1491        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1492        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1493        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1494        ' (SS bridges & dist. cnstr.)'/ &
1495        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1496        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1497        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1498        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1499        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1500        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1501        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1502        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1503        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1504        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1505        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1506        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1507        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1508        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1509        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1510        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1511        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1512        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1513        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1514        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1515        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1516        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1517        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1518        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1519        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1520        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1521        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1522        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1523        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1524        'ECATPTRAN=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot tran)'/ &
1525        'ECATPANG=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot angle)'/ &
1526        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1527        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1528        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1529        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1530        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1531        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1532        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1533        'ELIPBOND=',1pE16.6,'(matrini bond energy)'/&
1534        'ELIPANG=',1pE16.6,'(matrini angle energy)'/&
1535        'ELIPLJ=',1pE16.6,'(matrini Lennard-Jones energy)'/&
1536        'ELIPELEC=',1pE16.6,'(matrini electrostatic energy)'/&
1537        'ETOT=  ',1pE16.6,' (total)')
1538 #else
1539       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1540         estr,wbond,ebe,wang,&
1541         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1542         ecorr,wcorr,&
1543         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1544         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1545         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1546         etube,wtube, ehomology_constr,&
1547         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1548         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1549         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1550         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1551         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1552         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1553         ecation_nucl,wcatnucl,ehomology_constr,etot
1554    10 format (/'Virtual-chain energies:'// &
1555        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1556        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1557        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1558        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1559        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1560        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1561        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1562        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1563        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1564        ' (SS bridges & dist. cnstr.)'/ &
1565        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1566        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1567        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1568        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1569        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1570        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1571        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1572        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1573        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1574        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1575        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1576        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1577        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1578        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1579        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1580        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1581        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1582        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1583        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1584        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1585        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1586        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1587        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1588        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1589        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1590        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1591        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1592        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1593        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1594        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1595        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1596        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1597        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1598        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1599        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1600        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1601        'ELIPBOND=',1pE16.6,'(matrini bond energy)'/&
1602        'ELIPANG=',1pE16.6,'(matrini angle energy)'/&
1603        'ELIPLJ=',1pE16.6,'(matrini Lennard-Jones energy)'/&
1604        'ELIPELEC=',1pE16.6,'(matrini electrostatic energy)'/&
1605        'ETOT=  ',1pE16.6,' (total)')
1606 #endif
1607       return
1608       end subroutine enerprint
1609 !-----------------------------------------------------------------------------
1610       subroutine elj(evdw)
1611 !
1612 ! This subroutine calculates the interaction energy of nonbonded side chains
1613 ! assuming the LJ potential of interaction.
1614 !
1615 !      implicit real(kind=8) (a-h,o-z)
1616 !      include 'DIMENSIONS'
1617       real(kind=8),parameter :: accur=1.0d-10
1618 !      include 'COMMON.GEO'
1619 !      include 'COMMON.VAR'
1620 !      include 'COMMON.LOCAL'
1621 !      include 'COMMON.CHAIN'
1622 !      include 'COMMON.DERIV'
1623 !      include 'COMMON.INTERACT'
1624 !      include 'COMMON.TORSION'
1625 !      include 'COMMON.SBRIDGE'
1626 !      include 'COMMON.NAMES'
1627 !      include 'COMMON.IOUNITS'
1628 !      include 'COMMON.CONTACTS'
1629       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1630       integer :: num_conti
1631 !el local variables
1632       integer :: i,itypi,iint,j,itypi1,itypj,k
1633       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1634        aa,bb,sslipj,ssgradlipj
1635       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1636       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1637
1638 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1639       evdw=0.0D0
1640 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1641 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1642 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1643 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1644
1645       do i=iatsc_s,iatsc_e
1646         itypi=iabs(itype(i,1))
1647         if (itypi.eq.ntyp1) cycle
1648         itypi1=iabs(itype(i+1,1))
1649         xi=c(1,nres+i)
1650         yi=c(2,nres+i)
1651         zi=c(3,nres+i)
1652         call to_box(xi,yi,zi)
1653         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1654
1655 ! Change 12/1/95
1656         num_conti=0
1657 !
1658 ! Calculate SC interaction energy.
1659 !
1660         do iint=1,nint_gr(i)
1661 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1662 !d   &                  'iend=',iend(i,iint)
1663           do j=istart(i,iint),iend(i,iint)
1664             itypj=iabs(itype(j,1))
1665             if (itypj.eq.ntyp1) cycle
1666             xj=c(1,nres+j)-xi
1667             yj=c(2,nres+j)-yi
1668             zj=c(3,nres+j)-zi
1669             call to_box(xj,yj,zj)
1670             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1671             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1672              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1673             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1674              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1675             xj=boxshift(xj-xi,boxxsize)
1676             yj=boxshift(yj-yi,boxysize)
1677             zj=boxshift(zj-zi,boxzsize)
1678 ! Change 12/1/95 to calculate four-body interactions
1679             rij=xj*xj+yj*yj+zj*zj
1680             rrij=1.0D0/rij
1681 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1682             eps0ij=eps(itypi,itypj)
1683             fac=rrij**expon2
1684             e1=fac*fac*aa_aq(itypi,itypj)
1685             e2=fac*bb_aq(itypi,itypj)
1686             evdwij=e1+e2
1687 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1688 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1689 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1690 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1691 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1692 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1693             evdw=evdw+evdwij
1694 !
1695 ! Calculate the components of the gradient in DC and X
1696 !
1697             fac=-rrij*(e1+evdwij)
1698             gg(1)=xj*fac
1699             gg(2)=yj*fac
1700             gg(3)=zj*fac
1701             do k=1,3
1702               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1703               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1704               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1705               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1706             enddo
1707 !grad            do k=i,j-1
1708 !grad              do l=1,3
1709 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1710 !grad              enddo
1711 !grad            enddo
1712 !
1713 ! 12/1/95, revised on 5/20/97
1714 !
1715 ! Calculate the contact function. The ith column of the array JCONT will
1716 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1717 ! greater than I). The arrays FACONT and GACONT will contain the values of
1718 ! the contact function and its derivative.
1719 !
1720 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1721 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1722 ! Uncomment next line, if the correlation interactions are contact function only
1723             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1724               rij=dsqrt(rij)
1725               sigij=sigma(itypi,itypj)
1726               r0ij=rs0(itypi,itypj)
1727 !
1728 ! Check whether the SC's are not too far to make a contact.
1729 !
1730               rcut=1.5d0*r0ij
1731               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1732 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1733 !
1734               if (fcont.gt.0.0D0) then
1735 ! If the SC-SC distance if close to sigma, apply spline.
1736 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1737 !Adam &             fcont1,fprimcont1)
1738 !Adam           fcont1=1.0d0-fcont1
1739 !Adam           if (fcont1.gt.0.0d0) then
1740 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1741 !Adam             fcont=fcont*fcont1
1742 !Adam           endif
1743 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1744 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1745 !ga             do k=1,3
1746 !ga               gg(k)=gg(k)*eps0ij
1747 !ga             enddo
1748 !ga             eps0ij=-evdwij*eps0ij
1749 ! Uncomment for AL's type of SC correlation interactions.
1750 !adam           eps0ij=-evdwij
1751                 num_conti=num_conti+1
1752                 jcont(num_conti,i)=j
1753                 facont(num_conti,i)=fcont*eps0ij
1754                 fprimcont=eps0ij*fprimcont/rij
1755                 fcont=expon*fcont
1756 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1757 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1758 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1759 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1760                 gacont(1,num_conti,i)=-fprimcont*xj
1761                 gacont(2,num_conti,i)=-fprimcont*yj
1762                 gacont(3,num_conti,i)=-fprimcont*zj
1763 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1764 !d              write (iout,'(2i3,3f10.5)')
1765 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1766               endif
1767             endif
1768           enddo      ! j
1769         enddo        ! iint
1770 ! Change 12/1/95
1771         num_cont(i)=num_conti
1772       enddo          ! i
1773       do i=1,nct
1774         do j=1,3
1775           gvdwc(j,i)=expon*gvdwc(j,i)
1776           gvdwx(j,i)=expon*gvdwx(j,i)
1777         enddo
1778       enddo
1779 !******************************************************************************
1780 !
1781 !                              N O T E !!!
1782 !
1783 ! To save time, the factor of EXPON has been extracted from ALL components
1784 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1785 ! use!
1786 !
1787 !******************************************************************************
1788       return
1789       end subroutine elj
1790 !-----------------------------------------------------------------------------
1791       subroutine eljk(evdw)
1792 !
1793 ! This subroutine calculates the interaction energy of nonbonded side chains
1794 ! assuming the LJK potential of interaction.
1795 !
1796 !      implicit real(kind=8) (a-h,o-z)
1797 !      include 'DIMENSIONS'
1798 !      include 'COMMON.GEO'
1799 !      include 'COMMON.VAR'
1800 !      include 'COMMON.LOCAL'
1801 !      include 'COMMON.CHAIN'
1802 !      include 'COMMON.DERIV'
1803 !      include 'COMMON.INTERACT'
1804 !      include 'COMMON.IOUNITS'
1805 !      include 'COMMON.NAMES'
1806       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1807       logical :: scheck
1808 !el local variables
1809       integer :: i,iint,j,itypi,itypi1,k,itypj
1810       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1811          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1812       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1813
1814 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1815       evdw=0.0D0
1816       do i=iatsc_s,iatsc_e
1817         itypi=iabs(itype(i,1))
1818         if (itypi.eq.ntyp1) cycle
1819         itypi1=iabs(itype(i+1,1))
1820         xi=c(1,nres+i)
1821         yi=c(2,nres+i)
1822         zi=c(3,nres+i)
1823         call to_box(xi,yi,zi)
1824         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1825
1826 !
1827 ! Calculate SC interaction energy.
1828 !
1829         do iint=1,nint_gr(i)
1830           do j=istart(i,iint),iend(i,iint)
1831             itypj=iabs(itype(j,1))
1832             if (itypj.eq.ntyp1) cycle
1833             xj=c(1,nres+j)-xi
1834             yj=c(2,nres+j)-yi
1835             zj=c(3,nres+j)-zi
1836             call to_box(xj,yj,zj)
1837             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1838             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1839              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1840             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1841              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1842             xj=boxshift(xj-xi,boxxsize)
1843             yj=boxshift(yj-yi,boxysize)
1844             zj=boxshift(zj-zi,boxzsize)
1845             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1846             fac_augm=rrij**expon
1847             e_augm=augm(itypi,itypj)*fac_augm
1848             r_inv_ij=dsqrt(rrij)
1849             rij=1.0D0/r_inv_ij
1850             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1851             fac=r_shift_inv**expon
1852             e1=fac*fac*aa_aq(itypi,itypj)
1853             e2=fac*bb_aq(itypi,itypj)
1854             evdwij=e_augm+e1+e2
1855 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1856 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1857 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1858 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1859 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1860 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1861 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1862             evdw=evdw+evdwij
1863 !
1864 ! Calculate the components of the gradient in DC and X
1865 !
1866             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1867             gg(1)=xj*fac
1868             gg(2)=yj*fac
1869             gg(3)=zj*fac
1870             do k=1,3
1871               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1872               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1873               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1874               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1875             enddo
1876 !grad            do k=i,j-1
1877 !grad              do l=1,3
1878 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1879 !grad              enddo
1880 !grad            enddo
1881           enddo      ! j
1882         enddo        ! iint
1883       enddo          ! i
1884       do i=1,nct
1885         do j=1,3
1886           gvdwc(j,i)=expon*gvdwc(j,i)
1887           gvdwx(j,i)=expon*gvdwx(j,i)
1888         enddo
1889       enddo
1890       return
1891       end subroutine eljk
1892 !-----------------------------------------------------------------------------
1893       subroutine ebp(evdw)
1894 !
1895 ! This subroutine calculates the interaction energy of nonbonded side chains
1896 ! assuming the Berne-Pechukas potential of interaction.
1897 !
1898       use comm_srutu
1899       use calc_data
1900 !      implicit real(kind=8) (a-h,o-z)
1901 !      include 'DIMENSIONS'
1902 !      include 'COMMON.GEO'
1903 !      include 'COMMON.VAR'
1904 !      include 'COMMON.LOCAL'
1905 !      include 'COMMON.CHAIN'
1906 !      include 'COMMON.DERIV'
1907 !      include 'COMMON.NAMES'
1908 !      include 'COMMON.INTERACT'
1909 !      include 'COMMON.IOUNITS'
1910 !      include 'COMMON.CALC'
1911       use comm_srutu
1912 !el      integer :: icall
1913 !el      common /srutu/ icall
1914 !     double precision rrsave(maxdim)
1915       logical :: lprn
1916 !el local variables
1917       integer :: iint,itypi,itypi1,itypj
1918       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1919         ssgradlipj, aa, bb
1920       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1921
1922 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1923       evdw=0.0D0
1924 !     if (icall.eq.0) then
1925 !       lprn=.true.
1926 !     else
1927         lprn=.false.
1928 !     endif
1929 !el      ind=0
1930       do i=iatsc_s,iatsc_e
1931         itypi=iabs(itype(i,1))
1932         if (itypi.eq.ntyp1) cycle
1933         itypi1=iabs(itype(i+1,1))
1934         xi=c(1,nres+i)
1935         yi=c(2,nres+i)
1936         zi=c(3,nres+i)
1937         call to_box(xi,yi,zi)
1938         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1939         dxi=dc_norm(1,nres+i)
1940         dyi=dc_norm(2,nres+i)
1941         dzi=dc_norm(3,nres+i)
1942 !        dsci_inv=dsc_inv(itypi)
1943         dsci_inv=vbld_inv(i+nres)
1944 !
1945 ! Calculate SC interaction energy.
1946 !
1947         do iint=1,nint_gr(i)
1948           do j=istart(i,iint),iend(i,iint)
1949 !el            ind=ind+1
1950             itypj=iabs(itype(j,1))
1951             if (itypj.eq.ntyp1) cycle
1952 !            dscj_inv=dsc_inv(itypj)
1953             dscj_inv=vbld_inv(j+nres)
1954             chi1=chi(itypi,itypj)
1955             chi2=chi(itypj,itypi)
1956             chi12=chi1*chi2
1957             chip1=chip(itypi)
1958             chip2=chip(itypj)
1959             chip12=chip1*chip2
1960             alf1=alp(itypi)
1961             alf2=alp(itypj)
1962             alf12=0.5D0*(alf1+alf2)
1963 ! For diagnostics only!!!
1964 !           chi1=0.0D0
1965 !           chi2=0.0D0
1966 !           chi12=0.0D0
1967 !           chip1=0.0D0
1968 !           chip2=0.0D0
1969 !           chip12=0.0D0
1970 !           alf1=0.0D0
1971 !           alf2=0.0D0
1972 !           alf12=0.0D0
1973             xj=c(1,nres+j)-xi
1974             yj=c(2,nres+j)-yi
1975             zj=c(3,nres+j)-zi
1976             call to_box(xj,yj,zj)
1977             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1978             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1979              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1980             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1981              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1982             xj=boxshift(xj-xi,boxxsize)
1983             yj=boxshift(yj-yi,boxysize)
1984             zj=boxshift(zj-zi,boxzsize)
1985             dxj=dc_norm(1,nres+j)
1986             dyj=dc_norm(2,nres+j)
1987             dzj=dc_norm(3,nres+j)
1988             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1989 !d          if (icall.eq.0) then
1990 !d            rrsave(ind)=rrij
1991 !d          else
1992 !d            rrij=rrsave(ind)
1993 !d          endif
1994             rij=dsqrt(rrij)
1995 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1996             call sc_angular
1997 ! Calculate whole angle-dependent part of epsilon and contributions
1998 ! to its derivatives
1999             fac=(rrij*sigsq)**expon2
2000             e1=fac*fac*aa_aq(itypi,itypj)
2001             e2=fac*bb_aq(itypi,itypj)
2002             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2003             eps2der=evdwij*eps3rt
2004             eps3der=evdwij*eps2rt
2005             evdwij=evdwij*eps2rt*eps3rt
2006             evdw=evdw+evdwij
2007             if (lprn) then
2008             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2009             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2010 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
2011 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2012 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
2013 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
2014 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
2015 !d     &        evdwij
2016             endif
2017 ! Calculate gradient components.
2018             e1=e1*eps1*eps2rt**2*eps3rt**2
2019             fac=-expon*(e1+evdwij)
2020             sigder=fac/sigsq
2021             fac=rrij*fac
2022 ! Calculate radial part of the gradient
2023             gg(1)=xj*fac
2024             gg(2)=yj*fac
2025             gg(3)=zj*fac
2026 ! Calculate the angular part of the gradient and sum add the contributions
2027 ! to the appropriate components of the Cartesian gradient.
2028             call sc_grad
2029           enddo      ! j
2030         enddo        ! iint
2031       enddo          ! i
2032 !     stop
2033       return
2034       end subroutine ebp
2035 !-----------------------------------------------------------------------------
2036       subroutine egb(evdw)
2037 !
2038 ! This subroutine calculates the interaction energy of nonbonded side chains
2039 ! assuming the Gay-Berne potential of interaction.
2040 !
2041       use calc_data
2042 !      implicit real(kind=8) (a-h,o-z)
2043 !      include 'DIMENSIONS'
2044 !      include 'COMMON.GEO'
2045 !      include 'COMMON.VAR'
2046 !      include 'COMMON.LOCAL'
2047 !      include 'COMMON.CHAIN'
2048 !      include 'COMMON.DERIV'
2049 !      include 'COMMON.NAMES'
2050 !      include 'COMMON.INTERACT'
2051 !      include 'COMMON.IOUNITS'
2052 !      include 'COMMON.CALC'
2053 !      include 'COMMON.CONTROL'
2054 !      include 'COMMON.SBRIDGE'
2055       logical :: lprn
2056 !el local variables
2057       integer :: iint,itypi,itypi1,itypj,subchap,icont
2058       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
2059       real(kind=8) :: evdw,sig0ij
2060       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
2061                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
2062                     sslipi,sslipj,faclip
2063       integer :: ii
2064       real(kind=8) :: fracinbuf
2065
2066 !cccc      energy_dec=.false.
2067 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2068       evdw=0.0D0
2069       lprn=.false.
2070 !     if (icall.eq.0) lprn=.false.
2071 !el      ind=0
2072       dCAVdOM2=0.0d0
2073       dGCLdOM2=0.0d0
2074       dPOLdOM2=0.0d0
2075       dCAVdOM1=0.0d0
2076       dGCLdOM1=0.0d0
2077       dPOLdOM1=0.0d0
2078 !             write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
2079       if (nres_molec(1).eq.0) return
2080       do icont=g_listscsc_start,g_listscsc_end
2081       i=newcontlisti(icont)
2082       j=newcontlistj(icont)
2083 !      write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
2084 !      do i=iatsc_s,iatsc_e
2085 !C        print *,"I am in EVDW",i
2086         itypi=iabs(itype(i,1))
2087 !        if (i.ne.47) cycle
2088         if (itypi.eq.ntyp1) cycle
2089         itypi1=iabs(itype(i+1,1))
2090         xi=c(1,nres+i)
2091         yi=c(2,nres+i)
2092         zi=c(3,nres+i)
2093         call to_box(xi,yi,zi)
2094         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2095
2096         dxi=dc_norm(1,nres+i)
2097         dyi=dc_norm(2,nres+i)
2098         dzi=dc_norm(3,nres+i)
2099 !        dsci_inv=dsc_inv(itypi)
2100         dsci_inv=vbld_inv(i+nres)
2101 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
2102 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
2103 !
2104 ! Calculate SC interaction energy.
2105 !
2106 !        do iint=1,nint_gr(i)
2107 !          do j=istart(i,iint),iend(i,iint)
2108             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
2109               call dyn_ssbond_ene(i,j,evdwij)
2110               evdw=evdw+evdwij
2111               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
2112                               'evdw',i,j,evdwij,' ss'
2113 !              if (energy_dec) write (iout,*) &
2114 !                              'evdw',i,j,evdwij,' ss'
2115              do k=j+1,nres
2116 !C search over all next residues
2117               if (dyn_ss_mask(k)) then
2118 !C check if they are cysteins
2119 !C              write(iout,*) 'k=',k
2120
2121 !c              write(iout,*) "PRZED TRI", evdwij
2122 !               evdwij_przed_tri=evdwij
2123               call triple_ssbond_ene(i,j,k,evdwij)
2124 !c               if(evdwij_przed_tri.ne.evdwij) then
2125 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2126 !c               endif
2127
2128 !c              write(iout,*) "PO TRI", evdwij
2129 !C call the energy function that removes the artifical triple disulfide
2130 !C bond the soubroutine is located in ssMD.F
2131               evdw=evdw+evdwij
2132               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
2133                             'evdw',i,j,evdwij,'tss'
2134               endif!dyn_ss_mask(k)
2135              enddo! k
2136             ELSE
2137 !el            ind=ind+1
2138             itypj=iabs(itype(j,1))
2139             if (itypj.eq.ntyp1) cycle
2140 !             if (j.ne.78) cycle
2141 !            dscj_inv=dsc_inv(itypj)
2142             dscj_inv=vbld_inv(j+nres)
2143 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
2144 !              1.0d0/vbld(j+nres) !d
2145 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
2146             sig0ij=sigma(itypi,itypj)
2147             chi1=chi(itypi,itypj)
2148             chi2=chi(itypj,itypi)
2149             chi12=chi1*chi2
2150             chip1=chip(itypi)
2151             chip2=chip(itypj)
2152             chip12=chip1*chip2
2153             alf1=alp(itypi)
2154             alf2=alp(itypj)
2155             alf12=0.5D0*(alf1+alf2)
2156 ! For diagnostics only!!!
2157 !           chi1=0.0D0
2158 !           chi2=0.0D0
2159 !           chi12=0.0D0
2160 !           chip1=0.0D0
2161 !           chip2=0.0D0
2162 !           chip12=0.0D0
2163 !           alf1=0.0D0
2164 !           alf2=0.0D0
2165 !           alf12=0.0D0
2166            xj=c(1,nres+j)
2167            yj=c(2,nres+j)
2168            zj=c(3,nres+j)
2169               call to_box(xj,yj,zj)
2170               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2171 !              write (iout,*) "KWA2", itypi,itypj
2172               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2173                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2174               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2175                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2176               xj=boxshift(xj-xi,boxxsize)
2177               yj=boxshift(yj-yi,boxysize)
2178               zj=boxshift(zj-zi,boxzsize)
2179             dxj=dc_norm(1,nres+j)
2180             dyj=dc_norm(2,nres+j)
2181             dzj=dc_norm(3,nres+j)
2182 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2183 !            write (iout,*) "j",j," dc_norm",& !d
2184 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2185 !          write(iout,*)"rrij ",rrij
2186 !          write(iout,*)"xj yj zj ", xj, yj, zj
2187 !          write(iout,*)"xi yi zi ", xi, yi, zi
2188 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2189             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2190             rij=dsqrt(rrij)
2191             sss_ele_cut=sscale_ele(1.0d0/(rij))
2192             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2193 !            print *,sss_ele_cut,sss_ele_grad,&
2194 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2195             if (sss_ele_cut.le.0.0) cycle
2196 ! Calculate angle-dependent terms of energy and contributions to their
2197 ! derivatives.
2198             call sc_angular
2199             sigsq=1.0D0/sigsq
2200             sig=sig0ij*dsqrt(sigsq)
2201             rij_shift=1.0D0/rij-sig+sig0ij
2202 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2203 !            "sig0ij",sig0ij
2204 ! for diagnostics; uncomment
2205 !            rij_shift=1.2*sig0ij
2206 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2207             if (rij_shift.le.0.0D0) then
2208               evdw=1.0D20
2209 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2210 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2211 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2212               return
2213             endif
2214             sigder=-sig*sigsq
2215 !---------------------------------------------------------------
2216             rij_shift=1.0D0/rij_shift
2217             fac=rij_shift**expon
2218             faclip=fac
2219             e1=fac*fac*aa!(itypi,itypj)
2220             e2=fac*bb!(itypi,itypj)
2221             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2222             eps2der=evdwij*eps3rt
2223             eps3der=evdwij*eps2rt
2224 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2225 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2226 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2227             evdwij=evdwij*eps2rt*eps3rt
2228             evdw=evdw+evdwij*sss_ele_cut
2229             if (lprn) then
2230             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2231             epsi=bb**2/aa!(itypi,itypj)
2232             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2233               restyp(itypi,1),i,restyp(itypj,1),j, &
2234               epsi,sigm,chi1,chi2,chip1,chip2, &
2235               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2236               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2237               evdwij
2238             endif
2239
2240             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2241                              'evdw',i,j,evdwij,1.0D0/rij,1.0D0/rij_shift,dabs(aa/bb)**(1.0D0/6.0D0)!,"egb"
2242 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2243 !            if (energy_dec) write (iout,*) &
2244 !                             'evdw',i,j,evdwij
2245 !                       print *,"ZALAMKA", evdw
2246
2247 ! Calculate gradient components.
2248             e1=e1*eps1*eps2rt**2*eps3rt**2
2249             fac=-expon*(e1+evdwij)*rij_shift
2250             sigder=fac*sigder
2251             fac=rij*fac
2252 !            print *,'before fac',fac,rij,evdwij
2253             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2254             *rij
2255 !            print *,'grad part scale',fac,   &
2256 !             evdwij*sss_ele_grad/sss_ele_cut &
2257 !            /sigma(itypi,itypj)*rij
2258 !            fac=0.0d0
2259 ! Calculate the radial part of the gradient
2260             gg(1)=xj*fac
2261             gg(2)=yj*fac
2262             gg(3)=zj*fac
2263 !C Calculate the radial part of the gradient
2264             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2265        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2266         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2267        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2268             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2269             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2270
2271 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2272 ! Calculate angular part of the gradient.
2273             call sc_grad
2274             ENDIF    ! dyn_ss
2275 !          enddo      ! j
2276 !        enddo        ! iint
2277       enddo          ! i
2278 !       print *,"ZALAMKA", evdw
2279 !      write (iout,*) "Number of loop steps in EGB:",ind
2280 !ccc      energy_dec=.false.
2281       return
2282       end subroutine egb
2283 !-----------------------------------------------------------------------------
2284       subroutine egbv(evdw)
2285 !
2286 ! This subroutine calculates the interaction energy of nonbonded side chains
2287 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2288 !
2289       use comm_srutu
2290       use calc_data
2291 !      implicit real(kind=8) (a-h,o-z)
2292 !      include 'DIMENSIONS'
2293 !      include 'COMMON.GEO'
2294 !      include 'COMMON.VAR'
2295 !      include 'COMMON.LOCAL'
2296 !      include 'COMMON.CHAIN'
2297 !      include 'COMMON.DERIV'
2298 !      include 'COMMON.NAMES'
2299 !      include 'COMMON.INTERACT'
2300 !      include 'COMMON.IOUNITS'
2301 !      include 'COMMON.CALC'
2302       use comm_srutu
2303 !el      integer :: icall
2304 !el      common /srutu/ icall
2305       logical :: lprn
2306 !el local variables
2307       integer :: iint,itypi,itypi1,itypj
2308       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2309          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2310       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2311
2312 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2313       evdw=0.0D0
2314       lprn=.false.
2315 !     if (icall.eq.0) lprn=.true.
2316 !el      ind=0
2317       do i=iatsc_s,iatsc_e
2318         itypi=iabs(itype(i,1))
2319         if (itypi.eq.ntyp1) cycle
2320         itypi1=iabs(itype(i+1,1))
2321         xi=c(1,nres+i)
2322         yi=c(2,nres+i)
2323         zi=c(3,nres+i)
2324         call to_box(xi,yi,zi)
2325         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2326         dxi=dc_norm(1,nres+i)
2327         dyi=dc_norm(2,nres+i)
2328         dzi=dc_norm(3,nres+i)
2329 !        dsci_inv=dsc_inv(itypi)
2330         dsci_inv=vbld_inv(i+nres)
2331 !
2332 ! Calculate SC interaction energy.
2333 !
2334         do iint=1,nint_gr(i)
2335           do j=istart(i,iint),iend(i,iint)
2336 !el            ind=ind+1
2337             itypj=iabs(itype(j,1))
2338             if (itypj.eq.ntyp1) cycle
2339 !            dscj_inv=dsc_inv(itypj)
2340             dscj_inv=vbld_inv(j+nres)
2341             sig0ij=sigma(itypi,itypj)
2342             r0ij=r0(itypi,itypj)
2343             chi1=chi(itypi,itypj)
2344             chi2=chi(itypj,itypi)
2345             chi12=chi1*chi2
2346             chip1=chip(itypi)
2347             chip2=chip(itypj)
2348             chip12=chip1*chip2
2349             alf1=alp(itypi)
2350             alf2=alp(itypj)
2351             alf12=0.5D0*(alf1+alf2)
2352 ! For diagnostics only!!!
2353 !           chi1=0.0D0
2354 !           chi2=0.0D0
2355 !           chi12=0.0D0
2356 !           chip1=0.0D0
2357 !           chip2=0.0D0
2358 !           chip12=0.0D0
2359 !           alf1=0.0D0
2360 !           alf2=0.0D0
2361 !           alf12=0.0D0
2362             xj=c(1,nres+j)-xi
2363             yj=c(2,nres+j)-yi
2364             zj=c(3,nres+j)-zi
2365            call to_box(xj,yj,zj)
2366            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2367            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2368             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2369            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2370             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2371            xj=boxshift(xj-xi,boxxsize)
2372            yj=boxshift(yj-yi,boxysize)
2373            zj=boxshift(zj-zi,boxzsize)
2374             dxj=dc_norm(1,nres+j)
2375             dyj=dc_norm(2,nres+j)
2376             dzj=dc_norm(3,nres+j)
2377             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2378             rij=dsqrt(rrij)
2379 ! Calculate angle-dependent terms of energy and contributions to their
2380 ! derivatives.
2381             call sc_angular
2382             sigsq=1.0D0/sigsq
2383             sig=sig0ij*dsqrt(sigsq)
2384             rij_shift=1.0D0/rij-sig+r0ij
2385 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2386             if (rij_shift.le.0.0D0) then
2387               evdw=1.0D20
2388               return
2389             endif
2390             sigder=-sig*sigsq
2391 !---------------------------------------------------------------
2392             rij_shift=1.0D0/rij_shift
2393             fac=rij_shift**expon
2394             e1=fac*fac*aa_aq(itypi,itypj)
2395             e2=fac*bb_aq(itypi,itypj)
2396             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2397             eps2der=evdwij*eps3rt
2398             eps3der=evdwij*eps2rt
2399             fac_augm=rrij**expon
2400             e_augm=augm(itypi,itypj)*fac_augm
2401             evdwij=evdwij*eps2rt*eps3rt
2402             evdw=evdw+evdwij+e_augm
2403             if (lprn) then
2404             sigm=dabs(aa_aq(itypi,itypj)/&
2405             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2406             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2407             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2408               restyp(itypi,1),i,restyp(itypj,1),j,&
2409               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2410               chi1,chi2,chip1,chip2,&
2411               eps1,eps2rt**2,eps3rt**2,&
2412               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2413               evdwij+e_augm
2414             endif
2415 ! Calculate gradient components.
2416             e1=e1*eps1*eps2rt**2*eps3rt**2
2417             fac=-expon*(e1+evdwij)*rij_shift
2418             sigder=fac*sigder
2419             fac=rij*fac-2*expon*rrij*e_augm
2420 ! Calculate the radial part of the gradient
2421             gg(1)=xj*fac
2422             gg(2)=yj*fac
2423             gg(3)=zj*fac
2424 ! Calculate angular part of the gradient.
2425             call sc_grad
2426           enddo      ! j
2427         enddo        ! iint
2428       enddo          ! i
2429       end subroutine egbv
2430 !-----------------------------------------------------------------------------
2431 !el      subroutine sc_angular in module geometry
2432 !-----------------------------------------------------------------------------
2433       subroutine e_softsphere(evdw)
2434 !
2435 ! This subroutine calculates the interaction energy of nonbonded side chains
2436 ! assuming the LJ potential of interaction.
2437 !
2438 !      implicit real(kind=8) (a-h,o-z)
2439 !      include 'DIMENSIONS'
2440       real(kind=8),parameter :: accur=1.0d-10
2441 !      include 'COMMON.GEO'
2442 !      include 'COMMON.VAR'
2443 !      include 'COMMON.LOCAL'
2444 !      include 'COMMON.CHAIN'
2445 !      include 'COMMON.DERIV'
2446 !      include 'COMMON.INTERACT'
2447 !      include 'COMMON.TORSION'
2448 !      include 'COMMON.SBRIDGE'
2449 !      include 'COMMON.NAMES'
2450 !      include 'COMMON.IOUNITS'
2451 !      include 'COMMON.CONTACTS'
2452       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2453 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2454 !el local variables
2455       integer :: i,iint,j,itypi,itypi1,itypj,k
2456       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2457       real(kind=8) :: fac
2458
2459       evdw=0.0D0
2460       do i=iatsc_s,iatsc_e
2461         itypi=iabs(itype(i,1))
2462         if (itypi.eq.ntyp1) cycle
2463         itypi1=iabs(itype(i+1,1))
2464         xi=c(1,nres+i)
2465         yi=c(2,nres+i)
2466         zi=c(3,nres+i)
2467         call to_box(xi,yi,zi)
2468
2469 !
2470 ! Calculate SC interaction energy.
2471 !
2472         do iint=1,nint_gr(i)
2473 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2474 !d   &                  'iend=',iend(i,iint)
2475           do j=istart(i,iint),iend(i,iint)
2476             itypj=iabs(itype(j,1))
2477             if (itypj.eq.ntyp1) cycle
2478             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2479             yj=boxshift(c(2,nres+j)-yi,boxysize)
2480             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2481             rij=xj*xj+yj*yj+zj*zj
2482 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2483             r0ij=r0(itypi,itypj)
2484             r0ijsq=r0ij*r0ij
2485 !            print *,i,j,r0ij,dsqrt(rij)
2486             if (rij.lt.r0ijsq) then
2487               evdwij=0.25d0*(rij-r0ijsq)**2
2488               fac=rij-r0ijsq
2489             else
2490               evdwij=0.0d0
2491               fac=0.0d0
2492             endif
2493             evdw=evdw+evdwij
2494 !
2495 ! Calculate the components of the gradient in DC and X
2496 !
2497             gg(1)=xj*fac
2498             gg(2)=yj*fac
2499             gg(3)=zj*fac
2500             do k=1,3
2501               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2502               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2503               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2504               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2505             enddo
2506 !grad            do k=i,j-1
2507 !grad              do l=1,3
2508 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2509 !grad              enddo
2510 !grad            enddo
2511           enddo ! j
2512         enddo ! iint
2513       enddo ! i
2514       return
2515       end subroutine e_softsphere
2516 !-----------------------------------------------------------------------------
2517       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2518 !
2519 ! Soft-sphere potential of p-p interaction
2520 !
2521 !      implicit real(kind=8) (a-h,o-z)
2522 !      include 'DIMENSIONS'
2523 !      include 'COMMON.CONTROL'
2524 !      include 'COMMON.IOUNITS'
2525 !      include 'COMMON.GEO'
2526 !      include 'COMMON.VAR'
2527 !      include 'COMMON.LOCAL'
2528 !      include 'COMMON.CHAIN'
2529 !      include 'COMMON.DERIV'
2530 !      include 'COMMON.INTERACT'
2531 !      include 'COMMON.CONTACTS'
2532 !      include 'COMMON.TORSION'
2533 !      include 'COMMON.VECTORS'
2534 !      include 'COMMON.FFIELD'
2535       real(kind=8),dimension(3) :: ggg
2536 !d      write(iout,*) 'In EELEC_soft_sphere'
2537 !el local variables
2538       integer :: i,j,k,num_conti,iteli,itelj
2539       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2540       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2541       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2542
2543       ees=0.0D0
2544       evdw1=0.0D0
2545       eel_loc=0.0d0
2546       eello_turn3=0.0d0
2547       eello_turn4=0.0d0
2548 !el      ind=0
2549       do i=iatel_s,iatel_e
2550         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2551         dxi=dc(1,i)
2552         dyi=dc(2,i)
2553         dzi=dc(3,i)
2554         xmedi=c(1,i)+0.5d0*dxi
2555         ymedi=c(2,i)+0.5d0*dyi
2556         zmedi=c(3,i)+0.5d0*dzi
2557         call to_box(xmedi,ymedi,zmedi)
2558         num_conti=0
2559 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2560         do j=ielstart(i),ielend(i)
2561           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2562 !el          ind=ind+1
2563           iteli=itel(i)
2564           itelj=itel(j)
2565           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2566           r0ij=rpp(iteli,itelj)
2567           r0ijsq=r0ij*r0ij
2568           dxj=dc(1,j)
2569           dyj=dc(2,j)
2570           dzj=dc(3,j)
2571           xj=c(1,j)+0.5D0*dxj-xmedi
2572           yj=c(2,j)+0.5D0*dyj-ymedi
2573           zj=c(3,j)+0.5D0*dzj-zmedi
2574           call to_box(xj,yj,zj)
2575           xj=boxshift(xj-xmedi,boxxsize)
2576           yj=boxshift(yj-ymedi,boxysize)
2577           zj=boxshift(zj-zmedi,boxzsize)
2578           rij=xj*xj+yj*yj+zj*zj
2579           if (rij.lt.r0ijsq) then
2580             evdw1ij=0.25d0*(rij-r0ijsq)**2
2581             fac=rij-r0ijsq
2582           else
2583             evdw1ij=0.0d0
2584             fac=0.0d0
2585           endif
2586           evdw1=evdw1+evdw1ij
2587 !
2588 ! Calculate contributions to the Cartesian gradient.
2589 !
2590           ggg(1)=fac*xj
2591           ggg(2)=fac*yj
2592           ggg(3)=fac*zj
2593           do k=1,3
2594             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2595             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2596           enddo
2597 !
2598 ! Loop over residues i+1 thru j-1.
2599 !
2600 !grad          do k=i+1,j-1
2601 !grad            do l=1,3
2602 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2603 !grad            enddo
2604 !grad          enddo
2605         enddo ! j
2606       enddo   ! i
2607 !grad      do i=nnt,nct-1
2608 !grad        do k=1,3
2609 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2610 !grad        enddo
2611 !grad        do j=i+1,nct-1
2612 !grad          do k=1,3
2613 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2614 !grad          enddo
2615 !grad        enddo
2616 !grad      enddo
2617       return
2618       end subroutine eelec_soft_sphere
2619 !-----------------------------------------------------------------------------
2620       subroutine vec_and_deriv
2621 !      implicit real(kind=8) (a-h,o-z)
2622 !      include 'DIMENSIONS'
2623 #ifdef MPI
2624       include 'mpif.h'
2625 #endif
2626 !      include 'COMMON.IOUNITS'
2627 !      include 'COMMON.GEO'
2628 !      include 'COMMON.VAR'
2629 !      include 'COMMON.LOCAL'
2630 !      include 'COMMON.CHAIN'
2631 !      include 'COMMON.VECTORS'
2632 !      include 'COMMON.SETUP'
2633 !      include 'COMMON.TIME1'
2634       real(kind=8),dimension(3,3,2) :: uyder,uzder
2635       real(kind=8),dimension(2) :: vbld_inv_temp
2636 ! Compute the local reference systems. For reference system (i), the
2637 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2638 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2639 !el local variables
2640       integer :: i,j,k,l
2641       real(kind=8) :: facy,fac,costh
2642
2643 #ifdef PARVEC
2644       do i=ivec_start,ivec_end
2645 #else
2646       do i=1,nres-1
2647 #endif
2648           if (i.eq.nres-1) then
2649 ! Case of the last full residue
2650 ! Compute the Z-axis
2651             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2652             costh=dcos(pi-theta(nres))
2653             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2654             do k=1,3
2655               uz(k,i)=fac*uz(k,i)
2656             enddo
2657 ! Compute the derivatives of uz
2658             uzder(1,1,1)= 0.0d0
2659             uzder(2,1,1)=-dc_norm(3,i-1)
2660             uzder(3,1,1)= dc_norm(2,i-1)
2661             uzder(1,2,1)= dc_norm(3,i-1)
2662             uzder(2,2,1)= 0.0d0
2663             uzder(3,2,1)=-dc_norm(1,i-1)
2664             uzder(1,3,1)=-dc_norm(2,i-1)
2665             uzder(2,3,1)= dc_norm(1,i-1)
2666             uzder(3,3,1)= 0.0d0
2667             uzder(1,1,2)= 0.0d0
2668             uzder(2,1,2)= dc_norm(3,i)
2669             uzder(3,1,2)=-dc_norm(2,i)
2670             uzder(1,2,2)=-dc_norm(3,i)
2671             uzder(2,2,2)= 0.0d0
2672             uzder(3,2,2)= dc_norm(1,i)
2673             uzder(1,3,2)= dc_norm(2,i)
2674             uzder(2,3,2)=-dc_norm(1,i)
2675             uzder(3,3,2)= 0.0d0
2676 ! Compute the Y-axis
2677             facy=fac
2678             do k=1,3
2679               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2680             enddo
2681 ! Compute the derivatives of uy
2682             do j=1,3
2683               do k=1,3
2684                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2685                               -dc_norm(k,i)*dc_norm(j,i-1)
2686                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2687               enddo
2688               uyder(j,j,1)=uyder(j,j,1)-costh
2689               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2690             enddo
2691             do j=1,2
2692               do k=1,3
2693                 do l=1,3
2694                   uygrad(l,k,j,i)=uyder(l,k,j)
2695                   uzgrad(l,k,j,i)=uzder(l,k,j)
2696                 enddo
2697               enddo
2698             enddo
2699             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2700             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2701             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2702             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2703           else
2704 ! Other residues
2705 ! Compute the Z-axis
2706             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2707             costh=dcos(pi-theta(i+2))
2708             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2709             do k=1,3
2710               uz(k,i)=fac*uz(k,i)
2711             enddo
2712 ! Compute the derivatives of uz
2713             uzder(1,1,1)= 0.0d0
2714             uzder(2,1,1)=-dc_norm(3,i+1)
2715             uzder(3,1,1)= dc_norm(2,i+1)
2716             uzder(1,2,1)= dc_norm(3,i+1)
2717             uzder(2,2,1)= 0.0d0
2718             uzder(3,2,1)=-dc_norm(1,i+1)
2719             uzder(1,3,1)=-dc_norm(2,i+1)
2720             uzder(2,3,1)= dc_norm(1,i+1)
2721             uzder(3,3,1)= 0.0d0
2722             uzder(1,1,2)= 0.0d0
2723             uzder(2,1,2)= dc_norm(3,i)
2724             uzder(3,1,2)=-dc_norm(2,i)
2725             uzder(1,2,2)=-dc_norm(3,i)
2726             uzder(2,2,2)= 0.0d0
2727             uzder(3,2,2)= dc_norm(1,i)
2728             uzder(1,3,2)= dc_norm(2,i)
2729             uzder(2,3,2)=-dc_norm(1,i)
2730             uzder(3,3,2)= 0.0d0
2731 ! Compute the Y-axis
2732             facy=fac
2733             do k=1,3
2734               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2735             enddo
2736 ! Compute the derivatives of uy
2737             do j=1,3
2738               do k=1,3
2739                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2740                               -dc_norm(k,i)*dc_norm(j,i+1)
2741                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2742               enddo
2743               uyder(j,j,1)=uyder(j,j,1)-costh
2744               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2745             enddo
2746             do j=1,2
2747               do k=1,3
2748                 do l=1,3
2749                   uygrad(l,k,j,i)=uyder(l,k,j)
2750                   uzgrad(l,k,j,i)=uzder(l,k,j)
2751                 enddo
2752               enddo
2753             enddo
2754             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2755             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2756             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2757             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2758           endif
2759       enddo
2760       do i=1,nres-1
2761         vbld_inv_temp(1)=vbld_inv(i+1)
2762         if (i.lt.nres-1) then
2763           vbld_inv_temp(2)=vbld_inv(i+2)
2764           else
2765           vbld_inv_temp(2)=vbld_inv(i)
2766           endif
2767         do j=1,2
2768           do k=1,3
2769             do l=1,3
2770               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2771               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2772             enddo
2773           enddo
2774         enddo
2775       enddo
2776 #if defined(PARVEC) && defined(MPI)
2777       if (nfgtasks1.gt.1) then
2778         time00=MPI_Wtime()
2779 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2780 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2781 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2782         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2783          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2784          FG_COMM1,IERR)
2785         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2786          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2787          FG_COMM1,IERR)
2788         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2789          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2790          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2791         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2792          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2793          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2794         time_gather=time_gather+MPI_Wtime()-time00
2795       endif
2796 !      if (fg_rank.eq.0) then
2797 !        write (iout,*) "Arrays UY and UZ"
2798 !        do i=1,nres-1
2799 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2800 !     &     (uz(k,i),k=1,3)
2801 !        enddo
2802 !      endif
2803 #endif
2804       return
2805       end subroutine vec_and_deriv
2806 !-----------------------------------------------------------------------------
2807       subroutine check_vecgrad
2808 !      implicit real(kind=8) (a-h,o-z)
2809 !      include 'DIMENSIONS'
2810 !      include 'COMMON.IOUNITS'
2811 !      include 'COMMON.GEO'
2812 !      include 'COMMON.VAR'
2813 !      include 'COMMON.LOCAL'
2814 !      include 'COMMON.CHAIN'
2815 !      include 'COMMON.VECTORS'
2816       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2817       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2818       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2819       real(kind=8),dimension(3) :: erij
2820       real(kind=8) :: delta=1.0d-7
2821 !el local variables
2822       integer :: i,j,k,l
2823
2824       call vec_and_deriv
2825 !d      do i=1,nres
2826 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2827 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2828 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2829 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2830 !d     &     (dc_norm(if90,i),if90=1,3)
2831 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2832 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2833 !d          write(iout,'(a)')
2834 !d      enddo
2835       do i=1,nres
2836         do j=1,2
2837           do k=1,3
2838             do l=1,3
2839               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2840               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2841             enddo
2842           enddo
2843         enddo
2844       enddo
2845       call vec_and_deriv
2846       do i=1,nres
2847         do j=1,3
2848           uyt(j,i)=uy(j,i)
2849           uzt(j,i)=uz(j,i)
2850         enddo
2851       enddo
2852       do i=1,nres
2853 !d        write (iout,*) 'i=',i
2854         do k=1,3
2855           erij(k)=dc_norm(k,i)
2856         enddo
2857         do j=1,3
2858           do k=1,3
2859             dc_norm(k,i)=erij(k)
2860           enddo
2861           dc_norm(j,i)=dc_norm(j,i)+delta
2862 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2863 !          do k=1,3
2864 !            dc_norm(k,i)=dc_norm(k,i)/fac
2865 !          enddo
2866 !          write (iout,*) (dc_norm(k,i),k=1,3)
2867 !          write (iout,*) (erij(k),k=1,3)
2868           call vec_and_deriv
2869           do k=1,3
2870             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2871             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2872             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2873             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2874           enddo
2875 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2876 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2877 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2878         enddo
2879         do k=1,3
2880           dc_norm(k,i)=erij(k)
2881         enddo
2882 !d        do k=1,3
2883 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2884 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2885 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2886 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2887 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2888 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2889 !d          write (iout,'(a)')
2890 !d        enddo
2891       enddo
2892       return
2893       end subroutine check_vecgrad
2894 !-----------------------------------------------------------------------------
2895       subroutine set_matrices
2896 !      implicit real(kind=8) (a-h,o-z)
2897 !      include 'DIMENSIONS'
2898 #ifdef MPI
2899       include "mpif.h"
2900 !      include "COMMON.SETUP"
2901       integer :: IERR
2902       integer :: status(MPI_STATUS_SIZE)
2903 #endif
2904 !      include 'COMMON.IOUNITS'
2905 !      include 'COMMON.GEO'
2906 !      include 'COMMON.VAR'
2907 !      include 'COMMON.LOCAL'
2908 !      include 'COMMON.CHAIN'
2909 !      include 'COMMON.DERIV'
2910 !      include 'COMMON.INTERACT'
2911 !      include 'COMMON.CONTACTS'
2912 !      include 'COMMON.TORSION'
2913 !      include 'COMMON.VECTORS'
2914 !      include 'COMMON.FFIELD'
2915       real(kind=8) :: auxvec(2),auxmat(2,2)
2916       integer :: i,iti1,iti,k,l
2917       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2918        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2919 !       print *,"in set matrices"
2920 !
2921 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2922 ! to calculate the el-loc multibody terms of various order.
2923 !
2924 !AL el      mu=0.0d0
2925
2926 #ifdef PARMAT
2927       do i=ivec_start+2,ivec_end+2
2928 #else
2929       do i=3,nres+1
2930 #endif
2931         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2932           if (itype(i-2,1).eq.0) then
2933           iti = nloctyp
2934           else
2935           iti = itype2loc(itype(i-2,1))
2936           endif
2937         else
2938           iti=nloctyp
2939         endif
2940 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2941         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2942           iti1 = itype2loc(itype(i-1,1))
2943         else
2944           iti1=nloctyp
2945         endif
2946 !        print *,i,itype(i-2,1),iti
2947 #ifdef NEWCORR
2948         cost1=dcos(theta(i-1))
2949         sint1=dsin(theta(i-1))
2950         sint1sq=sint1*sint1
2951         sint1cub=sint1sq*sint1
2952         sint1cost1=2*sint1*cost1
2953 !        print *,"cost1",cost1,theta(i-1)
2954 !c        write (iout,*) "bnew1",i,iti
2955 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2956 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2957 !c        write (iout,*) "bnew2",i,iti
2958 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2959 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2960         k=1
2961 !        print *,bnew1(1,k,iti),"bnew1"
2962         do k=1,2
2963           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2964 !          print *,b1k
2965 !          write(*,*) shape(b1)
2966 !          if(.not.allocated(b1)) print *, "WTF?"
2967           b1(k,i-2)=sint1*b1k
2968 !
2969 !             print *,b1(k,i-2)
2970
2971           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2972                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2973 !             print *,gtb1(k,i-2)
2974
2975           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2976           b2(k,i-2)=sint1*b2k
2977 !             print *,b2(k,i-2)
2978
2979           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2980                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2981 !             print *,gtb2(k,i-2)
2982
2983         enddo
2984 !        print *,b1k,b2k
2985         do k=1,2
2986           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2987           cc(1,k,i-2)=sint1sq*aux
2988           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2989                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2990           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2991           dd(1,k,i-2)=sint1sq*aux
2992           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2993                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2994         enddo
2995 !        print *,"after cc"
2996         cc(2,1,i-2)=cc(1,2,i-2)
2997         cc(2,2,i-2)=-cc(1,1,i-2)
2998         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2999         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3000         dd(2,1,i-2)=dd(1,2,i-2)
3001         dd(2,2,i-2)=-dd(1,1,i-2)
3002         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3003         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3004 !        print *,"after dd"
3005
3006         do k=1,2
3007           do l=1,2
3008             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3009             EE(l,k,i-2)=sint1sq*aux
3010             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3011           enddo
3012         enddo
3013         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3014         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3015         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3016         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3017         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3018         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3019         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3020 !        print *,"after ee"
3021
3022 !c        b1tilde(1,i-2)=b1(1,i-2)
3023 !c        b1tilde(2,i-2)=-b1(2,i-2)
3024 !c        b2tilde(1,i-2)=b2(1,i-2)
3025 !c        b2tilde(2,i-2)=-b2(2,i-2)
3026 #ifdef DEBUG
3027         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3028         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3029         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3030         write (iout,*) 'theta=', theta(i-1)
3031 #endif
3032 #else
3033         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3034 !         write(iout,*) "i,",molnum(i),nloctyp
3035 !         print *, "i,",molnum(i),i,itype(i-2,1)
3036         if (molnum(i).eq.1) then
3037           if (itype(i-2,1).eq.ntyp1) then
3038            iti=nloctyp
3039           else
3040           iti = itype2loc(itype(i-2,1))
3041           endif
3042         else
3043           iti=nloctyp
3044         endif
3045         else
3046           iti=nloctyp
3047         endif
3048 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3049 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3050         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3051           iti1 = itype2loc(itype(i-1,1))
3052         else
3053           iti1=nloctyp
3054         endif
3055 !        print *,i,iti
3056         b1(1,i-2)=b(3,iti)
3057         b1(2,i-2)=b(5,iti)
3058         b2(1,i-2)=b(2,iti)
3059         b2(2,i-2)=b(4,iti)
3060         do k=1,2
3061           do l=1,2
3062            CC(k,l,i-2)=ccold(k,l,iti)
3063            DD(k,l,i-2)=ddold(k,l,iti)
3064            EE(k,l,i-2)=eeold(k,l,iti)
3065           enddo
3066         enddo
3067 #endif
3068         b1tilde(1,i-2)= b1(1,i-2)
3069         b1tilde(2,i-2)=-b1(2,i-2)
3070         b2tilde(1,i-2)= b2(1,i-2)
3071         b2tilde(2,i-2)=-b2(2,i-2)
3072 !c
3073         Ctilde(1,1,i-2)= CC(1,1,i-2)
3074         Ctilde(1,2,i-2)= CC(1,2,i-2)
3075         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3076         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3077 !c
3078         Dtilde(1,1,i-2)= DD(1,1,i-2)
3079         Dtilde(1,2,i-2)= DD(1,2,i-2)
3080         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3081         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3082       enddo
3083 #ifdef PARMAT
3084       do i=ivec_start+2,ivec_end+2
3085 #else
3086       do i=3,nres+1
3087 #endif
3088
3089 !      print *,i,"i"
3090         if (i .lt. nres+1) then
3091           sin1=dsin(phi(i))
3092           cos1=dcos(phi(i))
3093           sintab(i-2)=sin1
3094           costab(i-2)=cos1
3095           obrot(1,i-2)=cos1
3096           obrot(2,i-2)=sin1
3097           sin2=dsin(2*phi(i))
3098           cos2=dcos(2*phi(i))
3099           sintab2(i-2)=sin2
3100           costab2(i-2)=cos2
3101           obrot2(1,i-2)=cos2
3102           obrot2(2,i-2)=sin2
3103           Ug(1,1,i-2)=-cos1
3104           Ug(1,2,i-2)=-sin1
3105           Ug(2,1,i-2)=-sin1
3106           Ug(2,2,i-2)= cos1
3107           Ug2(1,1,i-2)=-cos2
3108           Ug2(1,2,i-2)=-sin2
3109           Ug2(2,1,i-2)=-sin2
3110           Ug2(2,2,i-2)= cos2
3111         else
3112           costab(i-2)=1.0d0
3113           sintab(i-2)=0.0d0
3114           obrot(1,i-2)=1.0d0
3115           obrot(2,i-2)=0.0d0
3116           obrot2(1,i-2)=0.0d0
3117           obrot2(2,i-2)=0.0d0
3118           Ug(1,1,i-2)=1.0d0
3119           Ug(1,2,i-2)=0.0d0
3120           Ug(2,1,i-2)=0.0d0
3121           Ug(2,2,i-2)=1.0d0
3122           Ug2(1,1,i-2)=0.0d0
3123           Ug2(1,2,i-2)=0.0d0
3124           Ug2(2,1,i-2)=0.0d0
3125           Ug2(2,2,i-2)=0.0d0
3126         endif
3127         if (i .gt. 3 .and. i .lt. nres+1) then
3128           obrot_der(1,i-2)=-sin1
3129           obrot_der(2,i-2)= cos1
3130           Ugder(1,1,i-2)= sin1
3131           Ugder(1,2,i-2)=-cos1
3132           Ugder(2,1,i-2)=-cos1
3133           Ugder(2,2,i-2)=-sin1
3134           dwacos2=cos2+cos2
3135           dwasin2=sin2+sin2
3136           obrot2_der(1,i-2)=-dwasin2
3137           obrot2_der(2,i-2)= dwacos2
3138           Ug2der(1,1,i-2)= dwasin2
3139           Ug2der(1,2,i-2)=-dwacos2
3140           Ug2der(2,1,i-2)=-dwacos2
3141           Ug2der(2,2,i-2)=-dwasin2
3142         else
3143           obrot_der(1,i-2)=0.0d0
3144           obrot_der(2,i-2)=0.0d0
3145           Ugder(1,1,i-2)=0.0d0
3146           Ugder(1,2,i-2)=0.0d0
3147           Ugder(2,1,i-2)=0.0d0
3148           Ugder(2,2,i-2)=0.0d0
3149           obrot2_der(1,i-2)=0.0d0
3150           obrot2_der(2,i-2)=0.0d0
3151           Ug2der(1,1,i-2)=0.0d0
3152           Ug2der(1,2,i-2)=0.0d0
3153           Ug2der(2,1,i-2)=0.0d0
3154           Ug2der(2,2,i-2)=0.0d0
3155         endif
3156 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3157         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3158            if (itype(i-2,1).eq.0) then
3159           iti=ntortyp+1
3160            else
3161           iti = itype2loc(itype(i-2,1))
3162            endif
3163         else
3164           iti=nloctyp
3165         endif
3166 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3167         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3168            if (itype(i-1,1).eq.0) then
3169           iti1=nloctyp
3170            else
3171           iti1 = itype2loc(itype(i-1,1))
3172            endif
3173         else
3174           iti1=nloctyp
3175         endif
3176 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3177 !d        write (iout,*) '*******i',i,' iti1',iti
3178 !        write (iout,*) 'b1',b1(:,iti)
3179 !        write (iout,*) 'b2',b2(:,i-2)
3180 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3181 !        if (i .gt. iatel_s+2) then
3182         if (i .gt. nnt+2) then
3183           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3184 #ifdef NEWCORR
3185           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3186 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3187 #endif
3188
3189           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3190           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3191           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3192           then
3193           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3194           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3195           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3196           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3197           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3198           endif
3199         else
3200           do k=1,2
3201             Ub2(k,i-2)=0.0d0
3202             Ctobr(k,i-2)=0.0d0
3203             Dtobr2(k,i-2)=0.0d0
3204             do l=1,2
3205               EUg(l,k,i-2)=0.0d0
3206               CUg(l,k,i-2)=0.0d0
3207               DUg(l,k,i-2)=0.0d0
3208               DtUg2(l,k,i-2)=0.0d0
3209             enddo
3210           enddo
3211         endif
3212         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3213         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3214         do k=1,2
3215           muder(k,i-2)=Ub2der(k,i-2)
3216         enddo
3217 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3218         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3219           if (itype(i-1,1).eq.0) then
3220            iti1=nloctyp
3221           elseif (itype(i-1,1).le.ntyp) then
3222             iti1 = itype2loc(itype(i-1,1))
3223           else
3224             iti1=nloctyp
3225           endif
3226         else
3227           iti1=nloctyp
3228         endif
3229         do k=1,2
3230           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3231         enddo
3232         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3233         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3234         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3235 !d        write (iout,*) 'mu1',mu1(:,i-2)
3236 !d        write (iout,*) 'mu2',mu2(:,i-2)
3237         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3238         then
3239         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3240         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3241         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3242         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3243         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3244 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3245         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3246         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3247         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3248         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3249         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3250         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3251         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3252         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3253         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3254         endif
3255       enddo
3256 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3257 ! The order of matrices is from left to right.
3258       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3259       then
3260 !      do i=max0(ivec_start,2),ivec_end
3261       do i=2,nres-1
3262         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3263         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3264         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3265         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3266         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3267         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3268         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3269         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3270       enddo
3271       endif
3272 #if defined(MPI) && defined(PARMAT)
3273 #ifdef DEBUG
3274 !      if (fg_rank.eq.0) then
3275         write (iout,*) "Arrays UG and UGDER before GATHER"
3276         do i=1,nres-1
3277           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3278            ((ug(l,k,i),l=1,2),k=1,2),&
3279            ((ugder(l,k,i),l=1,2),k=1,2)
3280         enddo
3281         write (iout,*) "Arrays UG2 and UG2DER"
3282         do i=1,nres-1
3283           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3284            ((ug2(l,k,i),l=1,2),k=1,2),&
3285            ((ug2der(l,k,i),l=1,2),k=1,2)
3286         enddo
3287         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3288         do i=1,nres-1
3289           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3290            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3291            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3292         enddo
3293         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3294         do i=1,nres-1
3295           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3296            costab(i),sintab(i),costab2(i),sintab2(i)
3297         enddo
3298         write (iout,*) "Array MUDER"
3299         do i=1,nres-1
3300           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3301         enddo
3302 !      endif
3303 #endif
3304       if (nfgtasks.gt.1) then
3305         time00=MPI_Wtime()
3306 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3307 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3308 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3309 #ifdef MATGATHER
3310         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3311          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3312          FG_COMM1,IERR)
3313         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3314          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3315          FG_COMM1,IERR)
3316         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3317          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3318          FG_COMM1,IERR)
3319         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3320          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3321          FG_COMM1,IERR)
3322         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3323          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3324          FG_COMM1,IERR)
3325         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3326          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3327          FG_COMM1,IERR)
3328         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3329          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3330          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3331         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3332          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3333          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3334         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3335          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3336          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3337         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3338          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3339          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3340         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3341         then
3342         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3343          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3344          FG_COMM1,IERR)
3345         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3346          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3347          FG_COMM1,IERR)
3348         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3349          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3350          FG_COMM1,IERR)
3351        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3352          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3353          FG_COMM1,IERR)
3354         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3355          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3356          FG_COMM1,IERR)
3357         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3358          ivec_count(fg_rank1),&
3359          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3360          FG_COMM1,IERR)
3361         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3362          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3363          FG_COMM1,IERR)
3364         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3365          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3366          FG_COMM1,IERR)
3367         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3368          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3369          FG_COMM1,IERR)
3370         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3371          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3372          FG_COMM1,IERR)
3373         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3374          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3375          FG_COMM1,IERR)
3376         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3377          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3378          FG_COMM1,IERR)
3379         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3380          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3381          FG_COMM1,IERR)
3382         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3383          ivec_count(fg_rank1),&
3384          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3385          FG_COMM1,IERR)
3386         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3387          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3388          FG_COMM1,IERR)
3389        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3390          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3391          FG_COMM1,IERR)
3392         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3393          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3394          FG_COMM1,IERR)
3395        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3396          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3397          FG_COMM1,IERR)
3398         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3399          ivec_count(fg_rank1),&
3400          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3401          FG_COMM1,IERR)
3402         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3403          ivec_count(fg_rank1),&
3404          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3405          FG_COMM1,IERR)
3406         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3407          ivec_count(fg_rank1),&
3408          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3409          MPI_MAT2,FG_COMM1,IERR)
3410         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3411          ivec_count(fg_rank1),&
3412          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3413          MPI_MAT2,FG_COMM1,IERR)
3414         endif
3415 #else
3416 ! Passes matrix info through the ring
3417       isend=fg_rank1
3418       irecv=fg_rank1-1
3419       if (irecv.lt.0) irecv=nfgtasks1-1
3420       iprev=irecv
3421       inext=fg_rank1+1
3422       if (inext.ge.nfgtasks1) inext=0
3423       do i=1,nfgtasks1-1
3424 !        write (iout,*) "isend",isend," irecv",irecv
3425 !        call flush(iout)
3426         lensend=lentyp(isend)
3427         lenrecv=lentyp(irecv)
3428 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3429 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3430 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3431 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3432 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3433 !        write (iout,*) "Gather ROTAT1"
3434 !        call flush(iout)
3435 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3436 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3437 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3438 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3439 !        write (iout,*) "Gather ROTAT2"
3440 !        call flush(iout)
3441         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3442          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3443          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3444          iprev,4400+irecv,FG_COMM,status,IERR)
3445 !        write (iout,*) "Gather ROTAT_OLD"
3446 !        call flush(iout)
3447         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3448          MPI_PRECOMP11(lensend),inext,5500+isend,&
3449          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3450          iprev,5500+irecv,FG_COMM,status,IERR)
3451 !        write (iout,*) "Gather PRECOMP11"
3452 !        call flush(iout)
3453         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3454          MPI_PRECOMP12(lensend),inext,6600+isend,&
3455          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3456          iprev,6600+irecv,FG_COMM,status,IERR)
3457 !        write (iout,*) "Gather PRECOMP12"
3458 !        call flush(iout)
3459         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3460         then
3461         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3462          MPI_ROTAT2(lensend),inext,7700+isend,&
3463          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3464          iprev,7700+irecv,FG_COMM,status,IERR)
3465 !        write (iout,*) "Gather PRECOMP21"
3466 !        call flush(iout)
3467         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3468          MPI_PRECOMP22(lensend),inext,8800+isend,&
3469          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3470          iprev,8800+irecv,FG_COMM,status,IERR)
3471 !        write (iout,*) "Gather PRECOMP22"
3472 !        call flush(iout)
3473         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3474          MPI_PRECOMP23(lensend),inext,9900+isend,&
3475          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3476          MPI_PRECOMP23(lenrecv),&
3477          iprev,9900+irecv,FG_COMM,status,IERR)
3478 !        write (iout,*) "Gather PRECOMP23"
3479 !        call flush(iout)
3480         endif
3481         isend=irecv
3482         irecv=irecv-1
3483         if (irecv.lt.0) irecv=nfgtasks1-1
3484       enddo
3485 #endif
3486         time_gather=time_gather+MPI_Wtime()-time00
3487       endif
3488 #ifdef DEBUG
3489 !      if (fg_rank.eq.0) then
3490         write (iout,*) "Arrays UG and UGDER"
3491         do i=1,nres-1
3492           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3493            ((ug(l,k,i),l=1,2),k=1,2),&
3494            ((ugder(l,k,i),l=1,2),k=1,2)
3495         enddo
3496         write (iout,*) "Arrays UG2 and UG2DER"
3497         do i=1,nres-1
3498           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3499            ((ug2(l,k,i),l=1,2),k=1,2),&
3500            ((ug2der(l,k,i),l=1,2),k=1,2)
3501         enddo
3502         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3503         do i=1,nres-1
3504           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3505            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3506            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3507         enddo
3508         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3509         do i=1,nres-1
3510           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3511            costab(i),sintab(i),costab2(i),sintab2(i)
3512         enddo
3513         write (iout,*) "Array MUDER"
3514         do i=1,nres-1
3515           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3516         enddo
3517 !      endif
3518 #endif
3519 #endif
3520 !d      do i=1,nres
3521 !d        iti = itortyp(itype(i,1))
3522 !d        write (iout,*) i
3523 !d        do j=1,2
3524 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3525 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3526 !d        enddo
3527 !d      enddo
3528       return
3529       end subroutine set_matrices
3530 !-----------------------------------------------------------------------------
3531       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3532 !
3533 ! This subroutine calculates the average interaction energy and its gradient
3534 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3535 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3536 ! The potential depends both on the distance of peptide-group centers and on
3537 ! the orientation of the CA-CA virtual bonds.
3538 !
3539       use comm_locel
3540 !      implicit real(kind=8) (a-h,o-z)
3541 #ifdef MPI
3542       include 'mpif.h'
3543 #endif
3544 !      include 'DIMENSIONS'
3545 !      include 'COMMON.CONTROL'
3546 !      include 'COMMON.SETUP'
3547 !      include 'COMMON.IOUNITS'
3548 !      include 'COMMON.GEO'
3549 !      include 'COMMON.VAR'
3550 !      include 'COMMON.LOCAL'
3551 !      include 'COMMON.CHAIN'
3552 !      include 'COMMON.DERIV'
3553 !      include 'COMMON.INTERACT'
3554 !      include 'COMMON.CONTACTS'
3555 !      include 'COMMON.TORSION'
3556 !      include 'COMMON.VECTORS'
3557 !      include 'COMMON.FFIELD'
3558 !      include 'COMMON.TIME1'
3559       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3560       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3561       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3562 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3563       real(kind=8),dimension(4) :: muij
3564 !el      integer :: num_conti,j1,j2
3565 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3566 !el        dz_normi,xmedi,ymedi,zmedi
3567
3568 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3569 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3570 !el          num_conti,j1,j2
3571
3572 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3573 #ifdef MOMENT
3574       real(kind=8) :: scal_el=1.0d0
3575 #else
3576       real(kind=8) :: scal_el=0.5d0
3577 #endif
3578 ! 12/13/98
3579 ! 13-go grudnia roku pamietnego...
3580       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3581                                              0.0d0,1.0d0,0.0d0,&
3582                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3583 !el local variables
3584       integer :: i,k,j,icont
3585       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3586       real(kind=8) :: fac,t_eelecij,fracinbuf
3587
3588
3589 !d      write(iout,*) 'In EELEC'
3590 !        print *,"IN EELEC"
3591 !d      do i=1,nloctyp
3592 !d        write(iout,*) 'Type',i
3593 !d        write(iout,*) 'B1',B1(:,i)
3594 !d        write(iout,*) 'B2',B2(:,i)
3595 !d        write(iout,*) 'CC',CC(:,:,i)
3596 !d        write(iout,*) 'DD',DD(:,:,i)
3597 !d        write(iout,*) 'EE',EE(:,:,i)
3598 !d      enddo
3599 !d      call check_vecgrad
3600 !d      stop
3601 !      ees=0.0d0  !AS
3602 !      evdw1=0.0d0
3603 !      eel_loc=0.0d0
3604 !      eello_turn3=0.0d0
3605 !      eello_turn4=0.0d0
3606       t_eelecij=0.0d0
3607       ees=0.0D0
3608       evdw1=0.0D0
3609       eel_loc=0.0d0
3610       eello_turn3=0.0d0
3611       eello_turn4=0.0d0
3612       if (nres_molec(1).eq.0) return
3613 !
3614
3615       if (icheckgrad.eq.1) then
3616 !el
3617 !        do i=0,2*nres+2
3618 !          dc_norm(1,i)=0.0d0
3619 !          dc_norm(2,i)=0.0d0
3620 !          dc_norm(3,i)=0.0d0
3621 !        enddo
3622         do i=1,nres-1
3623           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3624           do k=1,3
3625             dc_norm(k,i)=dc(k,i)*fac
3626           enddo
3627 !          write (iout,*) 'i',i,' fac',fac
3628         enddo
3629       endif
3630 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3631 !        wturn6
3632       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3633           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3634           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3635 !        call vec_and_deriv
3636 #ifdef TIMING
3637         time01=MPI_Wtime()
3638 #endif
3639 !        print *, "before set matrices"
3640         call set_matrices
3641 !        print *, "after set matrices"
3642
3643 #ifdef TIMING
3644         time_mat=time_mat+MPI_Wtime()-time01
3645 #endif
3646       endif
3647 !       print *, "after set matrices"
3648 !d      do i=1,nres-1
3649 !d        write (iout,*) 'i=',i
3650 !d        do k=1,3
3651 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3652 !d        enddo
3653 !d        do k=1,3
3654 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3655 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3656 !d        enddo
3657 !d      enddo
3658       t_eelecij=0.0d0
3659       ees=0.0D0
3660       evdw1=0.0D0
3661       eel_loc=0.0d0
3662       eello_turn3=0.0d0
3663       eello_turn4=0.0d0
3664 !el      ind=0
3665       do i=1,nres
3666         num_cont_hb(i)=0
3667       enddo
3668 !d      print '(a)','Enter EELEC'
3669 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3670 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3671 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3672       do i=1,nres
3673         gel_loc_loc(i)=0.0d0
3674         gcorr_loc(i)=0.0d0
3675       enddo
3676 !
3677 !
3678 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3679 !
3680 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3681 !
3682
3683
3684 !        print *,"before iturn3 loop"
3685       do i=iturn3_start,iturn3_end
3686         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3687         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3688         dxi=dc(1,i)
3689         dyi=dc(2,i)
3690         dzi=dc(3,i)
3691         dx_normi=dc_norm(1,i)
3692         dy_normi=dc_norm(2,i)
3693         dz_normi=dc_norm(3,i)
3694         xmedi=c(1,i)+0.5d0*dxi
3695         ymedi=c(2,i)+0.5d0*dyi
3696         zmedi=c(3,i)+0.5d0*dzi
3697         call to_box(xmedi,ymedi,zmedi)
3698         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3699         num_conti=0
3700        call eelecij(i,i+2,ees,evdw1,eel_loc)
3701         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3702         num_cont_hb(i)=num_conti
3703       enddo
3704       do i=iturn4_start,iturn4_end
3705         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3706           .or. itype(i+3,1).eq.ntyp1 &
3707           .or. itype(i+4,1).eq.ntyp1) cycle
3708 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3709         dxi=dc(1,i)
3710         dyi=dc(2,i)
3711         dzi=dc(3,i)
3712         dx_normi=dc_norm(1,i)
3713         dy_normi=dc_norm(2,i)
3714         dz_normi=dc_norm(3,i)
3715         xmedi=c(1,i)+0.5d0*dxi
3716         ymedi=c(2,i)+0.5d0*dyi
3717         zmedi=c(3,i)+0.5d0*dzi
3718         call to_box(xmedi,ymedi,zmedi)
3719         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3720         num_conti=num_cont_hb(i)
3721         call eelecij(i,i+3,ees,evdw1,eel_loc)
3722         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3723         call eturn4(i,eello_turn4)
3724 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3725         num_cont_hb(i)=num_conti
3726       enddo   ! i
3727 !
3728 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3729 !
3730 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3731 !      do i=iatel_s,iatel_e
3732 ! JPRDLC
3733        do icont=g_listpp_start,g_listpp_end
3734         i=newcontlistppi(icont)
3735         j=newcontlistppj(icont)
3736         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3737         dxi=dc(1,i)
3738         dyi=dc(2,i)
3739         dzi=dc(3,i)
3740         dx_normi=dc_norm(1,i)
3741         dy_normi=dc_norm(2,i)
3742         dz_normi=dc_norm(3,i)
3743         xmedi=c(1,i)+0.5d0*dxi
3744         ymedi=c(2,i)+0.5d0*dyi
3745         zmedi=c(3,i)+0.5d0*dzi
3746         call to_box(xmedi,ymedi,zmedi)
3747         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3748
3749 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3750         num_conti=num_cont_hb(i)
3751 !        do j=ielstart(i),ielend(i)
3752 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3753           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3754           call eelecij(i,j,ees,evdw1,eel_loc)
3755 !        enddo ! j
3756         num_cont_hb(i)=num_conti
3757       enddo   ! i
3758 !      write (iout,*) "Number of loop steps in EELEC:",ind
3759 !d      do i=1,nres
3760 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3761 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3762 !d      enddo
3763 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3764 !cc      eel_loc=eel_loc+eello_turn3
3765 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3766       return
3767       end subroutine eelec
3768 !-----------------------------------------------------------------------------
3769       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3770
3771       use comm_locel
3772 !      implicit real(kind=8) (a-h,o-z)
3773 !      include 'DIMENSIONS'
3774 #ifdef MPI
3775       include "mpif.h"
3776 #endif
3777 !      include 'COMMON.CONTROL'
3778 !      include 'COMMON.IOUNITS'
3779 !      include 'COMMON.GEO'
3780 !      include 'COMMON.VAR'
3781 !      include 'COMMON.LOCAL'
3782 !      include 'COMMON.CHAIN'
3783 !      include 'COMMON.DERIV'
3784 !      include 'COMMON.INTERACT'
3785 !      include 'COMMON.CONTACTS'
3786 !      include 'COMMON.TORSION'
3787 !      include 'COMMON.VECTORS'
3788 !      include 'COMMON.FFIELD'
3789 !      include 'COMMON.TIME1'
3790       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3791       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3792       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3793 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3794       real(kind=8),dimension(4) :: muij
3795       real(kind=8) :: geel_loc_ij,geel_loc_ji
3796       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3797                     dist_temp, dist_init,rlocshield,fracinbuf
3798       integer xshift,yshift,zshift,ilist,iresshield
3799 !el      integer :: num_conti,j1,j2
3800 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3801 !el        dz_normi,xmedi,ymedi,zmedi
3802
3803 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3804 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3805 !el          num_conti,j1,j2
3806
3807 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3808 #ifdef MOMENT
3809       real(kind=8) :: scal_el=1.0d0
3810 #else
3811       real(kind=8) :: scal_el=0.5d0
3812 #endif
3813 ! 12/13/98
3814 ! 13-go grudnia roku pamietnego...
3815       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3816                                              0.0d0,1.0d0,0.0d0,&
3817                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3818 !      integer :: maxconts=nres/4
3819 !el local variables
3820       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3821       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3822       real(kind=8) ::  faclipij2, faclipij
3823       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3824       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3825                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3826                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3827                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3828                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3829                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3830                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3831                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3832 !      maxconts=nres/4
3833 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3834 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3835
3836 !          time00=MPI_Wtime()
3837 !d      write (iout,*) "eelecij",i,j
3838 !          ind=ind+1
3839           iteli=itel(i)
3840           itelj=itel(j)
3841           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3842           aaa=app(iteli,itelj)
3843           bbb=bpp(iteli,itelj)
3844           ael6i=ael6(iteli,itelj)
3845           ael3i=ael3(iteli,itelj)
3846           dxj=dc(1,j)
3847           dyj=dc(2,j)
3848           dzj=dc(3,j)
3849           dx_normj=dc_norm(1,j)
3850           dy_normj=dc_norm(2,j)
3851           dz_normj=dc_norm(3,j)
3852 !          xj=c(1,j)+0.5D0*dxj-xmedi
3853 !          yj=c(2,j)+0.5D0*dyj-ymedi
3854 !          zj=c(3,j)+0.5D0*dzj-zmedi
3855           xj=c(1,j)+0.5D0*dxj
3856           yj=c(2,j)+0.5D0*dyj
3857           zj=c(3,j)+0.5D0*dzj
3858
3859           call to_box(xj,yj,zj)
3860           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3861           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3862           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3863           xj=boxshift(xj-xmedi,boxxsize)
3864           yj=boxshift(yj-ymedi,boxysize)
3865           zj=boxshift(zj-zmedi,boxzsize)
3866
3867           rij=xj*xj+yj*yj+zj*zj
3868           rrmij=1.0D0/rij
3869           rij=dsqrt(rij)
3870 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3871             sss_ele_cut=sscale_ele(rij)
3872             sss_ele_grad=sscagrad_ele(rij)
3873 !             sss_ele_cut=1.0d0
3874 !             sss_ele_grad=0.0d0
3875 !            print *,sss_ele_cut,sss_ele_grad,&
3876 !            (rij),r_cut_ele,rlamb_ele
3877             if (sss_ele_cut.le.0.0) go to 128
3878
3879           rmij=1.0D0/rij
3880           r3ij=rrmij*rmij
3881           r6ij=r3ij*r3ij
3882           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3883           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3884           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3885           fac=cosa-3.0D0*cosb*cosg
3886           ev1=aaa*r6ij*r6ij
3887 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3888           if (j.eq.i+2) ev1=scal_el*ev1
3889           ev2=bbb*r6ij
3890           fac3=ael6i*r6ij
3891           fac4=ael3i*r3ij
3892           evdwij=ev1+ev2
3893           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3894           el2=fac4*fac
3895 !          eesij=el1+el2
3896           if (shield_mode.gt.0) then
3897 !C          fac_shield(i)=0.4
3898 !C          fac_shield(j)=0.6
3899           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3900           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3901           eesij=(el1+el2)
3902           ees=ees+eesij*sss_ele_cut
3903 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3904 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3905           else
3906           fac_shield(i)=1.0
3907           fac_shield(j)=1.0
3908           eesij=(el1+el2)
3909           ees=ees+eesij   &
3910             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3911 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3912           endif
3913
3914 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3915           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3916 !          ees=ees+eesij*sss_ele_cut
3917           evdw1=evdw1+evdwij*sss_ele_cut  &
3918            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3919 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3920 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3921 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3922 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3923
3924           if (energy_dec) then
3925 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3926 !                  'evdw1',i,j,evdwij,&
3927 !                  iteli,itelj,aaa,evdw1
3928               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3929               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3930           endif
3931 !
3932 ! Calculate contributions to the Cartesian gradient.
3933 !
3934 #ifdef SPLITELE
3935           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3936               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3937           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3938              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3939           fac1=fac
3940           erij(1)=xj*rmij
3941           erij(2)=yj*rmij
3942           erij(3)=zj*rmij
3943 !
3944 ! Radial derivatives. First process both termini of the fragment (i,j)
3945 !
3946           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3947           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3948           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3949            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3950           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3951             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3952
3953           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3954           (shield_mode.gt.0)) then
3955 !C          print *,i,j
3956           do ilist=1,ishield_list(i)
3957            iresshield=shield_list(ilist,i)
3958            do k=1,3
3959            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3960            *2.0*sss_ele_cut
3961            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3962                    rlocshield &
3963             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3964             *sss_ele_cut
3965             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3966            enddo
3967           enddo
3968           do ilist=1,ishield_list(j)
3969            iresshield=shield_list(ilist,j)
3970            do k=1,3
3971            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3972           *2.0*sss_ele_cut
3973            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3974                    rlocshield &
3975            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3976            *sss_ele_cut
3977            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3978            enddo
3979           enddo
3980           do k=1,3
3981             gshieldc(k,i)=gshieldc(k,i)+ &
3982                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3983            *sss_ele_cut
3984
3985             gshieldc(k,j)=gshieldc(k,j)+ &
3986                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3987            *sss_ele_cut
3988
3989             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3990                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3991            *sss_ele_cut
3992
3993             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3994                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3995            *sss_ele_cut
3996
3997            enddo
3998            endif
3999
4000
4001 !          do k=1,3
4002 !            ghalf=0.5D0*ggg(k)
4003 !            gelc(k,i)=gelc(k,i)+ghalf
4004 !            gelc(k,j)=gelc(k,j)+ghalf
4005 !          enddo
4006 ! 9/28/08 AL Gradient compotents will be summed only at the end
4007           do k=1,3
4008             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4009             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4010           enddo
4011             gelc_long(3,j)=gelc_long(3,j)+  &
4012           ssgradlipj*eesij/2.0d0*lipscale**2&
4013            *sss_ele_cut
4014
4015             gelc_long(3,i)=gelc_long(3,i)+  &
4016           ssgradlipi*eesij/2.0d0*lipscale**2&
4017            *sss_ele_cut
4018
4019
4020 !
4021 ! Loop over residues i+1 thru j-1.
4022 !
4023 !grad          do k=i+1,j-1
4024 !grad            do l=1,3
4025 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4026 !grad            enddo
4027 !grad          enddo
4028           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
4029            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4030           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
4031            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4032           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
4033            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4034
4035 !          do k=1,3
4036 !            ghalf=0.5D0*ggg(k)
4037 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4038 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4039 !          enddo
4040 ! 9/28/08 AL Gradient compotents will be summed only at the end
4041           do k=1,3
4042             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4043             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4044           enddo
4045
4046 !C Lipidic part for scaling weight
4047            gvdwpp(3,j)=gvdwpp(3,j)+ &
4048           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4049            gvdwpp(3,i)=gvdwpp(3,i)+ &
4050           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4051 !! Loop over residues i+1 thru j-1.
4052 !
4053 !grad          do k=i+1,j-1
4054 !grad            do l=1,3
4055 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4056 !grad            enddo
4057 !grad          enddo
4058 #else
4059           facvdw=(ev1+evdwij)*sss_ele_cut &
4060            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4061
4062           facel=(el1+eesij)*sss_ele_cut
4063           fac1=fac
4064           fac=-3*rrmij*(facvdw+facvdw+facel)
4065           erij(1)=xj*rmij
4066           erij(2)=yj*rmij
4067           erij(3)=zj*rmij
4068 !
4069 ! Radial derivatives. First process both termini of the fragment (i,j)
4070 !
4071           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
4072           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
4073           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
4074 !          do k=1,3
4075 !            ghalf=0.5D0*ggg(k)
4076 !            gelc(k,i)=gelc(k,i)+ghalf
4077 !            gelc(k,j)=gelc(k,j)+ghalf
4078 !          enddo
4079 ! 9/28/08 AL Gradient compotents will be summed only at the end
4080           do k=1,3
4081             gelc_long(k,j)=gelc(k,j)+ggg(k)
4082             gelc_long(k,i)=gelc(k,i)-ggg(k)
4083           enddo
4084 !
4085 ! Loop over residues i+1 thru j-1.
4086 !
4087 !grad          do k=i+1,j-1
4088 !grad            do l=1,3
4089 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4090 !grad            enddo
4091 !grad          enddo
4092 ! 9/28/08 AL Gradient compotents will be summed only at the end
4093           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
4094            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4095           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
4096            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4097           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
4098            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4099
4100           do k=1,3
4101             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4102             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4103           enddo
4104            gvdwpp(3,j)=gvdwpp(3,j)+ &
4105           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4106            gvdwpp(3,i)=gvdwpp(3,i)+ &
4107           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4108
4109 #endif
4110 !
4111 ! Angular part
4112 !
4113           ecosa=2.0D0*fac3*fac1+fac4
4114           fac4=-3.0D0*fac4
4115           fac3=-6.0D0*fac3
4116           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4117           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4118           do k=1,3
4119             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4120             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4121           enddo
4122 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4123 !d   &          (dcosg(k),k=1,3)
4124           do k=1,3
4125             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4126              *fac_shield(i)**2*fac_shield(j)**2 &
4127              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4128
4129           enddo
4130 !          do k=1,3
4131 !            ghalf=0.5D0*ggg(k)
4132 !            gelc(k,i)=gelc(k,i)+ghalf
4133 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4134 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4135 !            gelc(k,j)=gelc(k,j)+ghalf
4136 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4137 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4138 !          enddo
4139 !grad          do k=i+1,j-1
4140 !grad            do l=1,3
4141 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4142 !grad            enddo
4143 !grad          enddo
4144           do k=1,3
4145             gelc(k,i)=gelc(k,i) &
4146                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4147                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4148                      *sss_ele_cut &
4149                      *fac_shield(i)**2*fac_shield(j)**2 &
4150                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4151
4152             gelc(k,j)=gelc(k,j) &
4153                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4154                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4155                      *sss_ele_cut  &
4156                      *fac_shield(i)**2*fac_shield(j)**2  &
4157                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4158
4159             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4160             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4161           enddo
4162
4163           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4164               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4165               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4166 !
4167 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4168 !   energy of a peptide unit is assumed in the form of a second-order
4169 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4170 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4171 !   are computed for EVERY pair of non-contiguous peptide groups.
4172 !
4173           if (j.lt.nres-1) then
4174             j1=j+1
4175             j2=j-1
4176           else
4177             j1=j-1
4178             j2=j-2
4179           endif
4180           kkk=0
4181           do k=1,2
4182             do l=1,2
4183               kkk=kkk+1
4184               muij(kkk)=mu(k,i)*mu(l,j)
4185 #ifdef NEWCORR
4186              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4187 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4188              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4189              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4190 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4191              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4192 #endif
4193
4194             enddo
4195           enddo
4196 !d         write (iout,*) 'EELEC: i',i,' j',j
4197 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4198 !d          write(iout,*) 'muij',muij
4199           ury=scalar(uy(1,i),erij)
4200           urz=scalar(uz(1,i),erij)
4201           vry=scalar(uy(1,j),erij)
4202           vrz=scalar(uz(1,j),erij)
4203           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4204           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4205           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4206           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4207           fac=dsqrt(-ael6i)*r3ij
4208           a22=a22*fac
4209           a23=a23*fac
4210           a32=a32*fac
4211           a33=a33*fac
4212 !d          write (iout,'(4i5,4f10.5)')
4213 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4214 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4215 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4216 !d     &      uy(:,j),uz(:,j)
4217 !d          write (iout,'(4f10.5)')
4218 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4219 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4220 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4221 !d           write (iout,'(9f10.5/)')
4222 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4223 ! Derivatives of the elements of A in virtual-bond vectors
4224           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4225           do k=1,3
4226             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4227             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4228             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4229             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4230             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4231             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4232             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4233             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4234             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4235             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4236             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4237             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4238           enddo
4239 ! Compute radial contributions to the gradient
4240           facr=-3.0d0*rrmij
4241           a22der=a22*facr
4242           a23der=a23*facr
4243           a32der=a32*facr
4244           a33der=a33*facr
4245           agg(1,1)=a22der*xj
4246           agg(2,1)=a22der*yj
4247           agg(3,1)=a22der*zj
4248           agg(1,2)=a23der*xj
4249           agg(2,2)=a23der*yj
4250           agg(3,2)=a23der*zj
4251           agg(1,3)=a32der*xj
4252           agg(2,3)=a32der*yj
4253           agg(3,3)=a32der*zj
4254           agg(1,4)=a33der*xj
4255           agg(2,4)=a33der*yj
4256           agg(3,4)=a33der*zj
4257 ! Add the contributions coming from er
4258           fac3=-3.0d0*fac
4259           do k=1,3
4260             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4261             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4262             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4263             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4264           enddo
4265           do k=1,3
4266 ! Derivatives in DC(i)
4267 !grad            ghalf1=0.5d0*agg(k,1)
4268 !grad            ghalf2=0.5d0*agg(k,2)
4269 !grad            ghalf3=0.5d0*agg(k,3)
4270 !grad            ghalf4=0.5d0*agg(k,4)
4271             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4272             -3.0d0*uryg(k,2)*vry)!+ghalf1
4273             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4274             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4275             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4276             -3.0d0*urzg(k,2)*vry)!+ghalf3
4277             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4278             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4279 ! Derivatives in DC(i+1)
4280             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4281             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4282             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4283             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4284             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4285             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4286             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4287             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4288 ! Derivatives in DC(j)
4289             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4290             -3.0d0*vryg(k,2)*ury)!+ghalf1
4291             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4292             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4293             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4294             -3.0d0*vryg(k,2)*urz)!+ghalf3
4295             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4296             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4297 ! Derivatives in DC(j+1) or DC(nres-1)
4298             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4299             -3.0d0*vryg(k,3)*ury)
4300             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4301             -3.0d0*vrzg(k,3)*ury)
4302             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4303             -3.0d0*vryg(k,3)*urz)
4304             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4305             -3.0d0*vrzg(k,3)*urz)
4306 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4307 !grad              do l=1,4
4308 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4309 !grad              enddo
4310 !grad            endif
4311           enddo
4312           acipa(1,1)=a22
4313           acipa(1,2)=a23
4314           acipa(2,1)=a32
4315           acipa(2,2)=a33
4316           a22=-a22
4317           a23=-a23
4318           do l=1,2
4319             do k=1,3
4320               agg(k,l)=-agg(k,l)
4321               aggi(k,l)=-aggi(k,l)
4322               aggi1(k,l)=-aggi1(k,l)
4323               aggj(k,l)=-aggj(k,l)
4324               aggj1(k,l)=-aggj1(k,l)
4325             enddo
4326           enddo
4327           if (j.lt.nres-1) then
4328             a22=-a22
4329             a32=-a32
4330             do l=1,3,2
4331               do k=1,3
4332                 agg(k,l)=-agg(k,l)
4333                 aggi(k,l)=-aggi(k,l)
4334                 aggi1(k,l)=-aggi1(k,l)
4335                 aggj(k,l)=-aggj(k,l)
4336                 aggj1(k,l)=-aggj1(k,l)
4337               enddo
4338             enddo
4339           else
4340             a22=-a22
4341             a23=-a23
4342             a32=-a32
4343             a33=-a33
4344             do l=1,4
4345               do k=1,3
4346                 agg(k,l)=-agg(k,l)
4347                 aggi(k,l)=-aggi(k,l)
4348                 aggi1(k,l)=-aggi1(k,l)
4349                 aggj(k,l)=-aggj(k,l)
4350                 aggj1(k,l)=-aggj1(k,l)
4351               enddo
4352             enddo
4353           endif
4354           ENDIF ! WCORR
4355           IF (wel_loc.gt.0.0d0) THEN
4356 ! Contribution to the local-electrostatic energy coming from the i-j pair
4357           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4358            +a33*muij(4)
4359           if (shield_mode.eq.0) then
4360            fac_shield(i)=1.0
4361            fac_shield(j)=1.0
4362           endif
4363           eel_loc_ij=eel_loc_ij &
4364          *fac_shield(i)*fac_shield(j) &
4365          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4366 !C Now derivative over eel_loc
4367           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4368          (shield_mode.gt.0)) then
4369 !C          print *,i,j
4370
4371           do ilist=1,ishield_list(i)
4372            iresshield=shield_list(ilist,i)
4373            do k=1,3
4374            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4375                                                 /fac_shield(i)&
4376            *sss_ele_cut
4377            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4378                    rlocshield  &
4379           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4380           *sss_ele_cut
4381
4382             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4383            +rlocshield
4384            enddo
4385           enddo
4386           do ilist=1,ishield_list(j)
4387            iresshield=shield_list(ilist,j)
4388            do k=1,3
4389            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4390                                             /fac_shield(j)   &
4391             *sss_ele_cut
4392            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4393                    rlocshield  &
4394       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4395        *sss_ele_cut
4396
4397            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4398                   +rlocshield
4399
4400            enddo
4401           enddo
4402
4403           do k=1,3
4404             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4405                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4406                     *sss_ele_cut
4407             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4408                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4409                     *sss_ele_cut
4410             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4411                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4412                     *sss_ele_cut
4413             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4414                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4415                     *sss_ele_cut
4416
4417            enddo
4418            endif
4419
4420 #ifdef NEWCORR
4421          geel_loc_ij=(a22*gmuij1(1)&
4422           +a23*gmuij1(2)&
4423           +a32*gmuij1(3)&
4424           +a33*gmuij1(4))&
4425          *fac_shield(i)*fac_shield(j)&
4426                     *sss_ele_cut     &
4427          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4428
4429
4430 !c         write(iout,*) "derivative over thatai"
4431 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4432 !c     &   a33*gmuij1(4)
4433          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4434            geel_loc_ij*wel_loc
4435 !c         write(iout,*) "derivative over thatai-1"
4436 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4437 !c     &   a33*gmuij2(4)
4438          geel_loc_ij=&
4439           a22*gmuij2(1)&
4440           +a23*gmuij2(2)&
4441           +a32*gmuij2(3)&
4442           +a33*gmuij2(4)
4443          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4444            geel_loc_ij*wel_loc&
4445          *fac_shield(i)*fac_shield(j)&
4446                     *sss_ele_cut &
4447          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4448
4449
4450 !c  Derivative over j residue
4451          geel_loc_ji=a22*gmuji1(1)&
4452           +a23*gmuji1(2)&
4453           +a32*gmuji1(3)&
4454           +a33*gmuji1(4)
4455 !c         write(iout,*) "derivative over thataj"
4456 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4457 !c     &   a33*gmuji1(4)
4458
4459         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4460            geel_loc_ji*wel_loc&
4461          *fac_shield(i)*fac_shield(j)&
4462                     *sss_ele_cut &
4463          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4464
4465
4466          geel_loc_ji=&
4467           +a22*gmuji2(1)&
4468           +a23*gmuji2(2)&
4469           +a32*gmuji2(3)&
4470           +a33*gmuji2(4)
4471 !c         write(iout,*) "derivative over thataj-1"
4472 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4473 !c     &   a33*gmuji2(4)
4474          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4475            geel_loc_ji*wel_loc&
4476          *fac_shield(i)*fac_shield(j)&
4477                     *sss_ele_cut &
4478          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4479
4480 #endif
4481
4482 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4483 !           eel_loc_ij=0.0
4484 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4485 !                  'eelloc',i,j,eel_loc_ij
4486           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4487                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4488 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4489
4490 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4491 !          if (energy_dec) write (iout,*) "muij",muij
4492 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4493
4494           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4495 ! Partial derivatives in virtual-bond dihedral angles gamma
4496           if (i.gt.1) &
4497           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4498                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4499                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4500                  *sss_ele_cut  &
4501           *fac_shield(i)*fac_shield(j) &
4502           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4503
4504           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4505                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4506                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4507                  *sss_ele_cut &
4508           *fac_shield(i)*fac_shield(j) &
4509           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4510 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4511 !          do l=1,3
4512 !            ggg(1)=(agg(1,1)*muij(1)+ &
4513 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4514 !            *sss_ele_cut &
4515 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4516 !            ggg(2)=(agg(2,1)*muij(1)+ &
4517 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4518 !            *sss_ele_cut &
4519 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4520 !            ggg(3)=(agg(3,1)*muij(1)+ &
4521 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4522 !            *sss_ele_cut &
4523 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4524            xtemp(1)=xj
4525            xtemp(2)=yj
4526            xtemp(3)=zj
4527
4528            do l=1,3
4529             ggg(l)=(agg(l,1)*muij(1)+ &
4530                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4531             *sss_ele_cut &
4532           *fac_shield(i)*fac_shield(j) &
4533           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4534              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4535
4536
4537             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4538             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4539 !grad            ghalf=0.5d0*ggg(l)
4540 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4541 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4542           enddo
4543             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4544           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4545           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4546
4547             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4548           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4549           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4550
4551 !grad          do k=i+1,j2
4552 !grad            do l=1,3
4553 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4554 !grad            enddo
4555 !grad          enddo
4556 ! Remaining derivatives of eello
4557           do l=1,3
4558             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4559                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4560             *sss_ele_cut &
4561           *fac_shield(i)*fac_shield(j) &
4562           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4563
4564 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4565             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4566                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4567             +aggi1(l,4)*muij(4))&
4568             *sss_ele_cut &
4569           *fac_shield(i)*fac_shield(j) &
4570           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4571
4572 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4573             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4574                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4575             *sss_ele_cut &
4576           *fac_shield(i)*fac_shield(j) &
4577           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4578
4579 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4580             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4581                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4582             +aggj1(l,4)*muij(4))&
4583             *sss_ele_cut &
4584           *fac_shield(i)*fac_shield(j) &
4585          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4586
4587 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4588           enddo
4589           ENDIF
4590 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4591 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4592           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4593              .and. num_conti.le.maxconts) then
4594 !            write (iout,*) i,j," entered corr"
4595 !
4596 ! Calculate the contact function. The ith column of the array JCONT will
4597 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4598 ! greater than I). The arrays FACONT and GACONT will contain the values of
4599 ! the contact function and its derivative.
4600 !           r0ij=1.02D0*rpp(iteli,itelj)
4601 !           r0ij=1.11D0*rpp(iteli,itelj)
4602             r0ij=2.20D0*rpp(iteli,itelj)
4603 !           r0ij=1.55D0*rpp(iteli,itelj)
4604             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4605 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4606             if (fcont.gt.0.0D0) then
4607               num_conti=num_conti+1
4608               if (num_conti.gt.maxconts) then
4609 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4610 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4611                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4612                                ' will skip next contacts for this conf.', num_conti
4613               else
4614                 jcont_hb(num_conti,i)=j
4615 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4616 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4617                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4618                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4619 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4620 !  terms.
4621                 d_cont(num_conti,i)=rij
4622 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4623 !     --- Electrostatic-interaction matrix ---
4624                 a_chuj(1,1,num_conti,i)=a22
4625                 a_chuj(1,2,num_conti,i)=a23
4626                 a_chuj(2,1,num_conti,i)=a32
4627                 a_chuj(2,2,num_conti,i)=a33
4628 !     --- Gradient of rij
4629                 do kkk=1,3
4630                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4631                 enddo
4632                 kkll=0
4633                 do k=1,2
4634                   do l=1,2
4635                     kkll=kkll+1
4636                     do m=1,3
4637                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4638                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4639                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4640                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4641                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4642                     enddo
4643                   enddo
4644                 enddo
4645                 ENDIF
4646                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4647 ! Calculate contact energies
4648                 cosa4=4.0D0*cosa
4649                 wij=cosa-3.0D0*cosb*cosg
4650                 cosbg1=cosb+cosg
4651                 cosbg2=cosb-cosg
4652 !               fac3=dsqrt(-ael6i)/r0ij**3
4653                 fac3=dsqrt(-ael6i)*r3ij
4654 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4655                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4656                 if (ees0tmp.gt.0) then
4657                   ees0pij=dsqrt(ees0tmp)
4658                 else
4659                   ees0pij=0
4660                 endif
4661                 if (shield_mode.eq.0) then
4662                 fac_shield(i)=1.0d0
4663                 fac_shield(j)=1.0d0
4664                 else
4665                 ees0plist(num_conti,i)=j
4666                 endif
4667 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4668                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4669                 if (ees0tmp.gt.0) then
4670                   ees0mij=dsqrt(ees0tmp)
4671                 else
4672                   ees0mij=0
4673                 endif
4674 !               ees0mij=0.0D0
4675                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4676                      *sss_ele_cut &
4677                      *fac_shield(i)*fac_shield(j)
4678 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4679
4680                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4681                      *sss_ele_cut &
4682                      *fac_shield(i)*fac_shield(j)
4683 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4684
4685 ! Diagnostics. Comment out or remove after debugging!
4686 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4687 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4688 !               ees0m(num_conti,i)=0.0D0
4689 ! End diagnostics.
4690 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4691 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4692 ! Angular derivatives of the contact function
4693                 ees0pij1=fac3/ees0pij
4694                 ees0mij1=fac3/ees0mij
4695                 fac3p=-3.0D0*fac3*rrmij
4696                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4697                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4698 !               ees0mij1=0.0D0
4699                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4700                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4701                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4702                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4703                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4704                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4705                 ecosap=ecosa1+ecosa2
4706                 ecosbp=ecosb1+ecosb2
4707                 ecosgp=ecosg1+ecosg2
4708                 ecosam=ecosa1-ecosa2
4709                 ecosbm=ecosb1-ecosb2
4710                 ecosgm=ecosg1-ecosg2
4711 ! Diagnostics
4712 !               ecosap=ecosa1
4713 !               ecosbp=ecosb1
4714 !               ecosgp=ecosg1
4715 !               ecosam=0.0D0
4716 !               ecosbm=0.0D0
4717 !               ecosgm=0.0D0
4718 ! End diagnostics
4719                 facont_hb(num_conti,i)=fcont
4720                 fprimcont=fprimcont/rij
4721 !d              facont_hb(num_conti,i)=1.0D0
4722 ! Following line is for diagnostics.
4723 !d              fprimcont=0.0D0
4724                 do k=1,3
4725                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4726                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4727                 enddo
4728                 do k=1,3
4729                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4730                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4731                 enddo
4732                 gggp(1)=gggp(1)+ees0pijp*xj &
4733                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4734                 gggp(2)=gggp(2)+ees0pijp*yj &
4735                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4736                 gggp(3)=gggp(3)+ees0pijp*zj &
4737                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4738
4739                 gggm(1)=gggm(1)+ees0mijp*xj &
4740                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4741
4742                 gggm(2)=gggm(2)+ees0mijp*yj &
4743                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4744
4745                 gggm(3)=gggm(3)+ees0mijp*zj &
4746                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4747
4748 ! Derivatives due to the contact function
4749                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4750                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4751                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4752                 do k=1,3
4753 !
4754 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4755 !          following the change of gradient-summation algorithm.
4756 !
4757 !grad                  ghalfp=0.5D0*gggp(k)
4758 !grad                  ghalfm=0.5D0*gggm(k)
4759                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4760                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4761                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4762                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4763 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4764
4765
4766                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4767                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4768                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4769                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4770 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4771
4772
4773                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4774                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4775 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4776
4777                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4778                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4779                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4780                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4781 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4782
4783                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4784                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4785                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4786                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4787 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4788
4789                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4790                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4791 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4792
4793                 enddo
4794 ! Diagnostics. Comment out or remove after debugging!
4795 !diag           do k=1,3
4796 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4797 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4798 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4799 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4800 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4801 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4802 !diag           enddo
4803               ENDIF ! wcorr
4804               endif  ! num_conti.le.maxconts
4805             endif  ! fcont.gt.0
4806           endif    ! j.gt.i+1
4807           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4808             do k=1,4
4809               do l=1,3
4810                 ghalf=0.5d0*agg(l,k)
4811                 aggi(l,k)=aggi(l,k)+ghalf
4812                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4813                 aggj(l,k)=aggj(l,k)+ghalf
4814               enddo
4815             enddo
4816             if (j.eq.nres-1 .and. i.lt.j-2) then
4817               do k=1,4
4818                 do l=1,3
4819                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4820                 enddo
4821               enddo
4822             endif
4823           endif
4824  128  continue
4825 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4826       return
4827       end subroutine eelecij
4828 !-----------------------------------------------------------------------------
4829       subroutine eturn3(i,eello_turn3)
4830 ! Third- and fourth-order contributions from turns
4831
4832       use comm_locel
4833 !      implicit real(kind=8) (a-h,o-z)
4834 !      include 'DIMENSIONS'
4835 !      include 'COMMON.IOUNITS'
4836 !      include 'COMMON.GEO'
4837 !      include 'COMMON.VAR'
4838 !      include 'COMMON.LOCAL'
4839 !      include 'COMMON.CHAIN'
4840 !      include 'COMMON.DERIV'
4841 !      include 'COMMON.INTERACT'
4842 !      include 'COMMON.CONTACTS'
4843 !      include 'COMMON.TORSION'
4844 !      include 'COMMON.VECTORS'
4845 !      include 'COMMON.FFIELD'
4846 !      include 'COMMON.CONTROL'
4847       real(kind=8),dimension(3) :: ggg
4848       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4849         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4850        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4851
4852       real(kind=8),dimension(2) :: auxvec,auxvec1
4853 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4854       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4855 !el      integer :: num_conti,j1,j2
4856 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4857 !el        dz_normi,xmedi,ymedi,zmedi
4858
4859 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4860 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4861 !el         num_conti,j1,j2
4862 !el local variables
4863       integer :: i,j,l,k,ilist,iresshield
4864       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj
4865       xj=0.0d0
4866       yj=0.0d0
4867       j=i+2
4868 !      write (iout,*) "eturn3",i,j,j1,j2
4869           zj=(c(3,j)+c(3,j+1))/2.0d0
4870             call to_box(xj,yj,zj)
4871             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4872
4873       a_temp(1,1)=a22
4874       a_temp(1,2)=a23
4875       a_temp(2,1)=a32
4876       a_temp(2,2)=a33
4877 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4878 !
4879 !               Third-order contributions
4880 !
4881 !                 (i+2)o----(i+3)
4882 !                      | |
4883 !                      | |
4884 !                 (i+1)o----i
4885 !
4886 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4887 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4888         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4889         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4890         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4891         call transpose2(auxmat(1,1),auxmat1(1,1))
4892         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4893         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4894         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4895         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4896         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4897
4898         if (shield_mode.eq.0) then
4899         fac_shield(i)=1.0d0
4900         fac_shield(j)=1.0d0
4901         endif
4902
4903         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4904          *fac_shield(i)*fac_shield(j)  &
4905          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4906         eello_t3= &
4907         0.5d0*(pizda(1,1)+pizda(2,2)) &
4908         *fac_shield(i)*fac_shield(j)
4909
4910         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4911                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4912 !C#ifdef NEWCORR
4913 !C Derivatives in theta
4914         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4915        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4916         *fac_shield(i)*fac_shield(j) &
4917         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4918
4919         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4920        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4921         *fac_shield(i)*fac_shield(j) &
4922         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4923
4924
4925 !C#endif
4926
4927
4928
4929           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4930        (shield_mode.gt.0)) then
4931 !C          print *,i,j
4932
4933           do ilist=1,ishield_list(i)
4934            iresshield=shield_list(ilist,i)
4935            do k=1,3
4936            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4937            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4938                    rlocshield &
4939            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4940             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4941              +rlocshield
4942            enddo
4943           enddo
4944           do ilist=1,ishield_list(j)
4945            iresshield=shield_list(ilist,j)
4946            do k=1,3
4947            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4948            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4949                    rlocshield &
4950            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4951            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4952                   +rlocshield
4953
4954            enddo
4955           enddo
4956
4957           do k=1,3
4958             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4959                    grad_shield(k,i)*eello_t3/fac_shield(i)
4960             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4961                    grad_shield(k,j)*eello_t3/fac_shield(j)
4962             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4963                    grad_shield(k,i)*eello_t3/fac_shield(i)
4964             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4965                    grad_shield(k,j)*eello_t3/fac_shield(j)
4966            enddo
4967            endif
4968
4969 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4970 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4971 !d     &    ' eello_turn3_num',4*eello_turn3_num
4972 ! Derivatives in gamma(i)
4973         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4974         call transpose2(auxmat2(1,1),auxmat3(1,1))
4975         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4976         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4977           *fac_shield(i)*fac_shield(j)        &
4978           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4979 ! Derivatives in gamma(i+1)
4980         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4981         call transpose2(auxmat2(1,1),auxmat3(1,1))
4982         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4983         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4984           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4985           *fac_shield(i)*fac_shield(j)        &
4986           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4987
4988 ! Cartesian derivatives
4989         do l=1,3
4990 !            ghalf1=0.5d0*agg(l,1)
4991 !            ghalf2=0.5d0*agg(l,2)
4992 !            ghalf3=0.5d0*agg(l,3)
4993 !            ghalf4=0.5d0*agg(l,4)
4994           a_temp(1,1)=aggi(l,1)!+ghalf1
4995           a_temp(1,2)=aggi(l,2)!+ghalf2
4996           a_temp(2,1)=aggi(l,3)!+ghalf3
4997           a_temp(2,2)=aggi(l,4)!+ghalf4
4998           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4999           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
5000             +0.5d0*(pizda(1,1)+pizda(2,2))  &
5001           *fac_shield(i)*fac_shield(j)      &
5002           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5003
5004           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5005           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5006           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5007           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5008           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5009           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
5010             +0.5d0*(pizda(1,1)+pizda(2,2))    &
5011           *fac_shield(i)*fac_shield(j)        &
5012           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5013
5014           a_temp(1,1)=aggj(l,1)!+ghalf1
5015           a_temp(1,2)=aggj(l,2)!+ghalf2
5016           a_temp(2,1)=aggj(l,3)!+ghalf3
5017           a_temp(2,2)=aggj(l,4)!+ghalf4
5018           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5019           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
5020             +0.5d0*(pizda(1,1)+pizda(2,2))  &
5021           *fac_shield(i)*fac_shield(j)      &
5022           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5023
5024           a_temp(1,1)=aggj1(l,1)
5025           a_temp(1,2)=aggj1(l,2)
5026           a_temp(2,1)=aggj1(l,3)
5027           a_temp(2,2)=aggj1(l,4)
5028           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5029           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
5030             +0.5d0*(pizda(1,1)+pizda(2,2))    &
5031           *fac_shield(i)*fac_shield(j)        &
5032           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5033         enddo
5034          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
5035           ssgradlipi*eello_t3/4.0d0*lipscale
5036          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
5037           ssgradlipj*eello_t3/4.0d0*lipscale
5038          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
5039           ssgradlipi*eello_t3/4.0d0*lipscale
5040          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
5041           ssgradlipj*eello_t3/4.0d0*lipscale
5042
5043       return
5044       end subroutine eturn3
5045 !-----------------------------------------------------------------------------
5046       subroutine eturn4(i,eello_turn4)
5047 ! Third- and fourth-order contributions from turns
5048
5049       use comm_locel
5050 !      implicit real(kind=8) (a-h,o-z)
5051 !      include 'DIMENSIONS'
5052 !      include 'COMMON.IOUNITS'
5053 !      include 'COMMON.GEO'
5054 !      include 'COMMON.VAR'
5055 !      include 'COMMON.LOCAL'
5056 !      include 'COMMON.CHAIN'
5057 !      include 'COMMON.DERIV'
5058 !      include 'COMMON.INTERACT'
5059 !      include 'COMMON.CONTACTS'
5060 !      include 'COMMON.TORSION'
5061 !      include 'COMMON.VECTORS'
5062 !      include 'COMMON.FFIELD'
5063 !      include 'COMMON.CONTROL'
5064       real(kind=8),dimension(3) :: ggg
5065       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
5066         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
5067         gte1t,gte2t,gte3t,&
5068         gte1a,gtae3,gtae3e2, ae3gte2,&
5069         gtEpizda1,gtEpizda2,gtEpizda3
5070
5071       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
5072        auxgEvec3,auxgvec
5073
5074 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
5075       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
5076 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
5077 !el        dz_normi,xmedi,ymedi,zmedi
5078 !el      integer :: num_conti,j1,j2
5079 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
5080 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
5081 !el          num_conti,j1,j2
5082 !el local variables
5083       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
5084       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
5085          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj
5086       xj=0.0d0
5087       yj=0.0d0
5088       j=i+3
5089 !      if (j.ne.20) return
5090 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5091 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5092 !
5093 !               Fourth-order contributions
5094 !
5095 !                 (i+3)o----(i+4)
5096 !                     /  |
5097 !               (i+2)o   |
5098 !                     \  |
5099 !                 (i+1)o----i
5100 !
5101 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5102 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5103 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5104           zj=(c(3,j)+c(3,j+1))/2.0d0
5105             call to_box(xj,yj,zj)
5106             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
5107
5108
5109         a_temp(1,1)=a22
5110         a_temp(1,2)=a23
5111         a_temp(2,1)=a32
5112         a_temp(2,2)=a33
5113         iti1=i+1
5114         iti2=i+2
5115         iti3=i+3
5116 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5117         call transpose2(EUg(1,1,i+1),e1t(1,1))
5118         call transpose2(Eug(1,1,i+2),e2t(1,1))
5119         call transpose2(Eug(1,1,i+3),e3t(1,1))
5120 !C Ematrix derivative in theta
5121         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5122         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5123         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5124
5125         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5126         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5127         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5128         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5129 !c       auxalary matrix of E i+1
5130         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5131         s1=scalar2(b1(1,iti2),auxvec(1))
5132 !c derivative of theta i+2 with constant i+3
5133         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5134 !c derivative of theta i+2 with constant i+2
5135         gs32=scalar2(b1(1,i+2),auxgvec(1))
5136 !c derivative of E matix in theta of i+1
5137         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5138
5139         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5140         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5141         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5142 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5143         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5144 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5145         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5146         s2=scalar2(b1(1,i+1),auxvec(1))
5147 !c derivative of theta i+1 with constant i+3
5148         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5149 !c derivative of theta i+2 with constant i+1
5150         gs21=scalar2(b1(1,i+1),auxgvec(1))
5151 !c derivative of theta i+3 with constant i+1
5152         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5153
5154         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5155         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5156 !c ae3gte2 is derivative over i+2
5157         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5158
5159         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5160         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5161 !c i+2
5162         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5163 !c i+3
5164         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5165
5166         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5167         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5168         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5169         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5170         if (shield_mode.eq.0) then
5171         fac_shield(i)=1.0
5172         fac_shield(j)=1.0
5173         endif
5174
5175         eello_turn4=eello_turn4-(s1+s2+s3) &
5176         *fac_shield(i)*fac_shield(j)       &
5177         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5178         eello_t4=-(s1+s2+s3)  &
5179           *fac_shield(i)*fac_shield(j)
5180 !C Now derivative over shield:
5181           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5182          (shield_mode.gt.0)) then
5183 !C          print *,i,j
5184
5185           do ilist=1,ishield_list(i)
5186            iresshield=shield_list(ilist,i)
5187            do k=1,3
5188            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5189 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5190            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5191                    rlocshield &
5192             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5193             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5194            +rlocshield
5195            enddo
5196           enddo
5197           do ilist=1,ishield_list(j)
5198            iresshield=shield_list(ilist,j)
5199            do k=1,3
5200 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5201            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5202            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5203                    rlocshield  &
5204            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5205            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5206                   +rlocshield
5207 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5208
5209            enddo
5210           enddo
5211           do k=1,3
5212             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5213                    grad_shield(k,i)*eello_t4/fac_shield(i)
5214             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5215                    grad_shield(k,j)*eello_t4/fac_shield(j)
5216             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5217                    grad_shield(k,i)*eello_t4/fac_shield(i)
5218             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5219                    grad_shield(k,j)*eello_t4/fac_shield(j)
5220 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5221            enddo
5222            endif
5223 #ifdef NEWCORR
5224         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5225                        -(gs13+gsE13+gsEE1)*wturn4&
5226        *fac_shield(i)*fac_shield(j) &
5227        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5228
5229         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5230                          -(gs23+gs21+gsEE2)*wturn4&
5231        *fac_shield(i)*fac_shield(j)&
5232        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5233
5234         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5235                          -(gs32+gsE31+gsEE3)*wturn4&
5236        *fac_shield(i)*fac_shield(j)&
5237        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5238
5239
5240 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5241 !c     &   gs2
5242 #endif
5243         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5244            'eturn4',i,j,-(s1+s2+s3)
5245 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5246 !d     &    ' eello_turn4_num',8*eello_turn4_num
5247 ! Derivatives in gamma(i)
5248         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5249         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5250         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5251         s1=scalar2(b1(1,i+1),auxvec(1))
5252         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5253         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5254         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5255        *fac_shield(i)*fac_shield(j)  &
5256        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5257
5258 ! Derivatives in gamma(i+1)
5259         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5260         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5261         s2=scalar2(b1(1,iti1),auxvec(1))
5262         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5263         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5264         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5265         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5266        *fac_shield(i)*fac_shield(j)  &
5267        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5268
5269 ! Derivatives in gamma(i+2)
5270         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5271         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5272         s1=scalar2(b1(1,iti2),auxvec(1))
5273         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5274         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5275         s2=scalar2(b1(1,iti1),auxvec(1))
5276         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5277         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5278         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5279         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5280        *fac_shield(i)*fac_shield(j)  &
5281        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5282
5283 ! Cartesian derivatives
5284 ! Derivatives of this turn contributions in DC(i+2)
5285         if (j.lt.nres-1) then
5286           do l=1,3
5287             a_temp(1,1)=agg(l,1)
5288             a_temp(1,2)=agg(l,2)
5289             a_temp(2,1)=agg(l,3)
5290             a_temp(2,2)=agg(l,4)
5291             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5292             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5293             s1=scalar2(b1(1,iti2),auxvec(1))
5294             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5295             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5296             s2=scalar2(b1(1,iti1),auxvec(1))
5297             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5298             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5299             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5300             ggg(l)=-(s1+s2+s3)
5301             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5302        *fac_shield(i)*fac_shield(j)  &
5303        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5304
5305           enddo
5306         endif
5307 ! Remaining derivatives of this turn contribution
5308         do l=1,3
5309           a_temp(1,1)=aggi(l,1)
5310           a_temp(1,2)=aggi(l,2)
5311           a_temp(2,1)=aggi(l,3)
5312           a_temp(2,2)=aggi(l,4)
5313           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5314           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5315           s1=scalar2(b1(1,iti2),auxvec(1))
5316           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5317           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5318           s2=scalar2(b1(1,iti1),auxvec(1))
5319           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5320           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5321           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5322           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5323          *fac_shield(i)*fac_shield(j)  &
5324          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5325
5326
5327           a_temp(1,1)=aggi1(l,1)
5328           a_temp(1,2)=aggi1(l,2)
5329           a_temp(2,1)=aggi1(l,3)
5330           a_temp(2,2)=aggi1(l,4)
5331           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5332           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5333           s1=scalar2(b1(1,iti2),auxvec(1))
5334           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5335           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5336           s2=scalar2(b1(1,iti1),auxvec(1))
5337           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5338           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5339           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5340           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5341          *fac_shield(i)*fac_shield(j)  &
5342          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5343
5344
5345           a_temp(1,1)=aggj(l,1)
5346           a_temp(1,2)=aggj(l,2)
5347           a_temp(2,1)=aggj(l,3)
5348           a_temp(2,2)=aggj(l,4)
5349           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5350           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5351           s1=scalar2(b1(1,iti2),auxvec(1))
5352           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5353           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5354           s2=scalar2(b1(1,iti1),auxvec(1))
5355           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5356           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5357           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5358 !        if (j.lt.nres-1) then
5359           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5360          *fac_shield(i)*fac_shield(j)  &
5361          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5362 !        endif
5363
5364           a_temp(1,1)=aggj1(l,1)
5365           a_temp(1,2)=aggj1(l,2)
5366           a_temp(2,1)=aggj1(l,3)
5367           a_temp(2,2)=aggj1(l,4)
5368           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5369           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5370           s1=scalar2(b1(1,iti2),auxvec(1))
5371           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5372           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5373           s2=scalar2(b1(1,iti1),auxvec(1))
5374           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5375           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5376           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5377 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5378 !        if (j.lt.nres-1) then
5379 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5380           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5381          *fac_shield(i)*fac_shield(j)  &
5382          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5383 !            if (shield_mode.gt.0) then
5384 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5385 !            else
5386 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5387 !            endif
5388 !         endif
5389         enddo
5390          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5391           ssgradlipi*eello_t4/4.0d0*lipscale
5392          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5393           ssgradlipj*eello_t4/4.0d0*lipscale
5394          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5395           ssgradlipi*eello_t4/4.0d0*lipscale
5396          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5397           ssgradlipj*eello_t4/4.0d0*lipscale
5398
5399       return
5400       end subroutine eturn4
5401 !-----------------------------------------------------------------------------
5402       subroutine unormderiv(u,ugrad,unorm,ungrad)
5403 ! This subroutine computes the derivatives of a normalized vector u, given
5404 ! the derivatives computed without normalization conditions, ugrad. Returns
5405 ! ungrad.
5406 !      implicit none
5407       real(kind=8),dimension(3) :: u,vec
5408       real(kind=8),dimension(3,3) ::ugrad,ungrad
5409       real(kind=8) :: unorm      !,scalar
5410       integer :: i,j
5411 !      write (2,*) 'ugrad',ugrad
5412 !      write (2,*) 'u',u
5413       do i=1,3
5414         vec(i)=scalar(ugrad(1,i),u(1))
5415       enddo
5416 !      write (2,*) 'vec',vec
5417       do i=1,3
5418         do j=1,3
5419           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5420         enddo
5421       enddo
5422 !      write (2,*) 'ungrad',ungrad
5423       return
5424       end subroutine unormderiv
5425 !-----------------------------------------------------------------------------
5426       subroutine escp_soft_sphere(evdw2,evdw2_14)
5427 !
5428 ! This subroutine calculates the excluded-volume interaction energy between
5429 ! peptide-group centers and side chains and its gradient in virtual-bond and
5430 ! side-chain vectors.
5431 !
5432 !      implicit real(kind=8) (a-h,o-z)
5433 !      include 'DIMENSIONS'
5434 !      include 'COMMON.GEO'
5435 !      include 'COMMON.VAR'
5436 !      include 'COMMON.LOCAL'
5437 !      include 'COMMON.CHAIN'
5438 !      include 'COMMON.DERIV'
5439 !      include 'COMMON.INTERACT'
5440 !      include 'COMMON.FFIELD'
5441 !      include 'COMMON.IOUNITS'
5442 !      include 'COMMON.CONTROL'
5443       real(kind=8),dimension(3) :: ggg
5444 !el local variables
5445       integer :: i,iint,j,k,iteli,itypj
5446       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5447                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5448
5449       evdw2=0.0D0
5450       evdw2_14=0.0d0
5451       r0_scp=4.5d0
5452 !d    print '(a)','Enter ESCP'
5453 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5454       do i=iatscp_s,iatscp_e
5455         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5456         iteli=itel(i)
5457         xi=0.5D0*(c(1,i)+c(1,i+1))
5458         yi=0.5D0*(c(2,i)+c(2,i+1))
5459         zi=0.5D0*(c(3,i)+c(3,i+1))
5460           call to_box(xi,yi,zi)
5461
5462         do iint=1,nscp_gr(i)
5463
5464         do j=iscpstart(i,iint),iscpend(i,iint)
5465           if (itype(j,1).eq.ntyp1) cycle
5466           itypj=iabs(itype(j,1))
5467 ! Uncomment following three lines for SC-p interactions
5468 !         xj=c(1,nres+j)-xi
5469 !         yj=c(2,nres+j)-yi
5470 !         zj=c(3,nres+j)-zi
5471 ! Uncomment following three lines for Ca-p interactions
5472           xj=c(1,j)-xi
5473           yj=c(2,j)-yi
5474           zj=c(3,j)-zi
5475           call to_box(xj,yj,zj)
5476           xj=boxshift(xj-xi,boxxsize)
5477           yj=boxshift(yj-yi,boxysize)
5478           zj=boxshift(zj-zi,boxzsize)
5479           rij=xj*xj+yj*yj+zj*zj
5480           r0ij=r0_scp
5481           r0ijsq=r0ij*r0ij
5482           if (rij.lt.r0ijsq) then
5483             evdwij=0.25d0*(rij-r0ijsq)**2
5484             fac=rij-r0ijsq
5485           else
5486             evdwij=0.0d0
5487             fac=0.0d0
5488           endif
5489           evdw2=evdw2+evdwij
5490 !
5491 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5492 !
5493           ggg(1)=xj*fac
5494           ggg(2)=yj*fac
5495           ggg(3)=zj*fac
5496 !grad          if (j.lt.i) then
5497 !d          write (iout,*) 'j<i'
5498 ! Uncomment following three lines for SC-p interactions
5499 !           do k=1,3
5500 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5501 !           enddo
5502 !grad          else
5503 !d          write (iout,*) 'j>i'
5504 !grad            do k=1,3
5505 !grad              ggg(k)=-ggg(k)
5506 ! Uncomment following line for SC-p interactions
5507 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5508 !grad            enddo
5509 !grad          endif
5510 !grad          do k=1,3
5511 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5512 !grad          enddo
5513 !grad          kstart=min0(i+1,j)
5514 !grad          kend=max0(i-1,j-1)
5515 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5516 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5517 !grad          do k=kstart,kend
5518 !grad            do l=1,3
5519 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5520 !grad            enddo
5521 !grad          enddo
5522           do k=1,3
5523             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5524             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5525           enddo
5526         enddo
5527
5528         enddo ! iint
5529       enddo ! i
5530       return
5531       end subroutine escp_soft_sphere
5532 !-----------------------------------------------------------------------------
5533       subroutine escp(evdw2,evdw2_14)
5534 !
5535 ! This subroutine calculates the excluded-volume interaction energy between
5536 ! peptide-group centers and side chains and its gradient in virtual-bond and
5537 ! side-chain vectors.
5538 !
5539 !      implicit real(kind=8) (a-h,o-z)
5540 !      include 'DIMENSIONS'
5541 !      include 'COMMON.GEO'
5542 !      include 'COMMON.VAR'
5543 !      include 'COMMON.LOCAL'
5544 !      include 'COMMON.CHAIN'
5545 !      include 'COMMON.DERIV'
5546 !      include 'COMMON.INTERACT'
5547 !      include 'COMMON.FFIELD'
5548 !      include 'COMMON.IOUNITS'
5549 !      include 'COMMON.CONTROL'
5550       real(kind=8),dimension(3) :: ggg
5551 !el local variables
5552       integer :: i,iint,j,k,iteli,itypj,subchap,iconta
5553       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5554                    e1,e2,evdwij,rij
5555       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5556                     dist_temp, dist_init
5557       integer xshift,yshift,zshift
5558
5559       evdw2=0.0D0
5560       evdw2_14=0.0d0
5561 !d    print '(a)','Enter ESCP'
5562 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5563 !      do i=iatscp_s,iatscp_e
5564       if (nres_molec(1).eq.0) return
5565        do iconta=g_listscp_start,g_listscp_end
5566 !        print *,"icont",iconta,g_listscp_start,g_listscp_end
5567         i=newcontlistscpi(iconta)
5568         j=newcontlistscpj(iconta)
5569         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5570         iteli=itel(i)
5571         xi=0.5D0*(c(1,i)+c(1,i+1))
5572         yi=0.5D0*(c(2,i)+c(2,i+1))
5573         zi=0.5D0*(c(3,i)+c(3,i+1))
5574         call to_box(xi,yi,zi)
5575 !        print *,itel(i),i,j
5576 !        do iint=1,nscp_gr(i)
5577
5578 !        do j=iscpstart(i,iint),iscpend(i,iint)
5579           itypj=iabs(itype(j,1))
5580           if (itypj.eq.ntyp1) cycle
5581 ! Uncomment following three lines for SC-p interactions
5582 !         xj=c(1,nres+j)-xi
5583 !         yj=c(2,nres+j)-yi
5584 !         zj=c(3,nres+j)-zi
5585 ! Uncomment following three lines for Ca-p interactions
5586 !          xj=c(1,j)-xi
5587 !          yj=c(2,j)-yi
5588 !          zj=c(3,j)-zi
5589           xj=c(1,j)
5590           yj=c(2,j)
5591           zj=c(3,j)
5592
5593           call to_box(xj,yj,zj)
5594           xj=boxshift(xj-xi,boxxsize)
5595           yj=boxshift(yj-yi,boxysize)
5596           zj=boxshift(zj-zi,boxzsize)
5597
5598           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5599           rij=dsqrt(1.0d0/rrij)
5600             sss_ele_cut=sscale_ele(rij)
5601             sss_ele_grad=sscagrad_ele(rij)
5602 !            print *,sss_ele_cut,sss_ele_grad,&
5603 !            (rij),r_cut_ele,rlamb_ele
5604             if (sss_ele_cut.le.0.0) cycle
5605           fac=rrij**expon2
5606           e1=fac*fac*aad(itypj,iteli)
5607           e2=fac*bad(itypj,iteli)
5608           if (iabs(j-i) .le. 2) then
5609             e1=scal14*e1
5610             e2=scal14*e2
5611             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5612           endif
5613           evdwij=e1+e2
5614           evdw2=evdw2+evdwij*sss_ele_cut
5615 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5616 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5617           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5618              'evdw2',i,j,evdwij
5619 !
5620 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5621 !
5622           fac=-(evdwij+e1)*rrij*sss_ele_cut
5623           fac=fac+evdwij*sss_ele_grad/rij/expon
5624           ggg(1)=xj*fac
5625           ggg(2)=yj*fac
5626           ggg(3)=zj*fac
5627 !grad          if (j.lt.i) then
5628 !d          write (iout,*) 'j<i'
5629 ! Uncomment following three lines for SC-p interactions
5630 !           do k=1,3
5631 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5632 !           enddo
5633 !grad          else
5634 !d          write (iout,*) 'j>i'
5635 !grad            do k=1,3
5636 !grad              ggg(k)=-ggg(k)
5637 ! Uncomment following line for SC-p interactions
5638 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5639 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5640 !grad            enddo
5641 !grad          endif
5642 !grad          do k=1,3
5643 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5644 !grad          enddo
5645 !grad          kstart=min0(i+1,j)
5646 !grad          kend=max0(i-1,j-1)
5647 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5648 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5649 !grad          do k=kstart,kend
5650 !grad            do l=1,3
5651 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5652 !grad            enddo
5653 !grad          enddo
5654           do k=1,3
5655             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5656             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5657           enddo
5658 !        enddo
5659
5660 !        enddo ! iint
5661       enddo ! i
5662       do i=1,nct
5663         do j=1,3
5664           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5665           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5666           gradx_scp(j,i)=expon*gradx_scp(j,i)
5667         enddo
5668       enddo
5669 !******************************************************************************
5670 !
5671 !                              N O T E !!!
5672 !
5673 ! To save time the factor EXPON has been extracted from ALL components
5674 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5675 ! use!
5676 !
5677 !******************************************************************************
5678       return
5679       end subroutine escp
5680 !-----------------------------------------------------------------------------
5681       subroutine edis(ehpb)
5682 !
5683 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5684 !
5685 !      implicit real(kind=8) (a-h,o-z)
5686 !      include 'DIMENSIONS'
5687 !      include 'COMMON.SBRIDGE'
5688 !      include 'COMMON.CHAIN'
5689 !      include 'COMMON.DERIV'
5690 !      include 'COMMON.VAR'
5691 !      include 'COMMON.INTERACT'
5692 !      include 'COMMON.IOUNITS'
5693       real(kind=8),dimension(3) :: ggg,vec
5694 !el local variables
5695       integer :: i,j,ii,jj,iii,jjj,k,mnumii,mnumjj
5696       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga,xi,yi,zi,zj,yj,xj
5697
5698       ehpb=0.0D0
5699 !      write(iout,*)'edis: nhpb=',nhpb!,' fbr=',fbr
5700 !      write(iout,*)'link_start=',link_start,' link_end=',link_end
5701       if (link_end.eq.0) return
5702       do i=link_start,link_end
5703 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5704 ! CA-CA distance used in regularization of structure.
5705
5706         ii=ihpb(i)
5707         jj=jhpb(i)
5708 ! iii and jjj point to the residues for which the distance is assigned.
5709         if (ii.gt.nres) then
5710           iii=ii-nres
5711           jjj=jj-nres
5712         else
5713           iii=ii
5714           jjj=jj
5715         endif
5716         do j=1,3
5717          vec(j)=c(j,jj)-c(j,ii)
5718         enddo
5719         mnumii=molnum(iii)
5720         mnumjj=molnum(jjj)
5721         if (energy_dec) write(iout,*) i,ii,jj,mnumii,mnumjj,itype(jjj,mnumjj),itype(iii,mnumii)
5722         if ((itype(iii,mnumii).gt.ntyp_molec(mnumii)).or.(itype(jjj,mnumjj).gt.ntyp_molec(mnumjj))) cycle
5723
5724 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5725 !     &    dhpb(i),dhpb1(i),forcon(i)
5726 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5727 !    distance and angle dependent SS bond potential.
5728 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5729 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5730         if (.not.dyn_ss .and. i.le.nss) then
5731 ! 15/02/13 CC dynamic SSbond - additional check
5732          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5733         iabs(itype(jjj,1)).eq.1) then
5734           call ssbond_ene(iii,jjj,eij)
5735           ehpb=ehpb+2*eij
5736 !          write (iout,*) "eij",eij,iii,jjj
5737          endif
5738         else if (ii.gt.nres .and. jj.gt.nres) then
5739 !c Restraints from contact prediction
5740           dd=dist(ii,jj)
5741           if (constr_dist.eq.11) then
5742             ehpb=ehpb+fordepth(i)**4.0d0 &
5743                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5744             fac=fordepth(i)**4.0d0 &
5745                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5746           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5747             ehpb,fordepth(i),dd
5748            else
5749           if (dhpb1(i).gt.0.0d0) then
5750             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5751             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5752 !c            write (iout,*) "beta nmr",
5753 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5754           else
5755             dd=dist(ii,jj)
5756             rdis=dd-dhpb(i)
5757 !C Get the force constant corresponding to this distance.
5758             waga=forcon(i)
5759 !C Calculate the contribution to energy.
5760             ehpb=ehpb+waga*rdis*rdis
5761 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5762 !C
5763 !C Evaluate gradient.
5764 !C
5765             fac=waga*rdis/dd
5766           endif
5767           endif
5768           do j=1,3
5769             ggg(j)=fac*(c(j,jj)-c(j,ii))
5770           enddo
5771           do j=1,3
5772             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5773             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5774           enddo
5775           do k=1,3
5776             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5777             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5778           enddo
5779         else
5780           dd=dist(ii,jj)
5781
5782           if (constr_dist.eq.11) then
5783             ehpb=ehpb+fordepth(i)**4.0d0 &
5784                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5785             fac=fordepth(i)**4.0d0 &
5786                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5787           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5788          ehpb,fordepth(i),dd
5789            else
5790           if (dhpb1(i).gt.0.0d0) then
5791             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5792             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5793 !c            write (iout,*) "alph nmr",
5794 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5795           else
5796           xi=c(1,ii)
5797           yi=c(2,ii)
5798           zi=c(3,ii)
5799           call to_box(xi,yi,zi)
5800           xj=c(1,jj)
5801           yj=c(2,jj)
5802           zj=c(3,jj)
5803           call to_box(xj,yj,zj)
5804           xj=boxshift(xj-xi,boxxsize)
5805           yj=boxshift(yj-yi,boxysize)
5806           zj=boxshift(zj-zi,boxzsize)
5807           vec(1)=xj
5808           vec(2)=yj
5809           vec(3)=zj
5810           dd=sqrt(xj*xj+yj*yj+zj*zj)
5811             rdis=dd-dhpb(i)
5812 !C Get the force constant corresponding to this distance.
5813             waga=forcon(i)
5814 !C Calculate the contribution to energy.
5815             ehpb=ehpb+waga*rdis*rdis
5816           if (energy_dec) write (iout,'(a6,2i5,5f10.3)') "edis",ii,jj, &
5817          ehpb,dd,dhpb(i),waga,rdis
5818
5819 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5820 !C
5821 !C Evaluate gradient.
5822 !C
5823             fac=waga*rdis/dd
5824           endif
5825           endif
5826
5827             do j=1,3
5828               ggg(j)=fac*vec(j)
5829             enddo
5830 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5831 !C If this is a SC-SC distance, we need to calculate the contributions to the
5832 !C Cartesian gradient in the SC vectors (ghpbx).
5833           if (iii.lt.ii) then
5834           do j=1,3
5835             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5836             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5837           enddo
5838           endif
5839 !cgrad        do j=iii,jjj-1
5840 !cgrad          do k=1,3
5841 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5842 !cgrad          enddo
5843 !cgrad        enddo
5844           do k=1,3
5845             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5846             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5847           enddo
5848         endif
5849       enddo
5850       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5851
5852       return
5853       end subroutine edis
5854 !-----------------------------------------------------------------------------
5855       subroutine ssbond_ene(i,j,eij)
5856 !
5857 ! Calculate the distance and angle dependent SS-bond potential energy
5858 ! using a free-energy function derived based on RHF/6-31G** ab initio
5859 ! calculations of diethyl disulfide.
5860 !
5861 ! A. Liwo and U. Kozlowska, 11/24/03
5862 !
5863 !      implicit real(kind=8) (a-h,o-z)
5864 !      include 'DIMENSIONS'
5865 !      include 'COMMON.SBRIDGE'
5866 !      include 'COMMON.CHAIN'
5867 !      include 'COMMON.DERIV'
5868 !      include 'COMMON.LOCAL'
5869 !      include 'COMMON.INTERACT'
5870 !      include 'COMMON.VAR'
5871 !      include 'COMMON.IOUNITS'
5872       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5873 !el local variables
5874       integer :: i,j,itypi,itypj,k
5875       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5876                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5877                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5878                    cosphi,ggk
5879
5880       itypi=iabs(itype(i,1))
5881       xi=c(1,nres+i)
5882       yi=c(2,nres+i)
5883       zi=c(3,nres+i)
5884           call to_box(xi,yi,zi)
5885
5886       dxi=dc_norm(1,nres+i)
5887       dyi=dc_norm(2,nres+i)
5888       dzi=dc_norm(3,nres+i)
5889 !      dsci_inv=dsc_inv(itypi)
5890       dsci_inv=vbld_inv(nres+i)
5891       itypj=iabs(itype(j,1))
5892 !      dscj_inv=dsc_inv(itypj)
5893       dscj_inv=vbld_inv(nres+j)
5894       xj=c(1,nres+j)
5895       yj=c(2,nres+j)
5896       zj=c(3,nres+j)
5897           call to_box(xj,yj,zj)
5898       xj=boxshift(xj-xi,boxxsize)
5899       yj=boxshift(yj-yi,boxysize)
5900       zj=boxshift(zj-zi,boxzsize)
5901       dxj=dc_norm(1,nres+j)
5902       dyj=dc_norm(2,nres+j)
5903       dzj=dc_norm(3,nres+j)
5904       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5905       rij=dsqrt(rrij)
5906       erij(1)=xj*rij
5907       erij(2)=yj*rij
5908       erij(3)=zj*rij
5909       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5910       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5911       om12=dxi*dxj+dyi*dyj+dzi*dzj
5912       do k=1,3
5913         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5914         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5915       enddo
5916       rij=1.0d0/rij
5917       deltad=rij-d0cm
5918       deltat1=1.0d0-om1
5919       deltat2=1.0d0+om2
5920       deltat12=om2-om1+2.0d0
5921       cosphi=om12-om1*om2
5922       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5923         +akct*deltad*deltat12 &
5924         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5925 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, &
5926 !       " akct",akct," deltad",deltad," deltat",deltat1,deltat2, &
5927 !       " deltat12",deltat12," eij",eij
5928       ed=2*akcm*deltad+akct*deltat12
5929       pom1=akct*deltad
5930       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5931       eom1=-2*akth*deltat1-pom1-om2*pom2
5932       eom2= 2*akth*deltat2+pom1-om1*pom2
5933       eom12=pom2
5934       do k=1,3
5935         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5936         ghpbx(k,i)=ghpbx(k,i)-ggk &
5937                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5938                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5939         ghpbx(k,j)=ghpbx(k,j)+ggk &
5940                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5941                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5942         ghpbc(k,i)=ghpbc(k,i)-ggk
5943         ghpbc(k,j)=ghpbc(k,j)+ggk
5944       enddo
5945 !
5946 ! Calculate the components of the gradient in DC and X
5947 !
5948 !grad      do k=i,j-1
5949 !grad        do l=1,3
5950 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5951 !grad        enddo
5952 !grad      enddo
5953       return
5954       end subroutine ssbond_ene
5955 !-----------------------------------------------------------------------------
5956       subroutine ebond(estr)
5957 !
5958 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5959 !
5960 !      implicit real(kind=8) (a-h,o-z)
5961 !      include 'DIMENSIONS'
5962 !      include 'COMMON.LOCAL'
5963 !      include 'COMMON.GEO'
5964 !      include 'COMMON.INTERACT'
5965 !      include 'COMMON.DERIV'
5966 !      include 'COMMON.VAR'
5967 !      include 'COMMON.CHAIN'
5968 !      include 'COMMON.IOUNITS'
5969 !      include 'COMMON.NAMES'
5970 !      include 'COMMON.FFIELD'
5971 !      include 'COMMON.CONTROL'
5972 !      include 'COMMON.SETUP'
5973       real(kind=8),dimension(3) :: u,ud
5974 !el local variables
5975       integer :: i,j,iti,nbi,k
5976       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5977                    uprod1,uprod2
5978
5979       estr=0.0d0
5980       estr1=0.0d0
5981 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5982 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5983
5984       do i=ibondp_start,ibondp_end
5985 #ifdef FIVEDIAG
5986         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5987         diff = vbld(i)-vbldp0
5988 #else
5989         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5990         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5991 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5992 !C          do j=1,3
5993 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5994 !C            *dc(j,i-1)/vbld(i)
5995 !C          enddo
5996 !C          if (energy_dec) write(iout,*) &
5997 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5998         diff = vbld(i)-vbldpDUM
5999         else
6000         diff = vbld(i)-vbldp0
6001         endif
6002 #endif
6003         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
6004            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6005         estr=estr+diff*diff
6006         do j=1,3
6007           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6008         enddo
6009 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6010 !        endif
6011       enddo
6012       estr=0.5d0*AKP*estr+estr1
6013 !      print *,"estr_bb",estr,AKP
6014 !
6015 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6016 !
6017       do i=ibond_start,ibond_end
6018         iti=iabs(itype(i,1))
6019         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
6020         if (iti.ne.10 .and. iti.ne.ntyp1) then
6021           nbi=nbondterm(iti)
6022           if (nbi.eq.1) then
6023             diff=vbld(i+nres)-vbldsc0(1,iti)
6024             if (energy_dec) write (iout,*) &
6025             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
6026             AKSC(1,iti),AKSC(1,iti)*diff*diff
6027             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6028 !            print *,"estr_sc",estr
6029             do j=1,3
6030               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6031             enddo
6032           else
6033             do j=1,nbi
6034               diff=vbld(i+nres)-vbldsc0(j,iti)
6035               ud(j)=aksc(j,iti)*diff
6036               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6037             enddo
6038             uprod=u(1)
6039             do j=2,nbi
6040               uprod=uprod*u(j)
6041             enddo
6042             usum=0.0d0
6043             usumsqder=0.0d0
6044             do j=1,nbi
6045               uprod1=1.0d0
6046               uprod2=1.0d0
6047               do k=1,nbi
6048                 if (k.ne.j) then
6049                   uprod1=uprod1*u(k)
6050                   uprod2=uprod2*u(k)*u(k)
6051                 endif
6052               enddo
6053               usum=usum+uprod1
6054               usumsqder=usumsqder+ud(j)*uprod2
6055             enddo
6056             estr=estr+uprod/usum
6057 !            print *,"estr_sc",estr,i
6058
6059              if (energy_dec) write (iout,*) &
6060             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
6061             AKSC(1,iti),uprod/usum
6062             do j=1,3
6063              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6064             enddo
6065           endif
6066         endif
6067       enddo
6068       return
6069       end subroutine ebond
6070 #ifdef CRYST_THETA
6071 !-----------------------------------------------------------------------------
6072       subroutine ebend(etheta)
6073 !
6074 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6075 ! angles gamma and its derivatives in consecutive thetas and gammas.
6076 !
6077       use comm_calcthet
6078 !      implicit real(kind=8) (a-h,o-z)
6079 !      include 'DIMENSIONS'
6080 !      include 'COMMON.LOCAL'
6081 !      include 'COMMON.GEO'
6082 !      include 'COMMON.INTERACT'
6083 !      include 'COMMON.DERIV'
6084 !      include 'COMMON.VAR'
6085 !      include 'COMMON.CHAIN'
6086 !      include 'COMMON.IOUNITS'
6087 !      include 'COMMON.NAMES'
6088 !      include 'COMMON.FFIELD'
6089 !      include 'COMMON.CONTROL'
6090 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6091 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6092 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6093 !el      integer :: it
6094 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6095 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6096 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6097 !el local variables
6098       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6099        ichir21,ichir22
6100       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6101        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6102        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6103       real(kind=8),dimension(2) :: y,z
6104
6105       delta=0.02d0*pi
6106 !      time11=dexp(-2*time)
6107 !      time12=1.0d0
6108       etheta=0.0D0
6109 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6110       do i=ithet_start,ithet_end
6111         if (itype(i-1,1).eq.ntyp1) cycle
6112 ! Zero the energy function and its derivative at 0 or pi.
6113         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6114         it=itype(i-1,1)
6115         ichir1=isign(1,itype(i-2,1))
6116         ichir2=isign(1,itype(i,1))
6117          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6118          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6119          if (itype(i-1,1).eq.10) then
6120           itype1=isign(10,itype(i-2,1))
6121           ichir11=isign(1,itype(i-2,1))
6122           ichir12=isign(1,itype(i-2,1))
6123           itype2=isign(10,itype(i,1))
6124           ichir21=isign(1,itype(i,1))
6125           ichir22=isign(1,itype(i,1))
6126          endif
6127
6128         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6129 #ifdef OSF
6130           phii=phi(i)
6131           if (phii.ne.phii) phii=150.0
6132 #else
6133           phii=phi(i)
6134 #endif
6135           y(1)=dcos(phii)
6136           y(2)=dsin(phii)
6137         else
6138           y(1)=0.0D0
6139           y(2)=0.0D0
6140         endif
6141         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6142 #ifdef OSF
6143           phii1=phi(i+1)
6144           if (phii1.ne.phii1) phii1=150.0
6145           phii1=pinorm(phii1)
6146           z(1)=cos(phii1)
6147 #else
6148           phii1=phi(i+1)
6149           z(1)=dcos(phii1)
6150 #endif
6151           z(2)=dsin(phii1)
6152         else
6153           z(1)=0.0D0
6154           z(2)=0.0D0
6155         endif
6156 ! Calculate the "mean" value of theta from the part of the distribution
6157 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6158 ! In following comments this theta will be referred to as t_c.
6159         thet_pred_mean=0.0d0
6160         do k=1,2
6161             athetk=athet(k,it,ichir1,ichir2)
6162             bthetk=bthet(k,it,ichir1,ichir2)
6163           if (it.eq.10) then
6164              athetk=athet(k,itype1,ichir11,ichir12)
6165              bthetk=bthet(k,itype2,ichir21,ichir22)
6166           endif
6167          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6168         enddo
6169         dthett=thet_pred_mean*ssd
6170         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6171 ! Derivatives of the "mean" values in gamma1 and gamma2.
6172         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6173                +athet(2,it,ichir1,ichir2)*y(1))*ss
6174         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6175                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6176          if (it.eq.10) then
6177         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6178              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6179         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6180                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6181          endif
6182         if (theta(i).gt.pi-delta) then
6183           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6184                E_tc0)
6185           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6186           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6187           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6188               E_theta)
6189           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6190               E_tc)
6191         else if (theta(i).lt.delta) then
6192           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6193           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6194           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6195               E_theta)
6196           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6197           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6198               E_tc)
6199         else
6200           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6201               E_theta,E_tc)
6202         endif
6203         etheta=etheta+ethetai
6204         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6205             'ebend',i,ethetai
6206         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6207         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6208         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6209       enddo
6210 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6211
6212 ! Ufff.... We've done all this!!!
6213       return
6214       end subroutine ebend
6215 !-----------------------------------------------------------------------------
6216       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6217
6218       use comm_calcthet
6219 !      implicit real(kind=8) (a-h,o-z)
6220 !      include 'DIMENSIONS'
6221 !      include 'COMMON.LOCAL'
6222 !      include 'COMMON.IOUNITS'
6223 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6224 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6225 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6226       integer :: i,j,k
6227       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6228 !el      integer :: it
6229 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6230 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6231 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6232 !el local variables
6233       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6234        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6235
6236 ! Calculate the contributions to both Gaussian lobes.
6237 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6238 ! The "polynomial part" of the "standard deviation" of this part of
6239 ! the distribution.
6240         sig=polthet(3,it)
6241         do j=2,0,-1
6242           sig=sig*thet_pred_mean+polthet(j,it)
6243         enddo
6244 ! Derivative of the "interior part" of the "standard deviation of the"
6245 ! gamma-dependent Gaussian lobe in t_c.
6246         sigtc=3*polthet(3,it)
6247         do j=2,1,-1
6248           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6249         enddo
6250         sigtc=sig*sigtc
6251 ! Set the parameters of both Gaussian lobes of the distribution.
6252 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6253         fac=sig*sig+sigc0(it)
6254         sigcsq=fac+fac
6255         sigc=1.0D0/sigcsq
6256 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6257         sigsqtc=-4.0D0*sigcsq*sigtc
6258 !       print *,i,sig,sigtc,sigsqtc
6259 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6260         sigtc=-sigtc/(fac*fac)
6261 ! Following variable is sigma(t_c)**(-2)
6262         sigcsq=sigcsq*sigcsq
6263         sig0i=sig0(it)
6264         sig0inv=1.0D0/sig0i**2
6265         delthec=thetai-thet_pred_mean
6266         delthe0=thetai-theta0i
6267         term1=-0.5D0*sigcsq*delthec*delthec
6268         term2=-0.5D0*sig0inv*delthe0*delthe0
6269 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6270 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6271 ! to the energy (this being the log of the distribution) at the end of energy
6272 ! term evaluation for this virtual-bond angle.
6273         if (term1.gt.term2) then
6274           termm=term1
6275           term2=dexp(term2-termm)
6276           term1=1.0d0
6277         else
6278           termm=term2
6279           term1=dexp(term1-termm)
6280           term2=1.0d0
6281         endif
6282 ! The ratio between the gamma-independent and gamma-dependent lobes of
6283 ! the distribution is a Gaussian function of thet_pred_mean too.
6284         diffak=gthet(2,it)-thet_pred_mean
6285         ratak=diffak/gthet(3,it)**2
6286         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6287 ! Let's differentiate it in thet_pred_mean NOW.
6288         aktc=ak*ratak
6289 ! Now put together the distribution terms to make complete distribution.
6290         termexp=term1+ak*term2
6291         termpre=sigc+ak*sig0i
6292 ! Contribution of the bending energy from this theta is just the -log of
6293 ! the sum of the contributions from the two lobes and the pre-exponential
6294 ! factor. Simple enough, isn't it?
6295         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6296 ! NOW the derivatives!!!
6297 ! 6/6/97 Take into account the deformation.
6298         E_theta=(delthec*sigcsq*term1 &
6299              +ak*delthe0*sig0inv*term2)/termexp
6300         E_tc=((sigtc+aktc*sig0i)/termpre &
6301             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6302              aktc*term2)/termexp)
6303       return
6304       end subroutine theteng
6305 #else
6306 !-----------------------------------------------------------------------------
6307       subroutine ebend(etheta)
6308 !
6309 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6310 ! angles gamma and its derivatives in consecutive thetas and gammas.
6311 ! ab initio-derived potentials from
6312 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6313 !
6314 !      implicit real(kind=8) (a-h,o-z)
6315 !      include 'DIMENSIONS'
6316 !      include 'COMMON.LOCAL'
6317 !      include 'COMMON.GEO'
6318 !      include 'COMMON.INTERACT'
6319 !      include 'COMMON.DERIV'
6320 !      include 'COMMON.VAR'
6321 !      include 'COMMON.CHAIN'
6322 !      include 'COMMON.IOUNITS'
6323 !      include 'COMMON.NAMES'
6324 !      include 'COMMON.FFIELD'
6325 !      include 'COMMON.CONTROL'
6326       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6327       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6328       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6329       logical :: lprn=.false., lprn1=.false.
6330 !el local variables
6331       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6332       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6333       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6334 ! local variables for constrains
6335       real(kind=8) :: difi,thetiii
6336        integer itheta
6337 !      write(iout,*) "in ebend",ithet_start,ithet_end
6338       call flush(iout)
6339       etheta=0.0D0
6340       do i=ithet_start,ithet_end
6341         if (itype(i-1,1).eq.ntyp1) cycle
6342         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6343         if (iabs(itype(i+1,1)).eq.20) iblock=2
6344         if (iabs(itype(i+1,1)).ne.20) iblock=1
6345         dethetai=0.0d0
6346         dephii=0.0d0
6347         dephii1=0.0d0
6348         theti2=0.5d0*theta(i)
6349         ityp2=ithetyp((itype(i-1,1)))
6350         do k=1,nntheterm
6351           coskt(k)=dcos(k*theti2)
6352           sinkt(k)=dsin(k*theti2)
6353         enddo
6354         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6355 #ifdef OSF
6356           phii=phi(i)
6357           if (phii.ne.phii) phii=150.0
6358 #else
6359           phii=phi(i)
6360 #endif
6361           ityp1=ithetyp((itype(i-2,1)))
6362 ! propagation of chirality for glycine type
6363           do k=1,nsingle
6364             cosph1(k)=dcos(k*phii)
6365             sinph1(k)=dsin(k*phii)
6366           enddo
6367         else
6368           phii=0.0d0
6369           ityp1=ithetyp(itype(i-2,1))
6370           do k=1,nsingle
6371             cosph1(k)=0.0d0
6372             sinph1(k)=0.0d0
6373           enddo
6374         endif
6375         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6376 #ifdef OSF
6377           phii1=phi(i+1)
6378           if (phii1.ne.phii1) phii1=150.0
6379           phii1=pinorm(phii1)
6380 #else
6381           phii1=phi(i+1)
6382 #endif
6383           ityp3=ithetyp((itype(i,1)))
6384           do k=1,nsingle
6385             cosph2(k)=dcos(k*phii1)
6386             sinph2(k)=dsin(k*phii1)
6387           enddo
6388         else
6389           phii1=0.0d0
6390           ityp3=ithetyp(itype(i,1))
6391           do k=1,nsingle
6392             cosph2(k)=0.0d0
6393             sinph2(k)=0.0d0
6394           enddo
6395         endif
6396         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6397         do k=1,ndouble
6398           do l=1,k-1
6399             ccl=cosph1(l)*cosph2(k-l)
6400             ssl=sinph1(l)*sinph2(k-l)
6401             scl=sinph1(l)*cosph2(k-l)
6402             csl=cosph1(l)*sinph2(k-l)
6403             cosph1ph2(l,k)=ccl-ssl
6404             cosph1ph2(k,l)=ccl+ssl
6405             sinph1ph2(l,k)=scl+csl
6406             sinph1ph2(k,l)=scl-csl
6407           enddo
6408         enddo
6409         if (lprn) then
6410         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6411           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6412         write (iout,*) "coskt and sinkt"
6413         do k=1,nntheterm
6414           write (iout,*) k,coskt(k),sinkt(k)
6415         enddo
6416         endif
6417         do k=1,ntheterm
6418           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6419           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6420             *coskt(k)
6421           if (lprn) &
6422           write (iout,*) "k",k,&
6423            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6424            " ethetai",ethetai
6425         enddo
6426         if (lprn) then
6427         write (iout,*) "cosph and sinph"
6428         do k=1,nsingle
6429           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6430         enddo
6431         write (iout,*) "cosph1ph2 and sinph2ph2"
6432         do k=2,ndouble
6433           do l=1,k-1
6434             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6435                sinph1ph2(l,k),sinph1ph2(k,l)
6436           enddo
6437         enddo
6438         write(iout,*) "ethetai",ethetai
6439         endif
6440         do m=1,ntheterm2
6441           do k=1,nsingle
6442             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6443                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6444                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6445                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6446             ethetai=ethetai+sinkt(m)*aux
6447             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6448             dephii=dephii+k*sinkt(m)* &
6449                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6450                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6451             dephii1=dephii1+k*sinkt(m)* &
6452                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6453                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6454             if (lprn) &
6455             write (iout,*) "m",m," k",k," bbthet", &
6456                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6457                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6458                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6459                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6460           enddo
6461         enddo
6462         if (lprn) &
6463         write(iout,*) "ethetai",ethetai
6464         do m=1,ntheterm3
6465           do k=2,ndouble
6466             do l=1,k-1
6467               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6468                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6469                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6470                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6471               ethetai=ethetai+sinkt(m)*aux
6472               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6473               dephii=dephii+l*sinkt(m)* &
6474                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6475                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6476                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6477                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6478               dephii1=dephii1+(k-l)*sinkt(m)* &
6479                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6480                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6481                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6482                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6483               if (lprn) then
6484               write (iout,*) "m",m," k",k," l",l," ffthet",&
6485                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6486                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6487                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6488                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6489                   " ethetai",ethetai
6490               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6491                   cosph1ph2(k,l)*sinkt(m),&
6492                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6493               endif
6494             enddo
6495           enddo
6496         enddo
6497 10      continue
6498 !        lprn1=.true.
6499         if (lprn1) &
6500           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6501          i,theta(i)*rad2deg,phii*rad2deg,&
6502          phii1*rad2deg,ethetai
6503 !        lprn1=.false.
6504         etheta=etheta+ethetai
6505         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6506                                     'ebend',i,ethetai
6507         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6508         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6509         gloc(nphi+i-2,icg)=wang*dethetai
6510       enddo
6511 !-----------thete constrains
6512 !      if (tor_mode.ne.2) then
6513
6514       return
6515       end subroutine ebend
6516 #endif
6517 #ifdef CRYST_SC
6518 !-----------------------------------------------------------------------------
6519       subroutine esc(escloc)
6520 ! Calculate the local energy of a side chain and its derivatives in the
6521 ! corresponding virtual-bond valence angles THETA and the spherical angles
6522 ! ALPHA and OMEGA.
6523 !
6524       use comm_sccalc
6525 !      implicit real(kind=8) (a-h,o-z)
6526 !      include 'DIMENSIONS'
6527 !      include 'COMMON.GEO'
6528 !      include 'COMMON.LOCAL'
6529 !      include 'COMMON.VAR'
6530 !      include 'COMMON.INTERACT'
6531 !      include 'COMMON.DERIV'
6532 !      include 'COMMON.CHAIN'
6533 !      include 'COMMON.IOUNITS'
6534 !      include 'COMMON.NAMES'
6535 !      include 'COMMON.FFIELD'
6536 !      include 'COMMON.CONTROL'
6537       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6538          ddersc0,ddummy,xtemp,temp
6539 !el      real(kind=8) :: time11,time12,time112,theti
6540       real(kind=8) :: escloc,delta
6541 !el      integer :: it,nlobit
6542 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6543 !el local variables
6544       integer :: i,k
6545       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6546        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6547       delta=0.02d0*pi
6548       escloc=0.0D0
6549 !     write (iout,'(a)') 'ESC'
6550       do i=loc_start,loc_end
6551         it=itype(i,1)
6552         if (it.eq.ntyp1) cycle
6553         if (it.eq.10) goto 1
6554         nlobit=nlob(iabs(it))
6555 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6556 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6557         theti=theta(i+1)-pipol
6558         x(1)=dtan(theti)
6559         x(2)=alph(i)
6560         x(3)=omeg(i)
6561
6562         if (x(2).gt.pi-delta) then
6563           xtemp(1)=x(1)
6564           xtemp(2)=pi-delta
6565           xtemp(3)=x(3)
6566           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6567           xtemp(2)=pi
6568           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6569           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6570               escloci,dersc(2))
6571           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6572               ddersc0(1),dersc(1))
6573           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6574               ddersc0(3),dersc(3))
6575           xtemp(2)=pi-delta
6576           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6577           xtemp(2)=pi
6578           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6579           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6580                   dersc0(2),esclocbi,dersc02)
6581           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6582                   dersc12,dersc01)
6583           call splinthet(x(2),0.5d0*delta,ss,ssd)
6584           dersc0(1)=dersc01
6585           dersc0(2)=dersc02
6586           dersc0(3)=0.0d0
6587           do k=1,3
6588             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6589           enddo
6590           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6591 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6592 !    &             esclocbi,ss,ssd
6593           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6594 !         escloci=esclocbi
6595 !         write (iout,*) escloci
6596         else if (x(2).lt.delta) then
6597           xtemp(1)=x(1)
6598           xtemp(2)=delta
6599           xtemp(3)=x(3)
6600           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6601           xtemp(2)=0.0d0
6602           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6603           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6604               escloci,dersc(2))
6605           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6606               ddersc0(1),dersc(1))
6607           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6608               ddersc0(3),dersc(3))
6609           xtemp(2)=delta
6610           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6611           xtemp(2)=0.0d0
6612           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6613           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6614                   dersc0(2),esclocbi,dersc02)
6615           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6616                   dersc12,dersc01)
6617           dersc0(1)=dersc01
6618           dersc0(2)=dersc02
6619           dersc0(3)=0.0d0
6620           call splinthet(x(2),0.5d0*delta,ss,ssd)
6621           do k=1,3
6622             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6623           enddo
6624           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6625 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6626 !    &             esclocbi,ss,ssd
6627           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6628 !         write (iout,*) escloci
6629         else
6630           call enesc(x,escloci,dersc,ddummy,.false.)
6631         endif
6632
6633         escloc=escloc+escloci
6634         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6635            'escloc',i,escloci
6636 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6637
6638         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6639          wscloc*dersc(1)
6640         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6641         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6642     1   continue
6643       enddo
6644       return
6645       end subroutine esc
6646 !-----------------------------------------------------------------------------
6647       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6648
6649       use comm_sccalc
6650 !      implicit real(kind=8) (a-h,o-z)
6651 !      include 'DIMENSIONS'
6652 !      include 'COMMON.GEO'
6653 !      include 'COMMON.LOCAL'
6654 !      include 'COMMON.IOUNITS'
6655 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6656       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6657       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6658       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6659       real(kind=8) :: escloci
6660       logical :: mixed
6661 !el local variables
6662       integer :: j,iii,l,k !el,it,nlobit
6663       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6664 !el       time11,time12,time112
6665 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6666         escloc_i=0.0D0
6667         do j=1,3
6668           dersc(j)=0.0D0
6669           if (mixed) ddersc(j)=0.0d0
6670         enddo
6671         x3=x(3)
6672
6673 ! Because of periodicity of the dependence of the SC energy in omega we have
6674 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6675 ! To avoid underflows, first compute & store the exponents.
6676
6677         do iii=-1,1
6678
6679           x(3)=x3+iii*dwapi
6680
6681           do j=1,nlobit
6682             do k=1,3
6683               z(k)=x(k)-censc(k,j,it)
6684             enddo
6685             do k=1,3
6686               Axk=0.0D0
6687               do l=1,3
6688                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6689               enddo
6690               Ax(k,j,iii)=Axk
6691             enddo
6692             expfac=0.0D0
6693             do k=1,3
6694               expfac=expfac+Ax(k,j,iii)*z(k)
6695             enddo
6696             contr(j,iii)=expfac
6697           enddo ! j
6698
6699         enddo ! iii
6700
6701         x(3)=x3
6702 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6703 ! subsequent NaNs and INFs in energy calculation.
6704 ! Find the largest exponent
6705         emin=contr(1,-1)
6706         do iii=-1,1
6707           do j=1,nlobit
6708             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6709           enddo
6710         enddo
6711         emin=0.5D0*emin
6712 !d      print *,'it=',it,' emin=',emin
6713
6714 ! Compute the contribution to SC energy and derivatives
6715         do iii=-1,1
6716
6717           do j=1,nlobit
6718 #ifdef OSF
6719             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6720             if(adexp.ne.adexp) adexp=1.0
6721             expfac=dexp(adexp)
6722 #else
6723             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6724 #endif
6725 !d          print *,'j=',j,' expfac=',expfac
6726             escloc_i=escloc_i+expfac
6727             do k=1,3
6728               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6729             enddo
6730             if (mixed) then
6731               do k=1,3,2
6732                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6733                   +gaussc(k,2,j,it))*expfac
6734               enddo
6735             endif
6736           enddo
6737
6738         enddo ! iii
6739
6740         dersc(1)=dersc(1)/cos(theti)**2
6741         ddersc(1)=ddersc(1)/cos(theti)**2
6742         ddersc(3)=ddersc(3)
6743
6744         escloci=-(dlog(escloc_i)-emin)
6745         do j=1,3
6746           dersc(j)=dersc(j)/escloc_i
6747         enddo
6748         if (mixed) then
6749           do j=1,3,2
6750             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6751           enddo
6752         endif
6753       return
6754       end subroutine enesc
6755 !-----------------------------------------------------------------------------
6756       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6757
6758       use comm_sccalc
6759 !      implicit real(kind=8) (a-h,o-z)
6760 !      include 'DIMENSIONS'
6761 !      include 'COMMON.GEO'
6762 !      include 'COMMON.LOCAL'
6763 !      include 'COMMON.IOUNITS'
6764 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6765       real(kind=8),dimension(3) :: x,z,dersc
6766       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6767       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6768       real(kind=8) :: escloci,dersc12,emin
6769       logical :: mixed
6770 !el local varables
6771       integer :: j,k,l !el,it,nlobit
6772       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6773
6774       escloc_i=0.0D0
6775
6776       do j=1,3
6777         dersc(j)=0.0D0
6778       enddo
6779
6780       do j=1,nlobit
6781         do k=1,2
6782           z(k)=x(k)-censc(k,j,it)
6783         enddo
6784         z(3)=dwapi
6785         do k=1,3
6786           Axk=0.0D0
6787           do l=1,3
6788             Axk=Axk+gaussc(l,k,j,it)*z(l)
6789           enddo
6790           Ax(k,j)=Axk
6791         enddo
6792         expfac=0.0D0
6793         do k=1,3
6794           expfac=expfac+Ax(k,j)*z(k)
6795         enddo
6796         contr(j)=expfac
6797       enddo ! j
6798
6799 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6800 ! subsequent NaNs and INFs in energy calculation.
6801 ! Find the largest exponent
6802       emin=contr(1)
6803       do j=1,nlobit
6804         if (emin.gt.contr(j)) emin=contr(j)
6805       enddo
6806       emin=0.5D0*emin
6807
6808 ! Compute the contribution to SC energy and derivatives
6809
6810       dersc12=0.0d0
6811       do j=1,nlobit
6812         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6813         escloc_i=escloc_i+expfac
6814         do k=1,2
6815           dersc(k)=dersc(k)+Ax(k,j)*expfac
6816         enddo
6817         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6818                   +gaussc(1,2,j,it))*expfac
6819         dersc(3)=0.0d0
6820       enddo
6821
6822       dersc(1)=dersc(1)/cos(theti)**2
6823       dersc12=dersc12/cos(theti)**2
6824       escloci=-(dlog(escloc_i)-emin)
6825       do j=1,2
6826         dersc(j)=dersc(j)/escloc_i
6827       enddo
6828       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6829       return
6830       end subroutine enesc_bound
6831 #else
6832 !-----------------------------------------------------------------------------
6833       subroutine esc(escloc)
6834 ! Calculate the local energy of a side chain and its derivatives in the
6835 ! corresponding virtual-bond valence angles THETA and the spherical angles
6836 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6837 ! added by Urszula Kozlowska. 07/11/2007
6838 !
6839       use comm_sccalc
6840 !      implicit real(kind=8) (a-h,o-z)
6841 !      include 'DIMENSIONS'
6842 !      include 'COMMON.GEO'
6843 !      include 'COMMON.LOCAL'
6844 !      include 'COMMON.VAR'
6845 !      include 'COMMON.SCROT'
6846 !      include 'COMMON.INTERACT'
6847 !      include 'COMMON.DERIV'
6848 !      include 'COMMON.CHAIN'
6849 !      include 'COMMON.IOUNITS'
6850 !      include 'COMMON.NAMES'
6851 !      include 'COMMON.FFIELD'
6852 !      include 'COMMON.CONTROL'
6853 !      include 'COMMON.VECTORS'
6854       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6855       real(kind=8),dimension(65) :: x
6856       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6857          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6858       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6859       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6860          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6861 !el local variables
6862       integer :: i,j,k !el,it,nlobit
6863       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6864 !el      real(kind=8) :: time11,time12,time112,theti
6865 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6866       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6867                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6868                    sumene1x,sumene2x,sumene3x,sumene4x,&
6869                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6870                    cosfac2xx,sinfac2yy
6871 #ifdef DEBUG
6872       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6873                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6874                    de_dt_num
6875 #endif
6876 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6877
6878       delta=0.02d0*pi
6879       escloc=0.0D0
6880       do i=loc_start,loc_end
6881         if (itype(i,1).eq.ntyp1) cycle
6882         costtab(i+1) =dcos(theta(i+1))
6883         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6884         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6885         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6886         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6887         cosfac=dsqrt(cosfac2)
6888         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6889         sinfac=dsqrt(sinfac2)
6890         it=iabs(itype(i,1))
6891         if (it.eq.10) goto 1
6892 !
6893 !  Compute the axes of tghe local cartesian coordinates system; store in
6894 !   x_prime, y_prime and z_prime
6895 !
6896         do j=1,3
6897           x_prime(j) = 0.00
6898           y_prime(j) = 0.00
6899           z_prime(j) = 0.00
6900         enddo
6901 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6902 !     &   dc_norm(3,i+nres)
6903         do j = 1,3
6904           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6905           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6906         enddo
6907         do j = 1,3
6908           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6909         enddo
6910 !       write (2,*) "i",i
6911 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6912 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6913 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6914 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6915 !      & " xy",scalar(x_prime(1),y_prime(1)),
6916 !      & " xz",scalar(x_prime(1),z_prime(1)),
6917 !      & " yy",scalar(y_prime(1),y_prime(1)),
6918 !      & " yz",scalar(y_prime(1),z_prime(1)),
6919 !      & " zz",scalar(z_prime(1),z_prime(1))
6920 !
6921 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6922 ! to local coordinate system. Store in xx, yy, zz.
6923 !
6924         xx=0.0d0
6925         yy=0.0d0
6926         zz=0.0d0
6927         do j = 1,3
6928           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6929           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6930           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6931         enddo
6932
6933         xxtab(i)=xx
6934         yytab(i)=yy
6935         zztab(i)=zz
6936 !
6937 ! Compute the energy of the ith side cbain
6938 !
6939 !        write (2,*) "xx",xx," yy",yy," zz",zz
6940         it=iabs(itype(i,1))
6941         do j = 1,65
6942           x(j) = sc_parmin(j,it)
6943         enddo
6944 #ifdef CHECK_COORD
6945 !c diagnostics - remove later
6946         xx1 = dcos(alph(2))
6947         yy1 = dsin(alph(2))*dcos(omeg(2))
6948         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6949         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6950           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6951           xx1,yy1,zz1
6952 !,"  --- ", xx_w,yy_w,zz_w
6953 ! end diagnostics
6954 #endif
6955         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6956          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6957          + x(10)*yy*zz
6958         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6959          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6960          + x(20)*yy*zz
6961         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6962          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6963          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6964          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6965          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6966          +x(40)*xx*yy*zz
6967         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6968          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6969          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6970          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6971          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6972          +x(60)*xx*yy*zz
6973         dsc_i   = 0.743d0+x(61)
6974         dp2_i   = 1.9d0+x(62)
6975         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6976                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6977         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6978                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6979         s1=(1+x(63))/(0.1d0 + dscp1)
6980         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6981         s2=(1+x(65))/(0.1d0 + dscp2)
6982         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6983         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6984       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6985 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6986 !     &   sumene4,
6987 !     &   dscp1,dscp2,sumene
6988 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6989         escloc = escloc + sumene
6990        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
6991         " escloc",sumene,escloc,it,itype(i,1)
6992 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6993 !     & ,zz,xx,yy
6994 !#define DEBUG
6995 #ifdef DEBUG
6996 !
6997 ! This section to check the numerical derivatives of the energy of ith side
6998 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6999 ! #define DEBUG in the code to turn it on.
7000 !
7001         write (2,*) "sumene               =",sumene
7002         aincr=1.0d-7
7003         xxsave=xx
7004         xx=xx+aincr
7005         write (2,*) xx,yy,zz
7006         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7007         de_dxx_num=(sumenep-sumene)/aincr
7008         xx=xxsave
7009         write (2,*) "xx+ sumene from enesc=",sumenep
7010         yysave=yy
7011         yy=yy+aincr
7012         write (2,*) xx,yy,zz
7013         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7014         de_dyy_num=(sumenep-sumene)/aincr
7015         yy=yysave
7016         write (2,*) "yy+ sumene from enesc=",sumenep
7017         zzsave=zz
7018         zz=zz+aincr
7019         write (2,*) xx,yy,zz
7020         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7021         de_dzz_num=(sumenep-sumene)/aincr
7022         zz=zzsave
7023         write (2,*) "zz+ sumene from enesc=",sumenep
7024         costsave=cost2tab(i+1)
7025         sintsave=sint2tab(i+1)
7026         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7027         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7028         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7029         de_dt_num=(sumenep-sumene)/aincr
7030         write (2,*) " t+ sumene from enesc=",sumenep
7031         cost2tab(i+1)=costsave
7032         sint2tab(i+1)=sintsave
7033 ! End of diagnostics section.
7034 #endif
7035 !
7036 ! Compute the gradient of esc
7037 !
7038 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
7039         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7040         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7041         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7042         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7043         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7044         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7045         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7046         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7047         pom1=(sumene3*sint2tab(i+1)+sumene1) &
7048            *(pom_s1/dscp1+pom_s16*dscp1**4)
7049         pom2=(sumene4*cost2tab(i+1)+sumene2) &
7050            *(pom_s2/dscp2+pom_s26*dscp2**4)
7051         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7052         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
7053         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
7054         +x(40)*yy*zz
7055         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7056         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
7057         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
7058         +x(60)*yy*zz
7059         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
7060               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
7061               +(pom1+pom2)*pom_dx
7062 #ifdef DEBUG
7063         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
7064 #endif
7065 !
7066         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7067         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
7068         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
7069         +x(40)*xx*zz
7070         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7071         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
7072         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
7073         +x(59)*zz**2 +x(60)*xx*zz
7074         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
7075               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
7076               +(pom1-pom2)*pom_dy
7077 #ifdef DEBUG
7078         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
7079 #endif
7080 !
7081         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
7082         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
7083         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
7084         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
7085         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
7086         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
7087         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
7088         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7089 #ifdef DEBUG
7090         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7091 #endif
7092 !
7093         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7094         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7095         +pom1*pom_dt1+pom2*pom_dt2
7096 #ifdef DEBUG
7097         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7098 #endif
7099 !
7100 !
7101        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7102        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7103        cosfac2xx=cosfac2*xx
7104        sinfac2yy=sinfac2*yy
7105        do k = 1,3
7106          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7107             vbld_inv(i+1)
7108          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7109             vbld_inv(i)
7110          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7111          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7112 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7113 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7114 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7115 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7116          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7117          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7118          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7119          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7120          dZZ_Ci1(k)=0.0d0
7121          dZZ_Ci(k)=0.0d0
7122          do j=1,3
7123            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7124            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7125            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7126            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7127          enddo
7128
7129          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7130          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7131          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7132          (z_prime(k)-zz*dC_norm(k,i+nres))
7133 !
7134          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7135          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7136        enddo
7137
7138        do k=1,3
7139          dXX_Ctab(k,i)=dXX_Ci(k)
7140          dXX_C1tab(k,i)=dXX_Ci1(k)
7141          dYY_Ctab(k,i)=dYY_Ci(k)
7142          dYY_C1tab(k,i)=dYY_Ci1(k)
7143          dZZ_Ctab(k,i)=dZZ_Ci(k)
7144          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7145          dXX_XYZtab(k,i)=dXX_XYZ(k)
7146          dYY_XYZtab(k,i)=dYY_XYZ(k)
7147          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7148        enddo
7149
7150        do k = 1,3
7151 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7152 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7153 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7154 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7155 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7156 !     &    dt_dci(k)
7157 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7158 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7159          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7160           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7161          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7162           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7163          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7164           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7165        enddo
7166 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7167 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7168
7169 ! to check gradient call subroutine check_grad
7170
7171     1 continue
7172       enddo
7173       return
7174       end subroutine esc
7175 !-----------------------------------------------------------------------------
7176       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7177 !      implicit none
7178       real(kind=8),dimension(65) :: x
7179       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7180         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7181
7182       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7183         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7184         + x(10)*yy*zz
7185       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7186         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7187         + x(20)*yy*zz
7188       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7189         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7190         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7191         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7192         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7193         +x(40)*xx*yy*zz
7194       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7195         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7196         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7197         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7198         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7199         +x(60)*xx*yy*zz
7200       dsc_i   = 0.743d0+x(61)
7201       dp2_i   = 1.9d0+x(62)
7202       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7203                 *(xx*cost2+yy*sint2))
7204       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7205                 *(xx*cost2-yy*sint2))
7206       s1=(1+x(63))/(0.1d0 + dscp1)
7207       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7208       s2=(1+x(65))/(0.1d0 + dscp2)
7209       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7210       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7211        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7212       enesc=sumene
7213       return
7214       end function enesc
7215 #endif
7216 !-----------------------------------------------------------------------------
7217       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7218 !
7219 ! This procedure calculates two-body contact function g(rij) and its derivative:
7220 !
7221 !           eps0ij                                     !       x < -1
7222 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7223 !            0                                         !       x > 1
7224 !
7225 ! where x=(rij-r0ij)/delta
7226 !
7227 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7228 !
7229 !      implicit none
7230       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7231       real(kind=8) :: x,x2,x4,delta
7232 !     delta=0.02D0*r0ij
7233 !      delta=0.2D0*r0ij
7234       x=(rij-r0ij)/delta
7235       if (x.lt.-1.0D0) then
7236         fcont=eps0ij
7237         fprimcont=0.0D0
7238       else if (x.le.1.0D0) then
7239         x2=x*x
7240         x4=x2*x2
7241         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7242         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7243       else
7244         fcont=0.0D0
7245         fprimcont=0.0D0
7246       endif
7247       return
7248       end subroutine gcont
7249 !-----------------------------------------------------------------------------
7250       subroutine splinthet(theti,delta,ss,ssder)
7251 !      implicit real(kind=8) (a-h,o-z)
7252 !      include 'DIMENSIONS'
7253 !      include 'COMMON.VAR'
7254 !      include 'COMMON.GEO'
7255       real(kind=8) :: theti,delta,ss,ssder
7256       real(kind=8) :: thetup,thetlow
7257       thetup=pi-delta
7258       thetlow=delta
7259       if (theti.gt.pipol) then
7260         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7261       else
7262         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7263         ssder=-ssder
7264       endif
7265       return
7266       end subroutine splinthet
7267 !-----------------------------------------------------------------------------
7268       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7269 !      implicit none
7270       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7271       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7272       a1=fprim0*delta/(f1-f0)
7273       a2=3.0d0-2.0d0*a1
7274       a3=a1-2.0d0
7275       ksi=(x-x0)/delta
7276       ksi2=ksi*ksi
7277       ksi3=ksi2*ksi
7278       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7279       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7280       return
7281       end subroutine spline1
7282 !-----------------------------------------------------------------------------
7283       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7284 !      implicit none
7285       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7286       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7287       ksi=(x-x0)/delta
7288       ksi2=ksi*ksi
7289       ksi3=ksi2*ksi
7290       a1=fprim0x*delta
7291       a2=3*(f1x-f0x)-2*fprim0x*delta
7292       a3=fprim0x*delta-2*(f1x-f0x)
7293       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7294       return
7295       end subroutine spline2
7296 !-----------------------------------------------------------------------------
7297 #ifdef CRYST_TOR
7298 !-----------------------------------------------------------------------------
7299       subroutine etor(etors,edihcnstr)
7300 !      implicit real(kind=8) (a-h,o-z)
7301 !      include 'DIMENSIONS'
7302 !      include 'COMMON.VAR'
7303 !      include 'COMMON.GEO'
7304 !      include 'COMMON.LOCAL'
7305 !      include 'COMMON.TORSION'
7306 !      include 'COMMON.INTERACT'
7307 !      include 'COMMON.DERIV'
7308 !      include 'COMMON.CHAIN'
7309 !      include 'COMMON.NAMES'
7310 !      include 'COMMON.IOUNITS'
7311 !      include 'COMMON.FFIELD'
7312 !      include 'COMMON.TORCNSTR'
7313 !      include 'COMMON.CONTROL'
7314       real(kind=8) :: etors,edihcnstr
7315       logical :: lprn
7316 !el local variables
7317       integer :: i,j,
7318       real(kind=8) :: phii,fac,etors_ii
7319
7320 ! Set lprn=.true. for debugging
7321       lprn=.false.
7322 !      lprn=.true.
7323       etors=0.0D0
7324       do i=iphi_start,iphi_end
7325       etors_ii=0.0D0
7326         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7327             .or. itype(i,1).eq.ntyp1) cycle
7328         itori=itortyp(itype(i-2,1))
7329         itori1=itortyp(itype(i-1,1))
7330         phii=phi(i)
7331         gloci=0.0D0
7332 ! Proline-Proline pair is a special case...
7333         if (itori.eq.3 .and. itori1.eq.3) then
7334           if (phii.gt.-dwapi3) then
7335             cosphi=dcos(3*phii)
7336             fac=1.0D0/(1.0D0-cosphi)
7337             etorsi=v1(1,3,3)*fac
7338             etorsi=etorsi+etorsi
7339             etors=etors+etorsi-v1(1,3,3)
7340             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7341             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7342           endif
7343           do j=1,3
7344             v1ij=v1(j+1,itori,itori1)
7345             v2ij=v2(j+1,itori,itori1)
7346             cosphi=dcos(j*phii)
7347             sinphi=dsin(j*phii)
7348             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7349             if (energy_dec) etors_ii=etors_ii+ &
7350                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7351             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7352           enddo
7353         else
7354           do j=1,nterm_old
7355             v1ij=v1(j,itori,itori1)
7356             v2ij=v2(j,itori,itori1)
7357             cosphi=dcos(j*phii)
7358             sinphi=dsin(j*phii)
7359             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7360             if (energy_dec) etors_ii=etors_ii+ &
7361                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7362             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7363           enddo
7364         endif
7365         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7366              'etor',i,etors_ii
7367         if (lprn) &
7368         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7369         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7370         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7371         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7372 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7373       enddo
7374 ! 6/20/98 - dihedral angle constraints
7375       edihcnstr=0.0d0
7376       do i=1,ndih_constr
7377         itori=idih_constr(i)
7378         phii=phi(itori)
7379         difi=phii-phi0(i)
7380         if (difi.gt.drange(i)) then
7381           difi=difi-drange(i)
7382           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7383           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7384         else if (difi.lt.-drange(i)) then
7385           difi=difi+drange(i)
7386           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7387           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7388         endif
7389 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7390 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7391       enddo
7392 !      write (iout,*) 'edihcnstr',edihcnstr
7393       return
7394       end subroutine etor
7395 !-----------------------------------------------------------------------------
7396       subroutine etor_d(etors_d)
7397       real(kind=8) :: etors_d
7398       etors_d=0.0d0
7399       return
7400       end subroutine etor_d
7401 !-----------------------------------------------------------------------------
7402 !c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7403       subroutine e_modeller(ehomology_constr)
7404       real(kind=8) :: ehomology_constr
7405       ehomology_constr=0.0d0
7406       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7407       return
7408       end subroutine e_modeller
7409 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7410 #else
7411 !-----------------------------------------------------------------------------
7412       subroutine etor(etors)
7413 !      implicit real(kind=8) (a-h,o-z)
7414 !      include 'DIMENSIONS'
7415 !      include 'COMMON.VAR'
7416 !      include 'COMMON.GEO'
7417 !      include 'COMMON.LOCAL'
7418 !      include 'COMMON.TORSION'
7419 !      include 'COMMON.INTERACT'
7420 !      include 'COMMON.DERIV'
7421 !      include 'COMMON.CHAIN'
7422 !      include 'COMMON.NAMES'
7423 !      include 'COMMON.IOUNITS'
7424 !      include 'COMMON.FFIELD'
7425 !      include 'COMMON.TORCNSTR'
7426 !      include 'COMMON.CONTROL'
7427       real(kind=8) :: etors,edihcnstr
7428       logical :: lprn
7429 !el local variables
7430       integer :: i,j,iblock,itori,itori1
7431       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7432                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7433 ! Set lprn=.true. for debugging
7434       lprn=.false.
7435 !     lprn=.true.
7436       etors=0.0D0
7437       do i=iphi_start,iphi_end
7438         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7439              .or. itype(i-3,1).eq.ntyp1 &
7440              .or. itype(i,1).eq.ntyp1) cycle
7441         etors_ii=0.0D0
7442          if (iabs(itype(i,1)).eq.20) then
7443          iblock=2
7444          else
7445          iblock=1
7446          endif
7447         itori=itortyp(itype(i-2,1))
7448         itori1=itortyp(itype(i-1,1))
7449         phii=phi(i)
7450         gloci=0.0D0
7451 ! Regular cosine and sine terms
7452         do j=1,nterm(itori,itori1,iblock)
7453           v1ij=v1(j,itori,itori1,iblock)
7454           v2ij=v2(j,itori,itori1,iblock)
7455           cosphi=dcos(j*phii)
7456           sinphi=dsin(j*phii)
7457           etors=etors+v1ij*cosphi+v2ij*sinphi
7458           if (energy_dec) etors_ii=etors_ii+ &
7459                      v1ij*cosphi+v2ij*sinphi
7460           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7461         enddo
7462 ! Lorentz terms
7463 !                         v1
7464 !  E = SUM ----------------------------------- - v1
7465 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7466 !
7467         cosphi=dcos(0.5d0*phii)
7468         sinphi=dsin(0.5d0*phii)
7469         do j=1,nlor(itori,itori1,iblock)
7470           vl1ij=vlor1(j,itori,itori1)
7471           vl2ij=vlor2(j,itori,itori1)
7472           vl3ij=vlor3(j,itori,itori1)
7473           pom=vl2ij*cosphi+vl3ij*sinphi
7474           pom1=1.0d0/(pom*pom+1.0d0)
7475           etors=etors+vl1ij*pom1
7476           if (energy_dec) etors_ii=etors_ii+ &
7477                      vl1ij*pom1
7478           pom=-pom*pom1*pom1
7479           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7480         enddo
7481 ! Subtract the constant term
7482         etors=etors-v0(itori,itori1,iblock)
7483           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7484                'etor',i,etors_ii-v0(itori,itori1,iblock)
7485         if (lprn) &
7486         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7487         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7488         (v1(j,itori,itori1,iblock),j=1,6),&
7489         (v2(j,itori,itori1,iblock),j=1,6)
7490         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7491 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7492       enddo
7493 ! 6/20/98 - dihedral angle constraints
7494       return
7495       end subroutine etor
7496 !C The rigorous attempt to derive energy function
7497 !-------------------------------------------------------------------------------------------
7498       subroutine etor_kcc(etors)
7499       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7500       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7501        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7502        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7503        gradvalst2,etori
7504       logical lprn
7505       integer :: i,j,itori,itori1,nval,k,l
7506 !      lprn=.true.
7507       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7508       etors=0.0D0
7509       do i=iphi_start,iphi_end
7510 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7511 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7512 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7513 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7514         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7515            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7516         itori=itortyp(itype(i-2,1))
7517         itori1=itortyp(itype(i-1,1))
7518         phii=phi(i)
7519         glocig=0.0D0
7520         glocit1=0.0d0
7521         glocit2=0.0d0
7522 !C to avoid multiple devision by 2
7523 !c        theti22=0.5d0*theta(i)
7524 !C theta 12 is the theta_1 /2
7525 !C theta 22 is theta_2 /2
7526 !c        theti12=0.5d0*theta(i-1)
7527 !C and appropriate sinus function
7528         sinthet1=dsin(theta(i-1))
7529         sinthet2=dsin(theta(i))
7530         costhet1=dcos(theta(i-1))
7531         costhet2=dcos(theta(i))
7532 !C to speed up lets store its mutliplication
7533         sint1t2=sinthet2*sinthet1
7534         sint1t2n=1.0d0
7535 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7536 !C +d_n*sin(n*gamma)) *
7537 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7538 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7539         nval=nterm_kcc_Tb(itori,itori1)
7540         c1(0)=0.0d0
7541         c2(0)=0.0d0
7542         c1(1)=1.0d0
7543         c2(1)=1.0d0
7544         do j=2,nval
7545           c1(j)=c1(j-1)*costhet1
7546           c2(j)=c2(j-1)*costhet2
7547         enddo
7548         etori=0.0d0
7549
7550        do j=1,nterm_kcc(itori,itori1)
7551           cosphi=dcos(j*phii)
7552           sinphi=dsin(j*phii)
7553           sint1t2n1=sint1t2n
7554           sint1t2n=sint1t2n*sint1t2
7555           sumvalc=0.0d0
7556           gradvalct1=0.0d0
7557           gradvalct2=0.0d0
7558           do k=1,nval
7559             do l=1,nval
7560               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7561               gradvalct1=gradvalct1+ &
7562                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7563               gradvalct2=gradvalct2+ &
7564                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7565             enddo
7566           enddo
7567           gradvalct1=-gradvalct1*sinthet1
7568           gradvalct2=-gradvalct2*sinthet2
7569           sumvals=0.0d0
7570           gradvalst1=0.0d0
7571           gradvalst2=0.0d0
7572           do k=1,nval
7573             do l=1,nval
7574               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7575               gradvalst1=gradvalst1+ &
7576                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7577               gradvalst2=gradvalst2+ &
7578                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7579             enddo
7580           enddo
7581           gradvalst1=-gradvalst1*sinthet1
7582           gradvalst2=-gradvalst2*sinthet2
7583           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7584           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7585 !C glocig is the gradient local i site in gamma
7586           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7587 !C now gradient over theta_1
7588          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7589         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7590          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7591         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7592         enddo ! j
7593         etors=etors+etori
7594         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7595 !C derivative over theta1
7596         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7597 !C now derivative over theta2
7598         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7599         if (lprn) then
7600          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7601             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7602           write (iout,*) "c1",(c1(k),k=0,nval), &
7603          " c2",(c2(k),k=0,nval)
7604         endif
7605       enddo
7606       return
7607        end  subroutine etor_kcc
7608 !------------------------------------------------------------------------------
7609
7610         subroutine etor_constr(edihcnstr)
7611       real(kind=8) :: etors,edihcnstr
7612       logical :: lprn
7613 !el local variables
7614       integer :: i,j,iblock,itori,itori1
7615       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7616                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7617                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7618
7619       if (raw_psipred) then
7620         do i=idihconstr_start,idihconstr_end
7621           itori=idih_constr(i)
7622           phii=phi(itori)
7623           gaudih_i=vpsipred(1,i)
7624           gauder_i=0.0d0
7625           do j=1,2
7626             s = sdihed(j,i)
7627             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7628             dexpcos_i=dexp(-cos_i*cos_i)
7629             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7630           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7631                  *cos_i*dexpcos_i/s**2
7632           enddo
7633           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7634           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7635           if (energy_dec) &
7636           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7637           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7638           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7639           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7640           -wdihc*dlog(gaudih_i)
7641         enddo
7642       else
7643
7644       do i=idihconstr_start,idihconstr_end
7645         itori=idih_constr(i)
7646         phii=phi(itori)
7647         difi=pinorm(phii-phi0(i))
7648         if (difi.gt.drange(i)) then
7649           difi=difi-drange(i)
7650           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7651           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7652         else if (difi.lt.-drange(i)) then
7653           difi=difi+drange(i)
7654           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7655           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7656         else
7657           difi=0.0
7658         endif
7659       enddo
7660
7661       endif
7662
7663       return
7664
7665       end subroutine etor_constr
7666 !-----------------------------------------------------------------------------
7667       subroutine etor_d(etors_d)
7668 ! 6/23/01 Compute double torsional energy
7669 !      implicit real(kind=8) (a-h,o-z)
7670 !      include 'DIMENSIONS'
7671 !      include 'COMMON.VAR'
7672 !      include 'COMMON.GEO'
7673 !      include 'COMMON.LOCAL'
7674 !      include 'COMMON.TORSION'
7675 !      include 'COMMON.INTERACT'
7676 !      include 'COMMON.DERIV'
7677 !      include 'COMMON.CHAIN'
7678 !      include 'COMMON.NAMES'
7679 !      include 'COMMON.IOUNITS'
7680 !      include 'COMMON.FFIELD'
7681 !      include 'COMMON.TORCNSTR'
7682       real(kind=8) :: etors_d,etors_d_ii
7683       logical :: lprn
7684 !el local variables
7685       integer :: i,j,k,l,itori,itori1,itori2,iblock
7686       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7687                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7688                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7689                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7690 ! Set lprn=.true. for debugging
7691       lprn=.false.
7692 !     lprn=.true.
7693       etors_d=0.0D0
7694 !      write(iout,*) "a tu??"
7695       do i=iphid_start,iphid_end
7696         etors_d_ii=0.0D0
7697         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7698             .or. itype(i-3,1).eq.ntyp1 &
7699             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7700         itori=itortyp(itype(i-2,1))
7701         itori1=itortyp(itype(i-1,1))
7702         itori2=itortyp(itype(i,1))
7703         phii=phi(i)
7704         phii1=phi(i+1)
7705         gloci1=0.0D0
7706         gloci2=0.0D0
7707         iblock=1
7708         if (iabs(itype(i+1,1)).eq.20) iblock=2
7709
7710 ! Regular cosine and sine terms
7711         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7712           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7713           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7714           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7715           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7716           cosphi1=dcos(j*phii)
7717           sinphi1=dsin(j*phii)
7718           cosphi2=dcos(j*phii1)
7719           sinphi2=dsin(j*phii1)
7720           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7721            v2cij*cosphi2+v2sij*sinphi2
7722           if (energy_dec) etors_d_ii=etors_d_ii+ &
7723            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7724           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7725           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7726         enddo
7727         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7728           do l=1,k-1
7729             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7730             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7731             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7732             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7733             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7734             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7735             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7736             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7737             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7738               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7739             if (energy_dec) etors_d_ii=etors_d_ii+ &
7740               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7741               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7742             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7743               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7744             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7745               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7746           enddo
7747         enddo
7748         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7749                             'etor_d',i,etors_d_ii
7750         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7751         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7752       enddo
7753       return
7754       end subroutine etor_d
7755 #endif
7756 !----------------------------------------------------------------------------
7757 !----------------------------------------------------------------------------
7758       subroutine e_modeller(ehomology_constr)
7759 !      implicit none
7760 !      include 'DIMENSIONS'
7761       use MD_data, only: iset
7762       real(kind=8) :: ehomology_constr
7763       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7764       integer katy, odleglosci, test7
7765       real(kind=8) :: odleg, odleg2, odleg3, kat, kat2, kat3
7766       real(kind=8) :: Eval,Erot,min_odl
7767       real(kind=8),dimension(constr_homology) :: distance,distancek,godl,dih_diff,gdih, &
7768       gtheta,dscdiff, &
7769                 uscdiffk,guscdiff2,guscdiff3,&
7770                 theta_diff
7771
7772
7773 !
7774 !     FP - 30/10/2014 Temporary specifications for homology restraints
7775 !
7776       real(kind=8) :: utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,&
7777                       sgtheta
7778       real(kind=8), dimension (nres) :: guscdiff,usc_diff
7779       real(kind=8) :: sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,&
7780       sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,&
7781       betai,sum_sgodl,dij,max_template
7782 !      real(kind=8) :: dist,pinorm
7783 !
7784 !     include 'COMMON.SBRIDGE'
7785 !     include 'COMMON.CHAIN'
7786 !     include 'COMMON.GEO'
7787 !     include 'COMMON.DERIV'
7788 !     include 'COMMON.LOCAL'
7789 !     include 'COMMON.INTERACT'
7790 !     include 'COMMON.VAR'
7791 !     include 'COMMON.IOUNITS'
7792 !      include 'COMMON.MD'
7793 !     include 'COMMON.CONTROL'
7794 !     include 'COMMON.HOMOLOGY'
7795 !     include 'COMMON.QRESTR'
7796 !
7797 !     From subroutine Econstr_back
7798 !
7799 !     include 'COMMON.NAMES'
7800 !     include 'COMMON.TIME1'
7801 !
7802
7803
7804       do i=1,max_template
7805         distancek(i)=9999999.9
7806       enddo
7807
7808
7809       odleg=0.0d0
7810
7811 ! Pseudo-energy and gradient from homology restraints (MODELLER-like
7812 ! function)
7813 ! AL 5/2/14 - Introduce list of restraints
7814 !     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7815 #ifdef DEBUG
7816       write(iout,*) "------- dist restrs start -------"
7817 #endif
7818       do ii = link_start_homo,link_end_homo
7819          i = ires_homo(ii)
7820          j = jres_homo(ii)
7821          dij=dist(i,j)
7822 !        write (iout,*) "dij(",i,j,") =",dij
7823          nexl=0
7824          do k=1,constr_homology
7825 !           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7826            if(.not.l_homo(k,ii)) then
7827              nexl=nexl+1
7828              cycle
7829            endif
7830            distance(k)=odl(k,ii)-dij
7831 !          write (iout,*) "distance(",k,") =",distance(k)
7832 !
7833 !          For Gaussian-type Urestr
7834 !
7835            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7836 !          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7837 !          write (iout,*) "distancek(",k,") =",distancek(k)
7838 !          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7839 !
7840 !          For Lorentzian-type Urestr
7841 !
7842            if (waga_dist.lt.0.0d0) then
7843               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7844               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* &
7845                           (distance(k)**2+sigma_odlir(k,ii)**2))
7846            endif
7847          enddo
7848
7849 !         min_odl=minval(distancek)
7850          if (nexl.gt.0) then
7851            min_odl=0.0d0
7852          else
7853            do kk=1,constr_homology
7854             if(l_homo(kk,ii)) then
7855               min_odl=distancek(kk)
7856               exit
7857             endif
7858            enddo
7859            do kk=1,constr_homology
7860             if (l_homo(kk,ii) .and. distancek(kk).lt.min_odl) &
7861                    min_odl=distancek(kk)
7862            enddo
7863          endif
7864
7865 !        write (iout,* )"min_odl",min_odl
7866 #ifdef DEBUG
7867          write (iout,*) "ij dij",i,j,dij
7868          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7869          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7870          write (iout,* )"min_odl",min_odl
7871 #endif
7872 #ifdef OLDRESTR
7873          odleg2=0.0d0
7874 #else
7875          if (waga_dist.ge.0.0d0) then
7876            odleg2=nexl
7877          else
7878            odleg2=0.0d0
7879          endif
7880 #endif
7881          do k=1,constr_homology
7882 ! Nie wiem po co to liczycie jeszcze raz!
7883 !            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7884 !     &              (2*(sigma_odl(i,j,k))**2))
7885            if(.not.l_homo(k,ii)) cycle
7886            if (waga_dist.ge.0.0d0) then
7887 !
7888 !          For Gaussian-type Urestr
7889 !
7890             godl(k)=dexp(-distancek(k)+min_odl)
7891             odleg2=odleg2+godl(k)
7892 !
7893 !          For Lorentzian-type Urestr
7894 !
7895            else
7896             odleg2=odleg2+distancek(k)
7897            endif
7898
7899 !cc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7900 !cc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7901 !cc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7902 !cc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7903
7904          enddo
7905 !        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7906 !        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7907 #ifdef DEBUG
7908          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7909          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7910 #endif
7911            if (waga_dist.ge.0.0d0) then
7912 !
7913 !          For Gaussian-type Urestr
7914 !
7915               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7916 !
7917 !          For Lorentzian-type Urestr
7918 !
7919            else
7920               odleg=odleg+odleg2/constr_homology
7921            endif
7922 !
7923 !        write (iout,*) "odleg",odleg ! sum of -ln-s
7924 ! Gradient
7925 !
7926 !          For Gaussian-type Urestr
7927 !
7928          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7929          sum_sgodl=0.0d0
7930          do k=1,constr_homology
7931 !            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7932 !     &           *waga_dist)+min_odl
7933 !          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7934 !
7935          if(.not.l_homo(k,ii)) cycle
7936          if (waga_dist.ge.0.0d0) then
7937 !          For Gaussian-type Urestr
7938 !
7939            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7940 !
7941 !          For Lorentzian-type Urestr
7942 !
7943          else
7944            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ &
7945                 sigma_odlir(k,ii)**2)**2)
7946          endif
7947            sum_sgodl=sum_sgodl+sgodl
7948
7949 !            sgodl2=sgodl2+sgodl
7950 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7951 !      write(iout,*) "constr_homology=",constr_homology
7952 !      write(iout,*) i, j, k, "TEST K"
7953          enddo
7954 !         print *, "ok",iset
7955          if (waga_dist.ge.0.0d0) then
7956 !
7957 !          For Gaussian-type Urestr
7958 !
7959             grad_odl3=waga_homology(iset)*waga_dist &
7960                      *sum_sgodl/(sum_godl*dij)
7961 !         print *, "ok"
7962 !
7963 !          For Lorentzian-type Urestr
7964 !
7965          else
7966 ! Original grad expr modified by analogy w Gaussian-type Urestr grad
7967 !           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7968             grad_odl3=-waga_homology(iset)*waga_dist* &
7969                      sum_sgodl/(constr_homology*dij)
7970 !         print *, "ok2"
7971          endif
7972 !
7973 !        grad_odl3=sum_sgodl/(sum_godl*dij)
7974
7975
7976 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7977 !      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7978 !     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7979
7980 !cc      write(iout,*) godl, sgodl, grad_odl3
7981
7982 !          grad_odl=grad_odl+grad_odl3
7983
7984          do jik=1,3
7985             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7986 !cc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7987 !cc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7988 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7989             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7990             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7991 !cc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7992 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7993 !         if (i.eq.25.and.j.eq.27) then
7994 !         write(iout,*) "jik",jik,"i",i,"j",j
7995 !         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7996 !         write(iout,*) "grad_odl3",grad_odl3
7997 !         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7998 !         write(iout,*) "ggodl",ggodl
7999 !         write(iout,*) "ghpbc(",jik,i,")",
8000 !     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8001 !     &                 ghpbc(jik,j)
8002 !         endif
8003          enddo
8004 !cc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8005 !cc     & dLOG(odleg2),"-odleg=", -odleg
8006
8007       enddo ! ii-loop for dist
8008 #ifdef DEBUG
8009       write(iout,*) "------- dist restrs end -------"
8010 !     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8011 !    &     waga_d.eq.1.0d0) call sum_gradient
8012 #endif
8013 ! Pseudo-energy and gradient from dihedral-angle restraints from
8014 ! homology templates
8015 !      write (iout,*) "End of distance loop"
8016 !      call flush(iout)
8017       kat=0.0d0
8018 !      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8019 #ifdef DEBUG
8020       write(iout,*) "------- dih restrs start -------"
8021       do i=idihconstr_start_homo,idihconstr_end_homo
8022         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8023       enddo
8024 #endif
8025       do i=idihconstr_start_homo,idihconstr_end_homo
8026         kat2=0.0d0
8027 !        betai=beta(i,i+1,i+2,i+3)
8028         betai = phi(i)
8029 !       write (iout,*) "betai =",betai
8030         do k=1,constr_homology
8031           dih_diff(k)=pinorm(dih(k,i)-betai)
8032 !d          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8033 !d     &                  ,sigma_dih(k,i)
8034 !          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8035 !     &                                   -(6.28318-dih_diff(i,k))
8036 !          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8037 !     &                                   6.28318+dih_diff(i,k)
8038 #ifdef OLD_DIHED
8039           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8040 #else
8041           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8042 #endif
8043 !         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8044           gdih(k)=dexp(kat3)
8045           kat2=kat2+gdih(k)
8046 !          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8047 !          write(*,*)""
8048         enddo
8049 !       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8050 !       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8051 #ifdef DEBUG
8052         write (iout,*) "i",i," betai",betai," kat2",kat2
8053         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8054 #endif
8055         if (kat2.le.1.0d-14) cycle
8056         kat=kat-dLOG(kat2/constr_homology)
8057 !       write (iout,*) "kat",kat ! sum of -ln-s
8058
8059 !cc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8060 !cc     & dLOG(kat2), "-kat=", -kat
8061
8062 ! ----------------------------------------------------------------------
8063 ! Gradient
8064 ! ----------------------------------------------------------------------
8065
8066         sum_gdih=kat2
8067         sum_sgdih=0.0d0
8068         do k=1,constr_homology
8069 #ifdef OLD_DIHED
8070           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8071 #else
8072           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8073 #endif
8074 !         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8075           sum_sgdih=sum_sgdih+sgdih
8076         enddo
8077 !       grad_dih3=sum_sgdih/sum_gdih
8078         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8079 !         print *, "ok3"
8080
8081 !      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8082 !cc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8083 !cc     & gloc(nphi+i-3,icg)
8084         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8085 !        if (i.eq.25) then
8086 !        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8087 !        endif
8088 !cc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8089 !cc     & gloc(nphi+i-3,icg)
8090
8091       enddo ! i-loop for dih
8092 #ifdef DEBUG
8093       write(iout,*) "------- dih restrs end -------"
8094 #endif
8095
8096 ! Pseudo-energy and gradient for theta angle restraints from
8097 ! homology templates
8098 ! FP 01/15 - inserted from econstr_local_test.F, loop structure
8099 ! adapted
8100
8101 !
8102 !     For constr_homology reference structures (FP)
8103 !
8104 !     Uconst_back_tot=0.0d0
8105       Eval=0.0d0
8106       Erot=0.0d0
8107 !     Econstr_back legacy
8108       do i=1,nres
8109 !     do i=ithet_start,ithet_end
8110        dutheta(i)=0.0d0
8111       enddo
8112 !     do i=loc_start,loc_end
8113       do i=-1,nres
8114         do j=1,3
8115           duscdiff(j,i)=0.0d0
8116           duscdiffx(j,i)=0.0d0
8117         enddo
8118       enddo
8119 !
8120 !     do iref=1,nref
8121 !     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8122 !     write (iout,*) "waga_theta",waga_theta
8123       if (waga_theta.gt.0.0d0) then
8124 #ifdef DEBUG
8125       write (iout,*) "usampl",usampl
8126       write(iout,*) "------- theta restrs start -------"
8127 !     do i=ithet_start,ithet_end
8128 !       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8129 !     enddo
8130 #endif
8131 !     write (iout,*) "maxres",maxres,"nres",nres
8132
8133       do i=ithet_start,ithet_end
8134 !
8135 !     do i=1,nfrag_back
8136 !       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8137 !
8138 ! Deviation of theta angles wrt constr_homology ref structures
8139 !
8140         utheta_i=0.0d0 ! argument of Gaussian for single k
8141         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8142 !       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8143 !       over residues in a fragment
8144 !       write (iout,*) "theta(",i,")=",theta(i)
8145         do k=1,constr_homology
8146 !
8147 !         dtheta_i=theta(j)-thetaref(j,iref)
8148 !         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8149           theta_diff(k)=thetatpl(k,i)-theta(i)
8150 !d          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8151 !d     &                  ,sigma_theta(k,i)
8152
8153 !
8154           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8155 !         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8156           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8157           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8158 !         Gradient for single Gaussian restraint in subr Econstr_back
8159 !         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8160 !
8161         enddo
8162 !       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8163 !       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8164
8165 !
8166 !         Gradient for multiple Gaussian restraint
8167         sum_gtheta=gutheta_i
8168         sum_sgtheta=0.0d0
8169         do k=1,constr_homology
8170 !        New generalized expr for multiple Gaussian from Econstr_back
8171          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8172 !
8173 !        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8174           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8175         enddo
8176 !       Final value of gradient using same var as in Econstr_back
8177         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg) &
8178            +sum_sgtheta/sum_gtheta*waga_theta &
8179                     *waga_homology(iset)
8180 !         print *, "ok4"
8181
8182 !        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8183 !     &               *waga_homology(iset)
8184 !       dutheta(i)=sum_sgtheta/sum_gtheta
8185 !
8186 !       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8187         Eval=Eval-dLOG(gutheta_i/constr_homology)
8188 !       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8189 !       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8190 !       Uconst_back=Uconst_back+utheta(i)
8191       enddo ! (i-loop for theta)
8192 #ifdef DEBUG
8193       write(iout,*) "------- theta restrs end -------"
8194 #endif
8195       endif
8196 !
8197 ! Deviation of local SC geometry
8198 !
8199 ! Separation of two i-loops (instructed by AL - 11/3/2014)
8200 !
8201 !     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8202 !     write (iout,*) "waga_d",waga_d
8203
8204 #ifdef DEBUG
8205       write(iout,*) "------- SC restrs start -------"
8206       write (iout,*) "Initial duscdiff,duscdiffx"
8207       do i=loc_start,loc_end
8208         write (iout,*) i,(duscdiff(jik,i),jik=1,3), &
8209                       (duscdiffx(jik,i),jik=1,3)
8210       enddo
8211 #endif
8212       do i=loc_start,loc_end
8213         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8214         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8215 !       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8216 !       write(iout,*) "xxtab, yytab, zztab"
8217 !       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8218         do k=1,constr_homology
8219 !
8220           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8221 !                                    Original sign inverted for calc of gradients (s. Econstr_back)
8222           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8223           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8224 !         write(iout,*) "dxx, dyy, dzz"
8225 !d          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8226 !
8227           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8228 !         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8229 !         uscdiffk(k)=usc_diff(i)
8230           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8231 !          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8232 !     &       " guscdiff2",guscdiff2(k)
8233           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8234 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8235 !     &      xxref(j),yyref(j),zzref(j)
8236         enddo
8237 !
8238 !       Gradient
8239 !
8240 !       Generalized expression for multiple Gaussian acc to that for a single
8241 !       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8242 !
8243 !       Original implementation
8244 !       sum_guscdiff=guscdiff(i)
8245 !
8246 !       sum_sguscdiff=0.0d0
8247 !       do k=1,constr_homology
8248 !          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8249 !          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8250 !          sum_sguscdiff=sum_sguscdiff+sguscdiff
8251 !       enddo
8252 !
8253 !       Implementation of new expressions for gradient (Jan. 2015)
8254 !
8255 !       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8256         do k=1,constr_homology
8257 !
8258 !       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8259 !       before. Now the drivatives should be correct
8260 !
8261           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8262 !                                  Original sign inverted for calc of gradients (s. Econstr_back)
8263           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8264           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8265           sum_guscdiff=guscdiff2(k)* &!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8266                       sigma_d(k,i) ! for the grad wrt r'
8267 !         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8268
8269 !
8270 !         New implementation
8271          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8272          do jik=1,3
8273             duscdiff(jik,i-1)=duscdiff(jik,i-1)+ &
8274             sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ &
8275             dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8276             duscdiff(jik,i)=duscdiff(jik,i)+ &
8277             sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ &
8278             dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8279             duscdiffx(jik,i)=duscdiffx(jik,i)+ &
8280             sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ &
8281             dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8282 !         print *, "ok5"
8283 !
8284 #ifdef DEBUG
8285 !             write(iout,*) "jik",jik,"i",i
8286              write(iout,*) "dxx, dyy, dzz"
8287              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8288              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8289             write(iout,*) "sum_sguscdiff",sum_guscdiff,waga_homology(iset),waga_d
8290             write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8291             write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8292              write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8293              write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8294              write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8295              write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8296              write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8297              write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8298              write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8299              write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8300             write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8301             write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8302 !            endif
8303 #endif
8304          enddo
8305         enddo
8306 !         print *, "ok6"
8307 !
8308 !       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8309 !        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8310 !
8311 !        write (iout,*) i," uscdiff",uscdiff(i)
8312 !
8313 ! Put together deviations from local geometry
8314
8315 !       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8316 !      &            wfrag_back(3,i,iset)*uscdiff(i)
8317         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8318 !       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8319 !       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8320 !       Uconst_back=Uconst_back+usc_diff(i)
8321 !
8322 !     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8323 !
8324 !     New implment: multiplied by sum_sguscdiff
8325 !
8326
8327       enddo ! (i-loop for dscdiff)
8328
8329 !      endif
8330
8331 #ifdef DEBUG
8332       write(iout,*) "------- SC restrs end -------"
8333         write (iout,*) "------ After SC loop in e_modeller ------"
8334         do i=loc_start,loc_end
8335          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8336          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8337         enddo
8338       if (waga_theta.eq.1.0d0) then
8339       write (iout,*) "in e_modeller after SC restr end: dutheta"
8340       do i=ithet_start,ithet_end
8341         write (iout,*) i,dutheta(i)
8342       enddo
8343       endif
8344       if (waga_d.eq.1.0d0) then
8345       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8346       do i=1,nres
8347         write (iout,*) i,(duscdiff(j,i),j=1,3)
8348         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8349       enddo
8350       endif
8351 #endif
8352
8353 ! Total energy from homology restraints
8354 #ifdef DEBUG
8355       write (iout,*) "odleg",odleg," kat",kat
8356 #endif
8357 !
8358 ! Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8359 !
8360 !     ehomology_constr=odleg+kat
8361 !
8362 !     For Lorentzian-type Urestr
8363 !
8364
8365       if (waga_dist.ge.0.0d0) then
8366 !
8367 !          For Gaussian-type Urestr
8368 !
8369         ehomology_constr=(waga_dist*odleg+waga_angle*kat+ &
8370                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8371 !     write (iout,*) "ehomology_constr=",ehomology_constr
8372 !         print *, "ok7"
8373       else
8374 !
8375 !          For Lorentzian-type Urestr
8376 !
8377         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ &
8378                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8379 !     write (iout,*) "ehomology_constr=",ehomology_constr
8380          print *, "ok8"
8381       endif
8382 #ifdef DEBUG
8383       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, &
8384       "Eval",waga_theta,eval, &
8385         "Erot",waga_d,Erot
8386       write (iout,*) "ehomology_constr",ehomology_constr
8387 #endif
8388       return
8389 !
8390 ! FP 01/15 end
8391 !
8392   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8393   747 format(a12,i4,i4,i4,f8.3,f8.3)
8394   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8395   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8396   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, &
8397             f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8398       end subroutine e_modeller
8399
8400 !----------------------------------------------------------------------------
8401       subroutine ebend_kcc(etheta)
8402       logical lprn
8403       double precision thybt1(maxang_kcc),etheta
8404       integer :: i,iti,j,ihelp
8405       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
8406 !C Set lprn=.true. for debugging
8407       lprn=energy_dec
8408 !c     lprn=.true.
8409 !C      print *,"wchodze kcc"
8410       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8411       etheta=0.0D0
8412       do i=ithet_start,ithet_end
8413 !c        print *,i,itype(i-1),itype(i),itype(i-2)
8414         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
8415        .or.itype(i,1).eq.ntyp1) cycle
8416         iti=iabs(itortyp(itype(i-1,1)))
8417         sinthet=dsin(theta(i))
8418         costhet=dcos(theta(i))
8419         do j=1,nbend_kcc_Tb(iti)
8420           thybt1(j)=v1bend_chyb(j,iti)
8421         enddo
8422         sumth1thyb=v1bend_chyb(0,iti)+ &
8423          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8424         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
8425          sumth1thyb
8426         ihelp=nbend_kcc_Tb(iti)-1
8427         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8428         etheta=etheta+sumth1thyb
8429 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8430         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8431       enddo
8432       return
8433       end subroutine ebend_kcc
8434 !c------------
8435 !c-------------------------------------------------------------------------------------
8436       subroutine etheta_constr(ethetacnstr)
8437       real (kind=8) :: ethetacnstr,thetiii,difi
8438       integer :: i,itheta
8439       ethetacnstr=0.0d0
8440 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8441       do i=ithetaconstr_start,ithetaconstr_end
8442         itheta=itheta_constr(i)
8443         thetiii=theta(itheta)
8444         difi=pinorm(thetiii-theta_constr0(i))
8445         if (difi.gt.theta_drange(i)) then
8446           difi=difi-theta_drange(i)
8447           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8448           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8449          +for_thet_constr(i)*difi**3
8450         else if (difi.lt.-drange(i)) then
8451           difi=difi+drange(i)
8452           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8453           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8454           +for_thet_constr(i)*difi**3
8455         else
8456           difi=0.0
8457         endif
8458        if (energy_dec) then
8459         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
8460          i,itheta,rad2deg*thetiii,&
8461          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
8462          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
8463          gloc(itheta+nphi-2,icg)
8464         endif
8465       enddo
8466       return
8467       end subroutine etheta_constr
8468
8469 !-----------------------------------------------------------------------------
8470       subroutine eback_sc_corr(esccor)
8471 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
8472 !        conformational states; temporarily implemented as differences
8473 !        between UNRES torsional potentials (dependent on three types of
8474 !        residues) and the torsional potentials dependent on all 20 types
8475 !        of residues computed from AM1  energy surfaces of terminally-blocked
8476 !        amino-acid residues.
8477 !      implicit real(kind=8) (a-h,o-z)
8478 !      include 'DIMENSIONS'
8479 !      include 'COMMON.VAR'
8480 !      include 'COMMON.GEO'
8481 !      include 'COMMON.LOCAL'
8482 !      include 'COMMON.TORSION'
8483 !      include 'COMMON.SCCOR'
8484 !      include 'COMMON.INTERACT'
8485 !      include 'COMMON.DERIV'
8486 !      include 'COMMON.CHAIN'
8487 !      include 'COMMON.NAMES'
8488 !      include 'COMMON.IOUNITS'
8489 !      include 'COMMON.FFIELD'
8490 !      include 'COMMON.CONTROL'
8491       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
8492                    cosphi,sinphi
8493       logical :: lprn
8494       integer :: i,interty,j,isccori,isccori1,intertyp
8495 ! Set lprn=.true. for debugging
8496       lprn=.false.
8497 !      lprn=.true.
8498 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8499       esccor=0.0D0
8500       do i=itau_start,itau_end
8501         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
8502         esccor_ii=0.0D0
8503         isccori=isccortyp(itype(i-2,1))
8504         isccori1=isccortyp(itype(i-1,1))
8505
8506 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8507         phii=phi(i)
8508         do intertyp=1,3 !intertyp
8509          esccor_ii=0.0D0
8510 !c Added 09 May 2012 (Adasko)
8511 !c  Intertyp means interaction type of backbone mainchain correlation:
8512 !   1 = SC...Ca...Ca...Ca
8513 !   2 = Ca...Ca...Ca...SC
8514 !   3 = SC...Ca...Ca...SCi
8515         gloci=0.0D0
8516         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
8517             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
8518             (itype(i-1,1).eq.ntyp1))) &
8519           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
8520            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
8521            .or.(itype(i,1).eq.ntyp1))) &
8522           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
8523             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
8524             (itype(i-3,1).eq.ntyp1)))) cycle
8525         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
8526         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
8527        cycle
8528        do j=1,nterm_sccor(isccori,isccori1)
8529           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8530           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8531           cosphi=dcos(j*tauangle(intertyp,i))
8532           sinphi=dsin(j*tauangle(intertyp,i))
8533           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
8534           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8535           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8536         enddo
8537         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
8538                                 'esccor',i,intertyp,esccor_ii
8539 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8540         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8541         if (lprn) &
8542         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
8543         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
8544         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
8545         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8546         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8547        enddo !intertyp
8548       enddo
8549
8550       return
8551       end subroutine eback_sc_corr
8552 !-----------------------------------------------------------------------------
8553       subroutine multibody(ecorr)
8554 ! This subroutine calculates multi-body contributions to energy following
8555 ! the idea of Skolnick et al. If side chains I and J make a contact and
8556 ! at the same time side chains I+1 and J+1 make a contact, an extra
8557 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8558 !      implicit real(kind=8) (a-h,o-z)
8559 !      include 'DIMENSIONS'
8560 !      include 'COMMON.IOUNITS'
8561 !      include 'COMMON.DERIV'
8562 !      include 'COMMON.INTERACT'
8563 !      include 'COMMON.CONTACTS'
8564       real(kind=8),dimension(3) :: gx,gx1
8565       logical :: lprn
8566       real(kind=8) :: ecorr
8567       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
8568 ! Set lprn=.true. for debugging
8569       lprn=.false.
8570
8571       if (lprn) then
8572         write (iout,'(a)') 'Contact function values:'
8573         do i=nnt,nct-2
8574           write (iout,'(i2,20(1x,i2,f10.5))') &
8575               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8576         enddo
8577       endif
8578       ecorr=0.0D0
8579
8580 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8581 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8582       do i=nnt,nct
8583         do j=1,3
8584           gradcorr(j,i)=0.0D0
8585           gradxorr(j,i)=0.0D0
8586         enddo
8587       enddo
8588       do i=nnt,nct-2
8589
8590         DO ISHIFT = 3,4
8591
8592         i1=i+ishift
8593         num_conti=num_cont(i)
8594         num_conti1=num_cont(i1)
8595         do jj=1,num_conti
8596           j=jcont(jj,i)
8597           do kk=1,num_conti1
8598             j1=jcont(kk,i1)
8599             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8600 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8601 !d   &                   ' ishift=',ishift
8602 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8603 ! The system gains extra energy.
8604               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8605             endif   ! j1==j+-ishift
8606           enddo     ! kk
8607         enddo       ! jj
8608
8609         ENDDO ! ISHIFT
8610
8611       enddo         ! i
8612       return
8613       end subroutine multibody
8614 !-----------------------------------------------------------------------------
8615       real(kind=8) function esccorr(i,j,k,l,jj,kk)
8616 !      implicit real(kind=8) (a-h,o-z)
8617 !      include 'DIMENSIONS'
8618 !      include 'COMMON.IOUNITS'
8619 !      include 'COMMON.DERIV'
8620 !      include 'COMMON.INTERACT'
8621 !      include 'COMMON.CONTACTS'
8622       real(kind=8),dimension(3) :: gx,gx1
8623       logical :: lprn
8624       integer :: i,j,k,l,jj,kk,m,ll
8625       real(kind=8) :: eij,ekl
8626       lprn=.false.
8627       eij=facont(jj,i)
8628       ekl=facont(kk,k)
8629 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8630 ! Calculate the multi-body contribution to energy.
8631 ! Calculate multi-body contributions to the gradient.
8632 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8633 !d   & k,l,(gacont(m,kk,k),m=1,3)
8634       do m=1,3
8635         gx(m) =ekl*gacont(m,jj,i)
8636         gx1(m)=eij*gacont(m,kk,k)
8637         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8638         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8639         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8640         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8641       enddo
8642       do m=i,j-1
8643         do ll=1,3
8644           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8645         enddo
8646       enddo
8647       do m=k,l-1
8648         do ll=1,3
8649           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8650         enddo
8651       enddo
8652       esccorr=-eij*ekl
8653       return
8654       end function esccorr
8655 !-----------------------------------------------------------------------------
8656       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8657 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8658 !      implicit real(kind=8) (a-h,o-z)
8659 !      include 'DIMENSIONS'
8660 !      include 'COMMON.IOUNITS'
8661 #ifdef MPI
8662       include "mpif.h"
8663 !      integer :: maxconts !max_cont=maxconts  =nres/4
8664       integer,parameter :: max_dim=26
8665       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8666       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8667 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8668 !el      common /przechowalnia/ zapas
8669       integer :: status(MPI_STATUS_SIZE)
8670       integer,dimension((nres/4)*2) :: req !maxconts*2
8671       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
8672 #endif
8673 !      include 'COMMON.SETUP'
8674 !      include 'COMMON.FFIELD'
8675 !      include 'COMMON.DERIV'
8676 !      include 'COMMON.INTERACT'
8677 !      include 'COMMON.CONTACTS'
8678 !      include 'COMMON.CONTROL'
8679 !      include 'COMMON.LOCAL'
8680       real(kind=8),dimension(3) :: gx,gx1
8681       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
8682       logical :: lprn,ldone
8683 !el local variables
8684       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
8685               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
8686
8687 ! Set lprn=.true. for debugging
8688       lprn=.false.
8689 #ifdef MPI
8690 !      maxconts=nres/4
8691       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8692       n_corr=0
8693       n_corr1=0
8694       if (nfgtasks.le.1) goto 30
8695       if (lprn) then
8696         write (iout,'(a)') 'Contact function values before RECEIVE:'
8697         do i=nnt,nct-2
8698           write (iout,'(2i3,50(1x,i2,f5.2))') &
8699           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8700           j=1,num_cont_hb(i))
8701         enddo
8702       endif
8703       call flush(iout)
8704       do i=1,ntask_cont_from
8705         ncont_recv(i)=0
8706       enddo
8707       do i=1,ntask_cont_to
8708         ncont_sent(i)=0
8709       enddo
8710 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8711 !     & ntask_cont_to
8712 ! Make the list of contacts to send to send to other procesors
8713 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8714 !      call flush(iout)
8715       do i=iturn3_start,iturn3_end
8716 !        write (iout,*) "make contact list turn3",i," num_cont",
8717 !     &    num_cont_hb(i)
8718         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8719       enddo
8720       do i=iturn4_start,iturn4_end
8721 !        write (iout,*) "make contact list turn4",i," num_cont",
8722 !     &   num_cont_hb(i)
8723         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8724       enddo
8725       do ii=1,nat_sent
8726         i=iat_sent(ii)
8727 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8728 !     &    num_cont_hb(i)
8729         do j=1,num_cont_hb(i)
8730         do k=1,4
8731           jjc=jcont_hb(j,i)
8732           iproc=iint_sent_local(k,jjc,ii)
8733 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8734           if (iproc.gt.0) then
8735             ncont_sent(iproc)=ncont_sent(iproc)+1
8736             nn=ncont_sent(iproc)
8737             zapas(1,nn,iproc)=i
8738             zapas(2,nn,iproc)=jjc
8739             zapas(3,nn,iproc)=facont_hb(j,i)
8740             zapas(4,nn,iproc)=ees0p(j,i)
8741             zapas(5,nn,iproc)=ees0m(j,i)
8742             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8743             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8744             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8745             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8746             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8747             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8748             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8749             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8750             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8751             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8752             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8753             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8754             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8755             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8756             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8757             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8758             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8759             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8760             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8761             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8762             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8763           endif
8764         enddo
8765         enddo
8766       enddo
8767       if (lprn) then
8768       write (iout,*) &
8769         "Numbers of contacts to be sent to other processors",&
8770         (ncont_sent(i),i=1,ntask_cont_to)
8771       write (iout,*) "Contacts sent"
8772       do ii=1,ntask_cont_to
8773         nn=ncont_sent(ii)
8774         iproc=itask_cont_to(ii)
8775         write (iout,*) nn," contacts to processor",iproc,&
8776          " of CONT_TO_COMM group"
8777         do i=1,nn
8778           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8779         enddo
8780       enddo
8781       call flush(iout)
8782       endif
8783       CorrelType=477
8784       CorrelID=fg_rank+1
8785       CorrelType1=478
8786       CorrelID1=nfgtasks+fg_rank+1
8787       ireq=0
8788 ! Receive the numbers of needed contacts from other processors
8789       do ii=1,ntask_cont_from
8790         iproc=itask_cont_from(ii)
8791         ireq=ireq+1
8792         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8793           FG_COMM,req(ireq),IERR)
8794       enddo
8795 !      write (iout,*) "IRECV ended"
8796 !      call flush(iout)
8797 ! Send the number of contacts needed by other processors
8798       do ii=1,ntask_cont_to
8799         iproc=itask_cont_to(ii)
8800         ireq=ireq+1
8801         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8802           FG_COMM,req(ireq),IERR)
8803       enddo
8804 !      write (iout,*) "ISEND ended"
8805 !      write (iout,*) "number of requests (nn)",ireq
8806       call flush(iout)
8807       if (ireq.gt.0) &
8808         call MPI_Waitall(ireq,req,status_array,ierr)
8809 !      write (iout,*)
8810 !     &  "Numbers of contacts to be received from other processors",
8811 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8812 !      call flush(iout)
8813 ! Receive contacts
8814       ireq=0
8815       do ii=1,ntask_cont_from
8816         iproc=itask_cont_from(ii)
8817         nn=ncont_recv(ii)
8818 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8819 !     &   " of CONT_TO_COMM group"
8820         call flush(iout)
8821         if (nn.gt.0) then
8822           ireq=ireq+1
8823           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8824           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8825 !          write (iout,*) "ireq,req",ireq,req(ireq)
8826         endif
8827       enddo
8828 ! Send the contacts to processors that need them
8829       do ii=1,ntask_cont_to
8830         iproc=itask_cont_to(ii)
8831         nn=ncont_sent(ii)
8832 !        write (iout,*) nn," contacts to processor",iproc,
8833 !     &   " of CONT_TO_COMM group"
8834         if (nn.gt.0) then
8835           ireq=ireq+1
8836           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8837             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8838 !          write (iout,*) "ireq,req",ireq,req(ireq)
8839 !          do i=1,nn
8840 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8841 !          enddo
8842         endif
8843       enddo
8844 !      write (iout,*) "number of requests (contacts)",ireq
8845 !      write (iout,*) "req",(req(i),i=1,4)
8846 !      call flush(iout)
8847       if (ireq.gt.0) &
8848        call MPI_Waitall(ireq,req,status_array,ierr)
8849       do iii=1,ntask_cont_from
8850         iproc=itask_cont_from(iii)
8851         nn=ncont_recv(iii)
8852         if (lprn) then
8853         write (iout,*) "Received",nn," contacts from processor",iproc,&
8854          " of CONT_FROM_COMM group"
8855         call flush(iout)
8856         do i=1,nn
8857           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8858         enddo
8859         call flush(iout)
8860         endif
8861         do i=1,nn
8862           ii=zapas_recv(1,i,iii)
8863 ! Flag the received contacts to prevent double-counting
8864           jj=-zapas_recv(2,i,iii)
8865 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8866 !          call flush(iout)
8867           nnn=num_cont_hb(ii)+1
8868           num_cont_hb(ii)=nnn
8869           jcont_hb(nnn,ii)=jj
8870           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8871           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8872           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8873           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8874           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8875           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8876           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8877           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8878           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8879           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8880           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8881           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8882           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8883           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8884           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8885           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8886           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8887           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8888           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8889           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8890           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8891           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8892           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8893           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8894         enddo
8895       enddo
8896       call flush(iout)
8897       if (lprn) then
8898         write (iout,'(a)') 'Contact function values after receive:'
8899         do i=nnt,nct-2
8900           write (iout,'(2i3,50(1x,i3,f5.2))') &
8901           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8902           j=1,num_cont_hb(i))
8903         enddo
8904         call flush(iout)
8905       endif
8906    30 continue
8907 #endif
8908       if (lprn) then
8909         write (iout,'(a)') 'Contact function values:'
8910         do i=nnt,nct-2
8911           write (iout,'(2i3,50(1x,i3,f5.2))') &
8912           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8913           j=1,num_cont_hb(i))
8914         enddo
8915       endif
8916       ecorr=0.0D0
8917
8918 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8919 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8920 ! Remove the loop below after debugging !!!
8921       do i=nnt,nct
8922         do j=1,3
8923           gradcorr(j,i)=0.0D0
8924           gradxorr(j,i)=0.0D0
8925         enddo
8926       enddo
8927 ! Calculate the local-electrostatic correlation terms
8928       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8929         i1=i+1
8930         num_conti=num_cont_hb(i)
8931         num_conti1=num_cont_hb(i+1)
8932         do jj=1,num_conti
8933           j=jcont_hb(jj,i)
8934           jp=iabs(j)
8935           do kk=1,num_conti1
8936             j1=jcont_hb(kk,i1)
8937             jp1=iabs(j1)
8938 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8939 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8940             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8941                 .or. j.lt.0 .and. j1.gt.0) .and. &
8942                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8943 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8944 ! The system gains extra energy.
8945               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8946               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8947                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8948               n_corr=n_corr+1
8949             else if (j1.eq.j) then
8950 ! Contacts I-J and I-(J+1) occur simultaneously.
8951 ! The system loses extra energy.
8952 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8953             endif
8954           enddo ! kk
8955           do kk=1,num_conti
8956             j1=jcont_hb(kk,i)
8957 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8958 !    &         ' jj=',jj,' kk=',kk
8959             if (j1.eq.j+1) then
8960 ! Contacts I-J and (I+1)-J occur simultaneously.
8961 ! The system loses extra energy.
8962 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8963             endif ! j1==j+1
8964           enddo ! kk
8965         enddo ! jj
8966       enddo ! i
8967       return
8968       end subroutine multibody_hb
8969 !-----------------------------------------------------------------------------
8970       subroutine add_hb_contact(ii,jj,itask)
8971 !      implicit real(kind=8) (a-h,o-z)
8972 !      include "DIMENSIONS"
8973 !      include "COMMON.IOUNITS"
8974 !      include "COMMON.CONTACTS"
8975 !      integer,parameter :: maxconts=nres/4
8976       integer,parameter :: max_dim=26
8977       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8978 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8979 !      common /przechowalnia/ zapas
8980       integer :: i,j,ii,jj,iproc,nn,jjc
8981       integer,dimension(4) :: itask
8982 !      write (iout,*) "itask",itask
8983       do i=1,2
8984         iproc=itask(i)
8985         if (iproc.gt.0) then
8986           do j=1,num_cont_hb(ii)
8987             jjc=jcont_hb(j,ii)
8988 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8989             if (jjc.eq.jj) then
8990               ncont_sent(iproc)=ncont_sent(iproc)+1
8991               nn=ncont_sent(iproc)
8992               zapas(1,nn,iproc)=ii
8993               zapas(2,nn,iproc)=jjc
8994               zapas(3,nn,iproc)=facont_hb(j,ii)
8995               zapas(4,nn,iproc)=ees0p(j,ii)
8996               zapas(5,nn,iproc)=ees0m(j,ii)
8997               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8998               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8999               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9000               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9001               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9002               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9003               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9004               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9005               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9006               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9007               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9008               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9009               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9010               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9011               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9012               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9013               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9014               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9015               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9016               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9017               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9018               exit
9019             endif
9020           enddo
9021         endif
9022       enddo
9023       return
9024       end subroutine add_hb_contact
9025 !-----------------------------------------------------------------------------
9026       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
9027 ! This subroutine calculates multi-body contributions to hydrogen-bonding
9028 !      implicit real(kind=8) (a-h,o-z)
9029 !      include 'DIMENSIONS'
9030 !      include 'COMMON.IOUNITS'
9031       integer,parameter :: max_dim=70
9032 #ifdef MPI
9033       include "mpif.h"
9034 !      integer :: maxconts !max_cont=maxconts=nres/4
9035       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9036       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
9037 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
9038 !      common /przechowalnia/ zapas
9039       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
9040         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
9041         ierr,iii,nnn
9042 #endif
9043 !      include 'COMMON.SETUP'
9044 !      include 'COMMON.FFIELD'
9045 !      include 'COMMON.DERIV'
9046 !      include 'COMMON.LOCAL'
9047 !      include 'COMMON.INTERACT'
9048 !      include 'COMMON.CONTACTS'
9049 !      include 'COMMON.CHAIN'
9050 !      include 'COMMON.CONTROL'
9051       real(kind=8),dimension(3) :: gx,gx1
9052       integer,dimension(nres) :: num_cont_hb_old
9053       logical :: lprn,ldone
9054 !EL      double precision eello4,eello5,eelo6,eello_turn6
9055 !EL      external eello4,eello5,eello6,eello_turn6
9056 !el local variables
9057       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
9058               j1,jp1,i1,num_conti1
9059       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
9060       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
9061
9062 ! Set lprn=.true. for debugging
9063       lprn=.false.
9064       eturn6=0.0d0
9065 #ifdef MPI
9066 !      maxconts=nres/4
9067       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
9068       do i=1,nres
9069         num_cont_hb_old(i)=num_cont_hb(i)
9070       enddo
9071       n_corr=0
9072       n_corr1=0
9073       if (nfgtasks.le.1) goto 30
9074       if (lprn) then
9075         write (iout,'(a)') 'Contact function values before RECEIVE:'
9076         do i=nnt,nct-2
9077           write (iout,'(2i3,50(1x,i2,f5.2))') &
9078           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
9079           j=1,num_cont_hb(i))
9080         enddo
9081       endif
9082       call flush(iout)
9083       do i=1,ntask_cont_from
9084         ncont_recv(i)=0
9085       enddo
9086       do i=1,ntask_cont_to
9087         ncont_sent(i)=0
9088       enddo
9089 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9090 !     & ntask_cont_to
9091 ! Make the list of contacts to send to send to other procesors
9092       do i=iturn3_start,iturn3_end
9093 !        write (iout,*) "make contact list turn3",i," num_cont",
9094 !     &    num_cont_hb(i)
9095         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9096       enddo
9097       do i=iturn4_start,iturn4_end
9098 !        write (iout,*) "make contact list turn4",i," num_cont",
9099 !     &   num_cont_hb(i)
9100         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9101       enddo
9102       do ii=1,nat_sent
9103         i=iat_sent(ii)
9104 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
9105 !     &    num_cont_hb(i)
9106         do j=1,num_cont_hb(i)
9107         do k=1,4
9108           jjc=jcont_hb(j,i)
9109           iproc=iint_sent_local(k,jjc,ii)
9110 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9111           if (iproc.ne.0) then
9112             ncont_sent(iproc)=ncont_sent(iproc)+1
9113             nn=ncont_sent(iproc)
9114             zapas(1,nn,iproc)=i
9115             zapas(2,nn,iproc)=jjc
9116             zapas(3,nn,iproc)=d_cont(j,i)
9117             ind=3
9118             do kk=1,3
9119               ind=ind+1
9120               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9121             enddo
9122             do kk=1,2
9123               do ll=1,2
9124                 ind=ind+1
9125                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9126               enddo
9127             enddo
9128             do jj=1,5
9129               do kk=1,3
9130                 do ll=1,2
9131                   do mm=1,2
9132                     ind=ind+1
9133                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9134                   enddo
9135                 enddo
9136               enddo
9137             enddo
9138           endif
9139         enddo
9140         enddo
9141       enddo
9142       if (lprn) then
9143       write (iout,*) &
9144         "Numbers of contacts to be sent to other processors",&
9145         (ncont_sent(i),i=1,ntask_cont_to)
9146       write (iout,*) "Contacts sent"
9147       do ii=1,ntask_cont_to
9148         nn=ncont_sent(ii)
9149         iproc=itask_cont_to(ii)
9150         write (iout,*) nn," contacts to processor",iproc,&
9151          " of CONT_TO_COMM group"
9152         do i=1,nn
9153           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9154         enddo
9155       enddo
9156       call flush(iout)
9157       endif
9158       CorrelType=477
9159       CorrelID=fg_rank+1
9160       CorrelType1=478
9161       CorrelID1=nfgtasks+fg_rank+1
9162       ireq=0
9163 ! Receive the numbers of needed contacts from other processors
9164       do ii=1,ntask_cont_from
9165         iproc=itask_cont_from(ii)
9166         ireq=ireq+1
9167         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
9168           FG_COMM,req(ireq),IERR)
9169       enddo
9170 !      write (iout,*) "IRECV ended"
9171 !      call flush(iout)
9172 ! Send the number of contacts needed by other processors
9173       do ii=1,ntask_cont_to
9174         iproc=itask_cont_to(ii)
9175         ireq=ireq+1
9176         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
9177           FG_COMM,req(ireq),IERR)
9178       enddo
9179 !      write (iout,*) "ISEND ended"
9180 !      write (iout,*) "number of requests (nn)",ireq
9181       call flush(iout)
9182       if (ireq.gt.0) &
9183         call MPI_Waitall(ireq,req,status_array,ierr)
9184 !      write (iout,*)
9185 !     &  "Numbers of contacts to be received from other processors",
9186 !     &  (ncont_recv(i),i=1,ntask_cont_from)
9187 !      call flush(iout)
9188 ! Receive contacts
9189       ireq=0
9190       do ii=1,ntask_cont_from
9191         iproc=itask_cont_from(ii)
9192         nn=ncont_recv(ii)
9193 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9194 !     &   " of CONT_TO_COMM group"
9195         call flush(iout)
9196         if (nn.gt.0) then
9197           ireq=ireq+1
9198           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
9199           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9200 !          write (iout,*) "ireq,req",ireq,req(ireq)
9201         endif
9202       enddo
9203 ! Send the contacts to processors that need them
9204       do ii=1,ntask_cont_to
9205         iproc=itask_cont_to(ii)
9206         nn=ncont_sent(ii)
9207 !        write (iout,*) nn," contacts to processor",iproc,
9208 !     &   " of CONT_TO_COMM group"
9209         if (nn.gt.0) then
9210           ireq=ireq+1
9211           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
9212             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9213 !          write (iout,*) "ireq,req",ireq,req(ireq)
9214 !          do i=1,nn
9215 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9216 !          enddo
9217         endif
9218       enddo
9219 !      write (iout,*) "number of requests (contacts)",ireq
9220 !      write (iout,*) "req",(req(i),i=1,4)
9221 !      call flush(iout)
9222       if (ireq.gt.0) &
9223        call MPI_Waitall(ireq,req,status_array,ierr)
9224       do iii=1,ntask_cont_from
9225         iproc=itask_cont_from(iii)
9226         nn=ncont_recv(iii)
9227         if (lprn) then
9228         write (iout,*) "Received",nn," contacts from processor",iproc,&
9229          " of CONT_FROM_COMM group"
9230         call flush(iout)
9231         do i=1,nn
9232           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9233         enddo
9234         call flush(iout)
9235         endif
9236         do i=1,nn
9237           ii=zapas_recv(1,i,iii)
9238 ! Flag the received contacts to prevent double-counting
9239           jj=-zapas_recv(2,i,iii)
9240 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9241 !          call flush(iout)
9242           nnn=num_cont_hb(ii)+1
9243           num_cont_hb(ii)=nnn
9244           jcont_hb(nnn,ii)=jj
9245           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9246           ind=3
9247           do kk=1,3
9248             ind=ind+1
9249             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9250           enddo
9251           do kk=1,2
9252             do ll=1,2
9253               ind=ind+1
9254               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9255             enddo
9256           enddo
9257           do jj=1,5
9258             do kk=1,3
9259               do ll=1,2
9260                 do mm=1,2
9261                   ind=ind+1
9262                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9263                 enddo
9264               enddo
9265             enddo
9266           enddo
9267         enddo
9268       enddo
9269       call flush(iout)
9270       if (lprn) then
9271         write (iout,'(a)') 'Contact function values after receive:'
9272         do i=nnt,nct-2
9273           write (iout,'(2i3,50(1x,i3,5f6.3))') &
9274           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9275           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9276         enddo
9277         call flush(iout)
9278       endif
9279    30 continue
9280 #endif
9281       if (lprn) then
9282         write (iout,'(a)') 'Contact function values:'
9283         do i=nnt,nct-2
9284           write (iout,'(2i3,50(1x,i2,5f6.3))') &
9285           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9286           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9287         enddo
9288       endif
9289       ecorr=0.0D0
9290       ecorr5=0.0d0
9291       ecorr6=0.0d0
9292
9293 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
9294 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
9295 ! Remove the loop below after debugging !!!
9296       do i=nnt,nct
9297         do j=1,3
9298           gradcorr(j,i)=0.0D0
9299           gradxorr(j,i)=0.0D0
9300         enddo
9301       enddo
9302 ! Calculate the dipole-dipole interaction energies
9303       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9304       do i=iatel_s,iatel_e+1
9305         num_conti=num_cont_hb(i)
9306         do jj=1,num_conti
9307           j=jcont_hb(jj,i)
9308 #ifdef MOMENT
9309           call dipole(i,j,jj)
9310 #endif
9311         enddo
9312       enddo
9313       endif
9314 ! Calculate the local-electrostatic correlation terms
9315 !                write (iout,*) "gradcorr5 in eello5 before loop"
9316 !                do iii=1,nres
9317 !                  write (iout,'(i5,3f10.5)')
9318 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9319 !                enddo
9320       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9321 !        write (iout,*) "corr loop i",i
9322         i1=i+1
9323         num_conti=num_cont_hb(i)
9324         num_conti1=num_cont_hb(i+1)
9325         do jj=1,num_conti
9326           j=jcont_hb(jj,i)
9327           jp=iabs(j)
9328           do kk=1,num_conti1
9329             j1=jcont_hb(kk,i1)
9330             jp1=iabs(j1)
9331 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9332 !     &         ' jj=',jj,' kk=',kk
9333 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
9334             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
9335                 .or. j.lt.0 .and. j1.gt.0) .and. &
9336                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9337 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9338 ! The system gains extra energy.
9339               n_corr=n_corr+1
9340               sqd1=dsqrt(d_cont(jj,i))
9341               sqd2=dsqrt(d_cont(kk,i1))
9342               sred_geom = sqd1*sqd2
9343               IF (sred_geom.lt.cutoff_corr) THEN
9344                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
9345                   ekont,fprimcont)
9346 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9347 !d     &         ' jj=',jj,' kk=',kk
9348                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9349                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9350                 do l=1,3
9351                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9352                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9353                 enddo
9354                 n_corr1=n_corr1+1
9355 !d               write (iout,*) 'sred_geom=',sred_geom,
9356 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
9357 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9358 !d               write (iout,*) "g_contij",g_contij
9359 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9360 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9361                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9362                 if (wcorr4.gt.0.0d0) &
9363                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9364                   if (energy_dec.and.wcorr4.gt.0.0d0) &
9365                        write (iout,'(a6,4i5,0pf7.3)') &
9366                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9367 !                write (iout,*) "gradcorr5 before eello5"
9368 !                do iii=1,nres
9369 !                  write (iout,'(i5,3f10.5)')
9370 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9371 !                enddo
9372                 if (wcorr5.gt.0.0d0) &
9373                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9374 !                write (iout,*) "gradcorr5 after eello5"
9375 !                do iii=1,nres
9376 !                  write (iout,'(i5,3f10.5)')
9377 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9378 !                enddo
9379                   if (energy_dec.and.wcorr5.gt.0.0d0) &
9380                        write (iout,'(a6,4i5,0pf7.3)') &
9381                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9382 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9383 !d                write(2,*)'ijkl',i,jp,i+1,jp1
9384                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
9385                      .or. wturn6.eq.0.0d0))then
9386 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9387                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9388                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9389                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9390 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9391 !d     &            'ecorr6=',ecorr6
9392 !d                write (iout,'(4e15.5)') sred_geom,
9393 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9394 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9395 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9396                 else if (wturn6.gt.0.0d0 &
9397                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9398 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9399                   eturn6=eturn6+eello_turn6(i,jj,kk)
9400                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9401                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9402 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
9403                 endif
9404               ENDIF
9405 1111          continue
9406             endif
9407           enddo ! kk
9408         enddo ! jj
9409       enddo ! i
9410       do i=1,nres
9411         num_cont_hb(i)=num_cont_hb_old(i)
9412       enddo
9413 !                write (iout,*) "gradcorr5 in eello5"
9414 !                do iii=1,nres
9415 !                  write (iout,'(i5,3f10.5)')
9416 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9417 !                enddo
9418       return
9419       end subroutine multibody_eello
9420 !-----------------------------------------------------------------------------
9421       subroutine add_hb_contact_eello(ii,jj,itask)
9422 !      implicit real(kind=8) (a-h,o-z)
9423 !      include "DIMENSIONS"
9424 !      include "COMMON.IOUNITS"
9425 !      include "COMMON.CONTACTS"
9426 !      integer,parameter :: maxconts=nres/4
9427       integer,parameter :: max_dim=70
9428       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
9429 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
9430 !      common /przechowalnia/ zapas
9431
9432       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
9433       integer,dimension(4) ::itask
9434 !      write (iout,*) "itask",itask
9435       do i=1,2
9436         iproc=itask(i)
9437         if (iproc.gt.0) then
9438           do j=1,num_cont_hb(ii)
9439             jjc=jcont_hb(j,ii)
9440 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9441             if (jjc.eq.jj) then
9442               ncont_sent(iproc)=ncont_sent(iproc)+1
9443               nn=ncont_sent(iproc)
9444               zapas(1,nn,iproc)=ii
9445               zapas(2,nn,iproc)=jjc
9446               zapas(3,nn,iproc)=d_cont(j,ii)
9447               ind=3
9448               do kk=1,3
9449                 ind=ind+1
9450                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9451               enddo
9452               do kk=1,2
9453                 do ll=1,2
9454                   ind=ind+1
9455                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9456                 enddo
9457               enddo
9458               do jj=1,5
9459                 do kk=1,3
9460                   do ll=1,2
9461                     do mm=1,2
9462                       ind=ind+1
9463                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9464                     enddo
9465                   enddo
9466                 enddo
9467               enddo
9468               exit
9469             endif
9470           enddo
9471         endif
9472       enddo
9473       return
9474       end subroutine add_hb_contact_eello
9475 !-----------------------------------------------------------------------------
9476       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9477 !      implicit real(kind=8) (a-h,o-z)
9478 !      include 'DIMENSIONS'
9479 !      include 'COMMON.IOUNITS'
9480 !      include 'COMMON.DERIV'
9481 !      include 'COMMON.INTERACT'
9482 !      include 'COMMON.CONTACTS'
9483       real(kind=8),dimension(3) :: gx,gx1
9484       logical :: lprn
9485 !el local variables
9486       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
9487       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
9488                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
9489                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
9490                    rlocshield
9491
9492       lprn=.false.
9493       eij=facont_hb(jj,i)
9494       ekl=facont_hb(kk,k)
9495       ees0pij=ees0p(jj,i)
9496       ees0pkl=ees0p(kk,k)
9497       ees0mij=ees0m(jj,i)
9498       ees0mkl=ees0m(kk,k)
9499       ekont=eij*ekl
9500       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9501 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9502 ! Following 4 lines for diagnostics.
9503 !d    ees0pkl=0.0D0
9504 !d    ees0pij=1.0D0
9505 !d    ees0mkl=0.0D0
9506 !d    ees0mij=1.0D0
9507 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9508 !     & 'Contacts ',i,j,
9509 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9510 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9511 !     & 'gradcorr_long'
9512 ! Calculate the multi-body contribution to energy.
9513 !      ecorr=ecorr+ekont*ees
9514 ! Calculate multi-body contributions to the gradient.
9515       coeffpees0pij=coeffp*ees0pij
9516       coeffmees0mij=coeffm*ees0mij
9517       coeffpees0pkl=coeffp*ees0pkl
9518       coeffmees0mkl=coeffm*ees0mkl
9519       do ll=1,3
9520 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9521         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
9522         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
9523         coeffmees0mkl*gacontm_hb1(ll,jj,i))
9524         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
9525         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
9526         coeffmees0mkl*gacontm_hb2(ll,jj,i))
9527 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9528         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
9529         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
9530         coeffmees0mij*gacontm_hb1(ll,kk,k))
9531         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
9532         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
9533         coeffmees0mij*gacontm_hb2(ll,kk,k))
9534         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
9535            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
9536            coeffmees0mkl*gacontm_hb3(ll,jj,i))
9537         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9538         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9539         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
9540            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
9541            coeffmees0mij*gacontm_hb3(ll,kk,k))
9542         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9543         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9544 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9545       enddo
9546 !      write (iout,*)
9547 !grad      do m=i+1,j-1
9548 !grad        do ll=1,3
9549 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9550 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9551 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9552 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9553 !grad        enddo
9554 !grad      enddo
9555 !grad      do m=k+1,l-1
9556 !grad        do ll=1,3
9557 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9558 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
9559 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9560 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9561 !grad        enddo
9562 !grad      enddo
9563 !      write (iout,*) "ehbcorr",ekont*ees
9564       ehbcorr=ekont*ees
9565       if (shield_mode.gt.0) then
9566        j=ees0plist(jj,i)
9567        l=ees0plist(kk,k)
9568 !C        print *,i,j,fac_shield(i),fac_shield(j),
9569 !C     &fac_shield(k),fac_shield(l)
9570         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
9571            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9572           do ilist=1,ishield_list(i)
9573            iresshield=shield_list(ilist,i)
9574            do m=1,3
9575            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9576            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9577                    rlocshield  &
9578             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9579             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9580             +rlocshield
9581            enddo
9582           enddo
9583           do ilist=1,ishield_list(j)
9584            iresshield=shield_list(ilist,j)
9585            do m=1,3
9586            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9587            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9588                    rlocshield &
9589             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9590            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9591             +rlocshield
9592            enddo
9593           enddo
9594
9595           do ilist=1,ishield_list(k)
9596            iresshield=shield_list(ilist,k)
9597            do m=1,3
9598            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9599            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9600                    rlocshield &
9601             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9602            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9603             +rlocshield
9604            enddo
9605           enddo
9606           do ilist=1,ishield_list(l)
9607            iresshield=shield_list(ilist,l)
9608            do m=1,3
9609            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9610            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9611                    rlocshield &
9612             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9613            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9614             +rlocshield
9615            enddo
9616           enddo
9617           do m=1,3
9618             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
9619                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9620             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
9621                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9622             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
9623                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9624             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
9625                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9626
9627             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
9628                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9629             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
9630                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9631             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
9632                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9633             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
9634                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9635
9636            enddo
9637       endif
9638       endif
9639       return
9640       end function ehbcorr
9641 #ifdef MOMENT
9642 !-----------------------------------------------------------------------------
9643       subroutine dipole(i,j,jj)
9644 !      implicit real(kind=8) (a-h,o-z)
9645 !      include 'DIMENSIONS'
9646 !      include 'COMMON.IOUNITS'
9647 !      include 'COMMON.CHAIN'
9648 !      include 'COMMON.FFIELD'
9649 !      include 'COMMON.DERIV'
9650 !      include 'COMMON.INTERACT'
9651 !      include 'COMMON.CONTACTS'
9652 !      include 'COMMON.TORSION'
9653 !      include 'COMMON.VAR'
9654 !      include 'COMMON.GEO'
9655       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
9656       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
9657       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
9658
9659       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
9660       allocate(dipderx(3,5,4,maxconts,nres))
9661 !
9662
9663       iti1 = itortyp(itype(i+1,1))
9664       if (j.lt.nres-1) then
9665         itj1 = itype2loc(itype(j+1,1))
9666       else
9667         itj1=nloctyp
9668       endif
9669       do iii=1,2
9670         dipi(iii,1)=Ub2(iii,i)
9671         dipderi(iii)=Ub2der(iii,i)
9672         dipi(iii,2)=b1(iii,iti1)
9673         dipj(iii,1)=Ub2(iii,j)
9674         dipderj(iii)=Ub2der(iii,j)
9675         dipj(iii,2)=b1(iii,itj1)
9676       enddo
9677       kkk=0
9678       do iii=1,2
9679         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9680         do jjj=1,2
9681           kkk=kkk+1
9682           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9683         enddo
9684       enddo
9685       do kkk=1,5
9686         do lll=1,3
9687           mmm=0
9688           do iii=1,2
9689             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
9690               auxvec(1))
9691             do jjj=1,2
9692               mmm=mmm+1
9693               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9694             enddo
9695           enddo
9696         enddo
9697       enddo
9698       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9699       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9700       do iii=1,2
9701         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9702       enddo
9703       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9704       do iii=1,2
9705         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9706       enddo
9707       return
9708       end subroutine dipole
9709 #endif
9710 !-----------------------------------------------------------------------------
9711       subroutine calc_eello(i,j,k,l,jj,kk)
9712 !
9713 ! This subroutine computes matrices and vectors needed to calculate
9714 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
9715 !
9716       use comm_kut
9717 !      implicit real(kind=8) (a-h,o-z)
9718 !      include 'DIMENSIONS'
9719 !      include 'COMMON.IOUNITS'
9720 !      include 'COMMON.CHAIN'
9721 !      include 'COMMON.DERIV'
9722 !      include 'COMMON.INTERACT'
9723 !      include 'COMMON.CONTACTS'
9724 !      include 'COMMON.TORSION'
9725 !      include 'COMMON.VAR'
9726 !      include 'COMMON.GEO'
9727 !      include 'COMMON.FFIELD'
9728       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9729       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9730       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9731               itj1
9732 !el      logical :: lprn
9733 !el      common /kutas/ lprn
9734 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9735 !d     & ' jj=',jj,' kk=',kk
9736 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9737 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9738 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9739       do iii=1,2
9740         do jjj=1,2
9741           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9742           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9743         enddo
9744       enddo
9745       call transpose2(aa1(1,1),aa1t(1,1))
9746       call transpose2(aa2(1,1),aa2t(1,1))
9747       do kkk=1,5
9748         do lll=1,3
9749           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9750             aa1tder(1,1,lll,kkk))
9751           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9752             aa2tder(1,1,lll,kkk))
9753         enddo
9754       enddo
9755       if (l.eq.j+1) then
9756 ! parallel orientation of the two CA-CA-CA frames.
9757         if (i.gt.1) then
9758           iti=itortyp(itype(i,1))
9759         else
9760           iti=ntortyp+1
9761         endif
9762         itk1=itortyp(itype(k+1,1))
9763         itj=itortyp(itype(j,1))
9764         if (l.lt.nres-1) then
9765           itl1=itortyp(itype(l+1,1))
9766         else
9767           itl1=ntortyp+1
9768         endif
9769 ! A1 kernel(j+1) A2T
9770 !d        do iii=1,2
9771 !d          write (iout,'(3f10.5,5x,3f10.5)')
9772 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9773 !d        enddo
9774         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9775          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9776          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9777 ! Following matrices are needed only for 6-th order cumulants
9778         IF (wcorr6.gt.0.0d0) THEN
9779         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9780          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9781          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9782         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9783          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9784          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9785          ADtEAderx(1,1,1,1,1,1))
9786         lprn=.false.
9787         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9788          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9789          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9790          ADtEA1derx(1,1,1,1,1,1))
9791         ENDIF
9792 ! End 6-th order cumulants
9793 !d        lprn=.false.
9794 !d        if (lprn) then
9795 !d        write (2,*) 'In calc_eello6'
9796 !d        do iii=1,2
9797 !d          write (2,*) 'iii=',iii
9798 !d          do kkk=1,5
9799 !d            write (2,*) 'kkk=',kkk
9800 !d            do jjj=1,2
9801 !d              write (2,'(3(2f10.5),5x)')
9802 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9803 !d            enddo
9804 !d          enddo
9805 !d        enddo
9806 !d        endif
9807         call transpose2(EUgder(1,1,k),auxmat(1,1))
9808         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9809         call transpose2(EUg(1,1,k),auxmat(1,1))
9810         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9811         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9812         do iii=1,2
9813           do kkk=1,5
9814             do lll=1,3
9815               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9816                 EAEAderx(1,1,lll,kkk,iii,1))
9817             enddo
9818           enddo
9819         enddo
9820 ! A1T kernel(i+1) A2
9821         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9822          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9823          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9824 ! Following matrices are needed only for 6-th order cumulants
9825         IF (wcorr6.gt.0.0d0) THEN
9826         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9827          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9828          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9829         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9830          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9831          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9832          ADtEAderx(1,1,1,1,1,2))
9833         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9834          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9835          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9836          ADtEA1derx(1,1,1,1,1,2))
9837         ENDIF
9838 ! End 6-th order cumulants
9839         call transpose2(EUgder(1,1,l),auxmat(1,1))
9840         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9841         call transpose2(EUg(1,1,l),auxmat(1,1))
9842         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9843         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9844         do iii=1,2
9845           do kkk=1,5
9846             do lll=1,3
9847               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9848                 EAEAderx(1,1,lll,kkk,iii,2))
9849             enddo
9850           enddo
9851         enddo
9852 ! AEAb1 and AEAb2
9853 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9854 ! They are needed only when the fifth- or the sixth-order cumulants are
9855 ! indluded.
9856         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9857         call transpose2(AEA(1,1,1),auxmat(1,1))
9858         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9859         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9860         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9861         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9862         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9863         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9864         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9865         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9866         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9867         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9868         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9869         call transpose2(AEA(1,1,2),auxmat(1,1))
9870         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9871         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9872         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9873         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9874         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9875         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9876         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9877         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9878         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9879         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9880         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9881 ! Calculate the Cartesian derivatives of the vectors.
9882         do iii=1,2
9883           do kkk=1,5
9884             do lll=1,3
9885               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9886               call matvec2(auxmat(1,1),b1(1,iti),&
9887                 AEAb1derx(1,lll,kkk,iii,1,1))
9888               call matvec2(auxmat(1,1),Ub2(1,i),&
9889                 AEAb2derx(1,lll,kkk,iii,1,1))
9890               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9891                 AEAb1derx(1,lll,kkk,iii,2,1))
9892               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9893                 AEAb2derx(1,lll,kkk,iii,2,1))
9894               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9895               call matvec2(auxmat(1,1),b1(1,itj),&
9896                 AEAb1derx(1,lll,kkk,iii,1,2))
9897               call matvec2(auxmat(1,1),Ub2(1,j),&
9898                 AEAb2derx(1,lll,kkk,iii,1,2))
9899               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9900                 AEAb1derx(1,lll,kkk,iii,2,2))
9901               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9902                 AEAb2derx(1,lll,kkk,iii,2,2))
9903             enddo
9904           enddo
9905         enddo
9906         ENDIF
9907 ! End vectors
9908       else
9909 ! Antiparallel orientation of the two CA-CA-CA frames.
9910         if (i.gt.1) then
9911           iti=itortyp(itype(i,1))
9912         else
9913           iti=ntortyp+1
9914         endif
9915         itk1=itortyp(itype(k+1,1))
9916         itl=itortyp(itype(l,1))
9917         itj=itortyp(itype(j,1))
9918         if (j.lt.nres-1) then
9919           itj1=itortyp(itype(j+1,1))
9920         else
9921           itj1=ntortyp+1
9922         endif
9923 ! A2 kernel(j-1)T A1T
9924         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9925          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9926          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9927 ! Following matrices are needed only for 6-th order cumulants
9928         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9929            j.eq.i+4 .and. l.eq.i+3)) THEN
9930         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9931          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9932          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9933         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9934          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9935          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9936          ADtEAderx(1,1,1,1,1,1))
9937         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9938          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9939          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9940          ADtEA1derx(1,1,1,1,1,1))
9941         ENDIF
9942 ! End 6-th order cumulants
9943         call transpose2(EUgder(1,1,k),auxmat(1,1))
9944         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9945         call transpose2(EUg(1,1,k),auxmat(1,1))
9946         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9947         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9948         do iii=1,2
9949           do kkk=1,5
9950             do lll=1,3
9951               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9952                 EAEAderx(1,1,lll,kkk,iii,1))
9953             enddo
9954           enddo
9955         enddo
9956 ! A2T kernel(i+1)T A1
9957         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9958          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9959          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9960 ! Following matrices are needed only for 6-th order cumulants
9961         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9962            j.eq.i+4 .and. l.eq.i+3)) THEN
9963         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9964          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9965          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9966         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9967          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9968          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9969          ADtEAderx(1,1,1,1,1,2))
9970         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9971          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9972          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9973          ADtEA1derx(1,1,1,1,1,2))
9974         ENDIF
9975 ! End 6-th order cumulants
9976         call transpose2(EUgder(1,1,j),auxmat(1,1))
9977         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9978         call transpose2(EUg(1,1,j),auxmat(1,1))
9979         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9980         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9981         do iii=1,2
9982           do kkk=1,5
9983             do lll=1,3
9984               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9985                 EAEAderx(1,1,lll,kkk,iii,2))
9986             enddo
9987           enddo
9988         enddo
9989 ! AEAb1 and AEAb2
9990 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9991 ! They are needed only when the fifth- or the sixth-order cumulants are
9992 ! indluded.
9993         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9994           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9995         call transpose2(AEA(1,1,1),auxmat(1,1))
9996         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9997         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9998         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9999         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10000         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
10001         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10002         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
10003         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
10004         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10005         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10006         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10007         call transpose2(AEA(1,1,2),auxmat(1,1))
10008         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
10009         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10010         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10011         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10012         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
10013         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10014         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
10015         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
10016         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10017         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10018         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10019 ! Calculate the Cartesian derivatives of the vectors.
10020         do iii=1,2
10021           do kkk=1,5
10022             do lll=1,3
10023               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10024               call matvec2(auxmat(1,1),b1(1,iti),&
10025                 AEAb1derx(1,lll,kkk,iii,1,1))
10026               call matvec2(auxmat(1,1),Ub2(1,i),&
10027                 AEAb2derx(1,lll,kkk,iii,1,1))
10028               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10029                 AEAb1derx(1,lll,kkk,iii,2,1))
10030               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
10031                 AEAb2derx(1,lll,kkk,iii,2,1))
10032               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10033               call matvec2(auxmat(1,1),b1(1,itl),&
10034                 AEAb1derx(1,lll,kkk,iii,1,2))
10035               call matvec2(auxmat(1,1),Ub2(1,l),&
10036                 AEAb2derx(1,lll,kkk,iii,1,2))
10037               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
10038                 AEAb1derx(1,lll,kkk,iii,2,2))
10039               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
10040                 AEAb2derx(1,lll,kkk,iii,2,2))
10041             enddo
10042           enddo
10043         enddo
10044         ENDIF
10045 ! End vectors
10046       endif
10047       return
10048       end subroutine calc_eello
10049 !-----------------------------------------------------------------------------
10050       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
10051       use comm_kut
10052       implicit none
10053       integer :: nderg
10054       logical :: transp
10055       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
10056       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
10057       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
10058       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
10059       integer :: iii,kkk,lll
10060       integer :: jjj,mmm
10061 !el      logical :: lprn
10062 !el      common /kutas/ lprn
10063       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10064       do iii=1,nderg
10065         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
10066           AKAderg(1,1,iii))
10067       enddo
10068 !d      if (lprn) write (2,*) 'In kernel'
10069       do kkk=1,5
10070 !d        if (lprn) write (2,*) 'kkk=',kkk
10071         do lll=1,3
10072           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
10073             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10074 !d          if (lprn) then
10075 !d            write (2,*) 'lll=',lll
10076 !d            write (2,*) 'iii=1'
10077 !d            do jjj=1,2
10078 !d              write (2,'(3(2f10.5),5x)')
10079 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10080 !d            enddo
10081 !d          endif
10082           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
10083             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10084 !d          if (lprn) then
10085 !d            write (2,*) 'lll=',lll
10086 !d            write (2,*) 'iii=2'
10087 !d            do jjj=1,2
10088 !d              write (2,'(3(2f10.5),5x)')
10089 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10090 !d            enddo
10091 !d          endif
10092         enddo
10093       enddo
10094       return
10095       end subroutine kernel
10096 !-----------------------------------------------------------------------------
10097       real(kind=8) function eello4(i,j,k,l,jj,kk)
10098 !      implicit real(kind=8) (a-h,o-z)
10099 !      include 'DIMENSIONS'
10100 !      include 'COMMON.IOUNITS'
10101 !      include 'COMMON.CHAIN'
10102 !      include 'COMMON.DERIV'
10103 !      include 'COMMON.INTERACT'
10104 !      include 'COMMON.CONTACTS'
10105 !      include 'COMMON.TORSION'
10106 !      include 'COMMON.VAR'
10107 !      include 'COMMON.GEO'
10108       real(kind=8),dimension(2,2) :: pizda
10109       real(kind=8),dimension(3) :: ggg1,ggg2
10110       real(kind=8) ::  eel4,glongij,glongkl
10111       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
10112 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10113 !d        eello4=0.0d0
10114 !d        return
10115 !d      endif
10116 !d      print *,'eello4:',i,j,k,l,jj,kk
10117 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
10118 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
10119 !old      eij=facont_hb(jj,i)
10120 !old      ekl=facont_hb(kk,k)
10121 !old      ekont=eij*ekl
10122       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10123 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10124       gcorr_loc(k-1)=gcorr_loc(k-1) &
10125          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10126       if (l.eq.j+1) then
10127         gcorr_loc(l-1)=gcorr_loc(l-1) &
10128            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10129       else
10130         gcorr_loc(j-1)=gcorr_loc(j-1) &
10131            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10132       endif
10133       do iii=1,2
10134         do kkk=1,5
10135           do lll=1,3
10136             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
10137                               -EAEAderx(2,2,lll,kkk,iii,1)
10138 !d            derx(lll,kkk,iii)=0.0d0
10139           enddo
10140         enddo
10141       enddo
10142 !d      gcorr_loc(l-1)=0.0d0
10143 !d      gcorr_loc(j-1)=0.0d0
10144 !d      gcorr_loc(k-1)=0.0d0
10145 !d      eel4=1.0d0
10146 !d      write (iout,*)'Contacts have occurred for peptide groups',
10147 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10148 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10149       if (j.lt.nres-1) then
10150         j1=j+1
10151         j2=j-1
10152       else
10153         j1=j-1
10154         j2=j-2
10155       endif
10156       if (l.lt.nres-1) then
10157         l1=l+1
10158         l2=l-1
10159       else
10160         l1=l-1
10161         l2=l-2
10162       endif
10163       do ll=1,3
10164 !grad        ggg1(ll)=eel4*g_contij(ll,1)
10165 !grad        ggg2(ll)=eel4*g_contij(ll,2)
10166         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10167         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10168 !grad        ghalf=0.5d0*ggg1(ll)
10169         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10170         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10171         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10172         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10173         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10174         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10175 !grad        ghalf=0.5d0*ggg2(ll)
10176         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10177         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10178         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10179         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10180         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10181         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10182       enddo
10183 !grad      do m=i+1,j-1
10184 !grad        do ll=1,3
10185 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10186 !grad        enddo
10187 !grad      enddo
10188 !grad      do m=k+1,l-1
10189 !grad        do ll=1,3
10190 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10191 !grad        enddo
10192 !grad      enddo
10193 !grad      do m=i+2,j2
10194 !grad        do ll=1,3
10195 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10196 !grad        enddo
10197 !grad      enddo
10198 !grad      do m=k+2,l2
10199 !grad        do ll=1,3
10200 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10201 !grad        enddo
10202 !grad      enddo
10203 !d      do iii=1,nres-3
10204 !d        write (2,*) iii,gcorr_loc(iii)
10205 !d      enddo
10206       eello4=ekont*eel4
10207 !d      write (2,*) 'ekont',ekont
10208 !d      write (iout,*) 'eello4',ekont*eel4
10209       return
10210       end function eello4
10211 !-----------------------------------------------------------------------------
10212       real(kind=8) function eello5(i,j,k,l,jj,kk)
10213 !      implicit real(kind=8) (a-h,o-z)
10214 !      include 'DIMENSIONS'
10215 !      include 'COMMON.IOUNITS'
10216 !      include 'COMMON.CHAIN'
10217 !      include 'COMMON.DERIV'
10218 !      include 'COMMON.INTERACT'
10219 !      include 'COMMON.CONTACTS'
10220 !      include 'COMMON.TORSION'
10221 !      include 'COMMON.VAR'
10222 !      include 'COMMON.GEO'
10223       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10224       real(kind=8),dimension(2) :: vv
10225       real(kind=8),dimension(3) :: ggg1,ggg2
10226       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
10227       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
10228       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
10229 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10230 !                                                                              C
10231 !                            Parallel chains                                   C
10232 !                                                                              C
10233 !          o             o                   o             o                   C
10234 !         /l\           / \             \   / \           / \   /              C
10235 !        /   \         /   \             \ /   \         /   \ /               C
10236 !       j| o |l1       | o |                o| o |         | o |o                C
10237 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10238 !      \i/   \         /   \ /             /   \         /   \                 C
10239 !       o    k1             o                                                  C
10240 !         (I)          (II)                (III)          (IV)                 C
10241 !                                                                              C
10242 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10243 !                                                                              C
10244 !                            Antiparallel chains                               C
10245 !                                                                              C
10246 !          o             o                   o             o                   C
10247 !         /j\           / \             \   / \           / \   /              C
10248 !        /   \         /   \             \ /   \         /   \ /               C
10249 !      j1| o |l        | o |                o| o |         | o |o                C
10250 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10251 !      \i/   \         /   \ /             /   \         /   \                 C
10252 !       o     k1            o                                                  C
10253 !         (I)          (II)                (III)          (IV)                 C
10254 !                                                                              C
10255 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10256 !                                                                              C
10257 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
10258 !                                                                              C
10259 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10260 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10261 !d        eello5=0.0d0
10262 !d        return
10263 !d      endif
10264 !d      write (iout,*)
10265 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10266 !d     &   ' and',k,l
10267       itk=itortyp(itype(k,1))
10268       itl=itortyp(itype(l,1))
10269       itj=itortyp(itype(j,1))
10270       eello5_1=0.0d0
10271       eello5_2=0.0d0
10272       eello5_3=0.0d0
10273       eello5_4=0.0d0
10274 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10275 !d     &   eel5_3_num,eel5_4_num)
10276       do iii=1,2
10277         do kkk=1,5
10278           do lll=1,3
10279             derx(lll,kkk,iii)=0.0d0
10280           enddo
10281         enddo
10282       enddo
10283 !d      eij=facont_hb(jj,i)
10284 !d      ekl=facont_hb(kk,k)
10285 !d      ekont=eij*ekl
10286 !d      write (iout,*)'Contacts have occurred for peptide groups',
10287 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
10288 !d      goto 1111
10289 ! Contribution from the graph I.
10290 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10291 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10292       call transpose2(EUg(1,1,k),auxmat(1,1))
10293       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10294       vv(1)=pizda(1,1)-pizda(2,2)
10295       vv(2)=pizda(1,2)+pizda(2,1)
10296       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
10297        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10298 ! Explicit gradient in virtual-dihedral angles.
10299       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
10300        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
10301        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10302       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10303       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10304       vv(1)=pizda(1,1)-pizda(2,2)
10305       vv(2)=pizda(1,2)+pizda(2,1)
10306       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10307        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
10308        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10309       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10310       vv(1)=pizda(1,1)-pizda(2,2)
10311       vv(2)=pizda(1,2)+pizda(2,1)
10312       if (l.eq.j+1) then
10313         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10314          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10315          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10316       else
10317         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10318          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10319          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10320       endif
10321 ! Cartesian gradient
10322       do iii=1,2
10323         do kkk=1,5
10324           do lll=1,3
10325             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10326               pizda(1,1))
10327             vv(1)=pizda(1,1)-pizda(2,2)
10328             vv(2)=pizda(1,2)+pizda(2,1)
10329             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10330              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
10331              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10332           enddo
10333         enddo
10334       enddo
10335 !      goto 1112
10336 !1111  continue
10337 ! Contribution from graph II
10338       call transpose2(EE(1,1,itk),auxmat(1,1))
10339       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10340       vv(1)=pizda(1,1)+pizda(2,2)
10341       vv(2)=pizda(2,1)-pizda(1,2)
10342       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
10343        -0.5d0*scalar2(vv(1),Ctobr(1,k))
10344 ! Explicit gradient in virtual-dihedral angles.
10345       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10346        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10347       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10348       vv(1)=pizda(1,1)+pizda(2,2)
10349       vv(2)=pizda(2,1)-pizda(1,2)
10350       if (l.eq.j+1) then
10351         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10352          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10353          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10354       else
10355         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10356          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10357          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10358       endif
10359 ! Cartesian gradient
10360       do iii=1,2
10361         do kkk=1,5
10362           do lll=1,3
10363             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
10364               pizda(1,1))
10365             vv(1)=pizda(1,1)+pizda(2,2)
10366             vv(2)=pizda(2,1)-pizda(1,2)
10367             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10368              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
10369              -0.5d0*scalar2(vv(1),Ctobr(1,k))
10370           enddo
10371         enddo
10372       enddo
10373 !d      goto 1112
10374 !d1111  continue
10375       if (l.eq.j+1) then
10376 !d        goto 1110
10377 ! Parallel orientation
10378 ! Contribution from graph III
10379         call transpose2(EUg(1,1,l),auxmat(1,1))
10380         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10381         vv(1)=pizda(1,1)-pizda(2,2)
10382         vv(2)=pizda(1,2)+pizda(2,1)
10383         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
10384          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10385 ! Explicit gradient in virtual-dihedral angles.
10386         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10387          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
10388          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10389         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10390         vv(1)=pizda(1,1)-pizda(2,2)
10391         vv(2)=pizda(1,2)+pizda(2,1)
10392         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10393          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
10394          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10395         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10396         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10397         vv(1)=pizda(1,1)-pizda(2,2)
10398         vv(2)=pizda(1,2)+pizda(2,1)
10399         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10400          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
10401          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10402 ! Cartesian gradient
10403         do iii=1,2
10404           do kkk=1,5
10405             do lll=1,3
10406               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10407                 pizda(1,1))
10408               vv(1)=pizda(1,1)-pizda(2,2)
10409               vv(2)=pizda(1,2)+pizda(2,1)
10410               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10411                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
10412                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10413             enddo
10414           enddo
10415         enddo
10416 !d        goto 1112
10417 ! Contribution from graph IV
10418 !d1110    continue
10419         call transpose2(EE(1,1,itl),auxmat(1,1))
10420         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10421         vv(1)=pizda(1,1)+pizda(2,2)
10422         vv(2)=pizda(2,1)-pizda(1,2)
10423         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
10424          -0.5d0*scalar2(vv(1),Ctobr(1,l))
10425 ! Explicit gradient in virtual-dihedral angles.
10426         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10427          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10428         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10429         vv(1)=pizda(1,1)+pizda(2,2)
10430         vv(2)=pizda(2,1)-pizda(1,2)
10431         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10432          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
10433          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10434 ! Cartesian gradient
10435         do iii=1,2
10436           do kkk=1,5
10437             do lll=1,3
10438               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10439                 pizda(1,1))
10440               vv(1)=pizda(1,1)+pizda(2,2)
10441               vv(2)=pizda(2,1)-pizda(1,2)
10442               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10443                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
10444                -0.5d0*scalar2(vv(1),Ctobr(1,l))
10445             enddo
10446           enddo
10447         enddo
10448       else
10449 ! Antiparallel orientation
10450 ! Contribution from graph III
10451 !        goto 1110
10452         call transpose2(EUg(1,1,j),auxmat(1,1))
10453         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10454         vv(1)=pizda(1,1)-pizda(2,2)
10455         vv(2)=pizda(1,2)+pizda(2,1)
10456         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
10457          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10458 ! Explicit gradient in virtual-dihedral angles.
10459         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10460          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
10461          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10462         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10463         vv(1)=pizda(1,1)-pizda(2,2)
10464         vv(2)=pizda(1,2)+pizda(2,1)
10465         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10466          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
10467          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10468         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10469         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10470         vv(1)=pizda(1,1)-pizda(2,2)
10471         vv(2)=pizda(1,2)+pizda(2,1)
10472         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10473          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
10474          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10475 ! Cartesian gradient
10476         do iii=1,2
10477           do kkk=1,5
10478             do lll=1,3
10479               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10480                 pizda(1,1))
10481               vv(1)=pizda(1,1)-pizda(2,2)
10482               vv(2)=pizda(1,2)+pizda(2,1)
10483               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10484                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
10485                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10486             enddo
10487           enddo
10488         enddo
10489 !d        goto 1112
10490 ! Contribution from graph IV
10491 1110    continue
10492         call transpose2(EE(1,1,itj),auxmat(1,1))
10493         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10494         vv(1)=pizda(1,1)+pizda(2,2)
10495         vv(2)=pizda(2,1)-pizda(1,2)
10496         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
10497          -0.5d0*scalar2(vv(1),Ctobr(1,j))
10498 ! Explicit gradient in virtual-dihedral angles.
10499         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10500          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10501         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10502         vv(1)=pizda(1,1)+pizda(2,2)
10503         vv(2)=pizda(2,1)-pizda(1,2)
10504         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10505          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
10506          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10507 ! Cartesian gradient
10508         do iii=1,2
10509           do kkk=1,5
10510             do lll=1,3
10511               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10512                 pizda(1,1))
10513               vv(1)=pizda(1,1)+pizda(2,2)
10514               vv(2)=pizda(2,1)-pizda(1,2)
10515               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10516                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
10517                -0.5d0*scalar2(vv(1),Ctobr(1,j))
10518             enddo
10519           enddo
10520         enddo
10521       endif
10522 1112  continue
10523       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10524 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10525 !d        write (2,*) 'ijkl',i,j,k,l
10526 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10527 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10528 !d      endif
10529 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10530 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10531 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10532 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10533       if (j.lt.nres-1) then
10534         j1=j+1
10535         j2=j-1
10536       else
10537         j1=j-1
10538         j2=j-2
10539       endif
10540       if (l.lt.nres-1) then
10541         l1=l+1
10542         l2=l-1
10543       else
10544         l1=l-1
10545         l2=l-2
10546       endif
10547 !d      eij=1.0d0
10548 !d      ekl=1.0d0
10549 !d      ekont=1.0d0
10550 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10551 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
10552 !        summed up outside the subrouine as for the other subroutines
10553 !        handling long-range interactions. The old code is commented out
10554 !        with "cgrad" to keep track of changes.
10555       do ll=1,3
10556 !grad        ggg1(ll)=eel5*g_contij(ll,1)
10557 !grad        ggg2(ll)=eel5*g_contij(ll,2)
10558         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10559         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10560 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10561 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10562 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10563 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10564 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10565 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10566 !     &   gradcorr5ij,
10567 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10568 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10569 !grad        ghalf=0.5d0*ggg1(ll)
10570 !d        ghalf=0.0d0
10571         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10572         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10573         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10574         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10575         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10576         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10577 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10578 !grad        ghalf=0.5d0*ggg2(ll)
10579         ghalf=0.0d0
10580         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
10581         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10582         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
10583         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10584         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10585         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10586       enddo
10587 !d      goto 1112
10588 !grad      do m=i+1,j-1
10589 !grad        do ll=1,3
10590 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10591 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10592 !grad        enddo
10593 !grad      enddo
10594 !grad      do m=k+1,l-1
10595 !grad        do ll=1,3
10596 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10597 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10598 !grad        enddo
10599 !grad      enddo
10600 !1112  continue
10601 !grad      do m=i+2,j2
10602 !grad        do ll=1,3
10603 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10604 !grad        enddo
10605 !grad      enddo
10606 !grad      do m=k+2,l2
10607 !grad        do ll=1,3
10608 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10609 !grad        enddo
10610 !grad      enddo
10611 !d      do iii=1,nres-3
10612 !d        write (2,*) iii,g_corr5_loc(iii)
10613 !d      enddo
10614       eello5=ekont*eel5
10615 !d      write (2,*) 'ekont',ekont
10616 !d      write (iout,*) 'eello5',ekont*eel5
10617       return
10618       end function eello5
10619 !-----------------------------------------------------------------------------
10620       real(kind=8) function eello6(i,j,k,l,jj,kk)
10621 !      implicit real(kind=8) (a-h,o-z)
10622 !      include 'DIMENSIONS'
10623 !      include 'COMMON.IOUNITS'
10624 !      include 'COMMON.CHAIN'
10625 !      include 'COMMON.DERIV'
10626 !      include 'COMMON.INTERACT'
10627 !      include 'COMMON.CONTACTS'
10628 !      include 'COMMON.TORSION'
10629 !      include 'COMMON.VAR'
10630 !      include 'COMMON.GEO'
10631 !      include 'COMMON.FFIELD'
10632       real(kind=8),dimension(3) :: ggg1,ggg2
10633       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
10634                    eello6_6,eel6
10635       real(kind=8) :: gradcorr6ij,gradcorr6kl
10636       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
10637 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10638 !d        eello6=0.0d0
10639 !d        return
10640 !d      endif
10641 !d      write (iout,*)
10642 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10643 !d     &   ' and',k,l
10644       eello6_1=0.0d0
10645       eello6_2=0.0d0
10646       eello6_3=0.0d0
10647       eello6_4=0.0d0
10648       eello6_5=0.0d0
10649       eello6_6=0.0d0
10650 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10651 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10652       do iii=1,2
10653         do kkk=1,5
10654           do lll=1,3
10655             derx(lll,kkk,iii)=0.0d0
10656           enddo
10657         enddo
10658       enddo
10659 !d      eij=facont_hb(jj,i)
10660 !d      ekl=facont_hb(kk,k)
10661 !d      ekont=eij*ekl
10662 !d      eij=1.0d0
10663 !d      ekl=1.0d0
10664 !d      ekont=1.0d0
10665       if (l.eq.j+1) then
10666         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10667         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10668         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10669         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10670         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10671         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10672       else
10673         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10674         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10675         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10676         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10677         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10678           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10679         else
10680           eello6_5=0.0d0
10681         endif
10682         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10683       endif
10684 ! If turn contributions are considered, they will be handled separately.
10685       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10686 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10687 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10688 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10689 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10690 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10691 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10692 !d      goto 1112
10693       if (j.lt.nres-1) then
10694         j1=j+1
10695         j2=j-1
10696       else
10697         j1=j-1
10698         j2=j-2
10699       endif
10700       if (l.lt.nres-1) then
10701         l1=l+1
10702         l2=l-1
10703       else
10704         l1=l-1
10705         l2=l-2
10706       endif
10707       do ll=1,3
10708 !grad        ggg1(ll)=eel6*g_contij(ll,1)
10709 !grad        ggg2(ll)=eel6*g_contij(ll,2)
10710 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10711 !grad        ghalf=0.5d0*ggg1(ll)
10712 !d        ghalf=0.0d0
10713         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10714         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10715         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10716         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10717         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10718         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10719         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10720         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10721 !grad        ghalf=0.5d0*ggg2(ll)
10722 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10723 !d        ghalf=0.0d0
10724         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10725         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10726         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10727         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10728         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10729         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10730       enddo
10731 !d      goto 1112
10732 !grad      do m=i+1,j-1
10733 !grad        do ll=1,3
10734 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10735 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10736 !grad        enddo
10737 !grad      enddo
10738 !grad      do m=k+1,l-1
10739 !grad        do ll=1,3
10740 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10741 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10742 !grad        enddo
10743 !grad      enddo
10744 !grad1112  continue
10745 !grad      do m=i+2,j2
10746 !grad        do ll=1,3
10747 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10748 !grad        enddo
10749 !grad      enddo
10750 !grad      do m=k+2,l2
10751 !grad        do ll=1,3
10752 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10753 !grad        enddo
10754 !grad      enddo
10755 !d      do iii=1,nres-3
10756 !d        write (2,*) iii,g_corr6_loc(iii)
10757 !d      enddo
10758       eello6=ekont*eel6
10759 !d      write (2,*) 'ekont',ekont
10760 !d      write (iout,*) 'eello6',ekont*eel6
10761       return
10762       end function eello6
10763 !-----------------------------------------------------------------------------
10764       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10765       use comm_kut
10766 !      implicit real(kind=8) (a-h,o-z)
10767 !      include 'DIMENSIONS'
10768 !      include 'COMMON.IOUNITS'
10769 !      include 'COMMON.CHAIN'
10770 !      include 'COMMON.DERIV'
10771 !      include 'COMMON.INTERACT'
10772 !      include 'COMMON.CONTACTS'
10773 !      include 'COMMON.TORSION'
10774 !      include 'COMMON.VAR'
10775 !      include 'COMMON.GEO'
10776       real(kind=8),dimension(2) :: vv,vv1
10777       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10778       logical :: swap
10779 !el      logical :: lprn
10780 !el      common /kutas/ lprn
10781       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10782       real(kind=8) :: s1,s2,s3,s4,s5
10783 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10784 !                                                                              C
10785 !      Parallel       Antiparallel                                             C
10786 !                                                                              C
10787 !          o             o                                                     C
10788 !         /l\           /j\                                                    C
10789 !        /   \         /   \                                                   C
10790 !       /| o |         | o |\                                                  C
10791 !     \ j|/k\|  /   \  |/k\|l /                                                C
10792 !      \ /   \ /     \ /   \ /                                                 C
10793 !       o     o       o     o                                                  C
10794 !       i             i                                                        C
10795 !                                                                              C
10796 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10797       itk=itortyp(itype(k,1))
10798       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10799       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10800       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10801       call transpose2(EUgC(1,1,k),auxmat(1,1))
10802       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10803       vv1(1)=pizda1(1,1)-pizda1(2,2)
10804       vv1(2)=pizda1(1,2)+pizda1(2,1)
10805       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10806       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10807       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10808       s5=scalar2(vv(1),Dtobr2(1,i))
10809 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10810       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10811       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10812        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10813        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10814        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10815        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10816        +scalar2(vv(1),Dtobr2der(1,i)))
10817       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10818       vv1(1)=pizda1(1,1)-pizda1(2,2)
10819       vv1(2)=pizda1(1,2)+pizda1(2,1)
10820       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10821       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10822       if (l.eq.j+1) then
10823         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10824        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10825        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10826        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10827        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10828       else
10829         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10830        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10831        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10832        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10833        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10834       endif
10835       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10836       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10837       vv1(1)=pizda1(1,1)-pizda1(2,2)
10838       vv1(2)=pizda1(1,2)+pizda1(2,1)
10839       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10840        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10841        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10842        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10843       do iii=1,2
10844         if (swap) then
10845           ind=3-iii
10846         else
10847           ind=iii
10848         endif
10849         do kkk=1,5
10850           do lll=1,3
10851             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10852             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10853             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10854             call transpose2(EUgC(1,1,k),auxmat(1,1))
10855             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10856               pizda1(1,1))
10857             vv1(1)=pizda1(1,1)-pizda1(2,2)
10858             vv1(2)=pizda1(1,2)+pizda1(2,1)
10859             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10860             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10861              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10862             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10863              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10864             s5=scalar2(vv(1),Dtobr2(1,i))
10865             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10866           enddo
10867         enddo
10868       enddo
10869       return
10870       end function eello6_graph1
10871 !-----------------------------------------------------------------------------
10872       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10873       use comm_kut
10874 !      implicit real(kind=8) (a-h,o-z)
10875 !      include 'DIMENSIONS'
10876 !      include 'COMMON.IOUNITS'
10877 !      include 'COMMON.CHAIN'
10878 !      include 'COMMON.DERIV'
10879 !      include 'COMMON.INTERACT'
10880 !      include 'COMMON.CONTACTS'
10881 !      include 'COMMON.TORSION'
10882 !      include 'COMMON.VAR'
10883 !      include 'COMMON.GEO'
10884       logical :: swap
10885       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10886       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10887 !el      logical :: lprn
10888 !el      common /kutas/ lprn
10889       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10890       real(kind=8) :: s2,s3,s4
10891 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10892 !                                                                              C
10893 !      Parallel       Antiparallel                                             C
10894 !                                                                              C
10895 !          o             o                                                     C
10896 !     \   /l\           /j\   /                                                C
10897 !      \ /   \         /   \ /                                                 C
10898 !       o| o |         | o |o                                                  C
10899 !     \ j|/k\|      \  |/k\|l                                                  C
10900 !      \ /   \       \ /   \                                                   C
10901 !       o             o                                                        C
10902 !       i             i                                                        C
10903 !                                                                              C
10904 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10905 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10906 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10907 !           but not in a cluster cumulant
10908 #ifdef MOMENT
10909       s1=dip(1,jj,i)*dip(1,kk,k)
10910 #endif
10911       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10912       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10913       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10914       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10915       call transpose2(EUg(1,1,k),auxmat(1,1))
10916       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10917       vv(1)=pizda(1,1)-pizda(2,2)
10918       vv(2)=pizda(1,2)+pizda(2,1)
10919       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10920 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10921 #ifdef MOMENT
10922       eello6_graph2=-(s1+s2+s3+s4)
10923 #else
10924       eello6_graph2=-(s2+s3+s4)
10925 #endif
10926 !      eello6_graph2=-s3
10927 ! Derivatives in gamma(i-1)
10928       if (i.gt.1) then
10929 #ifdef MOMENT
10930         s1=dipderg(1,jj,i)*dip(1,kk,k)
10931 #endif
10932         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10933         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10934         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10935         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10936 #ifdef MOMENT
10937         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10938 #else
10939         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10940 #endif
10941 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10942       endif
10943 ! Derivatives in gamma(k-1)
10944 #ifdef MOMENT
10945       s1=dip(1,jj,i)*dipderg(1,kk,k)
10946 #endif
10947       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10948       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10949       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10950       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10951       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10952       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10953       vv(1)=pizda(1,1)-pizda(2,2)
10954       vv(2)=pizda(1,2)+pizda(2,1)
10955       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10956 #ifdef MOMENT
10957       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10958 #else
10959       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10960 #endif
10961 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10962 ! Derivatives in gamma(j-1) or gamma(l-1)
10963       if (j.gt.1) then
10964 #ifdef MOMENT
10965         s1=dipderg(3,jj,i)*dip(1,kk,k)
10966 #endif
10967         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10968         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10969         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10970         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10971         vv(1)=pizda(1,1)-pizda(2,2)
10972         vv(2)=pizda(1,2)+pizda(2,1)
10973         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10974 #ifdef MOMENT
10975         if (swap) then
10976           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10977         else
10978           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10979         endif
10980 #endif
10981         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10982 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10983       endif
10984 ! Derivatives in gamma(l-1) or gamma(j-1)
10985       if (l.gt.1) then
10986 #ifdef MOMENT
10987         s1=dip(1,jj,i)*dipderg(3,kk,k)
10988 #endif
10989         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10990         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10991         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10992         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10993         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10994         vv(1)=pizda(1,1)-pizda(2,2)
10995         vv(2)=pizda(1,2)+pizda(2,1)
10996         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10997 #ifdef MOMENT
10998         if (swap) then
10999           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11000         else
11001           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11002         endif
11003 #endif
11004         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11005 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11006       endif
11007 ! Cartesian derivatives.
11008       if (lprn) then
11009         write (2,*) 'In eello6_graph2'
11010         do iii=1,2
11011           write (2,*) 'iii=',iii
11012           do kkk=1,5
11013             write (2,*) 'kkk=',kkk
11014             do jjj=1,2
11015               write (2,'(3(2f10.5),5x)') &
11016               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11017             enddo
11018           enddo
11019         enddo
11020       endif
11021       do iii=1,2
11022         do kkk=1,5
11023           do lll=1,3
11024 #ifdef MOMENT
11025             if (iii.eq.1) then
11026               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11027             else
11028               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11029             endif
11030 #endif
11031             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
11032               auxvec(1))
11033             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11034             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
11035               auxvec(1))
11036             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11037             call transpose2(EUg(1,1,k),auxmat(1,1))
11038             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
11039               pizda(1,1))
11040             vv(1)=pizda(1,1)-pizda(2,2)
11041             vv(2)=pizda(1,2)+pizda(2,1)
11042             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11043 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11044 #ifdef MOMENT
11045             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11046 #else
11047             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11048 #endif
11049             if (swap) then
11050               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11051             else
11052               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11053             endif
11054           enddo
11055         enddo
11056       enddo
11057       return
11058       end function eello6_graph2
11059 !-----------------------------------------------------------------------------
11060       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
11061 !      implicit real(kind=8) (a-h,o-z)
11062 !      include 'DIMENSIONS'
11063 !      include 'COMMON.IOUNITS'
11064 !      include 'COMMON.CHAIN'
11065 !      include 'COMMON.DERIV'
11066 !      include 'COMMON.INTERACT'
11067 !      include 'COMMON.CONTACTS'
11068 !      include 'COMMON.TORSION'
11069 !      include 'COMMON.VAR'
11070 !      include 'COMMON.GEO'
11071       real(kind=8),dimension(2) :: vv,auxvec
11072       real(kind=8),dimension(2,2) :: pizda,auxmat
11073       logical :: swap
11074       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
11075       real(kind=8) :: s1,s2,s3,s4
11076 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11077 !                                                                              C
11078 !      Parallel       Antiparallel                                             C
11079 !                                                                              C
11080 !          o             o                                                     C
11081 !         /l\   /   \   /j\                                                    C
11082 !        /   \ /     \ /   \                                                   C
11083 !       /| o |o       o| o |\                                                  C
11084 !       j|/k\|  /      |/k\|l /                                                C
11085 !        /   \ /       /   \ /                                                 C
11086 !       /     o       /     o                                                  C
11087 !       i             i                                                        C
11088 !                                                                              C
11089 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11090 !
11091 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
11092 !           energy moment and not to the cluster cumulant.
11093       iti=itortyp(itype(i,1))
11094       if (j.lt.nres-1) then
11095         itj1=itortyp(itype(j+1,1))
11096       else
11097         itj1=ntortyp+1
11098       endif
11099       itk=itortyp(itype(k,1))
11100       itk1=itortyp(itype(k+1,1))
11101       if (l.lt.nres-1) then
11102         itl1=itortyp(itype(l+1,1))
11103       else
11104         itl1=ntortyp+1
11105       endif
11106 #ifdef MOMENT
11107       s1=dip(4,jj,i)*dip(4,kk,k)
11108 #endif
11109       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
11110       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
11111       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
11112       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
11113       call transpose2(EE(1,1,itk),auxmat(1,1))
11114       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11115       vv(1)=pizda(1,1)+pizda(2,2)
11116       vv(2)=pizda(2,1)-pizda(1,2)
11117       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11118 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11119 !d     & "sum",-(s2+s3+s4)
11120 #ifdef MOMENT
11121       eello6_graph3=-(s1+s2+s3+s4)
11122 #else
11123       eello6_graph3=-(s2+s3+s4)
11124 #endif
11125 !      eello6_graph3=-s4
11126 ! Derivatives in gamma(k-1)
11127       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
11128       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
11129       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11130       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11131 ! Derivatives in gamma(l-1)
11132       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
11133       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
11134       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11135       vv(1)=pizda(1,1)+pizda(2,2)
11136       vv(2)=pizda(2,1)-pizda(1,2)
11137       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11138       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11139 ! Cartesian derivatives.
11140       do iii=1,2
11141         do kkk=1,5
11142           do lll=1,3
11143 #ifdef MOMENT
11144             if (iii.eq.1) then
11145               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11146             else
11147               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11148             endif
11149 #endif
11150             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
11151               auxvec(1))
11152             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
11153             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
11154               auxvec(1))
11155             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
11156             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
11157               pizda(1,1))
11158             vv(1)=pizda(1,1)+pizda(2,2)
11159             vv(2)=pizda(2,1)-pizda(1,2)
11160             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11161 #ifdef MOMENT
11162             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11163 #else
11164             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11165 #endif
11166             if (swap) then
11167               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11168             else
11169               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11170             endif
11171 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11172           enddo
11173         enddo
11174       enddo
11175       return
11176       end function eello6_graph3
11177 !-----------------------------------------------------------------------------
11178       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11179 !      implicit real(kind=8) (a-h,o-z)
11180 !      include 'DIMENSIONS'
11181 !      include 'COMMON.IOUNITS'
11182 !      include 'COMMON.CHAIN'
11183 !      include 'COMMON.DERIV'
11184 !      include 'COMMON.INTERACT'
11185 !      include 'COMMON.CONTACTS'
11186 !      include 'COMMON.TORSION'
11187 !      include 'COMMON.VAR'
11188 !      include 'COMMON.GEO'
11189 !      include 'COMMON.FFIELD'
11190       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
11191       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
11192       logical :: swap
11193       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
11194               iii,kkk,lll
11195       real(kind=8) :: s1,s2,s3,s4
11196 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11197 !                                                                              C
11198 !      Parallel       Antiparallel                                             C
11199 !                                                                              C
11200 !          o             o                                                     C
11201 !         /l\   /   \   /j\                                                    C
11202 !        /   \ /     \ /   \                                                   C
11203 !       /| o |o       o| o |\                                                  C
11204 !     \ j|/k\|      \  |/k\|l                                                  C
11205 !      \ /   \       \ /   \                                                   C
11206 !       o     \       o     \                                                  C
11207 !       i             i                                                        C
11208 !                                                                              C
11209 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11210 !
11211 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
11212 !           energy moment and not to the cluster cumulant.
11213 !d      write (2,*) 'eello_graph4: wturn6',wturn6
11214       iti=itortyp(itype(i,1))
11215       itj=itortyp(itype(j,1))
11216       if (j.lt.nres-1) then
11217         itj1=itortyp(itype(j+1,1))
11218       else
11219         itj1=ntortyp+1
11220       endif
11221       itk=itortyp(itype(k,1))
11222       if (k.lt.nres-1) then
11223         itk1=itortyp(itype(k+1,1))
11224       else
11225         itk1=ntortyp+1
11226       endif
11227       itl=itortyp(itype(l,1))
11228       if (l.lt.nres-1) then
11229         itl1=itortyp(itype(l+1,1))
11230       else
11231         itl1=ntortyp+1
11232       endif
11233 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11234 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11235 !d     & ' itl',itl,' itl1',itl1
11236 #ifdef MOMENT
11237       if (imat.eq.1) then
11238         s1=dip(3,jj,i)*dip(3,kk,k)
11239       else
11240         s1=dip(2,jj,j)*dip(2,kk,l)
11241       endif
11242 #endif
11243       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11244       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11245       if (j.eq.l+1) then
11246         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
11247         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11248       else
11249         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
11250         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11251       endif
11252       call transpose2(EUg(1,1,k),auxmat(1,1))
11253       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11254       vv(1)=pizda(1,1)-pizda(2,2)
11255       vv(2)=pizda(2,1)+pizda(1,2)
11256       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11257 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11258 #ifdef MOMENT
11259       eello6_graph4=-(s1+s2+s3+s4)
11260 #else
11261       eello6_graph4=-(s2+s3+s4)
11262 #endif
11263 ! Derivatives in gamma(i-1)
11264       if (i.gt.1) then
11265 #ifdef MOMENT
11266         if (imat.eq.1) then
11267           s1=dipderg(2,jj,i)*dip(3,kk,k)
11268         else
11269           s1=dipderg(4,jj,j)*dip(2,kk,l)
11270         endif
11271 #endif
11272         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11273         if (j.eq.l+1) then
11274           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
11275           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11276         else
11277           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
11278           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11279         endif
11280         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11281         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11282 !d          write (2,*) 'turn6 derivatives'
11283 #ifdef MOMENT
11284           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11285 #else
11286           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11287 #endif
11288         else
11289 #ifdef MOMENT
11290           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11291 #else
11292           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11293 #endif
11294         endif
11295       endif
11296 ! Derivatives in gamma(k-1)
11297 #ifdef MOMENT
11298       if (imat.eq.1) then
11299         s1=dip(3,jj,i)*dipderg(2,kk,k)
11300       else
11301         s1=dip(2,jj,j)*dipderg(4,kk,l)
11302       endif
11303 #endif
11304       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11305       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11306       if (j.eq.l+1) then
11307         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
11308         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11309       else
11310         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
11311         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11312       endif
11313       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11314       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11315       vv(1)=pizda(1,1)-pizda(2,2)
11316       vv(2)=pizda(2,1)+pizda(1,2)
11317       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11318       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11319 #ifdef MOMENT
11320         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11321 #else
11322         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11323 #endif
11324       else
11325 #ifdef MOMENT
11326         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11327 #else
11328         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11329 #endif
11330       endif
11331 ! Derivatives in gamma(j-1) or gamma(l-1)
11332       if (l.eq.j+1 .and. l.gt.1) then
11333         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11334         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11335         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11336         vv(1)=pizda(1,1)-pizda(2,2)
11337         vv(2)=pizda(2,1)+pizda(1,2)
11338         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11339         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11340       else if (j.gt.1) then
11341         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11342         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11343         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11344         vv(1)=pizda(1,1)-pizda(2,2)
11345         vv(2)=pizda(2,1)+pizda(1,2)
11346         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11347         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11348           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11349         else
11350           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11351         endif
11352       endif
11353 ! Cartesian derivatives.
11354       do iii=1,2
11355         do kkk=1,5
11356           do lll=1,3
11357 #ifdef MOMENT
11358             if (iii.eq.1) then
11359               if (imat.eq.1) then
11360                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11361               else
11362                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11363               endif
11364             else
11365               if (imat.eq.1) then
11366                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11367               else
11368                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11369               endif
11370             endif
11371 #endif
11372             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
11373               auxvec(1))
11374             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11375             if (j.eq.l+1) then
11376               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11377                 b1(1,itj1),auxvec(1))
11378               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
11379             else
11380               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11381                 b1(1,itl1),auxvec(1))
11382               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
11383             endif
11384             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
11385               pizda(1,1))
11386             vv(1)=pizda(1,1)-pizda(2,2)
11387             vv(2)=pizda(2,1)+pizda(1,2)
11388             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11389             if (swap) then
11390               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11391 #ifdef MOMENT
11392                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11393                    -(s1+s2+s4)
11394 #else
11395                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11396                    -(s2+s4)
11397 #endif
11398                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11399               else
11400 #ifdef MOMENT
11401                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11402 #else
11403                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11404 #endif
11405                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11406               endif
11407             else
11408 #ifdef MOMENT
11409               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11410 #else
11411               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11412 #endif
11413               if (l.eq.j+1) then
11414                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11415               else
11416                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11417               endif
11418             endif
11419           enddo
11420         enddo
11421       enddo
11422       return
11423       end function eello6_graph4
11424 !-----------------------------------------------------------------------------
11425       real(kind=8) function eello_turn6(i,jj,kk)
11426 !      implicit real(kind=8) (a-h,o-z)
11427 !      include 'DIMENSIONS'
11428 !      include 'COMMON.IOUNITS'
11429 !      include 'COMMON.CHAIN'
11430 !      include 'COMMON.DERIV'
11431 !      include 'COMMON.INTERACT'
11432 !      include 'COMMON.CONTACTS'
11433 !      include 'COMMON.TORSION'
11434 !      include 'COMMON.VAR'
11435 !      include 'COMMON.GEO'
11436       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
11437       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
11438       real(kind=8),dimension(3) :: ggg1,ggg2
11439       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
11440       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
11441 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11442 !           the respective energy moment and not to the cluster cumulant.
11443 !el local variables
11444       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
11445       integer :: j1,j2,l1,l2,ll
11446       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
11447       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
11448       s1=0.0d0
11449       s8=0.0d0
11450       s13=0.0d0
11451 !
11452       eello_turn6=0.0d0
11453       j=i+4
11454       k=i+1
11455       l=i+3
11456       iti=itortyp(itype(i,1))
11457       itk=itortyp(itype(k,1))
11458       itk1=itortyp(itype(k+1,1))
11459       itl=itortyp(itype(l,1))
11460       itj=itortyp(itype(j,1))
11461 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11462 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
11463 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11464 !d        eello6=0.0d0
11465 !d        return
11466 !d      endif
11467 !d      write (iout,*)
11468 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11469 !d     &   ' and',k,l
11470 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
11471       do iii=1,2
11472         do kkk=1,5
11473           do lll=1,3
11474             derx_turn(lll,kkk,iii)=0.0d0
11475           enddo
11476         enddo
11477       enddo
11478 !d      eij=1.0d0
11479 !d      ekl=1.0d0
11480 !d      ekont=1.0d0
11481       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11482 !d      eello6_5=0.0d0
11483 !d      write (2,*) 'eello6_5',eello6_5
11484 #ifdef MOMENT
11485       call transpose2(AEA(1,1,1),auxmat(1,1))
11486       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11487       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
11488       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11489 #endif
11490       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11491       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11492       s2 = scalar2(b1(1,itk),vtemp1(1))
11493 #ifdef MOMENT
11494       call transpose2(AEA(1,1,2),atemp(1,1))
11495       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11496       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11497       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11498 #endif
11499       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11500       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11501       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11502 #ifdef MOMENT
11503       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11504       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11505       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11506       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11507       ss13 = scalar2(b1(1,itk),vtemp4(1))
11508       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11509 #endif
11510 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11511 !      s1=0.0d0
11512 !      s2=0.0d0
11513 !      s8=0.0d0
11514 !      s12=0.0d0
11515 !      s13=0.0d0
11516       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11517 ! Derivatives in gamma(i+2)
11518       s1d =0.0d0
11519       s8d =0.0d0
11520 #ifdef MOMENT
11521       call transpose2(AEA(1,1,1),auxmatd(1,1))
11522       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11523       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11524       call transpose2(AEAderg(1,1,2),atempd(1,1))
11525       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11526       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11527 #endif
11528       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11529       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11530       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11531 !      s1d=0.0d0
11532 !      s2d=0.0d0
11533 !      s8d=0.0d0
11534 !      s12d=0.0d0
11535 !      s13d=0.0d0
11536       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11537 ! Derivatives in gamma(i+3)
11538 #ifdef MOMENT
11539       call transpose2(AEA(1,1,1),auxmatd(1,1))
11540       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11541       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
11542       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11543 #endif
11544       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
11545       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11546       s2d = scalar2(b1(1,itk),vtemp1d(1))
11547 #ifdef MOMENT
11548       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11549       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11550 #endif
11551       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11552 #ifdef MOMENT
11553       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11554       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11555       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11556 #endif
11557 !      s1d=0.0d0
11558 !      s2d=0.0d0
11559 !      s8d=0.0d0
11560 !      s12d=0.0d0
11561 !      s13d=0.0d0
11562 #ifdef MOMENT
11563       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11564                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11565 #else
11566       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11567                     -0.5d0*ekont*(s2d+s12d)
11568 #endif
11569 ! Derivatives in gamma(i+4)
11570       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11571       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11572       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11573 #ifdef MOMENT
11574       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11575       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11576       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11577 #endif
11578 !      s1d=0.0d0
11579 !      s2d=0.0d0
11580 !      s8d=0.0d0
11581 !      s12d=0.0d0
11582 !      s13d=0.0d0
11583 #ifdef MOMENT
11584       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11585 #else
11586       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11587 #endif
11588 ! Derivatives in gamma(i+5)
11589 #ifdef MOMENT
11590       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11591       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11592       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11593 #endif
11594       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
11595       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11596       s2d = scalar2(b1(1,itk),vtemp1d(1))
11597 #ifdef MOMENT
11598       call transpose2(AEA(1,1,2),atempd(1,1))
11599       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11600       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11601 #endif
11602       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11603       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11604 #ifdef MOMENT
11605       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11606       ss13d = scalar2(b1(1,itk),vtemp4d(1))
11607       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11608 #endif
11609 !      s1d=0.0d0
11610 !      s2d=0.0d0
11611 !      s8d=0.0d0
11612 !      s12d=0.0d0
11613 !      s13d=0.0d0
11614 #ifdef MOMENT
11615       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11616                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11617 #else
11618       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11619                     -0.5d0*ekont*(s2d+s12d)
11620 #endif
11621 ! Cartesian derivatives
11622       do iii=1,2
11623         do kkk=1,5
11624           do lll=1,3
11625 #ifdef MOMENT
11626             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11627             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11628             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11629 #endif
11630             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11631             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
11632                 vtemp1d(1))
11633             s2d = scalar2(b1(1,itk),vtemp1d(1))
11634 #ifdef MOMENT
11635             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11636             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11637             s8d = -(atempd(1,1)+atempd(2,2))* &
11638                  scalar2(cc(1,1,itl),vtemp2(1))
11639 #endif
11640             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
11641                  auxmatd(1,1))
11642             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11643             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11644 !      s1d=0.0d0
11645 !      s2d=0.0d0
11646 !      s8d=0.0d0
11647 !      s12d=0.0d0
11648 !      s13d=0.0d0
11649 #ifdef MOMENT
11650             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11651               - 0.5d0*(s1d+s2d)
11652 #else
11653             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11654               - 0.5d0*s2d
11655 #endif
11656 #ifdef MOMENT
11657             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11658               - 0.5d0*(s8d+s12d)
11659 #else
11660             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11661               - 0.5d0*s12d
11662 #endif
11663           enddo
11664         enddo
11665       enddo
11666 #ifdef MOMENT
11667       do kkk=1,5
11668         do lll=1,3
11669           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
11670             achuj_tempd(1,1))
11671           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11672           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11673           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11674           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11675           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
11676             vtemp4d(1))
11677           ss13d = scalar2(b1(1,itk),vtemp4d(1))
11678           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11679           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11680         enddo
11681       enddo
11682 #endif
11683 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11684 !d     &  16*eel_turn6_num
11685 !d      goto 1112
11686       if (j.lt.nres-1) then
11687         j1=j+1
11688         j2=j-1
11689       else
11690         j1=j-1
11691         j2=j-2
11692       endif
11693       if (l.lt.nres-1) then
11694         l1=l+1
11695         l2=l-1
11696       else
11697         l1=l-1
11698         l2=l-2
11699       endif
11700       do ll=1,3
11701 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11702 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11703 !grad        ghalf=0.5d0*ggg1(ll)
11704 !d        ghalf=0.0d0
11705         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11706         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11707         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
11708           +ekont*derx_turn(ll,2,1)
11709         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11710         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
11711           +ekont*derx_turn(ll,4,1)
11712         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11713         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11714         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11715 !grad        ghalf=0.5d0*ggg2(ll)
11716 !d        ghalf=0.0d0
11717         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
11718           +ekont*derx_turn(ll,2,2)
11719         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11720         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
11721           +ekont*derx_turn(ll,4,2)
11722         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11723         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11724         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11725       enddo
11726 !d      goto 1112
11727 !grad      do m=i+1,j-1
11728 !grad        do ll=1,3
11729 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11730 !grad        enddo
11731 !grad      enddo
11732 !grad      do m=k+1,l-1
11733 !grad        do ll=1,3
11734 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11735 !grad        enddo
11736 !grad      enddo
11737 !grad1112  continue
11738 !grad      do m=i+2,j2
11739 !grad        do ll=1,3
11740 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11741 !grad        enddo
11742 !grad      enddo
11743 !grad      do m=k+2,l2
11744 !grad        do ll=1,3
11745 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11746 !grad        enddo
11747 !grad      enddo
11748 !d      do iii=1,nres-3
11749 !d        write (2,*) iii,g_corr6_loc(iii)
11750 !d      enddo
11751       eello_turn6=ekont*eel_turn6
11752 !d      write (2,*) 'ekont',ekont
11753 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11754       return
11755       end function eello_turn6
11756 !-----------------------------------------------------------------------------
11757       subroutine MATVEC2(A1,V1,V2)
11758 !DIR$ INLINEALWAYS MATVEC2
11759 #ifndef OSF
11760 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11761 #endif
11762 !      implicit real(kind=8) (a-h,o-z)
11763 !      include 'DIMENSIONS'
11764       real(kind=8),dimension(2) :: V1,V2
11765       real(kind=8),dimension(2,2) :: A1
11766       real(kind=8) :: vaux1,vaux2
11767 !      DO 1 I=1,2
11768 !        VI=0.0
11769 !        DO 3 K=1,2
11770 !    3     VI=VI+A1(I,K)*V1(K)
11771 !        Vaux(I)=VI
11772 !    1 CONTINUE
11773
11774       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11775       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11776
11777       v2(1)=vaux1
11778       v2(2)=vaux2
11779       end subroutine MATVEC2
11780 !-----------------------------------------------------------------------------
11781       subroutine MATMAT2(A1,A2,A3)
11782 #ifndef OSF
11783 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11784 #endif
11785 !      implicit real(kind=8) (a-h,o-z)
11786 !      include 'DIMENSIONS'
11787       real(kind=8),dimension(2,2) :: A1,A2,A3
11788       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11789 !      DIMENSION AI3(2,2)
11790 !        DO  J=1,2
11791 !          A3IJ=0.0
11792 !          DO K=1,2
11793 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11794 !          enddo
11795 !          A3(I,J)=A3IJ
11796 !       enddo
11797 !      enddo
11798
11799       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11800       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11801       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11802       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11803
11804       A3(1,1)=AI3_11
11805       A3(2,1)=AI3_21
11806       A3(1,2)=AI3_12
11807       A3(2,2)=AI3_22
11808       end subroutine MATMAT2
11809 !-----------------------------------------------------------------------------
11810       real(kind=8) function scalar2(u,v)
11811 !DIR$ INLINEALWAYS scalar2
11812       implicit none
11813       real(kind=8),dimension(2) :: u,v
11814       real(kind=8) :: sc
11815       integer :: i
11816       scalar2=u(1)*v(1)+u(2)*v(2)
11817       return
11818       end function scalar2
11819 !-----------------------------------------------------------------------------
11820       subroutine transpose2(a,at)
11821 !DIR$ INLINEALWAYS transpose2
11822 #ifndef OSF
11823 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11824 #endif
11825       implicit none
11826       real(kind=8),dimension(2,2) :: a,at
11827       at(1,1)=a(1,1)
11828       at(1,2)=a(2,1)
11829       at(2,1)=a(1,2)
11830       at(2,2)=a(2,2)
11831       return
11832       end subroutine transpose2
11833 !-----------------------------------------------------------------------------
11834       subroutine transpose(n,a,at)
11835       implicit none
11836       integer :: n,i,j
11837       real(kind=8),dimension(n,n) :: a,at
11838       do i=1,n
11839         do j=1,n
11840           at(j,i)=a(i,j)
11841         enddo
11842       enddo
11843       return
11844       end subroutine transpose
11845 !-----------------------------------------------------------------------------
11846       subroutine prodmat3(a1,a2,kk,transp,prod)
11847 !DIR$ INLINEALWAYS prodmat3
11848 #ifndef OSF
11849 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11850 #endif
11851       implicit none
11852       integer :: i,j
11853       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11854       logical :: transp
11855 !rc      double precision auxmat(2,2),prod_(2,2)
11856
11857       if (transp) then
11858 !rc        call transpose2(kk(1,1),auxmat(1,1))
11859 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11860 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11861
11862            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11863        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11864            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11865        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11866            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11867        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11868            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11869        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11870
11871       else
11872 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11873 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11874
11875            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11876         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11877            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11878         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11879            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11880         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11881            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11882         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11883
11884       endif
11885 !      call transpose2(a2(1,1),a2t(1,1))
11886
11887 !rc      print *,transp
11888 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11889 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11890
11891       return
11892       end subroutine prodmat3
11893 !-----------------------------------------------------------------------------
11894 ! energy_p_new_barrier.F
11895 !-----------------------------------------------------------------------------
11896       subroutine sum_gradient
11897 !      implicit real(kind=8) (a-h,o-z)
11898       use io_base, only: pdbout
11899 !      include 'DIMENSIONS'
11900 #ifndef ISNAN
11901       external proc_proc
11902 #ifdef WINPGI
11903 !MS$ATTRIBUTES C ::  proc_proc
11904 #endif
11905 #endif
11906 #ifdef MPI
11907       include 'mpif.h'
11908 #endif
11909       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11910                    gloc_scbuf !(3,maxres)
11911
11912       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11913 !#endif
11914 !el local variables
11915       integer :: i,j,k,ierror,ierr
11916       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11917                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11918                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11919                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11920                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11921                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11922                    gsccorr_max,gsccorrx_max,time00
11923
11924 !      include 'COMMON.SETUP'
11925 !      include 'COMMON.IOUNITS'
11926 !      include 'COMMON.FFIELD'
11927 !      include 'COMMON.DERIV'
11928 !      include 'COMMON.INTERACT'
11929 !      include 'COMMON.SBRIDGE'
11930 !      include 'COMMON.CHAIN'
11931 !      include 'COMMON.VAR'
11932 !      include 'COMMON.CONTROL'
11933 !      include 'COMMON.TIME1'
11934 !      include 'COMMON.MAXGRAD'
11935 !      include 'COMMON.SCCOR'
11936 #ifdef TIMING
11937       time01=MPI_Wtime()
11938 #endif
11939 !#define DEBUG
11940 #ifdef DEBUG
11941       write (iout,*) "sum_gradient gvdwc, gvdwx"
11942       do i=1,nres
11943         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11944          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11945       enddo
11946       call flush(iout)
11947 #endif
11948 #ifdef MPI
11949         gradbufc=0.0d0
11950         gradbufx=0.0d0
11951         gradbufc_sum=0.0d0
11952         gloc_scbuf=0.0d0
11953         glocbuf=0.0d0
11954 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11955         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11956           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11957 #endif
11958 !
11959 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11960 !            in virtual-bond-vector coordinates
11961 !
11962 #ifdef DEBUG
11963 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11964 !      do i=1,nres-1
11965 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11966 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11967 !      enddo
11968 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11969 !      do i=1,nres-1
11970 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11971 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11972 !      enddo
11973 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11974 !      do i=1,nres
11975 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11976 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11977 !         (gvdwc_scpp(j,i),j=1,3)
11978 !      enddo
11979 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11980 !      do i=1,nres
11981 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11982 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11983 !         (gelc_loc_long(j,i),j=1,3)
11984 !      enddo
11985       call flush(iout)
11986 #endif
11987 #ifdef SPLITELE
11988       do i=0,nct
11989         do j=1,3
11990           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11991                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11992                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11993                       wel_loc*gel_loc_long(j,i)+ &
11994                       wcorr*gradcorr_long(j,i)+ &
11995                       wcorr5*gradcorr5_long(j,i)+ &
11996                       wcorr6*gradcorr6_long(j,i)+ &
11997                       wturn6*gcorr6_turn_long(j,i)+ &
11998                       wstrain*ghpbc(j,i) &
11999                      +wliptran*gliptranc(j,i) &
12000                      +gradafm(j,i) &
12001                      +welec*gshieldc(j,i) &
12002                      +wcorr*gshieldc_ec(j,i) &
12003                      +wturn3*gshieldc_t3(j,i)&
12004                      +wturn4*gshieldc_t4(j,i)&
12005                      +wel_loc*gshieldc_ll(j,i)&
12006                      +wtube*gg_tube(j,i) &
12007                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
12008                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
12009                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
12010                      wcorr_nucl*gradcorr_nucl(j,i)&
12011                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
12012                      wcatprot* gradpepcat(j,i)+ &
12013                      wcatcat*gradcatcat(j,i)+   &
12014                      wscbase*gvdwc_scbase(j,i)+ &
12015                      wpepbase*gvdwc_pepbase(j,i)+&
12016                      wscpho*gvdwc_scpho(j,i)+   &
12017                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)+ &
12018                      gradlipbond(j,i)+gradlipang(j,i)+gradliplj(j,i)+gradlipelec(j,i)+&
12019                      wcat_tran*gradcattranc(j,i)+gradcatangc(j,i)
12020
12021
12022
12023
12024
12025         enddo
12026       enddo
12027 #else
12028       do i=0,nct
12029         do j=1,3
12030           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
12031                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
12032                       welec*gelc_long(j,i)+ &
12033                       wbond*gradb(j,i)+ &
12034                       wel_loc*gel_loc_long(j,i)+ &
12035                       wcorr*gradcorr_long(j,i)+ &
12036                       wcorr5*gradcorr5_long(j,i)+ &
12037                       wcorr6*gradcorr6_long(j,i)+ &
12038                       wturn6*gcorr6_turn_long(j,i)+ &
12039                       wstrain*ghpbc(j,i) &
12040                      +wliptran*gliptranc(j,i) &
12041                      +gradafm(j,i) &
12042                      +welec*gshieldc(j,i)&
12043                      +wcorr*gshieldc_ec(j,i) &
12044                      +wturn4*gshieldc_t4(j,i) &
12045                      +wel_loc*gshieldc_ll(j,i)&
12046                      +wtube*gg_tube(j,i) &
12047                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
12048                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
12049                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
12050                      wcorr_nucl*gradcorr_nucl(j,i) &
12051                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
12052                      wcatprot* gradpepcat(j,i)+ &
12053                      wcatcat*gradcatcat(j,i)+   &
12054                      wscbase*gvdwc_scbase(j,i)+ &
12055                      wpepbase*gvdwc_pepbase(j,i)+&
12056                      wscpho*gvdwc_scpho(j,i)+&
12057                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)+&
12058                      gradlipbond(j,i)+gradlipang(j,i)+gradliplj(j,i)+gradlipelec(j,i)+&
12059                      wcat_tran*gradcattranc(j,i)+gradcatangc(j,i)
12060
12061
12062
12063         enddo
12064       enddo
12065 #endif
12066 #ifdef MPI
12067       if (nfgtasks.gt.1) then
12068       time00=MPI_Wtime()
12069 #ifdef DEBUG
12070       write (iout,*) "gradbufc before allreduce"
12071       do i=1,nres
12072         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
12073       enddo
12074       call flush(iout)
12075 #endif
12076       do i=0,nres
12077         do j=1,3
12078           gradbufc_sum(j,i)=gradbufc(j,i)
12079         enddo
12080       enddo
12081 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
12082 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12083 !      time_reduce=time_reduce+MPI_Wtime()-time00
12084 #ifdef DEBUG
12085 !      write (iout,*) "gradbufc_sum after allreduce"
12086 !      do i=1,nres
12087 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
12088 !      enddo
12089 !      call flush(iout)
12090 #endif
12091 #ifdef TIMING
12092 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
12093 #endif
12094       do i=0,nres
12095         do k=1,3
12096           gradbufc(k,i)=0.0d0
12097         enddo
12098       enddo
12099 #ifdef DEBUG
12100       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
12101       write (iout,*) (i," jgrad_start",jgrad_start(i),&
12102                         " jgrad_end  ",jgrad_end(i),&
12103                         i=igrad_start,igrad_end)
12104 #endif
12105 !
12106 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
12107 ! do not parallelize this part.
12108 !
12109 !      do i=igrad_start,igrad_end
12110 !        do j=jgrad_start(i),jgrad_end(i)
12111 !          do k=1,3
12112 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
12113 !          enddo
12114 !        enddo
12115 !      enddo
12116       do j=1,3
12117         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
12118       enddo
12119       do i=nres-2,-1,-1
12120         do j=1,3
12121           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
12122         enddo
12123       enddo
12124 #ifdef DEBUG
12125       write (iout,*) "gradbufc after summing"
12126       do i=1,nres
12127         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
12128       enddo
12129       call flush(iout)
12130 #endif
12131       else
12132 #endif
12133 !el#define DEBUG
12134 #ifdef DEBUG
12135       write (iout,*) "gradbufc"
12136       do i=1,nres
12137         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
12138       enddo
12139       call flush(iout)
12140 #endif
12141 !el#undef DEBUG
12142       do i=-1,nres
12143         do j=1,3
12144           gradbufc_sum(j,i)=gradbufc(j,i)
12145           gradbufc(j,i)=0.0d0
12146         enddo
12147       enddo
12148       do j=1,3
12149         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
12150       enddo
12151       do i=nres-2,-1,-1
12152         do j=1,3
12153           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
12154         enddo
12155       enddo
12156 !      do i=nnt,nres-1
12157 !        do k=1,3
12158 !          gradbufc(k,i)=0.0d0
12159 !        enddo
12160 !        do j=i+1,nres
12161 !          do k=1,3
12162 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
12163 !          enddo
12164 !        enddo
12165 !      enddo
12166 !el#define DEBUG
12167 #ifdef DEBUG
12168       write (iout,*) "gradbufc after summing"
12169       do i=1,nres
12170         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
12171       enddo
12172       call flush(iout)
12173 #endif
12174 !el#undef DEBUG
12175 #ifdef MPI
12176       endif
12177 #endif
12178       do k=1,3
12179         gradbufc(k,nres)=0.0d0
12180       enddo
12181 !el----------------
12182 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
12183 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
12184 !el-----------------
12185       do i=-1,nct
12186         do j=1,3
12187 #ifdef SPLITELE
12188           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
12189                       wel_loc*gel_loc(j,i)+ &
12190                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
12191                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
12192                       wel_loc*gel_loc_long(j,i)+ &
12193                       wcorr*gradcorr_long(j,i)+ &
12194                       wcorr5*gradcorr5_long(j,i)+ &
12195                       wcorr6*gradcorr6_long(j,i)+ &
12196                       wturn6*gcorr6_turn_long(j,i))+ &
12197                       wbond*gradb(j,i)+ &
12198                       wcorr*gradcorr(j,i)+ &
12199                       wturn3*gcorr3_turn(j,i)+ &
12200                       wturn4*gcorr4_turn(j,i)+ &
12201                       wcorr5*gradcorr5(j,i)+ &
12202                       wcorr6*gradcorr6(j,i)+ &
12203                       wturn6*gcorr6_turn(j,i)+ &
12204                       wsccor*gsccorc(j,i) &
12205                      +wscloc*gscloc(j,i)  &
12206                      +wliptran*gliptranc(j,i) &
12207                      +gradafm(j,i) &
12208                      +welec*gshieldc(j,i) &
12209                      +welec*gshieldc_loc(j,i) &
12210                      +wcorr*gshieldc_ec(j,i) &
12211                      +wcorr*gshieldc_loc_ec(j,i) &
12212                      +wturn3*gshieldc_t3(j,i) &
12213                      +wturn3*gshieldc_loc_t3(j,i) &
12214                      +wturn4*gshieldc_t4(j,i) &
12215                      +wturn4*gshieldc_loc_t4(j,i) &
12216                      +wel_loc*gshieldc_ll(j,i) &
12217                      +wel_loc*gshieldc_loc_ll(j,i) &
12218                      +wtube*gg_tube(j,i) &
12219                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12220                      +wvdwpsb*gvdwpsb1(j,i))&
12221                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)!&
12222 !                     + gradcattranc(j,i)
12223 !                      if (i.eq.21) then
12224 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
12225 !                      wturn4*gshieldc_t4(j,i), &
12226 !                     wturn4*gshieldc_loc_t4(j,i)
12227 !                       endif
12228 !                 if ((i.le.2).and.(i.ge.1))
12229 !                       print *,gradc(j,i,icg),&
12230 !                      gradbufc(j,i),welec*gelc(j,i), &
12231 !                      wel_loc*gel_loc(j,i), &
12232 !                      wscp*gvdwc_scpp(j,i), &
12233 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
12234 !                      wel_loc*gel_loc_long(j,i), &
12235 !                      wcorr*gradcorr_long(j,i), &
12236 !                      wcorr5*gradcorr5_long(j,i), &
12237 !                      wcorr6*gradcorr6_long(j,i), &
12238 !                      wturn6*gcorr6_turn_long(j,i), &
12239 !                      wbond*gradb(j,i), &
12240 !                      wcorr*gradcorr(j,i), &
12241 !                      wturn3*gcorr3_turn(j,i), &
12242 !                      wturn4*gcorr4_turn(j,i), &
12243 !                      wcorr5*gradcorr5(j,i), &
12244 !                      wcorr6*gradcorr6(j,i), &
12245 !                      wturn6*gcorr6_turn(j,i), &
12246 !                      wsccor*gsccorc(j,i) &
12247 !                     ,wscloc*gscloc(j,i)  &
12248 !                     ,wliptran*gliptranc(j,i) &
12249 !                    ,gradafm(j,i) &
12250 !                     ,welec*gshieldc(j,i) &
12251 !                     ,welec*gshieldc_loc(j,i) &
12252 !                     ,wcorr*gshieldc_ec(j,i) &
12253 !                     ,wcorr*gshieldc_loc_ec(j,i) &
12254 !                     ,wturn3*gshieldc_t3(j,i) &
12255 !                     ,wturn3*gshieldc_loc_t3(j,i) &
12256 !                     ,wturn4*gshieldc_t4(j,i) &
12257 !                     ,wturn4*gshieldc_loc_t4(j,i) &
12258 !                     ,wel_loc*gshieldc_ll(j,i) &
12259 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
12260 !                     ,wtube*gg_tube(j,i) &
12261 !                     ,wbond_nucl*gradb_nucl(j,i) &
12262 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
12263 !                     wvdwpsb*gvdwpsb1(j,i)&
12264 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
12265 !
12266
12267 #else
12268           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
12269                       wel_loc*gel_loc(j,i)+ &
12270                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
12271                       welec*gelc_long(j,i)+ &
12272                       wel_loc*gel_loc_long(j,i)+ &
12273 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
12274                       wcorr5*gradcorr5_long(j,i)+ &
12275                       wcorr6*gradcorr6_long(j,i)+ &
12276                       wturn6*gcorr6_turn_long(j,i))+ &
12277                       wbond*gradb(j,i)+ &
12278                       wcorr*gradcorr(j,i)+ &
12279                       wturn3*gcorr3_turn(j,i)+ &
12280                       wturn4*gcorr4_turn(j,i)+ &
12281                       wcorr5*gradcorr5(j,i)+ &
12282                       wcorr6*gradcorr6(j,i)+ &
12283                       wturn6*gcorr6_turn(j,i)+ &
12284                       wsccor*gsccorc(j,i) &
12285                      +wscloc*gscloc(j,i) &
12286                      +gradafm(j,i) &
12287                      +wliptran*gliptranc(j,i) &
12288                      +welec*gshieldc(j,i) &
12289                      +welec*gshieldc_loc(j,i) &
12290                      +wcorr*gshieldc_ec(j,i) &
12291                      +wcorr*gshieldc_loc_ec(j,i) &
12292                      +wturn3*gshieldc_t3(j,i) &
12293                      +wturn3*gshieldc_loc_t3(j,i) &
12294                      +wturn4*gshieldc_t4(j,i) &
12295                      +wturn4*gshieldc_loc_t4(j,i) &
12296                      +wel_loc*gshieldc_ll(j,i) &
12297                      +wel_loc*gshieldc_loc_ll(j,i) &
12298                      +wtube*gg_tube(j,i) &
12299                      +wbond_nucl*gradb_nucl(j,i) &
12300                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12301                      +wvdwpsb*gvdwpsb1(j,i))&
12302                      +wsbloc*gsbloc(j,i)+wcatnucl*gradnuclcat(j,i)!&
12303 !                     + gradcattranc(j,i)
12304
12305
12306
12307
12308 #endif
12309           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
12310                         wbond*gradbx(j,i)+ &
12311                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
12312                         wsccor*gsccorx(j,i) &
12313                        +wscloc*gsclocx(j,i) &
12314                        +wliptran*gliptranx(j,i) &
12315                        +welec*gshieldx(j,i)     &
12316                        +wcorr*gshieldx_ec(j,i)  &
12317                        +wturn3*gshieldx_t3(j,i) &
12318                        +wturn4*gshieldx_t4(j,i) &
12319                        +wel_loc*gshieldx_ll(j,i)&
12320                        +wtube*gg_tube_sc(j,i)   &
12321                        +wbond_nucl*gradbx_nucl(j,i) &
12322                        +wvdwsb*gvdwsbx(j,i) &
12323                        +welsb*gelsbx(j,i) &
12324                        +wcorr_nucl*gradxorr_nucl(j,i)&
12325                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
12326                        +wsbloc*gsblocx(j,i) &
12327                        +wcatprot* gradpepcatx(j,i)&
12328                        +wscbase*gvdwx_scbase(j,i) &
12329                        +wpepbase*gvdwx_pepbase(j,i)&
12330                        +wscpho*gvdwx_scpho(j,i)+wcatnucl*gradnuclcatx(j,i)&
12331                        +wcat_tran*gradcattranx(j,i)+gradcatangx(j,i)
12332 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
12333
12334         enddo
12335       enddo
12336 !      write(iout,*), "const_homol",constr_homology
12337       if (constr_homology.gt.0) then
12338         do i=1,nct
12339           do j=1,3
12340             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
12341 !            write(iout,*) "duscdiff",duscdiff(j,i)
12342             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
12343           enddo
12344         enddo
12345       endif
12346 !#define DEBUG
12347 #ifdef DEBUG
12348       write (iout,*) "gloc before adding corr"
12349       do i=1,4*nres
12350         write (iout,*) i,gloc(i,icg)
12351       enddo
12352 #endif
12353       do i=1,nres-3
12354         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
12355          +wcorr5*g_corr5_loc(i) &
12356          +wcorr6*g_corr6_loc(i) &
12357          +wturn4*gel_loc_turn4(i) &
12358          +wturn3*gel_loc_turn3(i) &
12359          +wturn6*gel_loc_turn6(i) &
12360          +wel_loc*gel_loc_loc(i)
12361       enddo
12362 #ifdef DEBUG
12363       write (iout,*) "gloc after adding corr"
12364       do i=1,4*nres
12365         write (iout,*) i,gloc(i,icg)
12366       enddo
12367 #endif
12368 !#undef DEBUG
12369 #ifdef MPI
12370       if (nfgtasks.gt.1) then
12371         do j=1,3
12372           do i=0,nres
12373             gradbufc(j,i)=gradc(j,i,icg)
12374             gradbufx(j,i)=gradx(j,i,icg)
12375           enddo
12376         enddo
12377         do i=1,4*nres
12378           glocbuf(i)=gloc(i,icg)
12379         enddo
12380 !#define DEBUG
12381 #ifdef DEBUG
12382       write (iout,*) "gloc_sc before reduce"
12383       do i=1,nres
12384        do j=1,1
12385         write (iout,*) i,j,gloc_sc(j,i,icg)
12386        enddo
12387       enddo
12388 #endif
12389 !#undef DEBUG
12390         do i=0,nres
12391          do j=1,3
12392           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
12393          enddo
12394         enddo
12395         time00=MPI_Wtime()
12396         call MPI_Barrier(FG_COMM,IERR)
12397         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
12398         time00=MPI_Wtime()
12399         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
12400           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12401         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
12402           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12403         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
12404           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12405         time_reduce=time_reduce+MPI_Wtime()-time00
12406         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
12407           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12408         time_reduce=time_reduce+MPI_Wtime()-time00
12409 !#define DEBUG
12410 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
12411 #ifdef DEBUG
12412       write (iout,*) "gloc_sc after reduce"
12413       do i=0,nres
12414        do j=1,1
12415         write (iout,*) i,j,gloc_sc(j,i,icg)
12416        enddo
12417       enddo
12418 #endif
12419 !#undef DEBUG
12420 #ifdef DEBUG
12421       write (iout,*) "gloc after reduce"
12422       do i=1,4*nres
12423         write (iout,*) i,gloc(i,icg)
12424       enddo
12425 #endif
12426       endif
12427 #endif
12428       if (gnorm_check) then
12429 !
12430 ! Compute the maximum elements of the gradient
12431 !
12432       gvdwc_max=0.0d0
12433       gvdwc_scp_max=0.0d0
12434       gelc_max=0.0d0
12435       gvdwpp_max=0.0d0
12436       gradb_max=0.0d0
12437       ghpbc_max=0.0d0
12438       gradcorr_max=0.0d0
12439       gel_loc_max=0.0d0
12440       gcorr3_turn_max=0.0d0
12441       gcorr4_turn_max=0.0d0
12442       gradcorr5_max=0.0d0
12443       gradcorr6_max=0.0d0
12444       gcorr6_turn_max=0.0d0
12445       gsccorc_max=0.0d0
12446       gscloc_max=0.0d0
12447       gvdwx_max=0.0d0
12448       gradx_scp_max=0.0d0
12449       ghpbx_max=0.0d0
12450       gradxorr_max=0.0d0
12451       gsccorx_max=0.0d0
12452       gsclocx_max=0.0d0
12453       do i=1,nct
12454         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
12455         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
12456         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
12457         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
12458          gvdwc_scp_max=gvdwc_scp_norm
12459         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
12460         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
12461         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
12462         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
12463         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
12464         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
12465         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
12466         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
12467         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
12468         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
12469         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
12470         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
12471         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
12472           gcorr3_turn(1,i)))
12473         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
12474           gcorr3_turn_max=gcorr3_turn_norm
12475         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
12476           gcorr4_turn(1,i)))
12477         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
12478           gcorr4_turn_max=gcorr4_turn_norm
12479         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
12480         if (gradcorr5_norm.gt.gradcorr5_max) &
12481           gradcorr5_max=gradcorr5_norm
12482         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
12483         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
12484         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
12485           gcorr6_turn(1,i)))
12486         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
12487           gcorr6_turn_max=gcorr6_turn_norm
12488         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
12489         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
12490         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
12491         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
12492         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
12493         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
12494         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
12495         if (gradx_scp_norm.gt.gradx_scp_max) &
12496           gradx_scp_max=gradx_scp_norm
12497         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
12498         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
12499         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
12500         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
12501         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
12502         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
12503         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
12504         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
12505       enddo
12506       if (gradout) then
12507 #ifdef AIX
12508         open(istat,file=statname,position="append")
12509 #else
12510         open(istat,file=statname,access="append")
12511 #endif
12512         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
12513            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
12514            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
12515            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
12516            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
12517            gsccorx_max,gsclocx_max
12518         close(istat)
12519         if (gvdwc_max.gt.1.0d4) then
12520           write (iout,*) "gvdwc gvdwx gradb gradbx"
12521           do i=nnt,nct
12522             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
12523               gradb(j,i),gradbx(j,i),j=1,3)
12524           enddo
12525           call pdbout(0.0d0,'cipiszcze',iout)
12526           call flush(iout)
12527         endif
12528       endif
12529       endif
12530 !#define DEBUG
12531 #ifdef DEBUG
12532       write (iout,*) "gradc gradx gloc"
12533       do i=1,nres
12534         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
12535          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
12536       enddo
12537 #endif
12538 !#undef DEBUG
12539 #ifdef TIMING
12540       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
12541 #endif
12542       return
12543       end subroutine sum_gradient
12544 !-----------------------------------------------------------------------------
12545       subroutine sc_grad
12546 !      implicit real(kind=8) (a-h,o-z)
12547       use calc_data
12548 !      include 'DIMENSIONS'
12549 !      include 'COMMON.CHAIN'
12550 !      include 'COMMON.DERIV'
12551 !      include 'COMMON.CALC'
12552 !      include 'COMMON.IOUNITS'
12553       real(kind=8), dimension(3) :: dcosom1,dcosom2
12554 !      print *,"wchodze"
12555       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12556           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12557       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12558           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12559
12560       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12561            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12562            +dCAVdOM12+ dGCLdOM12
12563 ! diagnostics only
12564 !      eom1=0.0d0
12565 !      eom2=0.0d0
12566 !      eom12=evdwij*eps1_om12
12567 ! end diagnostics
12568 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
12569 !       " sigder",sigder
12570 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
12571 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
12572 !C      print *,sss_ele_cut,'in sc_grad'
12573       do k=1,3
12574         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12575         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
12576       enddo
12577       do k=1,3
12578         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
12579 !C      print *,'gg',k,gg(k)
12580        enddo
12581 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12582 !      write (iout,*) "gg",(gg(k),k=1,3)
12583       do k=1,3
12584         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
12585                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12586                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
12587                   *sss_ele_cut
12588
12589         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
12590                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12591                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
12592                   *sss_ele_cut
12593
12594 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12595 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12596 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12597 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12598       enddo
12599 !
12600 ! Calculate the components of the gradient in DC and X
12601 !
12602 !grad      do k=i,j-1
12603 !grad        do l=1,3
12604 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
12605 !grad        enddo
12606 !grad      enddo
12607       do l=1,3
12608         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
12609         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
12610       enddo
12611       return
12612       end subroutine sc_grad
12613
12614       subroutine sc_grad_cat
12615       use calc_data
12616       real(kind=8), dimension(3) :: dcosom1,dcosom2
12617       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12618           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12619       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12620           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12621
12622       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12623            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12624            +dCAVdOM12+ dGCLdOM12
12625 ! diagnostics only
12626 !      eom1=0.0d0
12627 !      eom2=0.0d0
12628 !      eom12=evdwij*eps1_om12
12629 ! end diagnostics
12630
12631       do k=1,3
12632         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12633         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
12634       enddo
12635       do k=1,3
12636         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
12637 !      print *,'gg',k,gg(k)
12638        enddo
12639 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12640 !      write (iout,*) "gg",(gg(k),k=1,3)
12641       do k=1,3
12642         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
12643                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
12644                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12645
12646 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
12647 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
12648 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
12649
12650 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12651 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12652 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12653 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12654       enddo
12655 !
12656 ! Calculate the components of the gradient in DC and X
12657 !
12658       do l=1,3
12659         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
12660         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
12661       enddo
12662       end subroutine sc_grad_cat
12663
12664       subroutine sc_grad_cat_pep
12665       use calc_data
12666       real(kind=8), dimension(3) :: dcosom1,dcosom2
12667       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12668           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12669       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12670           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12671
12672       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12673            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12674            +dCAVdOM12+ dGCLdOM12
12675 ! diagnostics only
12676 !      eom1=0.0d0
12677 !      eom2=0.0d0
12678 !      eom12=evdwij*eps1_om12
12679 ! end diagnostics
12680
12681       do k=1,3
12682         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
12683         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
12684         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
12685         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
12686                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
12687                  *dsci_inv*2.0 &
12688                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12689         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
12690                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
12691                  *dsci_inv*2.0 &
12692                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12693         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
12694       enddo
12695       end subroutine sc_grad_cat_pep
12696
12697 #ifdef CRYST_THETA
12698 !-----------------------------------------------------------------------------
12699       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
12700
12701       use comm_calcthet
12702 !      implicit real(kind=8) (a-h,o-z)
12703 !      include 'DIMENSIONS'
12704 !      include 'COMMON.LOCAL'
12705 !      include 'COMMON.IOUNITS'
12706 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
12707 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12708 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
12709       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
12710       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
12711 !el      integer :: it
12712 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
12713 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12714 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
12715 !el local variables
12716
12717       delthec=thetai-thet_pred_mean
12718       delthe0=thetai-theta0i
12719 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
12720       t3 = thetai-thet_pred_mean
12721       t6 = t3**2
12722       t9 = term1
12723       t12 = t3*sigcsq
12724       t14 = t12+t6*sigsqtc
12725       t16 = 1.0d0
12726       t21 = thetai-theta0i
12727       t23 = t21**2
12728       t26 = term2
12729       t27 = t21*t26
12730       t32 = termexp
12731       t40 = t32**2
12732       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
12733        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12734        *(-t12*t9-ak*sig0inv*t27)
12735       return
12736       end subroutine mixder
12737 #endif
12738 !-----------------------------------------------------------------------------
12739 ! cartder.F
12740 !-----------------------------------------------------------------------------
12741       subroutine cartder
12742 !-----------------------------------------------------------------------------
12743 ! This subroutine calculates the derivatives of the consecutive virtual
12744 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12745 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12746 ! in the angles alpha and omega, describing the location of a side chain
12747 ! in its local coordinate system.
12748 !
12749 ! The derivatives are stored in the following arrays:
12750 !
12751 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12752 ! The structure is as follows:
12753 !
12754 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12755 ! 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)
12756 !         . . . . . . . . . . . .  . . . . . .
12757 ! 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)
12758 !                          .
12759 !                          .
12760 !                          .
12761 ! 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)
12762 !
12763 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12764 ! The structure is same as above.
12765 !
12766 ! DCDS - the derivatives of the side chain vectors in the local spherical
12767 ! andgles alph and omega:
12768 !
12769 ! 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)
12770 ! 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)
12771 !                          .
12772 !                          .
12773 !                          .
12774 ! 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)
12775 !
12776 ! Version of March '95, based on an early version of November '91.
12777 !
12778 !**********************************************************************
12779 !      implicit real(kind=8) (a-h,o-z)
12780 !      include 'DIMENSIONS'
12781 !      include 'COMMON.VAR'
12782 !      include 'COMMON.CHAIN'
12783 !      include 'COMMON.DERIV'
12784 !      include 'COMMON.GEO'
12785 !      include 'COMMON.LOCAL'
12786 !      include 'COMMON.INTERACT'
12787       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12788       real(kind=8),dimension(3,3) :: dp,temp
12789 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12790       real(kind=8),dimension(3) :: xx,xx1
12791 !el local variables
12792       integer :: i,k,l,j,m,ind,ind1,jjj
12793       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12794                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12795                  sint2,xp,yp,xxp,yyp,zzp,dj
12796
12797 !      common /przechowalnia/ fromto
12798 #ifdef FIVEDIAG
12799       if(.not. allocated(fromto)) allocate(fromto(3,3))
12800 #else
12801       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12802 #endif
12803 ! get the position of the jth ijth fragment of the chain coordinate system
12804 ! in the fromto array.
12805 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12806 !
12807 !      maxdim=(nres-1)*(nres-2)/2
12808 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12809 ! calculate the derivatives of transformation matrix elements in theta
12810 !
12811
12812 !el      call flush(iout) !el
12813       do i=1,nres-2
12814         rdt(1,1,i)=-rt(1,2,i)
12815         rdt(1,2,i)= rt(1,1,i)
12816         rdt(1,3,i)= 0.0d0
12817         rdt(2,1,i)=-rt(2,2,i)
12818         rdt(2,2,i)= rt(2,1,i)
12819         rdt(2,3,i)= 0.0d0
12820         rdt(3,1,i)=-rt(3,2,i)
12821         rdt(3,2,i)= rt(3,1,i)
12822         rdt(3,3,i)= 0.0d0
12823       enddo
12824 !
12825 ! derivatives in phi
12826 !
12827       do i=2,nres-2
12828         drt(1,1,i)= 0.0d0
12829         drt(1,2,i)= 0.0d0
12830         drt(1,3,i)= 0.0d0
12831         drt(2,1,i)= rt(3,1,i)
12832         drt(2,2,i)= rt(3,2,i)
12833         drt(2,3,i)= rt(3,3,i)
12834         drt(3,1,i)=-rt(2,1,i)
12835         drt(3,2,i)=-rt(2,2,i)
12836         drt(3,3,i)=-rt(2,3,i)
12837       enddo
12838 !
12839 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12840 !
12841 #ifndef FIVEDIAG
12842       do i=2,nres-2
12843         ind=indmat(i,i+1)
12844         do k=1,3
12845           do l=1,3
12846             temp(k,l)=rt(k,l,i)
12847           enddo
12848         enddo
12849         do k=1,3
12850           do l=1,3
12851             fromto(k,l,ind)=temp(k,l)
12852           enddo
12853         enddo
12854
12855         do j=i+1,nres-2
12856           ind=indmat(i,j+1)
12857           do k=1,3
12858             do l=1,3
12859               dpkl=0.0d0
12860               do m=1,3
12861                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12862               enddo
12863               dp(k,l)=dpkl
12864               fromto(k,l,ind)=dpkl
12865             enddo
12866           enddo
12867           do k=1,3
12868             do l=1,3
12869               temp(k,l)=dp(k,l)
12870             enddo
12871           enddo
12872         enddo
12873       enddo
12874 #endif
12875 !
12876 ! Calculate derivatives.
12877 !
12878       ind1=0
12879       do i=1,nres-2
12880       ind1=ind1+1
12881 !
12882 ! Derivatives of DC(i+1) in theta(i+2)
12883 !
12884         do j=1,3
12885           do k=1,2
12886             dpjk=0.0D0
12887             do l=1,3
12888               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12889             enddo
12890             dp(j,k)=dpjk
12891             prordt(j,k,i)=dp(j,k)
12892           enddo
12893           dp(j,3)=0.0D0
12894           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12895         enddo
12896 !
12897 ! Derivatives of SC(i+1) in theta(i+2)
12898 !
12899         xx1(1)=-0.5D0*xloc(2,i+1)
12900         xx1(2)= 0.5D0*xloc(1,i+1)
12901         do j=1,3
12902           xj=0.0D0
12903           do k=1,2
12904             xj=xj+r(j,k,i)*xx1(k)
12905           enddo
12906           xx(j)=xj
12907         enddo
12908         do j=1,3
12909           rj=0.0D0
12910           do k=1,3
12911             rj=rj+prod(j,k,i)*xx(k)
12912           enddo
12913           dxdv(j,ind1)=rj
12914         enddo
12915 !
12916 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12917 ! than the other off-diagonal derivatives.
12918 !
12919         do j=1,3
12920           dxoiij=0.0D0
12921           do k=1,3
12922             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12923           enddo
12924           dxdv(j,ind1+1)=dxoiij
12925         enddo
12926 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12927 !
12928 ! Derivatives of DC(i+1) in phi(i+2)
12929 !
12930         do j=1,3
12931           do k=1,3
12932             dpjk=0.0
12933             do l=2,3
12934               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12935             enddo
12936             dp(j,k)=dpjk
12937             prodrt(j,k,i)=dp(j,k)
12938           enddo
12939           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12940         enddo
12941 !
12942 ! Derivatives of SC(i+1) in phi(i+2)
12943 !
12944         xx(1)= 0.0D0
12945         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12946         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12947         do j=1,3
12948           rj=0.0D0
12949           do k=2,3
12950             rj=rj+prod(j,k,i)*xx(k)
12951           enddo
12952           dxdv(j+3,ind1)=-rj
12953         enddo
12954 !
12955 ! Derivatives of SC(i+1) in phi(i+3).
12956 !
12957         do j=1,3
12958           dxoiij=0.0D0
12959           do k=1,3
12960             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12961           enddo
12962           dxdv(j+3,ind1+1)=dxoiij
12963         enddo
12964 !
12965 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12966 ! theta(nres) and phi(i+3) thru phi(nres).
12967 !
12968         do j=i+1,nres-2
12969         ind1=ind1+1
12970         ind=indmat(i+1,j+1)
12971 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12972 #ifdef FIVEDIAG
12973           call build_fromto(i+1,j+1,fromto)
12974 c          write(iout,'(7hfromto 9f10.5)')((fromto(k,l),l=1,3),k=1,3)
12975           do k=1,3
12976             do l=1,3
12977               tempkl=0.0D0
12978               do m=1,2
12979                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l)
12980               enddo
12981               temp(k,l)=tempkl
12982             enddo
12983           enddo
12984 #else
12985           do k=1,3
12986             do l=1,3
12987               tempkl=0.0D0
12988               do m=1,2
12989                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12990               enddo
12991               temp(k,l)=tempkl
12992             enddo
12993           enddo
12994 #endif
12995 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12996 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12997 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12998 ! Derivatives of virtual-bond vectors in theta
12999           do k=1,3
13000             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
13001           enddo
13002 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
13003 ! Derivatives of SC vectors in theta
13004           do k=1,3
13005             dxoijk=0.0D0
13006             do l=1,3
13007               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
13008             enddo
13009             dxdv(k,ind1+1)=dxoijk
13010           enddo
13011 !
13012 !--- Calculate the derivatives in phi
13013 !
13014 #ifdef FIVEDIAG
13015           do k=1,3
13016             do l=1,3
13017               tempkl=0.0D0
13018               do m=1,3
13019                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l)
13020               enddo
13021               temp(k,l)=tempkl
13022             enddo
13023           enddo
13024 #else
13025           do k=1,3
13026             do l=1,3
13027               tempkl=0.0D0
13028               do m=1,3
13029                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
13030               enddo
13031               temp(k,l)=tempkl
13032             enddo
13033           enddo
13034 #endif
13035
13036
13037           do k=1,3
13038             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
13039         enddo
13040           do k=1,3
13041             dxoijk=0.0D0
13042             do l=1,3
13043               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
13044             enddo
13045             dxdv(k+3,ind1+1)=dxoijk
13046           enddo
13047         enddo
13048       enddo
13049 !
13050 ! Derivatives in alpha and omega:
13051 !
13052       do i=2,nres-1
13053 !       dsci=dsc(itype(i,1))
13054         dsci=vbld(i+nres)
13055 #ifdef OSF
13056         alphi=alph(i)
13057         omegi=omeg(i)
13058         if(alphi.ne.alphi) alphi=100.0
13059         if(omegi.ne.omegi) omegi=-100.0
13060 #else
13061       alphi=alph(i)
13062       omegi=omeg(i)
13063 #endif
13064 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
13065       cosalphi=dcos(alphi)
13066       sinalphi=dsin(alphi)
13067       cosomegi=dcos(omegi)
13068       sinomegi=dsin(omegi)
13069       temp(1,1)=-dsci*sinalphi
13070       temp(2,1)= dsci*cosalphi*cosomegi
13071       temp(3,1)=-dsci*cosalphi*sinomegi
13072       temp(1,2)=0.0D0
13073       temp(2,2)=-dsci*sinalphi*sinomegi
13074       temp(3,2)=-dsci*sinalphi*cosomegi
13075       theta2=pi-0.5D0*theta(i+1)
13076       cost2=dcos(theta2)
13077       sint2=dsin(theta2)
13078       jjj=0
13079 !d      print *,((temp(l,k),l=1,3),k=1,2)
13080         do j=1,2
13081         xp=temp(1,j)
13082         yp=temp(2,j)
13083         xxp= xp*cost2+yp*sint2
13084         yyp=-xp*sint2+yp*cost2
13085         zzp=temp(3,j)
13086         xx(1)=xxp
13087         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
13088         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
13089         do k=1,3
13090           dj=0.0D0
13091           do l=1,3
13092             dj=dj+prod(k,l,i-1)*xx(l)
13093             enddo
13094           dxds(jjj+k,i)=dj
13095           enddo
13096         jjj=jjj+3
13097       enddo
13098       enddo
13099       return
13100       end subroutine cartder
13101 #ifdef FIVEDIAG
13102       subroutine build_fromto(i,j,fromto)
13103       implicit none
13104       integer i,j,jj,k,l,m
13105       double precision fromto(3,3),temp(3,3),dp(3,3)
13106       double precision dpkl
13107       save temp
13108 !
13109 ! generate the matrix products of type r(i)t(i)...r(j)t(j) on the fly
13110 !
13111 !      write (iout,*) "temp on entry"
13112 !      write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
13113 !      do i=2,nres-2
13114 !        ind=indmat(i,i+1)
13115       if (j.eq.i+1) then
13116         do k=1,3
13117           do l=1,3
13118             temp(k,l)=rt(k,l,i)
13119           enddo
13120         enddo
13121         do k=1,3
13122           do l=1,3
13123             fromto(k,l)=temp(k,l)
13124           enddo
13125         enddo
13126       else
13127 !        do j=i+1,nres-2
13128 !          ind=indmat(i,j+1)
13129           do k=1,3
13130             do l=1,3
13131               dpkl=0.0d0
13132               do m=1,3
13133                 dpkl=dpkl+temp(k,m)*rt(m,l,j-1)
13134               enddo
13135               dp(k,l)=dpkl
13136               fromto(k,l)=dpkl
13137             enddo
13138           enddo
13139           do k=1,3
13140             do l=1,3
13141               temp(k,l)=dp(k,l)
13142             enddo
13143           enddo
13144       endif
13145 !      write (iout,*) "temp upon exit"
13146 !      write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
13147 !        enddo
13148 !      enddo
13149       return
13150       end subroutine build_fromto
13151 #endif
13152
13153 !-----------------------------------------------------------------------------
13154 ! checkder_p.F
13155 !-----------------------------------------------------------------------------
13156       subroutine check_cartgrad
13157 ! Check the gradient of Cartesian coordinates in internal coordinates.
13158 !      implicit real(kind=8) (a-h,o-z)
13159 !      include 'DIMENSIONS'
13160 !      include 'COMMON.IOUNITS'
13161 !      include 'COMMON.VAR'
13162 !      include 'COMMON.CHAIN'
13163 !      include 'COMMON.GEO'
13164 !      include 'COMMON.LOCAL'
13165 !      include 'COMMON.DERIV'
13166       real(kind=8),dimension(6,nres) :: temp
13167       real(kind=8),dimension(3) :: xx,gg
13168       integer :: i,k,j,ii
13169       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
13170 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
13171 !
13172 ! Check the gradient of the virtual-bond and SC vectors in the internal
13173 ! coordinates.
13174 !
13175       aincr=1.0d-6
13176       aincr2=5.0d-7
13177       call cartder
13178       write (iout,'(a)') '**************** dx/dalpha'
13179       write (iout,'(a)')
13180       do i=2,nres-1
13181       alphi=alph(i)
13182       alph(i)=alph(i)+aincr
13183       do k=1,3
13184         temp(k,i)=dc(k,nres+i)
13185         enddo
13186       call chainbuild
13187       do k=1,3
13188         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
13189         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
13190         enddo
13191         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
13192         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
13193         write (iout,'(a)')
13194       alph(i)=alphi
13195       call chainbuild
13196       enddo
13197       write (iout,'(a)')
13198       write (iout,'(a)') '**************** dx/domega'
13199       write (iout,'(a)')
13200       do i=2,nres-1
13201       omegi=omeg(i)
13202       omeg(i)=omeg(i)+aincr
13203       do k=1,3
13204         temp(k,i)=dc(k,nres+i)
13205         enddo
13206       call chainbuild
13207       do k=1,3
13208           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
13209           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
13210                 (aincr*dabs(dxds(k+3,i))+aincr))
13211         enddo
13212         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
13213             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
13214         write (iout,'(a)')
13215       omeg(i)=omegi
13216       call chainbuild
13217       enddo
13218       write (iout,'(a)')
13219       write (iout,'(a)') '**************** dx/dtheta'
13220       write (iout,'(a)')
13221       do i=3,nres
13222       theti=theta(i)
13223         theta(i)=theta(i)+aincr
13224         do j=i-1,nres-1
13225           do k=1,3
13226             temp(k,j)=dc(k,nres+j)
13227           enddo
13228         enddo
13229         call chainbuild
13230         do j=i-1,nres-1
13231         ii = indmat(i-2,j)
13232 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
13233         do k=1,3
13234           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
13235           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
13236                   (aincr*dabs(dxdv(k,ii))+aincr))
13237           enddo
13238           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13239               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
13240           write(iout,'(a)')
13241         enddo
13242         write (iout,'(a)')
13243         theta(i)=theti
13244         call chainbuild
13245       enddo
13246       write (iout,'(a)') '***************** dx/dphi'
13247       write (iout,'(a)')
13248       do i=4,nres
13249         phi(i)=phi(i)+aincr
13250         do j=i-1,nres-1
13251           do k=1,3
13252             temp(k,j)=dc(k,nres+j)
13253           enddo
13254         enddo
13255         call chainbuild
13256         do j=i-1,nres-1
13257         ii = indmat(i-2,j)
13258 !         print *,'ii=',ii
13259         do k=1,3
13260           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
13261             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
13262                   (aincr*dabs(dxdv(k+3,ii))+aincr))
13263           enddo
13264           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13265               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13266           write(iout,'(a)')
13267         enddo
13268         phi(i)=phi(i)-aincr
13269         call chainbuild
13270       enddo
13271       write (iout,'(a)') '****************** ddc/dtheta'
13272       do i=1,nres-2
13273         thet=theta(i+2)
13274         theta(i+2)=thet+aincr
13275         do j=i,nres
13276           do k=1,3
13277             temp(k,j)=dc(k,j)
13278           enddo
13279         enddo
13280         call chainbuild
13281         do j=i+1,nres-1
13282         ii = indmat(i,j)
13283 !         print *,'ii=',ii
13284         do k=1,3
13285           gg(k)=(dc(k,j)-temp(k,j))/aincr
13286           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
13287                  (aincr*dabs(dcdv(k,ii))+aincr))
13288           enddo
13289           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13290                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
13291         write (iout,'(a)')
13292         enddo
13293         do j=1,nres
13294           do k=1,3
13295             dc(k,j)=temp(k,j)
13296           enddo
13297         enddo
13298         theta(i+2)=thet
13299       enddo
13300       write (iout,'(a)') '******************* ddc/dphi'
13301       do i=1,nres-3
13302         phii=phi(i+3)
13303         phi(i+3)=phii+aincr
13304         do j=1,nres
13305           do k=1,3
13306             temp(k,j)=dc(k,j)
13307           enddo
13308         enddo
13309         call chainbuild
13310         do j=i+2,nres-1
13311         ii = indmat(i+1,j)
13312 !         print *,'ii=',ii
13313         do k=1,3
13314           gg(k)=(dc(k,j)-temp(k,j))/aincr
13315             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
13316                  (aincr*dabs(dcdv(k+3,ii))+aincr))
13317           enddo
13318           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13319                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13320         write (iout,'(a)')
13321         enddo
13322         do j=1,nres
13323           do k=1,3
13324             dc(k,j)=temp(k,j)
13325           enddo
13326         enddo
13327         phi(i+3)=phii
13328       enddo
13329       return
13330       end subroutine check_cartgrad
13331 !-----------------------------------------------------------------------------
13332       subroutine check_ecart
13333 ! Check the gradient of the energy in Cartesian coordinates.
13334 !     implicit real(kind=8) (a-h,o-z)
13335 !     include 'DIMENSIONS'
13336 !     include 'COMMON.CHAIN'
13337 !     include 'COMMON.DERIV'
13338 !     include 'COMMON.IOUNITS'
13339 !     include 'COMMON.VAR'
13340 !     include 'COMMON.CONTACTS'
13341       use comm_srutu
13342 !el      integer :: icall
13343 !el      common /srutu/ icall
13344       real(kind=8),dimension(6) :: ggg
13345       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13346       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13347       real(kind=8),dimension(6,nres) :: grad_s
13348       real(kind=8),dimension(0:n_ene) :: energia,energia1
13349       integer :: uiparm(1)
13350       real(kind=8) :: urparm(1)
13351 !EL      external fdum
13352       integer :: nf,i,j,k
13353       real(kind=8) :: aincr,etot,etot1
13354       icg=1
13355       nf=0
13356       nfl=0
13357       call zerograd
13358       aincr=1.0D-5
13359       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
13360       nf=0
13361       icall=0
13362       call geom_to_var(nvar,x)
13363       call etotal(energia)
13364       etot=energia(0)
13365 !el      call enerprint(energia)
13366       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
13367       icall =1
13368       do i=1,nres
13369         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13370       enddo
13371       do i=1,nres
13372       do j=1,3
13373         grad_s(j,i)=gradc(j,i,icg)
13374         grad_s(j+3,i)=gradx(j,i,icg)
13375         enddo
13376       enddo
13377       call flush(iout)
13378       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13379       do i=1,nres
13380         do j=1,3
13381         xx(j)=c(j,i+nres)
13382         ddc(j)=dc(j,i)
13383         ddx(j)=dc(j,i+nres)
13384         enddo
13385       do j=1,3
13386         dc(j,i)=dc(j,i)+aincr
13387         do k=i+1,nres
13388           c(j,k)=c(j,k)+aincr
13389           c(j,k+nres)=c(j,k+nres)+aincr
13390           enddo
13391           call zerograd
13392           call etotal(energia1)
13393           etot1=energia1(0)
13394         ggg(j)=(etot1-etot)/aincr
13395         dc(j,i)=ddc(j)
13396         do k=i+1,nres
13397           c(j,k)=c(j,k)-aincr
13398           c(j,k+nres)=c(j,k+nres)-aincr
13399           enddo
13400         enddo
13401       do j=1,3
13402         c(j,i+nres)=c(j,i+nres)+aincr
13403         dc(j,i+nres)=dc(j,i+nres)+aincr
13404           call zerograd
13405           call etotal(energia1)
13406           etot1=energia1(0)
13407         ggg(j+3)=(etot1-etot)/aincr
13408         c(j,i+nres)=xx(j)
13409         dc(j,i+nres)=ddx(j)
13410         enddo
13411       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
13412          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
13413       enddo
13414       return
13415       end subroutine check_ecart
13416 #ifdef CARGRAD
13417 !-----------------------------------------------------------------------------
13418       subroutine check_ecartint
13419 ! Check the gradient of the energy in Cartesian coordinates.
13420       use io_base, only: intout
13421       use MD_data, only: iset
13422 !      implicit real*8 (a-h,o-z)
13423 !      include 'DIMENSIONS'
13424 !      include 'COMMON.CONTROL'
13425 !      include 'COMMON.CHAIN'
13426 !      include 'COMMON.DERIV'
13427 !      include 'COMMON.IOUNITS'
13428 !      include 'COMMON.VAR'
13429 !      include 'COMMON.CONTACTS'
13430 !      include 'COMMON.MD'
13431 !      include 'COMMON.LOCAL'
13432 !      include 'COMMON.SPLITELE'
13433       use comm_srutu
13434 !el      integer :: icall
13435 !el      common /srutu/ icall
13436       real(kind=8),dimension(6) :: ggg,ggg1
13437       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
13438       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13439       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
13440       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13441       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13442       real(kind=8),dimension(0:n_ene) :: energia,energia1
13443       integer :: uiparm(1)
13444       real(kind=8) :: urparm(1)
13445 !EL      external fdum
13446       integer :: i,j,k,nf
13447       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13448                    etot21,etot22
13449       r_cut=2.0d0
13450       rlambd=0.3d0
13451       icg=1
13452       nf=0
13453       nfl=0
13454       if (iset.eq.0) iset=1
13455       call intout
13456 !      call intcartderiv
13457 !      call checkintcartgrad
13458       call zerograd
13459       aincr=1.0D-5
13460       write(iout,*) 'Calling CHECK_ECARTINT.'
13461       nf=0
13462       icall=0
13463       call geom_to_var(nvar,x)
13464       write (iout,*) "split_ene ",split_ene
13465       call flush(iout)
13466       if (.not.split_ene) then
13467         call zerograd
13468         call etotal(energia)
13469         etot=energia(0)
13470         call cartgrad
13471         icall =1
13472         do i=1,nres
13473           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13474         enddo
13475         do j=1,3
13476           grad_s(j,0)=gcart(j,0)
13477         enddo
13478         do i=1,nres
13479           do j=1,3
13480             grad_s(j,i)=gcart(j,i)
13481             grad_s(j+3,i)=gxcart(j,i)
13482         write(iout,*) "before movement analytical gradient"
13483         do i=1,nres
13484           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13485           (gxcart(j,i),j=1,3)
13486         enddo
13487
13488           enddo
13489         enddo
13490       else
13491 !- split gradient check
13492         call zerograd
13493         call etotal_long(energia)
13494 !el        call enerprint(energia)
13495         call cartgrad
13496         icall =1
13497         do i=1,nres
13498           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13499           (gxcart(j,i),j=1,3)
13500         enddo
13501         do j=1,3
13502           grad_s(j,0)=gcart(j,0)
13503         enddo
13504         do i=1,nres
13505           do j=1,3
13506             grad_s(j,i)=gcart(j,i)
13507             grad_s(j+3,i)=gxcart(j,i)
13508           enddo
13509         enddo
13510         call zerograd
13511         call etotal_short(energia)
13512         call enerprint(energia)
13513         call cartgrad
13514         icall =1
13515         do i=1,nres
13516           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13517           (gxcart(j,i),j=1,3)
13518         enddo
13519         do j=1,3
13520           grad_s1(j,0)=gcart(j,0)
13521         enddo
13522         do i=1,nres
13523           do j=1,3
13524             grad_s1(j,i)=gcart(j,i)
13525             grad_s1(j+3,i)=gxcart(j,i)
13526           enddo
13527         enddo
13528       endif
13529       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13530 !      do i=1,nres
13531       do i=nnt,nct
13532         do j=1,3
13533           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
13534           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
13535         ddc(j)=c(j,i)
13536         ddx(j)=c(j,i+nres)
13537           dcnorm_safe1(j)=dc_norm(j,i-1)
13538           dcnorm_safe2(j)=dc_norm(j,i)
13539           dxnorm_safe(j)=dc_norm(j,i+nres)
13540         enddo
13541       do j=1,3
13542         c(j,i)=ddc(j)+aincr
13543           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
13544           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
13545           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13546           dc(j,i)=c(j,i+1)-c(j,i)
13547           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13548           call int_from_cart1(.false.)
13549           if (.not.split_ene) then
13550            call zerograd
13551             call etotal(energia1)
13552             etot1=energia1(0)
13553             write (iout,*) "ij",i,j," etot1",etot1
13554           else
13555 !- split gradient
13556             call etotal_long(energia1)
13557             etot11=energia1(0)
13558             call etotal_short(energia1)
13559             etot12=energia1(0)
13560           endif
13561 !- end split gradient
13562 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13563         c(j,i)=ddc(j)-aincr
13564           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
13565           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
13566           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13567           dc(j,i)=c(j,i+1)-c(j,i)
13568           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13569           call int_from_cart1(.false.)
13570           if (.not.split_ene) then
13571             call zerograd
13572             call etotal(energia1)
13573             etot2=energia1(0)
13574             write (iout,*) "ij",i,j," etot2",etot2
13575           ggg(j)=(etot1-etot2)/(2*aincr)
13576           else
13577 !- split gradient
13578             call etotal_long(energia1)
13579             etot21=energia1(0)
13580           ggg(j)=(etot11-etot21)/(2*aincr)
13581             call etotal_short(energia1)
13582             etot22=energia1(0)
13583           ggg1(j)=(etot12-etot22)/(2*aincr)
13584 !- end split gradient
13585 !            write (iout,*) "etot21",etot21," etot22",etot22
13586           endif
13587 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13588         c(j,i)=ddc(j)
13589           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
13590           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
13591           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13592           dc(j,i)=c(j,i+1)-c(j,i)
13593           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13594           dc_norm(j,i-1)=dcnorm_safe1(j)
13595           dc_norm(j,i)=dcnorm_safe2(j)
13596           dc_norm(j,i+nres)=dxnorm_safe(j)
13597         enddo
13598       do j=1,3
13599         c(j,i+nres)=ddx(j)+aincr
13600           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13601           call int_from_cart1(.false.)
13602           if (.not.split_ene) then
13603             call zerograd
13604             call etotal(energia1)
13605             etot1=energia1(0)
13606           else
13607 !- split gradient
13608             call etotal_long(energia1)
13609             etot11=energia1(0)
13610             call etotal_short(energia1)
13611             etot12=energia1(0)
13612           endif
13613 !- end split gradient
13614         c(j,i+nres)=ddx(j)-aincr
13615           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13616           call int_from_cart1(.false.)
13617           if (.not.split_ene) then
13618            call zerograd
13619            call etotal(energia1)
13620             etot2=energia1(0)
13621           ggg(j+3)=(etot1-etot2)/(2*aincr)
13622           else
13623 !- split gradient
13624             call etotal_long(energia1)
13625             etot21=energia1(0)
13626           ggg(j+3)=(etot11-etot21)/(2*aincr)
13627             call etotal_short(energia1)
13628             etot22=energia1(0)
13629           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13630 !- end split gradient
13631           endif
13632 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13633         c(j,i+nres)=ddx(j)
13634           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13635           dc_norm(j,i+nres)=dxnorm_safe(j)
13636           call int_from_cart1(.false.)
13637         enddo
13638       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13639          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13640         if (split_ene) then
13641           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13642          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13643          k=1,6)
13644          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13645          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13646          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13647         endif
13648       enddo
13649       return
13650       end subroutine check_ecartint
13651 #else
13652 !-----------------------------------------------------------------------------
13653       subroutine check_ecartint
13654 ! Check the gradient of the energy in Cartesian coordinates.
13655       use io_base, only: intout
13656       use MD_data, only: iset
13657 !      implicit real*8 (a-h,o-z)
13658 !      include 'DIMENSIONS'
13659 !      include 'COMMON.CONTROL'
13660 !      include 'COMMON.CHAIN'
13661 !      include 'COMMON.DERIV'
13662 !      include 'COMMON.IOUNITS'
13663 !      include 'COMMON.VAR'
13664 !      include 'COMMON.CONTACTS'
13665 !      include 'COMMON.MD'
13666 !      include 'COMMON.LOCAL'
13667 !      include 'COMMON.SPLITELE'
13668       use comm_srutu
13669 !el      integer :: icall
13670 !el      common /srutu/ icall
13671       real(kind=8),dimension(6) :: ggg,ggg1
13672       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13673       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13674       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
13675       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13676       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13677       real(kind=8),dimension(0:n_ene) :: energia,energia1
13678       integer :: uiparm(1)
13679       real(kind=8) :: urparm(1)
13680 !EL      external fdum
13681       integer :: i,j,k,nf
13682       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13683                    etot21,etot22
13684       r_cut=2.0d0
13685       rlambd=0.3d0
13686       icg=1
13687       nf=0
13688       nfl=0
13689       if (iset.eq.0) iset=1
13690       call intout
13691 !      call intcartderiv
13692 !      call checkintcartgrad
13693       call zerograd
13694       aincr=1.0D-6
13695       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
13696       nf=0
13697       icall=0
13698       call geom_to_var(nvar,x)
13699       if (.not.split_ene) then
13700         call etotal(energia)
13701         etot=energia(0)
13702 !        call enerprint(energia)
13703         call cartgrad
13704         icall =1
13705         do i=1,nres
13706           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13707         enddo
13708         do j=1,3
13709           grad_s(j,0)=gcart(j,0)
13710           grad_s(j+3,0)=gxcart(j,0)
13711         enddo
13712         do i=1,nres
13713           do j=1,3
13714             grad_s(j,i)=gcart(j,i)
13715             grad_s(j+3,i)=gxcart(j,i)
13716           enddo
13717         enddo
13718         write(iout,*) "before movement analytical gradient"
13719         do i=1,nres
13720           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13721           (gxcart(j,i),j=1,3)
13722         enddo
13723
13724       else
13725 !- split gradient check
13726         call zerograd
13727         call etotal_long(energia)
13728 !el        call enerprint(energia)
13729         call cartgrad
13730         icall =1
13731         do i=1,nres
13732           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13733           (gxcart(j,i),j=1,3)
13734         enddo
13735         do j=1,3
13736           grad_s(j,0)=gcart(j,0)
13737         enddo
13738         do i=1,nres
13739           do j=1,3
13740             grad_s(j,i)=gcart(j,i)
13741 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
13742             grad_s(j+3,i)=gxcart(j,i)
13743           enddo
13744         enddo
13745         call zerograd
13746         call etotal_short(energia)
13747 !el        call enerprint(energia)
13748         call cartgrad
13749         icall =1
13750         do i=1,nres
13751           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13752           (gxcart(j,i),j=1,3)
13753         enddo
13754         do j=1,3
13755           grad_s1(j,0)=gcart(j,0)
13756         enddo
13757         do i=1,nres
13758           do j=1,3
13759             grad_s1(j,i)=gcart(j,i)
13760             grad_s1(j+3,i)=gxcart(j,i)
13761           enddo
13762         enddo
13763       endif
13764       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13765       do i=0,nres
13766         do j=1,3
13767         xx(j)=c(j,i+nres)
13768         ddc(j)=dc(j,i)
13769         ddx(j)=dc(j,i+nres)
13770           do k=1,3
13771             dcnorm_safe(k)=dc_norm(k,i)
13772             dxnorm_safe(k)=dc_norm(k,i+nres)
13773           enddo
13774         enddo
13775       do j=1,3
13776         dc(j,i)=ddc(j)+aincr
13777           call chainbuild_cart
13778 #ifdef MPI
13779 ! Broadcast the order to compute internal coordinates to the slaves.
13780 !          if (nfgtasks.gt.1)
13781 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
13782 #endif
13783 !          call int_from_cart1(.false.)
13784           if (.not.split_ene) then
13785            call zerograd
13786             call etotal(energia1)
13787             etot1=energia1(0)
13788 !            call enerprint(energia1)
13789           else
13790 !- split gradient
13791             call etotal_long(energia1)
13792             etot11=energia1(0)
13793             call etotal_short(energia1)
13794             etot12=energia1(0)
13795 !            write (iout,*) "etot11",etot11," etot12",etot12
13796           endif
13797 !- end split gradient
13798 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13799         dc(j,i)=ddc(j)-aincr
13800           call chainbuild_cart
13801 !          call int_from_cart1(.false.)
13802           if (.not.split_ene) then
13803                   call zerograd
13804             call etotal(energia1)
13805 !            call enerprint(energia1)
13806             etot2=energia1(0)
13807           ggg(j)=(etot1-etot2)/(2*aincr)
13808           else
13809 !- split gradient
13810             call etotal_long(energia1)
13811             etot21=energia1(0)
13812           ggg(j)=(etot11-etot21)/(2*aincr)
13813             call etotal_short(energia1)
13814             etot22=energia1(0)
13815           ggg1(j)=(etot12-etot22)/(2*aincr)
13816 !- end split gradient
13817 !            write (iout,*) "etot21",etot21," etot22",etot22
13818           endif
13819 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13820         dc(j,i)=ddc(j)
13821           call chainbuild_cart
13822         enddo
13823       do j=1,3
13824         dc(j,i+nres)=ddx(j)+aincr
13825           call chainbuild_cart
13826 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
13827 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13828 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13829 !          write (iout,*) "dxnormnorm",dsqrt(
13830 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13831 !          write (iout,*) "dxnormnormsafe",dsqrt(
13832 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13833 !          write (iout,*)
13834           if (.not.split_ene) then
13835             call zerograd
13836             call etotal(energia1)
13837 !            call enerprint(energia1)
13838             etot1=energia1(0)
13839 !            print *,"ene",energia1(0),energia1(57)
13840           else
13841 !- split gradient
13842             call etotal_long(energia1)
13843             etot11=energia1(0)
13844             call etotal_short(energia1)
13845             etot12=energia1(0)
13846           endif
13847 !- end split gradient
13848 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13849         dc(j,i+nres)=ddx(j)-aincr
13850           call chainbuild_cart
13851 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13852 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13853 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13854 !          write (iout,*)
13855 !          write (iout,*) "dxnormnorm",dsqrt(
13856 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13857 !          write (iout,*) "dxnormnormsafe",dsqrt(
13858 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13859           if (.not.split_ene) then
13860             call zerograd
13861             call etotal(energia1)
13862             etot2=energia1(0)
13863 !            call enerprint(energia1)
13864 !            print *,"ene",energia1(0),energia1(57)
13865           ggg(j+3)=(etot1-etot2)/(2*aincr)
13866           else
13867 !- split gradient
13868             call etotal_long(energia1)
13869             etot21=energia1(0)
13870           ggg(j+3)=(etot11-etot21)/(2*aincr)
13871             call etotal_short(energia1)
13872             etot22=energia1(0)
13873           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13874 !- end split gradient
13875           endif
13876 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13877         dc(j,i+nres)=ddx(j)
13878           call chainbuild_cart
13879         enddo
13880       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13881          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13882         if (split_ene) then
13883           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13884          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13885          k=1,6)
13886          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13887          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13888          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13889         endif
13890       enddo
13891       return
13892       end subroutine check_ecartint
13893 #endif
13894 !-----------------------------------------------------------------------------
13895       subroutine check_eint
13896 ! Check the gradient of energy in internal coordinates.
13897 !      implicit real(kind=8) (a-h,o-z)
13898 !      include 'DIMENSIONS'
13899 !      include 'COMMON.CHAIN'
13900 !      include 'COMMON.DERIV'
13901 !      include 'COMMON.IOUNITS'
13902 !      include 'COMMON.VAR'
13903 !      include 'COMMON.GEO'
13904       use comm_srutu
13905 !el      integer :: icall
13906 !el      common /srutu/ icall
13907       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
13908       integer :: uiparm(1)
13909       real(kind=8) :: urparm(1)
13910       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
13911       character(len=6) :: key
13912 !EL      external fdum
13913       integer :: i,ii,nf
13914       real(kind=8) :: xi,aincr,etot,etot1,etot2
13915       call zerograd
13916       aincr=1.0D-7
13917       print '(a)','Calling CHECK_INT.'
13918       nf=0
13919       nfl=0
13920       icg=1
13921       call geom_to_var(nvar,x)
13922       call var_to_geom(nvar,x)
13923       call chainbuild
13924       icall=1
13925 !      print *,'ICG=',ICG
13926       call etotal(energia)
13927       etot = energia(0)
13928 !el      call enerprint(energia)
13929 !      print *,'ICG=',ICG
13930 #ifdef MPL
13931       if (MyID.ne.BossID) then
13932         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
13933         nf=x(nvar+1)
13934         nfl=x(nvar+2)
13935         icg=x(nvar+3)
13936       endif
13937 #endif
13938       nf=1
13939       nfl=3
13940 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13941       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13942 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13943       icall=1
13944       do i=1,nvar
13945         xi=x(i)
13946         x(i)=xi-0.5D0*aincr
13947         call var_to_geom(nvar,x)
13948         call chainbuild
13949         call etotal(energia1)
13950         etot1=energia1(0)
13951         x(i)=xi+0.5D0*aincr
13952         call var_to_geom(nvar,x)
13953         call chainbuild
13954         call etotal(energia2)
13955         etot2=energia2(0)
13956         gg(i)=(etot2-etot1)/aincr
13957         write (iout,*) i,etot1,etot2
13958         x(i)=xi
13959       enddo
13960       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13961           '     RelDiff*100% '
13962       do i=1,nvar
13963         if (i.le.nphi) then
13964           ii=i
13965           key = ' phi'
13966         else if (i.le.nphi+ntheta) then
13967           ii=i-nphi
13968           key=' theta'
13969         else if (i.le.nphi+ntheta+nside) then
13970            ii=i-(nphi+ntheta)
13971            key=' alpha'
13972         else
13973            ii=i-(nphi+ntheta+nside)
13974            key=' omega'
13975         endif
13976         write (iout,'(i3,a,i3,3(1pd16.6))') &
13977        i,key,ii,gg(i),gana(i),&
13978        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13979       enddo
13980       return
13981       end subroutine check_eint
13982 !-----------------------------------------------------------------------------
13983 ! econstr_local.F
13984 !-----------------------------------------------------------------------------
13985       subroutine Econstr_back
13986 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13987 !      implicit real(kind=8) (a-h,o-z)
13988 !      include 'DIMENSIONS'
13989 !      include 'COMMON.CONTROL'
13990 !      include 'COMMON.VAR'
13991 !      include 'COMMON.MD'
13992       use MD_data
13993 !#ifndef LANG0
13994 !      include 'COMMON.LANGEVIN'
13995 !#else
13996 !      include 'COMMON.LANGEVIN.lang0'
13997 !#endif
13998 !      include 'COMMON.CHAIN'
13999 !      include 'COMMON.DERIV'
14000 !      include 'COMMON.GEO'
14001 !      include 'COMMON.LOCAL'
14002 !      include 'COMMON.INTERACT'
14003 !      include 'COMMON.IOUNITS'
14004 !      include 'COMMON.NAMES'
14005 !      include 'COMMON.TIME1'
14006       integer :: i,j,ii,k
14007       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
14008
14009       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
14010       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
14011       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
14012
14013       Uconst_back=0.0d0
14014       do i=1,nres
14015         dutheta(i)=0.0d0
14016         dugamma(i)=0.0d0
14017         do j=1,3
14018           duscdiff(j,i)=0.0d0
14019           duscdiffx(j,i)=0.0d0
14020         enddo
14021       enddo
14022       do i=1,nfrag_back
14023         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
14024 !
14025 ! Deviations from theta angles
14026 !
14027         utheta_i=0.0d0
14028         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
14029           dtheta_i=theta(j)-thetaref(j)
14030           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
14031           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
14032         enddo
14033         utheta(i)=utheta_i/(ii-1)
14034 !
14035 ! Deviations from gamma angles
14036 !
14037         ugamma_i=0.0d0
14038         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
14039           dgamma_i=pinorm(phi(j)-phiref(j))
14040 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
14041           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
14042           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
14043 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
14044         enddo
14045         ugamma(i)=ugamma_i/(ii-2)
14046 !
14047 ! Deviations from local SC geometry
14048 !
14049         uscdiff(i)=0.0d0
14050         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
14051           dxx=xxtab(j)-xxref(j)
14052           dyy=yytab(j)-yyref(j)
14053           dzz=zztab(j)-zzref(j)
14054           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
14055           do k=1,3
14056             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
14057              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
14058              (ii-1)
14059             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
14060              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
14061              (ii-1)
14062             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
14063            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
14064             /(ii-1)
14065           enddo
14066 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
14067 !     &      xxref(j),yyref(j),zzref(j)
14068         enddo
14069         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
14070 !        write (iout,*) i," uscdiff",uscdiff(i)
14071 !
14072 ! Put together deviations from local geometry
14073 !
14074         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
14075           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
14076 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
14077 !     &   " uconst_back",uconst_back
14078         utheta(i)=dsqrt(utheta(i))
14079         ugamma(i)=dsqrt(ugamma(i))
14080         uscdiff(i)=dsqrt(uscdiff(i))
14081       enddo
14082       return
14083       end subroutine Econstr_back
14084 !-----------------------------------------------------------------------------
14085 ! energy_p_new-sep_barrier.F
14086 !-----------------------------------------------------------------------------
14087       real(kind=8) function sscale(r)
14088 !      include "COMMON.SPLITELE"
14089       real(kind=8) :: r,gamm
14090       if(r.lt.r_cut-rlamb) then
14091         sscale=1.0d0
14092       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
14093         gamm=(r-(r_cut-rlamb))/rlamb
14094         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14095       else
14096         sscale=0d0
14097       endif
14098       return
14099       end function sscale
14100       real(kind=8) function sscale_grad(r)
14101 !      include "COMMON.SPLITELE"
14102       real(kind=8) :: r,gamm
14103       if(r.lt.r_cut-rlamb) then
14104         sscale_grad=0.0d0
14105       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
14106         gamm=(r-(r_cut-rlamb))/rlamb
14107         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
14108       else
14109         sscale_grad=0d0
14110       endif
14111       return
14112       end function sscale_grad
14113 !SCALINING MARTINI
14114       real(kind=8) function sscale_martini(r)
14115 !      include "COMMON.SPLITELE"
14116       real(kind=8) :: r,gamm
14117 !      print *,"here2",r_cut_mart,r
14118       if(r.lt.r_cut_mart-rlamb_mart) then
14119         sscale_martini=1.0d0
14120       else if(r.le.r_cut_mart.and.r.ge.r_cut_mart-rlamb_mart) then
14121         gamm=(r-(r_cut_mart-rlamb_mart))/rlamb_mart
14122         sscale_martini=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14123       else
14124         sscale_martini=0.0d0
14125       endif
14126       return
14127       end function sscale_martini
14128       real(kind=8) function sscale_grad_martini(r)
14129 !      include "COMMON.SPLITELE"
14130       real(kind=8) :: r,gamm
14131       if(r.lt.r_cut_mart-rlamb_mart) then
14132         sscale_grad_martini=0.0d0
14133       else if(r.le.r_cut_mart.and.r.ge.r_cut_mart-rlamb_mart) then
14134         gamm=(r-(r_cut_mart-rlamb_mart))/rlamb_mart
14135         sscale_grad_martini=gamm*(6*gamm-6.0d0)/rlamb_mart
14136       else
14137         sscale_grad_martini=0.0d0
14138       endif
14139       return
14140       end function sscale_grad_martini
14141       real(kind=8) function sscale_martini_angle(r)
14142 !      include "COMMON.SPLITELE"
14143       real(kind=8) :: r,gamm,r_cut_angle,rlamb_angle
14144 !      print *,"here2",r_cut_angle,r
14145        r_cut_angle=3.12d0
14146        rlamb_angle=0.1d0
14147       if(r.lt.r_cut_angle-rlamb_angle) then
14148         sscale_martini_angle=1.0d0
14149       else if(r.le.r_cut_angle.and.r.ge.r_cut_angle-rlamb_angle) then
14150         gamm=(r-(r_cut_angle-rlamb_angle))/rlamb_angle
14151         sscale_martini_angle=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14152       else
14153         sscale_martini_angle=0.0d0
14154       endif
14155       return
14156       end function sscale_martini_angle
14157       real(kind=8) function sscale_grad_martini_angle(r)
14158 !      include "COMMON.SPLITELE"
14159       real(kind=8) :: r,gamm,r_cut_angle,rlamb_angle
14160        r_cut_angle=3.12d0
14161        rlamb_angle=0.1d0
14162       if(r.lt.r_cut_angle-rlamb_angle) then
14163         sscale_grad_martini_angle=0.0d0
14164       else if(r.le.r_cut_angle.and.r.ge.r_cut_angle-rlamb_angle) then
14165         gamm=(r-(r_cut_angle-rlamb_angle))/rlamb_angle
14166         sscale_grad_martini_angle=gamm*(6*gamm-6.0d0)/rlamb_angle
14167       else
14168         sscale_grad_martini_angle=0.0d0
14169       endif
14170       return
14171       end function sscale_grad_martini_angle
14172
14173
14174 !!!!!!!!!! PBCSCALE
14175       real(kind=8) function sscale_ele(r)
14176 !      include "COMMON.SPLITELE"
14177       real(kind=8) :: r,gamm
14178       if(r.lt.r_cut_ele-rlamb_ele) then
14179         sscale_ele=1.0d0
14180       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
14181         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
14182         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14183       else
14184         sscale_ele=0d0
14185       endif
14186       return
14187       end function sscale_ele
14188
14189       real(kind=8)  function sscagrad_ele(r)
14190       real(kind=8) :: r,gamm
14191 !      include "COMMON.SPLITELE"
14192       if(r.lt.r_cut_ele-rlamb_ele) then
14193         sscagrad_ele=0.0d0
14194       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
14195         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
14196         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
14197       else
14198         sscagrad_ele=0.0d0
14199       endif
14200       return
14201       end function sscagrad_ele
14202 !!!!!!!!!! PBCSCALE
14203       real(kind=8) function sscale2(r,r_cc,r_ll)
14204 !      include "COMMON.SPLITELE"
14205       real(kind=8) :: r,gamm,r_cc,r_ll
14206       if(r.lt.r_cc-r_ll) then
14207         sscale2=1.0d0
14208       else if(r.le.r_cc.and.r.ge.r_cc-r_ll) then
14209         gamm=(r-(r_cc-r_ll))/r_ll
14210         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
14211       else
14212         sscale2=0d0
14213       endif
14214       return
14215       end function sscale2
14216
14217       real(kind=8)  function sscagrad2(r,r_cc,r_ll)
14218       real(kind=8) :: r,gamm,r_cc,r_ll
14219 !      include "COMMON.SPLITELE"
14220       if(r.lt.r_cc-r_ll) then
14221         sscagrad2=0.0d0
14222       else if(r.le.r_cc.and.r.ge.r_cc-r_ll) then
14223         gamm=(r-(r_cc-r_ll))/r_ll
14224         sscagrad2=gamm*(6*gamm-6.0d0)/r_ll
14225       else
14226         sscagrad2=0.0d0
14227       endif
14228       return
14229       end function sscagrad2
14230
14231       real(kind=8) function sscalelip(r)
14232       real(kind=8) r,gamm
14233         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
14234       return
14235       end function sscalelip
14236 !C-----------------------------------------------------------------------
14237       real(kind=8) function sscagradlip(r)
14238       real(kind=8) r,gamm
14239         sscagradlip=r*(6.0d0*r-6.0d0)
14240       return
14241       end function sscagradlip
14242
14243 !!!!!!!!!!!!!!!
14244 !-----------------------------------------------------------------------------
14245       subroutine elj_long(evdw)
14246 !
14247 ! This subroutine calculates the interaction energy of nonbonded side chains
14248 ! assuming the LJ potential of interaction.
14249 !
14250 !      implicit real(kind=8) (a-h,o-z)
14251 !      include 'DIMENSIONS'
14252 !      include 'COMMON.GEO'
14253 !      include 'COMMON.VAR'
14254 !      include 'COMMON.LOCAL'
14255 !      include 'COMMON.CHAIN'
14256 !      include 'COMMON.DERIV'
14257 !      include 'COMMON.INTERACT'
14258 !      include 'COMMON.TORSION'
14259 !      include 'COMMON.SBRIDGE'
14260 !      include 'COMMON.NAMES'
14261 !      include 'COMMON.IOUNITS'
14262 !      include 'COMMON.CONTACTS'
14263       real(kind=8),parameter :: accur=1.0d-10
14264       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14265 !el local variables
14266       integer :: i,iint,j,k,itypi,itypi1,itypj
14267       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
14268       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
14269                       sslipj,ssgradlipj,aa,bb
14270 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
14271       evdw=0.0D0
14272       do i=iatsc_s,iatsc_e
14273         itypi=itype(i,1)
14274         if (itypi.eq.ntyp1) cycle
14275         itypi1=itype(i+1,1)
14276         xi=c(1,nres+i)
14277         yi=c(2,nres+i)
14278         zi=c(3,nres+i)
14279         call to_box(xi,yi,zi)
14280         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14281 !
14282 ! Calculate SC interaction energy.
14283 !
14284         do iint=1,nint_gr(i)
14285 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
14286 !d   &                  'iend=',iend(i,iint)
14287           do j=istart(i,iint),iend(i,iint)
14288             itypj=itype(j,1)
14289             if (itypj.eq.ntyp1) cycle
14290             xj=c(1,nres+j)-xi
14291             yj=c(2,nres+j)-yi
14292             zj=c(3,nres+j)-zi
14293             call to_box(xj,yj,zj)
14294             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14295             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14296              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14297             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14298              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14299             xj=boxshift(xj-xi,boxxsize)
14300             yj=boxshift(yj-yi,boxysize)
14301             zj=boxshift(zj-zi,boxzsize)
14302             rij=xj*xj+yj*yj+zj*zj
14303             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
14304             if (sss.lt.1.0d0) then
14305               rrij=1.0D0/rij
14306               eps0ij=eps(itypi,itypj)
14307               fac=rrij**expon2
14308               e1=fac*fac*aa_aq(itypi,itypj)
14309               e2=fac*bb_aq(itypi,itypj)
14310               evdwij=e1+e2
14311               evdw=evdw+(1.0d0-sss)*evdwij
14312 !
14313 ! Calculate the components of the gradient in DC and X
14314 !
14315               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
14316               gg(1)=xj*fac
14317               gg(2)=yj*fac
14318               gg(3)=zj*fac
14319               do k=1,3
14320                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14321                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14322                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14323                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14324               enddo
14325             endif
14326           enddo      ! j
14327         enddo        ! iint
14328       enddo          ! i
14329       do i=1,nct
14330         do j=1,3
14331           gvdwc(j,i)=expon*gvdwc(j,i)
14332           gvdwx(j,i)=expon*gvdwx(j,i)
14333         enddo
14334       enddo
14335 !******************************************************************************
14336 !
14337 !                              N O T E !!!
14338 !
14339 ! To save time, the factor of EXPON has been extracted from ALL components
14340 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14341 ! use!
14342 !
14343 !******************************************************************************
14344       return
14345       end subroutine elj_long
14346 !-----------------------------------------------------------------------------
14347       subroutine elj_short(evdw)
14348 !
14349 ! This subroutine calculates the interaction energy of nonbonded side chains
14350 ! assuming the LJ potential of interaction.
14351 !
14352 !      implicit real(kind=8) (a-h,o-z)
14353 !      include 'DIMENSIONS'
14354 !      include 'COMMON.GEO'
14355 !      include 'COMMON.VAR'
14356 !      include 'COMMON.LOCAL'
14357 !      include 'COMMON.CHAIN'
14358 !      include 'COMMON.DERIV'
14359 !      include 'COMMON.INTERACT'
14360 !      include 'COMMON.TORSION'
14361 !      include 'COMMON.SBRIDGE'
14362 !      include 'COMMON.NAMES'
14363 !      include 'COMMON.IOUNITS'
14364 !      include 'COMMON.CONTACTS'
14365       real(kind=8),parameter :: accur=1.0d-10
14366       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14367 !el local variables
14368       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
14369       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
14370       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
14371                       sslipj,ssgradlipj
14372 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
14373       evdw=0.0D0
14374       do i=iatsc_s,iatsc_e
14375         itypi=itype(i,1)
14376         if (itypi.eq.ntyp1) cycle
14377         itypi1=itype(i+1,1)
14378         xi=c(1,nres+i)
14379         yi=c(2,nres+i)
14380         zi=c(3,nres+i)
14381         call to_box(xi,yi,zi)
14382         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14383 ! Change 12/1/95
14384         num_conti=0
14385 !
14386 ! Calculate SC interaction energy.
14387 !
14388         do iint=1,nint_gr(i)
14389 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
14390 !d   &                  'iend=',iend(i,iint)
14391           do j=istart(i,iint),iend(i,iint)
14392             itypj=itype(j,1)
14393             if (itypj.eq.ntyp1) cycle
14394             xj=c(1,nres+j)-xi
14395             yj=c(2,nres+j)-yi
14396             zj=c(3,nres+j)-zi
14397 ! Change 12/1/95 to calculate four-body interactions
14398             rij=xj*xj+yj*yj+zj*zj
14399             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
14400             if (sss.gt.0.0d0) then
14401               rrij=1.0D0/rij
14402               eps0ij=eps(itypi,itypj)
14403               fac=rrij**expon2
14404               e1=fac*fac*aa_aq(itypi,itypj)
14405               e2=fac*bb_aq(itypi,itypj)
14406               evdwij=e1+e2
14407               evdw=evdw+sss*evdwij
14408 !
14409 ! Calculate the components of the gradient in DC and X
14410 !
14411               fac=-rrij*(e1+evdwij)*sss
14412               gg(1)=xj*fac
14413               gg(2)=yj*fac
14414               gg(3)=zj*fac
14415               do k=1,3
14416                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14417                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14418                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14419                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14420               enddo
14421             endif
14422           enddo      ! j
14423         enddo        ! iint
14424       enddo          ! i
14425       do i=1,nct
14426         do j=1,3
14427           gvdwc(j,i)=expon*gvdwc(j,i)
14428           gvdwx(j,i)=expon*gvdwx(j,i)
14429         enddo
14430       enddo
14431 !******************************************************************************
14432 !
14433 !                              N O T E !!!
14434 !
14435 ! To save time, the factor of EXPON has been extracted from ALL components
14436 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14437 ! use!
14438 !
14439 !******************************************************************************
14440       return
14441       end subroutine elj_short
14442 !-----------------------------------------------------------------------------
14443       subroutine eljk_long(evdw)
14444 !
14445 ! This subroutine calculates the interaction energy of nonbonded side chains
14446 ! assuming the LJK potential of interaction.
14447 !
14448 !      implicit real(kind=8) (a-h,o-z)
14449 !      include 'DIMENSIONS'
14450 !      include 'COMMON.GEO'
14451 !      include 'COMMON.VAR'
14452 !      include 'COMMON.LOCAL'
14453 !      include 'COMMON.CHAIN'
14454 !      include 'COMMON.DERIV'
14455 !      include 'COMMON.INTERACT'
14456 !      include 'COMMON.IOUNITS'
14457 !      include 'COMMON.NAMES'
14458       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14459       logical :: scheck
14460 !el local variables
14461       integer :: i,iint,j,k,itypi,itypi1,itypj
14462       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14463                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
14464 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14465       evdw=0.0D0
14466       do i=iatsc_s,iatsc_e
14467         itypi=itype(i,1)
14468         if (itypi.eq.ntyp1) cycle
14469         itypi1=itype(i+1,1)
14470         xi=c(1,nres+i)
14471         yi=c(2,nres+i)
14472         zi=c(3,nres+i)
14473           call to_box(xi,yi,zi)
14474
14475 !
14476 ! Calculate SC interaction energy.
14477 !
14478         do iint=1,nint_gr(i)
14479           do j=istart(i,iint),iend(i,iint)
14480             itypj=itype(j,1)
14481             if (itypj.eq.ntyp1) cycle
14482             xj=c(1,nres+j)-xi
14483             yj=c(2,nres+j)-yi
14484             zj=c(3,nres+j)-zi
14485           call to_box(xj,yj,zj)
14486       xj=boxshift(xj-xi,boxxsize)
14487       yj=boxshift(yj-yi,boxysize)
14488       zj=boxshift(zj-zi,boxzsize)
14489
14490             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14491             fac_augm=rrij**expon
14492             e_augm=augm(itypi,itypj)*fac_augm
14493             r_inv_ij=dsqrt(rrij)
14494             rij=1.0D0/r_inv_ij
14495             sss=sscale(rij/sigma(itypi,itypj))
14496             if (sss.lt.1.0d0) then
14497               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14498               fac=r_shift_inv**expon
14499               e1=fac*fac*aa_aq(itypi,itypj)
14500               e2=fac*bb_aq(itypi,itypj)
14501               evdwij=e_augm+e1+e2
14502 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14503 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14504 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14505 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14506 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14507 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14508 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14509               evdw=evdw+(1.0d0-sss)*evdwij
14510 !
14511 ! Calculate the components of the gradient in DC and X
14512 !
14513               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14514               fac=fac*(1.0d0-sss)
14515               gg(1)=xj*fac
14516               gg(2)=yj*fac
14517               gg(3)=zj*fac
14518               do k=1,3
14519                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14520                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14521                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14522                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14523               enddo
14524             endif
14525           enddo      ! j
14526         enddo        ! iint
14527       enddo          ! i
14528       do i=1,nct
14529         do j=1,3
14530           gvdwc(j,i)=expon*gvdwc(j,i)
14531           gvdwx(j,i)=expon*gvdwx(j,i)
14532         enddo
14533       enddo
14534       return
14535       end subroutine eljk_long
14536 !-----------------------------------------------------------------------------
14537       subroutine eljk_short(evdw)
14538 !
14539 ! This subroutine calculates the interaction energy of nonbonded side chains
14540 ! assuming the LJK potential of interaction.
14541 !
14542 !      implicit real(kind=8) (a-h,o-z)
14543 !      include 'DIMENSIONS'
14544 !      include 'COMMON.GEO'
14545 !      include 'COMMON.VAR'
14546 !      include 'COMMON.LOCAL'
14547 !      include 'COMMON.CHAIN'
14548 !      include 'COMMON.DERIV'
14549 !      include 'COMMON.INTERACT'
14550 !      include 'COMMON.IOUNITS'
14551 !      include 'COMMON.NAMES'
14552       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14553       logical :: scheck
14554 !el local variables
14555       integer :: i,iint,j,k,itypi,itypi1,itypj
14556       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14557                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
14558                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14559 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14560       evdw=0.0D0
14561       do i=iatsc_s,iatsc_e
14562         itypi=itype(i,1)
14563         if (itypi.eq.ntyp1) cycle
14564         itypi1=itype(i+1,1)
14565         xi=c(1,nres+i)
14566         yi=c(2,nres+i)
14567         zi=c(3,nres+i)
14568         call to_box(xi,yi,zi)
14569         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14570 !
14571 ! Calculate SC interaction energy.
14572 !
14573         do iint=1,nint_gr(i)
14574           do j=istart(i,iint),iend(i,iint)
14575             itypj=itype(j,1)
14576             if (itypj.eq.ntyp1) cycle
14577             xj=c(1,nres+j)-xi
14578             yj=c(2,nres+j)-yi
14579             zj=c(3,nres+j)-zi
14580             call to_box(xj,yj,zj)
14581             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14582             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14583              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14584             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14585              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14586             xj=boxshift(xj-xi,boxxsize)
14587             yj=boxshift(yj-yi,boxysize)
14588             zj=boxshift(zj-zi,boxzsize)
14589             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14590             fac_augm=rrij**expon
14591             e_augm=augm(itypi,itypj)*fac_augm
14592             r_inv_ij=dsqrt(rrij)
14593             rij=1.0D0/r_inv_ij
14594             sss=sscale(rij/sigma(itypi,itypj))
14595             if (sss.gt.0.0d0) then
14596               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14597               fac=r_shift_inv**expon
14598               e1=fac*fac*aa_aq(itypi,itypj)
14599               e2=fac*bb_aq(itypi,itypj)
14600               evdwij=e_augm+e1+e2
14601 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14602 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14603 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14604 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14605 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14606 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14607 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14608               evdw=evdw+sss*evdwij
14609 !
14610 ! Calculate the components of the gradient in DC and X
14611 !
14612               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14613               fac=fac*sss
14614               gg(1)=xj*fac
14615               gg(2)=yj*fac
14616               gg(3)=zj*fac
14617               do k=1,3
14618                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14619                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14620                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14621                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14622               enddo
14623             endif
14624           enddo      ! j
14625         enddo        ! iint
14626       enddo          ! i
14627       do i=1,nct
14628         do j=1,3
14629           gvdwc(j,i)=expon*gvdwc(j,i)
14630           gvdwx(j,i)=expon*gvdwx(j,i)
14631         enddo
14632       enddo
14633       return
14634       end subroutine eljk_short
14635 !-----------------------------------------------------------------------------
14636        subroutine ebp_long(evdw)
14637 ! This subroutine calculates the interaction energy of nonbonded side chains
14638 ! assuming the Berne-Pechukas potential of interaction.
14639 !
14640        use calc_data
14641 !      implicit real(kind=8) (a-h,o-z)
14642 !      include 'DIMENSIONS'
14643 !      include 'COMMON.GEO'
14644 !      include 'COMMON.VAR'
14645 !      include 'COMMON.LOCAL'
14646 !      include 'COMMON.CHAIN'
14647 !      include 'COMMON.DERIV'
14648 !      include 'COMMON.NAMES'
14649 !      include 'COMMON.INTERACT'
14650 !      include 'COMMON.IOUNITS'
14651 !      include 'COMMON.CALC'
14652        use comm_srutu
14653 !el      integer :: icall
14654 !el      common /srutu/ icall
14655 !     double precision rrsave(maxdim)
14656         logical :: lprn
14657 !el local variables
14658         integer :: iint,itypi,itypi1,itypj
14659         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
14660                         sslipj,ssgradlipj,aa,bb
14661         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
14662         evdw=0.0D0
14663 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14664         evdw=0.0D0
14665 !     if (icall.eq.0) then
14666 !       lprn=.true.
14667 !     else
14668       lprn=.false.
14669 !     endif
14670 !el      ind=0
14671       do i=iatsc_s,iatsc_e
14672       itypi=itype(i,1)
14673       if (itypi.eq.ntyp1) cycle
14674       itypi1=itype(i+1,1)
14675       xi=c(1,nres+i)
14676       yi=c(2,nres+i)
14677       zi=c(3,nres+i)
14678         call to_box(xi,yi,zi)
14679         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14680       dxi=dc_norm(1,nres+i)
14681       dyi=dc_norm(2,nres+i)
14682       dzi=dc_norm(3,nres+i)
14683 !        dsci_inv=dsc_inv(itypi)
14684       dsci_inv=vbld_inv(i+nres)
14685 !
14686 ! Calculate SC interaction energy.
14687 !
14688       do iint=1,nint_gr(i)
14689       do j=istart(i,iint),iend(i,iint)
14690 !el            ind=ind+1
14691       itypj=itype(j,1)
14692       if (itypj.eq.ntyp1) cycle
14693 !            dscj_inv=dsc_inv(itypj)
14694       dscj_inv=vbld_inv(j+nres)
14695 !chi1=chi(itypi,itypj)
14696 !chi2=chi(itypj,itypi)
14697 !chi12=chi1*chi2
14698 !chip1=chip(itypi)
14699       alf1=alp(itypi)
14700       alf2=alp(itypj)
14701       alf12=0.5D0*(alf1+alf2)
14702         xj=c(1,nres+j)-xi
14703         yj=c(2,nres+j)-yi
14704         zj=c(3,nres+j)-zi
14705             call to_box(xj,yj,zj)
14706             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14707             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14708              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14709             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14710              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14711             xj=boxshift(xj-xi,boxxsize)
14712             yj=boxshift(yj-yi,boxysize)
14713             zj=boxshift(zj-zi,boxzsize)
14714         dxj=dc_norm(1,nres+j)
14715         dyj=dc_norm(2,nres+j)
14716         dzj=dc_norm(3,nres+j)
14717         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14718         rij=dsqrt(rrij)
14719       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14720
14721         if (sss.lt.1.0d0) then
14722
14723         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14724         call sc_angular
14725         ! Calculate whole angle-dependent part of epsilon and contributions
14726         ! to its derivatives
14727         fac=(rrij*sigsq)**expon2
14728         e1=fac*fac*aa_aq(itypi,itypj)
14729         e2=fac*bb_aq(itypi,itypj)
14730       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14731         eps2der=evdwij*eps3rt
14732         eps3der=evdwij*eps2rt
14733         evdwij=evdwij*eps2rt*eps3rt
14734       evdw=evdw+evdwij*(1.0d0-sss)
14735         if (lprn) then
14736         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14737       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14738         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14739         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14740         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14741         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14742         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14743         !d     &          evdwij
14744         endif
14745         ! Calculate gradient components.
14746         e1=e1*eps1*eps2rt**2*eps3rt**2
14747       fac=-expon*(e1+evdwij)
14748         sigder=fac/sigsq
14749         fac=rrij*fac
14750         ! Calculate radial part of the gradient
14751         gg(1)=xj*fac
14752         gg(2)=yj*fac
14753         gg(3)=zj*fac
14754         ! Calculate the angular part of the gradient and sum add the contributions
14755         ! to the appropriate components of the Cartesian gradient.
14756       call sc_grad_scale(1.0d0-sss)
14757         endif
14758         enddo      ! j
14759         enddo        ! iint
14760         enddo          ! i
14761         !     stop
14762         return
14763         end subroutine ebp_long
14764         !-----------------------------------------------------------------------------
14765       subroutine ebp_short(evdw)
14766         !
14767         ! This subroutine calculates the interaction energy of nonbonded side chains
14768         ! assuming the Berne-Pechukas potential of interaction.
14769         !
14770         use calc_data
14771 !      implicit real(kind=8) (a-h,o-z)
14772         !      include 'DIMENSIONS'
14773         !      include 'COMMON.GEO'
14774         !      include 'COMMON.VAR'
14775         !      include 'COMMON.LOCAL'
14776         !      include 'COMMON.CHAIN'
14777         !      include 'COMMON.DERIV'
14778         !      include 'COMMON.NAMES'
14779         !      include 'COMMON.INTERACT'
14780         !      include 'COMMON.IOUNITS'
14781         !      include 'COMMON.CALC'
14782         use comm_srutu
14783         !el      integer :: icall
14784         !el      common /srutu/ icall
14785 !     double precision rrsave(maxdim)
14786         logical :: lprn
14787         !el local variables
14788         integer :: iint,itypi,itypi1,itypj
14789         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
14790         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
14791         sslipi,ssgradlipi,sslipj,ssgradlipj
14792         evdw=0.0D0
14793         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14794         evdw=0.0D0
14795         !     if (icall.eq.0) then
14796         !       lprn=.true.
14797         !     else
14798         lprn=.false.
14799         !     endif
14800         !el      ind=0
14801         do i=iatsc_s,iatsc_e
14802       itypi=itype(i,1)
14803         if (itypi.eq.ntyp1) cycle
14804         itypi1=itype(i+1,1)
14805         xi=c(1,nres+i)
14806         yi=c(2,nres+i)
14807         zi=c(3,nres+i)
14808         call to_box(xi,yi,zi)
14809       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14810
14811         dxi=dc_norm(1,nres+i)
14812         dyi=dc_norm(2,nres+i)
14813         dzi=dc_norm(3,nres+i)
14814         !        dsci_inv=dsc_inv(itypi)
14815       dsci_inv=vbld_inv(i+nres)
14816         !
14817         ! Calculate SC interaction energy.
14818         !
14819         do iint=1,nint_gr(i)
14820       do j=istart(i,iint),iend(i,iint)
14821         !el            ind=ind+1
14822       itypj=itype(j,1)
14823         if (itypj.eq.ntyp1) cycle
14824         !            dscj_inv=dsc_inv(itypj)
14825         dscj_inv=vbld_inv(j+nres)
14826         chi1=chi(itypi,itypj)
14827       chi2=chi(itypj,itypi)
14828         chi12=chi1*chi2
14829         chip1=chip(itypi)
14830       chip2=chip(itypj)
14831         chip12=chip1*chip2
14832         alf1=alp(itypi)
14833         alf2=alp(itypj)
14834       alf12=0.5D0*(alf1+alf2)
14835         xj=c(1,nres+j)-xi
14836         yj=c(2,nres+j)-yi
14837         zj=c(3,nres+j)-zi
14838         call to_box(xj,yj,zj)
14839       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14840         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14841         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14842         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14843              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14844             xj=boxshift(xj-xi,boxxsize)
14845             yj=boxshift(yj-yi,boxysize)
14846             zj=boxshift(zj-zi,boxzsize)
14847             dxj=dc_norm(1,nres+j)
14848             dyj=dc_norm(2,nres+j)
14849             dzj=dc_norm(3,nres+j)
14850             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14851             rij=dsqrt(rrij)
14852             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14853
14854             if (sss.gt.0.0d0) then
14855
14856 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14857               call sc_angular
14858 ! Calculate whole angle-dependent part of epsilon and contributions
14859 ! to its derivatives
14860               fac=(rrij*sigsq)**expon2
14861               e1=fac*fac*aa_aq(itypi,itypj)
14862               e2=fac*bb_aq(itypi,itypj)
14863               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14864               eps2der=evdwij*eps3rt
14865               eps3der=evdwij*eps2rt
14866               evdwij=evdwij*eps2rt*eps3rt
14867               evdw=evdw+evdwij*sss
14868               if (lprn) then
14869               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14870               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14871 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14872 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14873 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14874 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14875 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14876 !d     &          evdwij
14877               endif
14878 ! Calculate gradient components.
14879               e1=e1*eps1*eps2rt**2*eps3rt**2
14880               fac=-expon*(e1+evdwij)
14881               sigder=fac/sigsq
14882               fac=rrij*fac
14883 ! Calculate radial part of the gradient
14884               gg(1)=xj*fac
14885               gg(2)=yj*fac
14886               gg(3)=zj*fac
14887 ! Calculate the angular part of the gradient and sum add the contributions
14888 ! to the appropriate components of the Cartesian gradient.
14889               call sc_grad_scale(sss)
14890             endif
14891           enddo      ! j
14892         enddo        ! iint
14893       enddo          ! i
14894 !     stop
14895       return
14896       end subroutine ebp_short
14897 !-----------------------------------------------------------------------------
14898       subroutine egb_long(evdw)
14899 !
14900 ! This subroutine calculates the interaction energy of nonbonded side chains
14901 ! assuming the Gay-Berne potential of interaction.
14902 !
14903       use calc_data
14904 !      implicit real(kind=8) (a-h,o-z)
14905 !      include 'DIMENSIONS'
14906 !      include 'COMMON.GEO'
14907 !      include 'COMMON.VAR'
14908 !      include 'COMMON.LOCAL'
14909 !      include 'COMMON.CHAIN'
14910 !      include 'COMMON.DERIV'
14911 !      include 'COMMON.NAMES'
14912 !      include 'COMMON.INTERACT'
14913 !      include 'COMMON.IOUNITS'
14914 !      include 'COMMON.CALC'
14915 !      include 'COMMON.CONTROL'
14916       logical :: lprn
14917 !el local variables
14918       integer :: iint,itypi,itypi1,itypj,subchap
14919       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
14920       real(kind=8) :: sss,e1,e2,evdw,sss_grad
14921       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14922                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14923                     ssgradlipi,ssgradlipj
14924
14925
14926       evdw=0.0D0
14927 !cccc      energy_dec=.false.
14928 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14929       evdw=0.0D0
14930       lprn=.false.
14931 !     if (icall.eq.0) lprn=.false.
14932 !el      ind=0
14933       do i=iatsc_s,iatsc_e
14934         itypi=itype(i,1)
14935         if (itypi.eq.ntyp1) cycle
14936         itypi1=itype(i+1,1)
14937         xi=c(1,nres+i)
14938         yi=c(2,nres+i)
14939         zi=c(3,nres+i)
14940         call to_box(xi,yi,zi)
14941         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14942         dxi=dc_norm(1,nres+i)
14943         dyi=dc_norm(2,nres+i)
14944         dzi=dc_norm(3,nres+i)
14945 !        dsci_inv=dsc_inv(itypi)
14946         dsci_inv=vbld_inv(i+nres)
14947 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14948 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14949 !
14950 ! Calculate SC interaction energy.
14951 !
14952         do iint=1,nint_gr(i)
14953           do j=istart(i,iint),iend(i,iint)
14954             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14955 !              call dyn_ssbond_ene(i,j,evdwij)
14956 !              evdw=evdw+evdwij
14957 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14958 !                              'evdw',i,j,evdwij,' ss'
14959 !              if (energy_dec) write (iout,*) &
14960 !                              'evdw',i,j,evdwij,' ss'
14961 !             do k=j+1,iend(i,iint)
14962 !C search over all next residues
14963 !              if (dyn_ss_mask(k)) then
14964 !C check if they are cysteins
14965 !C              write(iout,*) 'k=',k
14966
14967 !c              write(iout,*) "PRZED TRI", evdwij
14968 !               evdwij_przed_tri=evdwij
14969 !              call triple_ssbond_ene(i,j,k,evdwij)
14970 !c               if(evdwij_przed_tri.ne.evdwij) then
14971 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14972 !c               endif
14973
14974 !c              write(iout,*) "PO TRI", evdwij
14975 !C call the energy function that removes the artifical triple disulfide
14976 !C bond the soubroutine is located in ssMD.F
14977 !              evdw=evdw+evdwij
14978               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14979                             'evdw',i,j,evdwij,'tss'
14980 !              endif!dyn_ss_mask(k)
14981 !             enddo! k
14982
14983             ELSE
14984 !el            ind=ind+1
14985             itypj=itype(j,1)
14986             if (itypj.eq.ntyp1) cycle
14987 !            dscj_inv=dsc_inv(itypj)
14988             dscj_inv=vbld_inv(j+nres)
14989 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14990 !     &       1.0d0/vbld(j+nres)
14991 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14992             sig0ij=sigma(itypi,itypj)
14993             chi1=chi(itypi,itypj)
14994             chi2=chi(itypj,itypi)
14995             chi12=chi1*chi2
14996             chip1=chip(itypi)
14997             chip2=chip(itypj)
14998             chip12=chip1*chip2
14999             alf1=alp(itypi)
15000             alf2=alp(itypj)
15001             alf12=0.5D0*(alf1+alf2)
15002             xj=c(1,nres+j)
15003             yj=c(2,nres+j)
15004             zj=c(3,nres+j)
15005 ! Searching for nearest neighbour
15006             call to_box(xj,yj,zj)
15007             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15008             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15009              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15010             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15011              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15012             xj=boxshift(xj-xi,boxxsize)
15013             yj=boxshift(yj-yi,boxysize)
15014             zj=boxshift(zj-zi,boxzsize)
15015             dxj=dc_norm(1,nres+j)
15016             dyj=dc_norm(2,nres+j)
15017             dzj=dc_norm(3,nres+j)
15018             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15019             rij=dsqrt(rrij)
15020             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15021             sss_ele_cut=sscale_ele(1.0d0/(rij))
15022             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
15023             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
15024             if (sss_ele_cut.le.0.0) cycle
15025             if (sss.lt.1.0d0) then
15026
15027 ! Calculate angle-dependent terms of energy and contributions to their
15028 ! derivatives.
15029               call sc_angular
15030               sigsq=1.0D0/sigsq
15031               sig=sig0ij*dsqrt(sigsq)
15032               rij_shift=1.0D0/rij-sig+sig0ij
15033 ! for diagnostics; uncomment
15034 !              rij_shift=1.2*sig0ij
15035 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15036               if (rij_shift.le.0.0D0) then
15037                 evdw=1.0D20
15038 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
15039 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
15040 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
15041                 return
15042               endif
15043               sigder=-sig*sigsq
15044 !---------------------------------------------------------------
15045               rij_shift=1.0D0/rij_shift
15046               fac=rij_shift**expon
15047               e1=fac*fac*aa
15048               e2=fac*bb
15049               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15050               eps2der=evdwij*eps3rt
15051               eps3der=evdwij*eps2rt
15052 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
15053 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
15054               evdwij=evdwij*eps2rt*eps3rt
15055               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
15056               if (lprn) then
15057               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15058               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15059               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15060                 restyp(itypi,1),i,restyp(itypj,1),j,&
15061                 epsi,sigm,chi1,chi2,chip1,chip2,&
15062                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
15063                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15064                 evdwij
15065               endif
15066
15067               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15068                               'evdw',i,j,evdwij
15069 !              if (energy_dec) write (iout,*) &
15070 !                              'evdw',i,j,evdwij,"egb_long"
15071
15072 ! Calculate gradient components.
15073               e1=e1*eps1*eps2rt**2*eps3rt**2
15074               fac=-expon*(e1+evdwij)*rij_shift
15075               sigder=fac*sigder
15076               fac=rij*fac
15077               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
15078               *rij-sss_grad/(1.0-sss)*rij  &
15079             /sigmaii(itypi,itypj))
15080 !              fac=0.0d0
15081 ! Calculate the radial part of the gradient
15082               gg(1)=xj*fac
15083               gg(2)=yj*fac
15084               gg(3)=zj*fac
15085 ! Calculate angular part of the gradient.
15086               call sc_grad_scale(1.0d0-sss)
15087             ENDIF    !mask_dyn_ss
15088             endif
15089           enddo      ! j
15090         enddo        ! iint
15091       enddo          ! i
15092 !      write (iout,*) "Number of loop steps in EGB:",ind
15093 !ccc      energy_dec=.false.
15094       return
15095       end subroutine egb_long
15096 !-----------------------------------------------------------------------------
15097       subroutine egb_short(evdw)
15098 !
15099 ! This subroutine calculates the interaction energy of nonbonded side chains
15100 ! assuming the Gay-Berne potential of interaction.
15101 !
15102       use calc_data
15103 !      implicit real(kind=8) (a-h,o-z)
15104 !      include 'DIMENSIONS'
15105 !      include 'COMMON.GEO'
15106 !      include 'COMMON.VAR'
15107 !      include 'COMMON.LOCAL'
15108 !      include 'COMMON.CHAIN'
15109 !      include 'COMMON.DERIV'
15110 !      include 'COMMON.NAMES'
15111 !      include 'COMMON.INTERACT'
15112 !      include 'COMMON.IOUNITS'
15113 !      include 'COMMON.CALC'
15114 !      include 'COMMON.CONTROL'
15115       logical :: lprn
15116 !el local variables
15117       integer :: iint,itypi,itypi1,itypj,subchap
15118       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
15119       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
15120       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15121                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
15122                     ssgradlipi,ssgradlipj
15123       evdw=0.0D0
15124 !cccc      energy_dec=.false.
15125 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15126       evdw=0.0D0
15127       lprn=.false.
15128 !     if (icall.eq.0) lprn=.false.
15129 !el      ind=0
15130       do i=iatsc_s,iatsc_e
15131         itypi=itype(i,1)
15132         if (itypi.eq.ntyp1) cycle
15133         itypi1=itype(i+1,1)
15134         xi=c(1,nres+i)
15135         yi=c(2,nres+i)
15136         zi=c(3,nres+i)
15137         call to_box(xi,yi,zi)
15138         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15139
15140         dxi=dc_norm(1,nres+i)
15141         dyi=dc_norm(2,nres+i)
15142         dzi=dc_norm(3,nres+i)
15143 !        dsci_inv=dsc_inv(itypi)
15144         dsci_inv=vbld_inv(i+nres)
15145
15146         dxi=dc_norm(1,nres+i)
15147         dyi=dc_norm(2,nres+i)
15148         dzi=dc_norm(3,nres+i)
15149 !        dsci_inv=dsc_inv(itypi)
15150         dsci_inv=vbld_inv(i+nres)
15151         do iint=1,nint_gr(i)
15152           do j=istart(i,iint),iend(i,iint)
15153             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
15154               call dyn_ssbond_ene(i,j,evdwij)
15155               evdw=evdw+evdwij
15156               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15157                               'evdw',i,j,evdwij,' ss'
15158              do k=j+1,iend(i,iint)
15159 !C search over all next residues
15160               if (dyn_ss_mask(k)) then
15161 !C check if they are cysteins
15162 !C              write(iout,*) 'k=',k
15163
15164 !c              write(iout,*) "PRZED TRI", evdwij
15165 !               evdwij_przed_tri=evdwij
15166               call triple_ssbond_ene(i,j,k,evdwij)
15167 !c               if(evdwij_przed_tri.ne.evdwij) then
15168 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
15169 !c               endif
15170
15171 !c              write(iout,*) "PO TRI", evdwij
15172 !C call the energy function that removes the artifical triple disulfide
15173 !C bond the soubroutine is located in ssMD.F
15174               evdw=evdw+evdwij
15175               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
15176                             'evdw',i,j,evdwij,'tss'
15177               endif!dyn_ss_mask(k)
15178              enddo! k
15179             ELSE
15180
15181 !          typj=itype(j,1)
15182             if (itypj.eq.ntyp1) cycle
15183 !            dscj_inv=dsc_inv(itypj)
15184             dscj_inv=vbld_inv(j+nres)
15185             dscj_inv=dsc_inv(itypj)
15186 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
15187 !     &       1.0d0/vbld(j+nres)
15188 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
15189             sig0ij=sigma(itypi,itypj)
15190             chi1=chi(itypi,itypj)
15191             chi2=chi(itypj,itypi)
15192             chi12=chi1*chi2
15193             chip1=chip(itypi)
15194             chip2=chip(itypj)
15195             chip12=chip1*chip2
15196             alf1=alp(itypi)
15197             alf2=alp(itypj)
15198             alf12=0.5D0*(alf1+alf2)
15199 !            xj=c(1,nres+j)-xi
15200 !            yj=c(2,nres+j)-yi
15201 !            zj=c(3,nres+j)-zi
15202             xj=c(1,nres+j)
15203             yj=c(2,nres+j)
15204             zj=c(3,nres+j)
15205 ! Searching for nearest neighbour
15206             call to_box(xj,yj,zj)
15207             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15208             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15209              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15210             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15211              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15212             xj=boxshift(xj-xi,boxxsize)
15213             yj=boxshift(yj-yi,boxysize)
15214             zj=boxshift(zj-zi,boxzsize)
15215             dxj=dc_norm(1,nres+j)
15216             dyj=dc_norm(2,nres+j)
15217             dzj=dc_norm(3,nres+j)
15218             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15219             rij=dsqrt(rrij)
15220             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15221             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
15222             sss_ele_cut=sscale_ele(1.0d0/(rij))
15223             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
15224             if (sss_ele_cut.le.0.0) cycle
15225
15226             if (sss.gt.0.0d0) then
15227
15228 ! Calculate angle-dependent terms of energy and contributions to their
15229 ! derivatives.
15230               call sc_angular
15231               sigsq=1.0D0/sigsq
15232               sig=sig0ij*dsqrt(sigsq)
15233               rij_shift=1.0D0/rij-sig+sig0ij
15234 ! for diagnostics; uncomment
15235 !              rij_shift=1.2*sig0ij
15236 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15237               if (rij_shift.le.0.0D0) then
15238                 evdw=1.0D20
15239 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
15240 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
15241 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
15242                 return
15243               endif
15244               sigder=-sig*sigsq
15245 !---------------------------------------------------------------
15246               rij_shift=1.0D0/rij_shift
15247               fac=rij_shift**expon
15248               e1=fac*fac*aa
15249               e2=fac*bb
15250               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15251               eps2der=evdwij*eps3rt
15252               eps3der=evdwij*eps2rt
15253 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
15254 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
15255               evdwij=evdwij*eps2rt*eps3rt
15256               evdw=evdw+evdwij*sss*sss_ele_cut
15257               if (lprn) then
15258               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15259               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15260               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15261                 restyp(itypi,1),i,restyp(itypj,1),j,&
15262                 epsi,sigm,chi1,chi2,chip1,chip2,&
15263                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
15264                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15265                 evdwij
15266               endif
15267
15268               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15269                               'evdw',i,j,evdwij
15270 !              if (energy_dec) write (iout,*) &
15271 !                              'evdw',i,j,evdwij,"egb_short"
15272
15273 ! Calculate gradient components.
15274               e1=e1*eps1*eps2rt**2*eps3rt**2
15275               fac=-expon*(e1+evdwij)*rij_shift
15276               sigder=fac*sigder
15277               fac=rij*fac
15278               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
15279             *rij+sss_grad/sss*rij  &
15280             /sigmaii(itypi,itypj))
15281
15282 !              fac=0.0d0
15283 ! Calculate the radial part of the gradient
15284               gg(1)=xj*fac
15285               gg(2)=yj*fac
15286               gg(3)=zj*fac
15287 ! Calculate angular part of the gradient.
15288               call sc_grad_scale(sss)
15289             endif
15290           ENDIF !mask_dyn_ss
15291           enddo      ! j
15292         enddo        ! iint
15293       enddo          ! i
15294 !      write (iout,*) "Number of loop steps in EGB:",ind
15295 !ccc      energy_dec=.false.
15296       return
15297       end subroutine egb_short
15298 !-----------------------------------------------------------------------------
15299       subroutine egbv_long(evdw)
15300 !
15301 ! This subroutine calculates the interaction energy of nonbonded side chains
15302 ! assuming the Gay-Berne-Vorobjev potential of interaction.
15303 !
15304       use calc_data
15305 !      implicit real(kind=8) (a-h,o-z)
15306 !      include 'DIMENSIONS'
15307 !      include 'COMMON.GEO'
15308 !      include 'COMMON.VAR'
15309 !      include 'COMMON.LOCAL'
15310 !      include 'COMMON.CHAIN'
15311 !      include 'COMMON.DERIV'
15312 !      include 'COMMON.NAMES'
15313 !      include 'COMMON.INTERACT'
15314 !      include 'COMMON.IOUNITS'
15315 !      include 'COMMON.CALC'
15316       use comm_srutu
15317 !el      integer :: icall
15318 !el      common /srutu/ icall
15319       logical :: lprn
15320 !el local variables
15321       integer :: iint,itypi,itypi1,itypj
15322       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
15323                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
15324       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
15325       evdw=0.0D0
15326 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15327       evdw=0.0D0
15328       lprn=.false.
15329 !     if (icall.eq.0) lprn=.true.
15330 !el      ind=0
15331       do i=iatsc_s,iatsc_e
15332         itypi=itype(i,1)
15333         if (itypi.eq.ntyp1) cycle
15334         itypi1=itype(i+1,1)
15335         xi=c(1,nres+i)
15336         yi=c(2,nres+i)
15337         zi=c(3,nres+i)
15338         call to_box(xi,yi,zi)
15339         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15340         dxi=dc_norm(1,nres+i)
15341         dyi=dc_norm(2,nres+i)
15342         dzi=dc_norm(3,nres+i)
15343
15344 !        dsci_inv=dsc_inv(itypi)
15345         dsci_inv=vbld_inv(i+nres)
15346 !
15347 ! Calculate SC interaction energy.
15348 !
15349         do iint=1,nint_gr(i)
15350           do j=istart(i,iint),iend(i,iint)
15351 !el            ind=ind+1
15352             itypj=itype(j,1)
15353             if (itypj.eq.ntyp1) cycle
15354 !            dscj_inv=dsc_inv(itypj)
15355             dscj_inv=vbld_inv(j+nres)
15356             sig0ij=sigma(itypi,itypj)
15357             r0ij=r0(itypi,itypj)
15358             chi1=chi(itypi,itypj)
15359             chi2=chi(itypj,itypi)
15360             chi12=chi1*chi2
15361             chip1=chip(itypi)
15362             chip2=chip(itypj)
15363             chip12=chip1*chip2
15364             alf1=alp(itypi)
15365             alf2=alp(itypj)
15366             alf12=0.5D0*(alf1+alf2)
15367             xj=c(1,nres+j)-xi
15368             yj=c(2,nres+j)-yi
15369             zj=c(3,nres+j)-zi
15370             call to_box(xj,yj,zj)
15371             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15372             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15373             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15374             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15375             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15376             xj=boxshift(xj-xi,boxxsize)
15377             yj=boxshift(yj-yi,boxysize)
15378             zj=boxshift(zj-zi,boxzsize)
15379             dxj=dc_norm(1,nres+j)
15380             dyj=dc_norm(2,nres+j)
15381             dzj=dc_norm(3,nres+j)
15382             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15383             rij=dsqrt(rrij)
15384
15385             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15386
15387             if (sss.lt.1.0d0) then
15388
15389 ! Calculate angle-dependent terms of energy and contributions to their
15390 ! derivatives.
15391               call sc_angular
15392               sigsq=1.0D0/sigsq
15393               sig=sig0ij*dsqrt(sigsq)
15394               rij_shift=1.0D0/rij-sig+r0ij
15395 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15396               if (rij_shift.le.0.0D0) then
15397                 evdw=1.0D20
15398                 return
15399               endif
15400               sigder=-sig*sigsq
15401 !---------------------------------------------------------------
15402               rij_shift=1.0D0/rij_shift
15403               fac=rij_shift**expon
15404               e1=fac*fac*aa_aq(itypi,itypj)
15405               e2=fac*bb_aq(itypi,itypj)
15406               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15407               eps2der=evdwij*eps3rt
15408               eps3der=evdwij*eps2rt
15409               fac_augm=rrij**expon
15410               e_augm=augm(itypi,itypj)*fac_augm
15411               evdwij=evdwij*eps2rt*eps3rt
15412               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
15413               if (lprn) then
15414               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15415               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15416               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15417                 restyp(itypi,1),i,restyp(itypj,1),j,&
15418                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15419                 chi1,chi2,chip1,chip2,&
15420                 eps1,eps2rt**2,eps3rt**2,&
15421                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15422                 evdwij+e_augm
15423               endif
15424 ! Calculate gradient components.
15425               e1=e1*eps1*eps2rt**2*eps3rt**2
15426               fac=-expon*(e1+evdwij)*rij_shift
15427               sigder=fac*sigder
15428               fac=rij*fac-2*expon*rrij*e_augm
15429 ! Calculate the radial part of the gradient
15430               gg(1)=xj*fac
15431               gg(2)=yj*fac
15432               gg(3)=zj*fac
15433 ! Calculate angular part of the gradient.
15434               call sc_grad_scale(1.0d0-sss)
15435             endif
15436           enddo      ! j
15437         enddo        ! iint
15438       enddo          ! i
15439       end subroutine egbv_long
15440 !-----------------------------------------------------------------------------
15441       subroutine egbv_short(evdw)
15442 !
15443 ! This subroutine calculates the interaction energy of nonbonded side chains
15444 ! assuming the Gay-Berne-Vorobjev potential of interaction.
15445 !
15446       use calc_data
15447 !      implicit real(kind=8) (a-h,o-z)
15448 !      include 'DIMENSIONS'
15449 !      include 'COMMON.GEO'
15450 !      include 'COMMON.VAR'
15451 !      include 'COMMON.LOCAL'
15452 !      include 'COMMON.CHAIN'
15453 !      include 'COMMON.DERIV'
15454 !      include 'COMMON.NAMES'
15455 !      include 'COMMON.INTERACT'
15456 !      include 'COMMON.IOUNITS'
15457 !      include 'COMMON.CALC'
15458       use comm_srutu
15459 !el      integer :: icall
15460 !el      common /srutu/ icall
15461       logical :: lprn
15462 !el local variables
15463       integer :: iint,itypi,itypi1,itypj
15464       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
15465                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
15466       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
15467       evdw=0.0D0
15468 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15469       evdw=0.0D0
15470       lprn=.false.
15471 !     if (icall.eq.0) lprn=.true.
15472 !el      ind=0
15473       do i=iatsc_s,iatsc_e
15474         itypi=itype(i,1)
15475         if (itypi.eq.ntyp1) cycle
15476         itypi1=itype(i+1,1)
15477         xi=c(1,nres+i)
15478         yi=c(2,nres+i)
15479         zi=c(3,nres+i)
15480         dxi=dc_norm(1,nres+i)
15481         dyi=dc_norm(2,nres+i)
15482         dzi=dc_norm(3,nres+i)
15483         call to_box(xi,yi,zi)
15484         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15485 !        dsci_inv=dsc_inv(itypi)
15486         dsci_inv=vbld_inv(i+nres)
15487 !
15488 ! Calculate SC interaction energy.
15489 !
15490         do iint=1,nint_gr(i)
15491           do j=istart(i,iint),iend(i,iint)
15492 !el            ind=ind+1
15493             itypj=itype(j,1)
15494             if (itypj.eq.ntyp1) cycle
15495 !            dscj_inv=dsc_inv(itypj)
15496             dscj_inv=vbld_inv(j+nres)
15497             sig0ij=sigma(itypi,itypj)
15498             r0ij=r0(itypi,itypj)
15499             chi1=chi(itypi,itypj)
15500             chi2=chi(itypj,itypi)
15501             chi12=chi1*chi2
15502             chip1=chip(itypi)
15503             chip2=chip(itypj)
15504             chip12=chip1*chip2
15505             alf1=alp(itypi)
15506             alf2=alp(itypj)
15507             alf12=0.5D0*(alf1+alf2)
15508             xj=c(1,nres+j)-xi
15509             yj=c(2,nres+j)-yi
15510             zj=c(3,nres+j)-zi
15511             call to_box(xj,yj,zj)
15512             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15513             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15514             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15515             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15516             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15517             xj=boxshift(xj-xi,boxxsize)
15518             yj=boxshift(yj-yi,boxysize)
15519             zj=boxshift(zj-zi,boxzsize)
15520             dxj=dc_norm(1,nres+j)
15521             dyj=dc_norm(2,nres+j)
15522             dzj=dc_norm(3,nres+j)
15523             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15524             rij=dsqrt(rrij)
15525
15526             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15527
15528             if (sss.gt.0.0d0) then
15529
15530 ! Calculate angle-dependent terms of energy and contributions to their
15531 ! derivatives.
15532               call sc_angular
15533               sigsq=1.0D0/sigsq
15534               sig=sig0ij*dsqrt(sigsq)
15535               rij_shift=1.0D0/rij-sig+r0ij
15536 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15537               if (rij_shift.le.0.0D0) then
15538                 evdw=1.0D20
15539                 return
15540               endif
15541               sigder=-sig*sigsq
15542 !---------------------------------------------------------------
15543               rij_shift=1.0D0/rij_shift
15544               fac=rij_shift**expon
15545               e1=fac*fac*aa_aq(itypi,itypj)
15546               e2=fac*bb_aq(itypi,itypj)
15547               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15548               eps2der=evdwij*eps3rt
15549               eps3der=evdwij*eps2rt
15550               fac_augm=rrij**expon
15551               e_augm=augm(itypi,itypj)*fac_augm
15552               evdwij=evdwij*eps2rt*eps3rt
15553               evdw=evdw+(evdwij+e_augm)*sss
15554               if (lprn) then
15555               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15556               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15557               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15558                 restyp(itypi,1),i,restyp(itypj,1),j,&
15559                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15560                 chi1,chi2,chip1,chip2,&
15561                 eps1,eps2rt**2,eps3rt**2,&
15562                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15563                 evdwij+e_augm
15564               endif
15565 ! Calculate gradient components.
15566               e1=e1*eps1*eps2rt**2*eps3rt**2
15567               fac=-expon*(e1+evdwij)*rij_shift
15568               sigder=fac*sigder
15569               fac=rij*fac-2*expon*rrij*e_augm
15570 ! Calculate the radial part of the gradient
15571               gg(1)=xj*fac
15572               gg(2)=yj*fac
15573               gg(3)=zj*fac
15574 ! Calculate angular part of the gradient.
15575               call sc_grad_scale(sss)
15576             endif
15577           enddo      ! j
15578         enddo        ! iint
15579       enddo          ! i
15580       end subroutine egbv_short
15581 !-----------------------------------------------------------------------------
15582       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15583 !
15584 ! This subroutine calculates the average interaction energy and its gradient
15585 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
15586 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
15587 ! The potential depends both on the distance of peptide-group centers and on
15588 ! the orientation of the CA-CA virtual bonds.
15589 !
15590 !      implicit real(kind=8) (a-h,o-z)
15591
15592       use comm_locel
15593 #ifdef MPI
15594       include 'mpif.h'
15595 #endif
15596 !      include 'DIMENSIONS'
15597 !      include 'COMMON.CONTROL'
15598 !      include 'COMMON.SETUP'
15599 !      include 'COMMON.IOUNITS'
15600 !      include 'COMMON.GEO'
15601 !      include 'COMMON.VAR'
15602 !      include 'COMMON.LOCAL'
15603 !      include 'COMMON.CHAIN'
15604 !      include 'COMMON.DERIV'
15605 !      include 'COMMON.INTERACT'
15606 !      include 'COMMON.CONTACTS'
15607 !      include 'COMMON.TORSION'
15608 !      include 'COMMON.VECTORS'
15609 !      include 'COMMON.FFIELD'
15610 !      include 'COMMON.TIME1'
15611       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
15612       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
15613       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15614 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15615       real(kind=8),dimension(4) :: muij
15616 !el      integer :: num_conti,j1,j2
15617 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15618 !el                   dz_normi,xmedi,ymedi,zmedi
15619 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15620 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15621 !el          num_conti,j1,j2
15622 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15623 #ifdef MOMENT
15624       real(kind=8) :: scal_el=1.0d0
15625 #else
15626       real(kind=8) :: scal_el=0.5d0
15627 #endif
15628 ! 12/13/98
15629 ! 13-go grudnia roku pamietnego...
15630       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15631                                              0.0d0,1.0d0,0.0d0,&
15632                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15633 !el local variables
15634       integer :: i,j,k
15635       real(kind=8) :: fac
15636       real(kind=8) :: dxj,dyj,dzj
15637       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
15638
15639 !      allocate(num_cont_hb(nres)) !(maxres)
15640 !d      write(iout,*) 'In EELEC'
15641 !d      do i=1,nloctyp
15642 !d        write(iout,*) 'Type',i
15643 !d        write(iout,*) 'B1',B1(:,i)
15644 !d        write(iout,*) 'B2',B2(:,i)
15645 !d        write(iout,*) 'CC',CC(:,:,i)
15646 !d        write(iout,*) 'DD',DD(:,:,i)
15647 !d        write(iout,*) 'EE',EE(:,:,i)
15648 !d      enddo
15649 !d      call check_vecgrad
15650 !d      stop
15651       if (icheckgrad.eq.1) then
15652         do i=1,nres-1
15653           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
15654           do k=1,3
15655             dc_norm(k,i)=dc(k,i)*fac
15656           enddo
15657 !          write (iout,*) 'i',i,' fac',fac
15658         enddo
15659       endif
15660       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15661           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
15662           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
15663 !        call vec_and_deriv
15664 #ifdef TIMING
15665         time01=MPI_Wtime()
15666 #endif
15667 !        print *, "before set matrices"
15668         call set_matrices
15669 !        print *,"after set martices"
15670 #ifdef TIMING
15671         time_mat=time_mat+MPI_Wtime()-time01
15672 #endif
15673       endif
15674 !d      do i=1,nres-1
15675 !d        write (iout,*) 'i=',i
15676 !d        do k=1,3
15677 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
15678 !d        enddo
15679 !d        do k=1,3
15680 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
15681 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
15682 !d        enddo
15683 !d      enddo
15684       t_eelecij=0.0d0
15685       ees=0.0D0
15686       evdw1=0.0D0
15687       eel_loc=0.0d0
15688       eello_turn3=0.0d0
15689       eello_turn4=0.0d0
15690 !el      ind=0
15691       do i=1,nres
15692         num_cont_hb(i)=0
15693       enddo
15694 !d      print '(a)','Enter EELEC'
15695 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
15696 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
15697 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
15698       do i=1,nres
15699         gel_loc_loc(i)=0.0d0
15700         gcorr_loc(i)=0.0d0
15701       enddo
15702 !
15703 !
15704 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
15705 !
15706 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
15707 !
15708       do i=iturn3_start,iturn3_end
15709         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
15710         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
15711         dxi=dc(1,i)
15712         dyi=dc(2,i)
15713         dzi=dc(3,i)
15714         dx_normi=dc_norm(1,i)
15715         dy_normi=dc_norm(2,i)
15716         dz_normi=dc_norm(3,i)
15717         xmedi=c(1,i)+0.5d0*dxi
15718         ymedi=c(2,i)+0.5d0*dyi
15719         zmedi=c(3,i)+0.5d0*dzi
15720         call to_box(xmedi,ymedi,zmedi)
15721         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15722         num_conti=0
15723         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
15724         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
15725         num_cont_hb(i)=num_conti
15726       enddo
15727       do i=iturn4_start,iturn4_end
15728         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
15729           .or. itype(i+3,1).eq.ntyp1 &
15730           .or. itype(i+4,1).eq.ntyp1) cycle
15731         dxi=dc(1,i)
15732         dyi=dc(2,i)
15733         dzi=dc(3,i)
15734         dx_normi=dc_norm(1,i)
15735         dy_normi=dc_norm(2,i)
15736         dz_normi=dc_norm(3,i)
15737         xmedi=c(1,i)+0.5d0*dxi
15738         ymedi=c(2,i)+0.5d0*dyi
15739         zmedi=c(3,i)+0.5d0*dzi
15740
15741         call to_box(xmedi,ymedi,zmedi)
15742         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15743
15744         num_conti=num_cont_hb(i)
15745         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
15746         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
15747           call eturn4(i,eello_turn4)
15748         num_cont_hb(i)=num_conti
15749       enddo   ! i
15750 !
15751 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
15752 !
15753       do i=iatel_s,iatel_e
15754         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15755         dxi=dc(1,i)
15756         dyi=dc(2,i)
15757         dzi=dc(3,i)
15758         dx_normi=dc_norm(1,i)
15759         dy_normi=dc_norm(2,i)
15760         dz_normi=dc_norm(3,i)
15761         xmedi=c(1,i)+0.5d0*dxi
15762         ymedi=c(2,i)+0.5d0*dyi
15763         zmedi=c(3,i)+0.5d0*dzi
15764         call to_box(xmedi,ymedi,zmedi)
15765         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15766 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
15767         num_conti=num_cont_hb(i)
15768         do j=ielstart(i),ielend(i)
15769           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15770           call eelecij_scale(i,j,ees,evdw1,eel_loc)
15771         enddo ! j
15772         num_cont_hb(i)=num_conti
15773       enddo   ! i
15774 !      write (iout,*) "Number of loop steps in EELEC:",ind
15775 !d      do i=1,nres
15776 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
15777 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
15778 !d      enddo
15779 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
15780 !cc      eel_loc=eel_loc+eello_turn3
15781 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
15782       return
15783       end subroutine eelec_scale
15784 !-----------------------------------------------------------------------------
15785       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
15786 !      implicit real(kind=8) (a-h,o-z)
15787
15788       use comm_locel
15789 !      include 'DIMENSIONS'
15790 #ifdef MPI
15791       include "mpif.h"
15792 #endif
15793 !      include 'COMMON.CONTROL'
15794 !      include 'COMMON.IOUNITS'
15795 !      include 'COMMON.GEO'
15796 !      include 'COMMON.VAR'
15797 !      include 'COMMON.LOCAL'
15798 !      include 'COMMON.CHAIN'
15799 !      include 'COMMON.DERIV'
15800 !      include 'COMMON.INTERACT'
15801 !      include 'COMMON.CONTACTS'
15802 !      include 'COMMON.TORSION'
15803 !      include 'COMMON.VECTORS'
15804 !      include 'COMMON.FFIELD'
15805 !      include 'COMMON.TIME1'
15806       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
15807       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
15808       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15809 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15810       real(kind=8),dimension(4) :: muij
15811       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15812                     dist_temp, dist_init,sss_grad
15813       integer xshift,yshift,zshift
15814
15815 !el      integer :: num_conti,j1,j2
15816 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15817 !el                   dz_normi,xmedi,ymedi,zmedi
15818 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15819 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15820 !el          num_conti,j1,j2
15821 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15822 #ifdef MOMENT
15823       real(kind=8) :: scal_el=1.0d0
15824 #else
15825       real(kind=8) :: scal_el=0.5d0
15826 #endif
15827 ! 12/13/98
15828 ! 13-go grudnia roku pamietnego...
15829       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15830                                              0.0d0,1.0d0,0.0d0,&
15831                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15832 !el local variables
15833       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15834       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15835       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15836       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15837       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15838       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15839       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15840                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15841                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15842                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15843                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15844                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
15845 !      integer :: maxconts
15846 !      maxconts = nres/4
15847 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15848 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15849 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15850 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15851 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15852 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15853 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15854 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15855 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15856 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15857 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15858 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15859 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15860
15861 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15862 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15863
15864 #ifdef MPI
15865           time00=MPI_Wtime()
15866 #endif
15867 !d      write (iout,*) "eelecij",i,j
15868 !el          ind=ind+1
15869           iteli=itel(i)
15870           itelj=itel(j)
15871           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15872           aaa=app(iteli,itelj)
15873           bbb=bpp(iteli,itelj)
15874           ael6i=ael6(iteli,itelj)
15875           ael3i=ael3(iteli,itelj)
15876           dxj=dc(1,j)
15877           dyj=dc(2,j)
15878           dzj=dc(3,j)
15879           dx_normj=dc_norm(1,j)
15880           dy_normj=dc_norm(2,j)
15881           dz_normj=dc_norm(3,j)
15882 !          xj=c(1,j)+0.5D0*dxj-xmedi
15883 !          yj=c(2,j)+0.5D0*dyj-ymedi
15884 !          zj=c(3,j)+0.5D0*dzj-zmedi
15885           xj=c(1,j)+0.5D0*dxj
15886           yj=c(2,j)+0.5D0*dyj
15887           zj=c(3,j)+0.5D0*dzj
15888           call to_box(xj,yj,zj)
15889           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15890           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
15891           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15892           xj=boxshift(xj-xmedi,boxxsize)
15893           yj=boxshift(yj-ymedi,boxysize)
15894           zj=boxshift(zj-zmedi,boxzsize)
15895           rij=xj*xj+yj*yj+zj*zj
15896           rrmij=1.0D0/rij
15897           rij=dsqrt(rij)
15898           rmij=1.0D0/rij
15899 ! For extracting the short-range part of Evdwpp
15900           sss=sscale(rij/rpp(iteli,itelj))
15901             sss_ele_cut=sscale_ele(rij)
15902             sss_ele_grad=sscagrad_ele(rij)
15903             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15904 !             sss_ele_cut=1.0d0
15905 !             sss_ele_grad=0.0d0
15906             if (sss_ele_cut.le.0.0) go to 128
15907
15908           r3ij=rrmij*rmij
15909           r6ij=r3ij*r3ij
15910           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15911           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15912           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15913           fac=cosa-3.0D0*cosb*cosg
15914           ev1=aaa*r6ij*r6ij
15915 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15916           if (j.eq.i+2) ev1=scal_el*ev1
15917           ev2=bbb*r6ij
15918           fac3=ael6i*r6ij
15919           fac4=ael3i*r3ij
15920           evdwij=ev1+ev2
15921           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15922           el2=fac4*fac
15923           eesij=el1+el2
15924 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15925           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15926           ees=ees+eesij*sss_ele_cut
15927           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15928 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15929 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15930 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15931 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15932
15933           if (energy_dec) then
15934               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15935               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15936           endif
15937
15938 !
15939 ! Calculate contributions to the Cartesian gradient.
15940 !
15941 #ifdef SPLITELE
15942           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15943           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15944           fac1=fac
15945           erij(1)=xj*rmij
15946           erij(2)=yj*rmij
15947           erij(3)=zj*rmij
15948 !
15949 ! Radial derivatives. First process both termini of the fragment (i,j)
15950 !
15951           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15952           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15953           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15954 !          do k=1,3
15955 !            ghalf=0.5D0*ggg(k)
15956 !            gelc(k,i)=gelc(k,i)+ghalf
15957 !            gelc(k,j)=gelc(k,j)+ghalf
15958 !          enddo
15959 ! 9/28/08 AL Gradient compotents will be summed only at the end
15960           do k=1,3
15961             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15962             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15963           enddo
15964 !
15965 ! Loop over residues i+1 thru j-1.
15966 !
15967 !grad          do k=i+1,j-1
15968 !grad            do l=1,3
15969 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15970 !grad            enddo
15971 !grad          enddo
15972           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15973           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15974           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15975           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15976           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15977           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15978 !          do k=1,3
15979 !            ghalf=0.5D0*ggg(k)
15980 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15981 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15982 !          enddo
15983 ! 9/28/08 AL Gradient compotents will be summed only at the end
15984           do k=1,3
15985             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15986             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15987           enddo
15988 !
15989 ! Loop over residues i+1 thru j-1.
15990 !
15991 !grad          do k=i+1,j-1
15992 !grad            do l=1,3
15993 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15994 !grad            enddo
15995 !grad          enddo
15996 #else
15997           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15998           facel=(el1+eesij)*sss_ele_cut
15999           fac1=fac
16000           fac=-3*rrmij*(facvdw+facvdw+facel)
16001           erij(1)=xj*rmij
16002           erij(2)=yj*rmij
16003           erij(3)=zj*rmij
16004 !
16005 ! Radial derivatives. First process both termini of the fragment (i,j)
16006 !
16007           ggg(1)=fac*xj
16008           ggg(2)=fac*yj
16009           ggg(3)=fac*zj
16010 !          do k=1,3
16011 !            ghalf=0.5D0*ggg(k)
16012 !            gelc(k,i)=gelc(k,i)+ghalf
16013 !            gelc(k,j)=gelc(k,j)+ghalf
16014 !          enddo
16015 ! 9/28/08 AL Gradient compotents will be summed only at the end
16016           do k=1,3
16017             gelc_long(k,j)=gelc(k,j)+ggg(k)
16018             gelc_long(k,i)=gelc(k,i)-ggg(k)
16019           enddo
16020 !
16021 ! Loop over residues i+1 thru j-1.
16022 !
16023 !grad          do k=i+1,j-1
16024 !grad            do l=1,3
16025 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
16026 !grad            enddo
16027 !grad          enddo
16028 ! 9/28/08 AL Gradient compotents will be summed only at the end
16029           ggg(1)=facvdw*xj
16030           ggg(2)=facvdw*yj
16031           ggg(3)=facvdw*zj
16032           do k=1,3
16033             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16034             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16035           enddo
16036 #endif
16037 !
16038 ! Angular part
16039 !
16040           ecosa=2.0D0*fac3*fac1+fac4
16041           fac4=-3.0D0*fac4
16042           fac3=-6.0D0*fac3
16043           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
16044           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
16045           do k=1,3
16046             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
16047             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
16048           enddo
16049 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
16050 !d   &          (dcosg(k),k=1,3)
16051           do k=1,3
16052             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
16053           enddo
16054 !          do k=1,3
16055 !            ghalf=0.5D0*ggg(k)
16056 !            gelc(k,i)=gelc(k,i)+ghalf
16057 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
16058 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16059 !            gelc(k,j)=gelc(k,j)+ghalf
16060 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
16061 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16062 !          enddo
16063 !grad          do k=i+1,j-1
16064 !grad            do l=1,3
16065 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
16066 !grad            enddo
16067 !grad          enddo
16068           do k=1,3
16069             gelc(k,i)=gelc(k,i) &
16070                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16071                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
16072                      *sss_ele_cut
16073             gelc(k,j)=gelc(k,j) &
16074                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16075                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
16076                      *sss_ele_cut
16077             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
16078             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
16079           enddo
16080           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
16081               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
16082               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
16083 !
16084 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
16085 !   energy of a peptide unit is assumed in the form of a second-order
16086 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
16087 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
16088 !   are computed for EVERY pair of non-contiguous peptide groups.
16089 !
16090           if (j.lt.nres-1) then
16091             j1=j+1
16092             j2=j-1
16093           else
16094             j1=j-1
16095             j2=j-2
16096           endif
16097           kkk=0
16098           do k=1,2
16099             do l=1,2
16100               kkk=kkk+1
16101               muij(kkk)=mu(k,i)*mu(l,j)
16102             enddo
16103           enddo
16104 !d         write (iout,*) 'EELEC: i',i,' j',j
16105 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
16106 !d          write(iout,*) 'muij',muij
16107           ury=scalar(uy(1,i),erij)
16108           urz=scalar(uz(1,i),erij)
16109           vry=scalar(uy(1,j),erij)
16110           vrz=scalar(uz(1,j),erij)
16111           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
16112           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
16113           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
16114           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
16115           fac=dsqrt(-ael6i)*r3ij
16116           a22=a22*fac
16117           a23=a23*fac
16118           a32=a32*fac
16119           a33=a33*fac
16120 !d          write (iout,'(4i5,4f10.5)')
16121 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
16122 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
16123 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
16124 !d     &      uy(:,j),uz(:,j)
16125 !d          write (iout,'(4f10.5)')
16126 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
16127 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
16128 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
16129 !d           write (iout,'(9f10.5/)')
16130 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
16131 ! Derivatives of the elements of A in virtual-bond vectors
16132           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
16133           do k=1,3
16134             uryg(k,1)=scalar(erder(1,k),uy(1,i))
16135             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
16136             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
16137             urzg(k,1)=scalar(erder(1,k),uz(1,i))
16138             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
16139             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
16140             vryg(k,1)=scalar(erder(1,k),uy(1,j))
16141             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
16142             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
16143             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
16144             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
16145             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
16146           enddo
16147 ! Compute radial contributions to the gradient
16148           facr=-3.0d0*rrmij
16149           a22der=a22*facr
16150           a23der=a23*facr
16151           a32der=a32*facr
16152           a33der=a33*facr
16153           agg(1,1)=a22der*xj
16154           agg(2,1)=a22der*yj
16155           agg(3,1)=a22der*zj
16156           agg(1,2)=a23der*xj
16157           agg(2,2)=a23der*yj
16158           agg(3,2)=a23der*zj
16159           agg(1,3)=a32der*xj
16160           agg(2,3)=a32der*yj
16161           agg(3,3)=a32der*zj
16162           agg(1,4)=a33der*xj
16163           agg(2,4)=a33der*yj
16164           agg(3,4)=a33der*zj
16165 ! Add the contributions coming from er
16166           fac3=-3.0d0*fac
16167           do k=1,3
16168             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
16169             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
16170             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
16171             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
16172           enddo
16173           do k=1,3
16174 ! Derivatives in DC(i)
16175 !grad            ghalf1=0.5d0*agg(k,1)
16176 !grad            ghalf2=0.5d0*agg(k,2)
16177 !grad            ghalf3=0.5d0*agg(k,3)
16178 !grad            ghalf4=0.5d0*agg(k,4)
16179             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
16180             -3.0d0*uryg(k,2)*vry)!+ghalf1
16181             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
16182             -3.0d0*uryg(k,2)*vrz)!+ghalf2
16183             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
16184             -3.0d0*urzg(k,2)*vry)!+ghalf3
16185             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
16186             -3.0d0*urzg(k,2)*vrz)!+ghalf4
16187 ! Derivatives in DC(i+1)
16188             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
16189             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
16190             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
16191             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
16192             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
16193             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
16194             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
16195             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
16196 ! Derivatives in DC(j)
16197             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
16198             -3.0d0*vryg(k,2)*ury)!+ghalf1
16199             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
16200             -3.0d0*vrzg(k,2)*ury)!+ghalf2
16201             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
16202             -3.0d0*vryg(k,2)*urz)!+ghalf3
16203             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
16204             -3.0d0*vrzg(k,2)*urz)!+ghalf4
16205 ! Derivatives in DC(j+1) or DC(nres-1)
16206             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
16207             -3.0d0*vryg(k,3)*ury)
16208             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
16209             -3.0d0*vrzg(k,3)*ury)
16210             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
16211             -3.0d0*vryg(k,3)*urz)
16212             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
16213             -3.0d0*vrzg(k,3)*urz)
16214 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
16215 !grad              do l=1,4
16216 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
16217 !grad              enddo
16218 !grad            endif
16219           enddo
16220           acipa(1,1)=a22
16221           acipa(1,2)=a23
16222           acipa(2,1)=a32
16223           acipa(2,2)=a33
16224           a22=-a22
16225           a23=-a23
16226           do l=1,2
16227             do k=1,3
16228               agg(k,l)=-agg(k,l)
16229               aggi(k,l)=-aggi(k,l)
16230               aggi1(k,l)=-aggi1(k,l)
16231               aggj(k,l)=-aggj(k,l)
16232               aggj1(k,l)=-aggj1(k,l)
16233             enddo
16234           enddo
16235           if (j.lt.nres-1) then
16236             a22=-a22
16237             a32=-a32
16238             do l=1,3,2
16239               do k=1,3
16240                 agg(k,l)=-agg(k,l)
16241                 aggi(k,l)=-aggi(k,l)
16242                 aggi1(k,l)=-aggi1(k,l)
16243                 aggj(k,l)=-aggj(k,l)
16244                 aggj1(k,l)=-aggj1(k,l)
16245               enddo
16246             enddo
16247           else
16248             a22=-a22
16249             a23=-a23
16250             a32=-a32
16251             a33=-a33
16252             do l=1,4
16253               do k=1,3
16254                 agg(k,l)=-agg(k,l)
16255                 aggi(k,l)=-aggi(k,l)
16256                 aggi1(k,l)=-aggi1(k,l)
16257                 aggj(k,l)=-aggj(k,l)
16258                 aggj1(k,l)=-aggj1(k,l)
16259               enddo
16260             enddo
16261           endif
16262           ENDIF ! WCORR
16263           IF (wel_loc.gt.0.0d0) THEN
16264 ! Contribution to the local-electrostatic energy coming from the i-j pair
16265           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
16266            +a33*muij(4)
16267 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
16268 !           print *,"EELLOC",i,gel_loc_loc(i-1)
16269           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
16270                   'eelloc',i,j,eel_loc_ij
16271 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
16272
16273           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
16274 ! Partial derivatives in virtual-bond dihedral angles gamma
16275           if (i.gt.1) &
16276           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
16277                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
16278                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
16279                  *sss_ele_cut
16280           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
16281                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
16282                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
16283                  *sss_ele_cut
16284            xtemp(1)=xj
16285            xtemp(2)=yj
16286            xtemp(3)=zj
16287
16288 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
16289           do l=1,3
16290             ggg(l)=(agg(l,1)*muij(1)+ &
16291                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
16292             *sss_ele_cut &
16293              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
16294
16295             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
16296             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
16297 !grad            ghalf=0.5d0*ggg(l)
16298 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
16299 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
16300           enddo
16301 !grad          do k=i+1,j2
16302 !grad            do l=1,3
16303 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
16304 !grad            enddo
16305 !grad          enddo
16306 ! Remaining derivatives of eello
16307           do l=1,3
16308             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
16309                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
16310             *sss_ele_cut
16311
16312             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
16313                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
16314             *sss_ele_cut
16315
16316             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
16317                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
16318             *sss_ele_cut
16319
16320             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
16321                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
16322             *sss_ele_cut
16323
16324           enddo
16325           ENDIF
16326 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
16327 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
16328           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
16329              .and. num_conti.le.maxconts) then
16330 !            write (iout,*) i,j," entered corr"
16331 !
16332 ! Calculate the contact function. The ith column of the array JCONT will
16333 ! contain the numbers of atoms that make contacts with the atom I (of numbers
16334 ! greater than I). The arrays FACONT and GACONT will contain the values of
16335 ! the contact function and its derivative.
16336 !           r0ij=1.02D0*rpp(iteli,itelj)
16337 !           r0ij=1.11D0*rpp(iteli,itelj)
16338             r0ij=2.20D0*rpp(iteli,itelj)
16339 !           r0ij=1.55D0*rpp(iteli,itelj)
16340             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
16341 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
16342             if (fcont.gt.0.0D0) then
16343               num_conti=num_conti+1
16344               if (num_conti.gt.maxconts) then
16345 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
16346                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
16347                                ' will skip next contacts for this conf.',num_conti
16348               else
16349                 jcont_hb(num_conti,i)=j
16350 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
16351 !d     &           " jcont_hb",jcont_hb(num_conti,i)
16352                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
16353                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
16354 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
16355 !  terms.
16356                 d_cont(num_conti,i)=rij
16357 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
16358 !     --- Electrostatic-interaction matrix ---
16359                 a_chuj(1,1,num_conti,i)=a22
16360                 a_chuj(1,2,num_conti,i)=a23
16361                 a_chuj(2,1,num_conti,i)=a32
16362                 a_chuj(2,2,num_conti,i)=a33
16363 !     --- Gradient of rij
16364                 do kkk=1,3
16365                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
16366                 enddo
16367                 kkll=0
16368                 do k=1,2
16369                   do l=1,2
16370                     kkll=kkll+1
16371                     do m=1,3
16372                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
16373                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
16374                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
16375                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
16376                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
16377                     enddo
16378                   enddo
16379                 enddo
16380                 ENDIF
16381                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
16382 ! Calculate contact energies
16383                 cosa4=4.0D0*cosa
16384                 wij=cosa-3.0D0*cosb*cosg
16385                 cosbg1=cosb+cosg
16386                 cosbg2=cosb-cosg
16387 !               fac3=dsqrt(-ael6i)/r0ij**3
16388                 fac3=dsqrt(-ael6i)*r3ij
16389 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
16390                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
16391                 if (ees0tmp.gt.0) then
16392                   ees0pij=dsqrt(ees0tmp)
16393                 else
16394                   ees0pij=0
16395                 endif
16396 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
16397                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
16398                 if (ees0tmp.gt.0) then
16399                   ees0mij=dsqrt(ees0tmp)
16400                 else
16401                   ees0mij=0
16402                 endif
16403 !               ees0mij=0.0D0
16404                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
16405                      *sss_ele_cut
16406
16407                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
16408                      *sss_ele_cut
16409
16410 ! Diagnostics. Comment out or remove after debugging!
16411 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
16412 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
16413 !               ees0m(num_conti,i)=0.0D0
16414 ! End diagnostics.
16415 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
16416 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
16417 ! Angular derivatives of the contact function
16418                 ees0pij1=fac3/ees0pij
16419                 ees0mij1=fac3/ees0mij
16420                 fac3p=-3.0D0*fac3*rrmij
16421                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
16422                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
16423 !               ees0mij1=0.0D0
16424                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
16425                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
16426                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
16427                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
16428                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
16429                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
16430                 ecosap=ecosa1+ecosa2
16431                 ecosbp=ecosb1+ecosb2
16432                 ecosgp=ecosg1+ecosg2
16433                 ecosam=ecosa1-ecosa2
16434                 ecosbm=ecosb1-ecosb2
16435                 ecosgm=ecosg1-ecosg2
16436 ! Diagnostics
16437 !               ecosap=ecosa1
16438 !               ecosbp=ecosb1
16439 !               ecosgp=ecosg1
16440 !               ecosam=0.0D0
16441 !               ecosbm=0.0D0
16442 !               ecosgm=0.0D0
16443 ! End diagnostics
16444                 facont_hb(num_conti,i)=fcont
16445                 fprimcont=fprimcont/rij
16446 !d              facont_hb(num_conti,i)=1.0D0
16447 ! Following line is for diagnostics.
16448 !d              fprimcont=0.0D0
16449                 do k=1,3
16450                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
16451                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
16452                 enddo
16453                 do k=1,3
16454                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
16455                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
16456                 enddo
16457 !                gggp(1)=gggp(1)+ees0pijp*xj
16458 !                gggp(2)=gggp(2)+ees0pijp*yj
16459 !                gggp(3)=gggp(3)+ees0pijp*zj
16460 !                gggm(1)=gggm(1)+ees0mijp*xj
16461 !                gggm(2)=gggm(2)+ees0mijp*yj
16462 !                gggm(3)=gggm(3)+ees0mijp*zj
16463                 gggp(1)=gggp(1)+ees0pijp*xj &
16464                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16465                 gggp(2)=gggp(2)+ees0pijp*yj &
16466                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16467                 gggp(3)=gggp(3)+ees0pijp*zj &
16468                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16469
16470                 gggm(1)=gggm(1)+ees0mijp*xj &
16471                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16472
16473                 gggm(2)=gggm(2)+ees0mijp*yj &
16474                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16475
16476                 gggm(3)=gggm(3)+ees0mijp*zj &
16477                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16478
16479 ! Derivatives due to the contact function
16480                 gacont_hbr(1,num_conti,i)=fprimcont*xj
16481                 gacont_hbr(2,num_conti,i)=fprimcont*yj
16482                 gacont_hbr(3,num_conti,i)=fprimcont*zj
16483                 do k=1,3
16484 !
16485 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
16486 !          following the change of gradient-summation algorithm.
16487 !
16488 !grad                  ghalfp=0.5D0*gggp(k)
16489 !grad                  ghalfm=0.5D0*gggm(k)
16490 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
16491 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16492 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16493 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
16494 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16495 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16496 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
16497 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
16498 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16499 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16500 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
16501 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16502 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16503 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
16504                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
16505                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16506                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16507                      *sss_ele_cut
16508
16509                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
16510                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16511                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
16512                      *sss_ele_cut
16513
16514                   gacontp_hb3(k,num_conti,i)=gggp(k) &
16515                      *sss_ele_cut
16516
16517                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
16518                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16519                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16520                      *sss_ele_cut
16521
16522                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
16523                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16524                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
16525                      *sss_ele_cut
16526
16527                   gacontm_hb3(k,num_conti,i)=gggm(k) &
16528                      *sss_ele_cut
16529
16530                 enddo
16531               ENDIF ! wcorr
16532               endif  ! num_conti.le.maxconts
16533             endif  ! fcont.gt.0
16534           endif    ! j.gt.i+1
16535           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
16536             do k=1,4
16537               do l=1,3
16538                 ghalf=0.5d0*agg(l,k)
16539                 aggi(l,k)=aggi(l,k)+ghalf
16540                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
16541                 aggj(l,k)=aggj(l,k)+ghalf
16542               enddo
16543             enddo
16544             if (j.eq.nres-1 .and. i.lt.j-2) then
16545               do k=1,4
16546                 do l=1,3
16547                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
16548                 enddo
16549               enddo
16550             endif
16551           endif
16552  128      continue
16553 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
16554       return
16555       end subroutine eelecij_scale
16556 !-----------------------------------------------------------------------------
16557       subroutine evdwpp_short(evdw1)
16558 !
16559 ! Compute Evdwpp
16560 !
16561 !      implicit real(kind=8) (a-h,o-z)
16562 !      include 'DIMENSIONS'
16563 !      include 'COMMON.CONTROL'
16564 !      include 'COMMON.IOUNITS'
16565 !      include 'COMMON.GEO'
16566 !      include 'COMMON.VAR'
16567 !      include 'COMMON.LOCAL'
16568 !      include 'COMMON.CHAIN'
16569 !      include 'COMMON.DERIV'
16570 !      include 'COMMON.INTERACT'
16571 !      include 'COMMON.CONTACTS'
16572 !      include 'COMMON.TORSION'
16573 !      include 'COMMON.VECTORS'
16574 !      include 'COMMON.FFIELD'
16575       real(kind=8),dimension(3) :: ggg
16576 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
16577 #ifdef MOMENT
16578       real(kind=8) :: scal_el=1.0d0
16579 #else
16580       real(kind=8) :: scal_el=0.5d0
16581 #endif
16582 !el local variables
16583       integer :: i,j,k,iteli,itelj,num_conti,isubchap
16584       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
16585       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
16586                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
16587                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
16588       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16589                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
16590                    sslipj,ssgradlipj,faclipij2
16591       integer xshift,yshift,zshift
16592
16593
16594       evdw1=0.0D0
16595 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
16596 !     & " iatel_e_vdw",iatel_e_vdw
16597       call flush(iout)
16598       do i=iatel_s_vdw,iatel_e_vdw
16599         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
16600         dxi=dc(1,i)
16601         dyi=dc(2,i)
16602         dzi=dc(3,i)
16603         dx_normi=dc_norm(1,i)
16604         dy_normi=dc_norm(2,i)
16605         dz_normi=dc_norm(3,i)
16606         xmedi=c(1,i)+0.5d0*dxi
16607         ymedi=c(2,i)+0.5d0*dyi
16608         zmedi=c(3,i)+0.5d0*dzi
16609         call to_box(xmedi,ymedi,zmedi)
16610         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
16611         num_conti=0
16612 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
16613 !     &   ' ielend',ielend_vdw(i)
16614         call flush(iout)
16615         do j=ielstart_vdw(i),ielend_vdw(i)
16616           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
16617 !el          ind=ind+1
16618           iteli=itel(i)
16619           itelj=itel(j)
16620           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
16621           aaa=app(iteli,itelj)
16622           bbb=bpp(iteli,itelj)
16623           dxj=dc(1,j)
16624           dyj=dc(2,j)
16625           dzj=dc(3,j)
16626           dx_normj=dc_norm(1,j)
16627           dy_normj=dc_norm(2,j)
16628           dz_normj=dc_norm(3,j)
16629 !          xj=c(1,j)+0.5D0*dxj-xmedi
16630 !          yj=c(2,j)+0.5D0*dyj-ymedi
16631 !          zj=c(3,j)+0.5D0*dzj-zmedi
16632           xj=c(1,j)+0.5D0*dxj
16633           yj=c(2,j)+0.5D0*dyj
16634           zj=c(3,j)+0.5D0*dzj
16635           call to_box(xj,yj,zj)
16636           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
16637           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
16638           xj=boxshift(xj-xmedi,boxxsize)
16639           yj=boxshift(yj-ymedi,boxysize)
16640           zj=boxshift(zj-zmedi,boxzsize)
16641           rij=xj*xj+yj*yj+zj*zj
16642           rrmij=1.0D0/rij
16643           rij=dsqrt(rij)
16644           sss=sscale(rij/rpp(iteli,itelj))
16645             sss_ele_cut=sscale_ele(rij)
16646             sss_ele_grad=sscagrad_ele(rij)
16647             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
16648             if (sss_ele_cut.le.0.0) cycle
16649           if (sss.gt.0.0d0) then
16650             rmij=1.0D0/rij
16651             r3ij=rrmij*rmij
16652             r6ij=r3ij*r3ij
16653             ev1=aaa*r6ij*r6ij
16654 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
16655             if (j.eq.i+2) ev1=scal_el*ev1
16656             ev2=bbb*r6ij
16657             evdwij=ev1+ev2
16658             if (energy_dec) then
16659               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
16660             endif
16661             evdw1=evdw1+evdwij*sss*sss_ele_cut
16662 !
16663 ! Calculate contributions to the Cartesian gradient.
16664 !
16665             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
16666 !            ggg(1)=facvdw*xj
16667 !            ggg(2)=facvdw*yj
16668 !            ggg(3)=facvdw*zj
16669           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
16670           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
16671           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
16672           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
16673           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
16674           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
16675
16676             do k=1,3
16677               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16678               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16679             enddo
16680           endif
16681         enddo ! j
16682       enddo   ! i
16683       return
16684       end subroutine evdwpp_short
16685 !-----------------------------------------------------------------------------
16686       subroutine escp_long(evdw2,evdw2_14)
16687 !
16688 ! This subroutine calculates the excluded-volume interaction energy between
16689 ! peptide-group centers and side chains and its gradient in virtual-bond and
16690 ! side-chain vectors.
16691 !
16692 !      implicit real(kind=8) (a-h,o-z)
16693 !      include 'DIMENSIONS'
16694 !      include 'COMMON.GEO'
16695 !      include 'COMMON.VAR'
16696 !      include 'COMMON.LOCAL'
16697 !      include 'COMMON.CHAIN'
16698 !      include 'COMMON.DERIV'
16699 !      include 'COMMON.INTERACT'
16700 !      include 'COMMON.FFIELD'
16701 !      include 'COMMON.IOUNITS'
16702 !      include 'COMMON.CONTROL'
16703       real(kind=8),dimension(3) :: ggg
16704 !el local variables
16705       integer :: i,iint,j,k,iteli,itypj,subchap
16706       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16707       real(kind=8) :: evdw2,evdw2_14,evdwij
16708       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16709                     dist_temp, dist_init
16710
16711       evdw2=0.0D0
16712       evdw2_14=0.0d0
16713 !d    print '(a)','Enter ESCP'
16714 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16715       do i=iatscp_s,iatscp_e
16716         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16717         iteli=itel(i)
16718         xi=0.5D0*(c(1,i)+c(1,i+1))
16719         yi=0.5D0*(c(2,i)+c(2,i+1))
16720         zi=0.5D0*(c(3,i)+c(3,i+1))
16721         call to_box(xi,yi,zi)
16722         do iint=1,nscp_gr(i)
16723
16724         do j=iscpstart(i,iint),iscpend(i,iint)
16725           itypj=itype(j,1)
16726           if (itypj.eq.ntyp1) cycle
16727 ! Uncomment following three lines for SC-p interactions
16728 !         xj=c(1,nres+j)-xi
16729 !         yj=c(2,nres+j)-yi
16730 !         zj=c(3,nres+j)-zi
16731 ! Uncomment following three lines for Ca-p interactions
16732           xj=c(1,j)
16733           yj=c(2,j)
16734           zj=c(3,j)
16735           call to_box(xj,yj,zj)
16736           xj=boxshift(xj-xi,boxxsize)
16737           yj=boxshift(yj-yi,boxysize)
16738           zj=boxshift(zj-zi,boxzsize)
16739           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16740
16741           rij=dsqrt(1.0d0/rrij)
16742             sss_ele_cut=sscale_ele(rij)
16743             sss_ele_grad=sscagrad_ele(rij)
16744 !            print *,sss_ele_cut,sss_ele_grad,&
16745 !            (rij),r_cut_ele,rlamb_ele
16746             if (sss_ele_cut.le.0.0) cycle
16747           sss=sscale((rij/rscp(itypj,iteli)))
16748           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16749           if (sss.lt.1.0d0) then
16750
16751             fac=rrij**expon2
16752             e1=fac*fac*aad(itypj,iteli)
16753             e2=fac*bad(itypj,iteli)
16754             if (iabs(j-i) .le. 2) then
16755               e1=scal14*e1
16756               e2=scal14*e2
16757               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16758             endif
16759             evdwij=e1+e2
16760             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16761             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16762                 'evdw2',i,j,sss,evdwij
16763 !
16764 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16765 !
16766             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16767             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16768             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16769             ggg(1)=xj*fac
16770             ggg(2)=yj*fac
16771             ggg(3)=zj*fac
16772 ! Uncomment following three lines for SC-p interactions
16773 !           do k=1,3
16774 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16775 !           enddo
16776 ! Uncomment following line for SC-p interactions
16777 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16778             do k=1,3
16779               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16780               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16781             enddo
16782           endif
16783         enddo
16784
16785         enddo ! iint
16786       enddo ! i
16787       do i=1,nct
16788         do j=1,3
16789           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16790           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16791           gradx_scp(j,i)=expon*gradx_scp(j,i)
16792         enddo
16793       enddo
16794 !******************************************************************************
16795 !
16796 !                              N O T E !!!
16797 !
16798 ! To save time the factor EXPON has been extracted from ALL components
16799 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16800 ! use!
16801 !
16802 !******************************************************************************
16803       return
16804       end subroutine escp_long
16805 !-----------------------------------------------------------------------------
16806       subroutine escp_short(evdw2,evdw2_14)
16807 !
16808 ! This subroutine calculates the excluded-volume interaction energy between
16809 ! peptide-group centers and side chains and its gradient in virtual-bond and
16810 ! side-chain vectors.
16811 !
16812 !      implicit real(kind=8) (a-h,o-z)
16813 !      include 'DIMENSIONS'
16814 !      include 'COMMON.GEO'
16815 !      include 'COMMON.VAR'
16816 !      include 'COMMON.LOCAL'
16817 !      include 'COMMON.CHAIN'
16818 !      include 'COMMON.DERIV'
16819 !      include 'COMMON.INTERACT'
16820 !      include 'COMMON.FFIELD'
16821 !      include 'COMMON.IOUNITS'
16822 !      include 'COMMON.CONTROL'
16823       real(kind=8),dimension(3) :: ggg
16824 !el local variables
16825       integer :: i,iint,j,k,iteli,itypj,subchap
16826       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16827       real(kind=8) :: evdw2,evdw2_14,evdwij
16828       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16829                     dist_temp, dist_init
16830
16831       evdw2=0.0D0
16832       evdw2_14=0.0d0
16833 !d    print '(a)','Enter ESCP'
16834 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16835       do i=iatscp_s,iatscp_e
16836         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16837         iteli=itel(i)
16838         xi=0.5D0*(c(1,i)+c(1,i+1))
16839         yi=0.5D0*(c(2,i)+c(2,i+1))
16840         zi=0.5D0*(c(3,i)+c(3,i+1))
16841         call to_box(xi,yi,zi)
16842         if (zi.lt.0) zi=zi+boxzsize
16843
16844         do iint=1,nscp_gr(i)
16845
16846         do j=iscpstart(i,iint),iscpend(i,iint)
16847           itypj=itype(j,1)
16848           if (itypj.eq.ntyp1) cycle
16849 ! Uncomment following three lines for SC-p interactions
16850 !         xj=c(1,nres+j)-xi
16851 !         yj=c(2,nres+j)-yi
16852 !         zj=c(3,nres+j)-zi
16853 ! Uncomment following three lines for Ca-p interactions
16854 !          xj=c(1,j)-xi
16855 !          yj=c(2,j)-yi
16856 !          zj=c(3,j)-zi
16857           xj=c(1,j)
16858           yj=c(2,j)
16859           zj=c(3,j)
16860           call to_box(xj,yj,zj)
16861           xj=boxshift(xj-xi,boxxsize)
16862           yj=boxshift(yj-yi,boxysize)
16863           zj=boxshift(zj-zi,boxzsize)
16864           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16865           rij=dsqrt(1.0d0/rrij)
16866             sss_ele_cut=sscale_ele(rij)
16867             sss_ele_grad=sscagrad_ele(rij)
16868 !            print *,sss_ele_cut,sss_ele_grad,&
16869 !            (rij),r_cut_ele,rlamb_ele
16870             if (sss_ele_cut.le.0.0) cycle
16871           sss=sscale(rij/rscp(itypj,iteli))
16872           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16873           if (sss.gt.0.0d0) then
16874
16875             fac=rrij**expon2
16876             e1=fac*fac*aad(itypj,iteli)
16877             e2=fac*bad(itypj,iteli)
16878             if (iabs(j-i) .le. 2) then
16879               e1=scal14*e1
16880               e2=scal14*e2
16881               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16882             endif
16883             evdwij=e1+e2
16884             evdw2=evdw2+evdwij*sss*sss_ele_cut
16885             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16886                 'evdw2',i,j,sss,evdwij
16887 !
16888 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16889 !
16890             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16891             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16892             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16893
16894             ggg(1)=xj*fac
16895             ggg(2)=yj*fac
16896             ggg(3)=zj*fac
16897 ! Uncomment following three lines for SC-p interactions
16898 !           do k=1,3
16899 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16900 !           enddo
16901 ! Uncomment following line for SC-p interactions
16902 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16903             do k=1,3
16904               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16905               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16906             enddo
16907           endif
16908         enddo
16909
16910         enddo ! iint
16911       enddo ! i
16912       do i=1,nct
16913         do j=1,3
16914           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16915           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16916           gradx_scp(j,i)=expon*gradx_scp(j,i)
16917         enddo
16918       enddo
16919 !******************************************************************************
16920 !
16921 !                              N O T E !!!
16922 !
16923 ! To save time the factor EXPON has been extracted from ALL components
16924 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16925 ! use!
16926 !
16927 !******************************************************************************
16928       return
16929       end subroutine escp_short
16930 !-----------------------------------------------------------------------------
16931 ! energy_p_new-sep_barrier.F
16932 !-----------------------------------------------------------------------------
16933       subroutine sc_grad_scale(scalfac)
16934 !      implicit real(kind=8) (a-h,o-z)
16935       use calc_data
16936 !      include 'DIMENSIONS'
16937 !      include 'COMMON.CHAIN'
16938 !      include 'COMMON.DERIV'
16939 !      include 'COMMON.CALC'
16940 !      include 'COMMON.IOUNITS'
16941       real(kind=8),dimension(3) :: dcosom1,dcosom2
16942       real(kind=8) :: scalfac
16943 !el local variables
16944 !      integer :: i,j,k,l
16945
16946       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16947       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16948       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16949            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16950 ! diagnostics only
16951 !      eom1=0.0d0
16952 !      eom2=0.0d0
16953 !      eom12=evdwij*eps1_om12
16954 ! end diagnostics
16955 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16956 !     &  " sigder",sigder
16957 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16958 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16959       do k=1,3
16960         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16961         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16962       enddo
16963       do k=1,3
16964         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16965          *sss_ele_cut
16966       enddo
16967 !      write (iout,*) "gg",(gg(k),k=1,3)
16968       do k=1,3
16969         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16970                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16971                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16972                  *sss_ele_cut
16973         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16974                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16975                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16976          *sss_ele_cut
16977 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16978 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16979 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16980 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16981       enddo
16982 !
16983 ! Calculate the components of the gradient in DC and X
16984 !
16985       do l=1,3
16986         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16987         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16988       enddo
16989       return
16990       end subroutine sc_grad_scale
16991 !-----------------------------------------------------------------------------
16992 ! energy_split-sep.F
16993 !-----------------------------------------------------------------------------
16994       subroutine etotal_long(energia)
16995 !
16996 ! Compute the long-range slow-varying contributions to the energy
16997 !
16998 !      implicit real(kind=8) (a-h,o-z)
16999 !      include 'DIMENSIONS'
17000       use MD_data, only: totT,usampl,eq_time
17001 #ifndef ISNAN
17002       external proc_proc
17003 #ifdef WINPGI
17004 !MS$ATTRIBUTES C ::  proc_proc
17005 #endif
17006 #endif
17007 #ifdef MPI
17008       include "mpif.h"
17009       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
17010 #endif
17011 !      include 'COMMON.SETUP'
17012 !      include 'COMMON.IOUNITS'
17013 !      include 'COMMON.FFIELD'
17014 !      include 'COMMON.DERIV'
17015 !      include 'COMMON.INTERACT'
17016 !      include 'COMMON.SBRIDGE'
17017 !      include 'COMMON.CHAIN'
17018 !      include 'COMMON.VAR'
17019 !      include 'COMMON.LOCAL'
17020 !      include 'COMMON.MD'
17021       real(kind=8),dimension(0:n_ene) :: energia
17022 !el local variables
17023       integer :: i,n_corr,n_corr1,ierror,ierr
17024       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
17025                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
17026                   ecorr,ecorr5,ecorr6,eturn6,time00, ehomology_constr
17027 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
17028 !elwrite(iout,*)"in etotal long"
17029
17030       if (modecalc.eq.12.or.modecalc.eq.14) then
17031 #ifdef MPI
17032 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
17033 #else
17034         call int_from_cart1(.false.)
17035 #endif
17036       endif
17037 !elwrite(iout,*)"in etotal long"
17038       ehomology_constr=0.0d0
17039 #ifdef MPI
17040 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
17041 !     & " absolute rank",myrank," nfgtasks",nfgtasks
17042       call flush(iout)
17043       if (nfgtasks.gt.1) then
17044         time00=MPI_Wtime()
17045 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
17046         if (fg_rank.eq.0) then
17047           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
17048 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
17049 !          call flush(iout)
17050 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
17051 ! FG slaves as WEIGHTS array.
17052           weights_(1)=wsc
17053           weights_(2)=wscp
17054           weights_(3)=welec
17055           weights_(4)=wcorr
17056           weights_(5)=wcorr5
17057           weights_(6)=wcorr6
17058           weights_(7)=wel_loc
17059           weights_(8)=wturn3
17060           weights_(9)=wturn4
17061           weights_(10)=wturn6
17062           weights_(11)=wang
17063           weights_(12)=wscloc
17064           weights_(13)=wtor
17065           weights_(14)=wtor_d
17066           weights_(15)=wstrain
17067           weights_(16)=wvdwpp
17068           weights_(17)=wbond
17069           weights_(18)=scal14
17070           weights_(21)=wsccor
17071 ! FG Master broadcasts the WEIGHTS_ array
17072           call MPI_Bcast(weights_(1),n_ene,&
17073               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17074         else
17075 ! FG slaves receive the WEIGHTS array
17076           call MPI_Bcast(weights(1),n_ene,&
17077               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17078           wsc=weights(1)
17079           wscp=weights(2)
17080           welec=weights(3)
17081           wcorr=weights(4)
17082           wcorr5=weights(5)
17083           wcorr6=weights(6)
17084           wel_loc=weights(7)
17085           wturn3=weights(8)
17086           wturn4=weights(9)
17087           wturn6=weights(10)
17088           wang=weights(11)
17089           wscloc=weights(12)
17090           wtor=weights(13)
17091           wtor_d=weights(14)
17092           wstrain=weights(15)
17093           wvdwpp=weights(16)
17094           wbond=weights(17)
17095           scal14=weights(18)
17096           wsccor=weights(21)
17097         endif
17098         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
17099           king,FG_COMM,IERR)
17100          time_Bcast=time_Bcast+MPI_Wtime()-time00
17101          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
17102 !        call chainbuild_cart
17103 !        call int_from_cart1(.false.)
17104       endif
17105 !      write (iout,*) 'Processor',myrank,
17106 !     &  ' calling etotal_short ipot=',ipot
17107 !      call flush(iout)
17108 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
17109 #endif
17110 !d    print *,'nnt=',nnt,' nct=',nct
17111 !
17112 !elwrite(iout,*)"in etotal long"
17113 ! Compute the side-chain and electrostatic interaction energy
17114 !
17115       goto (101,102,103,104,105,106) ipot
17116 ! Lennard-Jones potential.
17117   101 call elj_long(evdw)
17118 !d    print '(a)','Exit ELJ'
17119       goto 107
17120 ! Lennard-Jones-Kihara potential (shifted).
17121   102 call eljk_long(evdw)
17122       goto 107
17123 ! Berne-Pechukas potential (dilated LJ, angular dependence).
17124   103 call ebp_long(evdw)
17125       goto 107
17126 ! Gay-Berne potential (shifted LJ, angular dependence).
17127   104 call egb_long(evdw)
17128       goto 107
17129 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
17130   105 call egbv_long(evdw)
17131       goto 107
17132 ! Soft-sphere potential
17133   106 call e_softsphere(evdw)
17134 !
17135 ! Calculate electrostatic (H-bonding) energy of the main chain.
17136 !
17137   107 continue
17138       call vec_and_deriv
17139       if (ipot.lt.6) then
17140 #ifdef SPLITELE
17141          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
17142              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
17143              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
17144              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
17145 #else
17146          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
17147              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
17148              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
17149              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
17150 #endif
17151            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
17152          else
17153             ees=0
17154             evdw1=0
17155             eel_loc=0
17156             eello_turn3=0
17157             eello_turn4=0
17158          endif
17159       else
17160 !        write (iout,*) "Soft-spheer ELEC potential"
17161         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
17162          eello_turn4)
17163       endif
17164 !
17165 ! Calculate excluded-volume interaction energy between peptide groups
17166 ! and side chains.
17167 !
17168       if (ipot.lt.6) then
17169        if(wscp.gt.0d0) then
17170         call escp_long(evdw2,evdw2_14)
17171        else
17172         evdw2=0
17173         evdw2_14=0
17174        endif
17175       else
17176         call escp_soft_sphere(evdw2,evdw2_14)
17177       endif
17178 !
17179 ! 12/1/95 Multi-body terms
17180 !
17181       n_corr=0
17182       n_corr1=0
17183       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
17184           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
17185          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
17186 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
17187 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
17188       else
17189          ecorr=0.0d0
17190          ecorr5=0.0d0
17191          ecorr6=0.0d0
17192          eturn6=0.0d0
17193       endif
17194       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
17195          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
17196       endif
17197 !
17198 ! If performing constraint dynamics, call the constraint energy
17199 !  after the equilibration time
17200       if(usampl.and.totT.gt.eq_time) then
17201          call EconstrQ
17202          call Econstr_back
17203       else
17204          Uconst=0.0d0
17205          Uconst_back=0.0d0
17206       endif
17207 !
17208 ! Sum the energies
17209 !
17210       do i=1,n_ene
17211         energia(i)=0.0d0
17212       enddo
17213       energia(1)=evdw
17214 #ifdef SCP14
17215       energia(2)=evdw2-evdw2_14
17216       energia(18)=evdw2_14
17217 #else
17218       energia(2)=evdw2
17219       energia(18)=0.0d0
17220 #endif
17221 #ifdef SPLITELE
17222       energia(3)=ees
17223       energia(16)=evdw1
17224 #else
17225       energia(3)=ees+evdw1
17226       energia(16)=0.0d0
17227 #endif
17228       energia(4)=ecorr
17229       energia(5)=ecorr5
17230       energia(6)=ecorr6
17231       energia(7)=eel_loc
17232       energia(8)=eello_turn3
17233       energia(9)=eello_turn4
17234       energia(10)=eturn6
17235       energia(20)=Uconst+Uconst_back
17236       energia(51)=ehomology_constr
17237       call sum_energy(energia,.true.)
17238 !      write (iout,*) "Exit ETOTAL_LONG"
17239       call flush(iout)
17240       return
17241       end subroutine etotal_long
17242 !-----------------------------------------------------------------------------
17243       subroutine etotal_short(energia)
17244 !
17245 ! Compute the short-range fast-varying contributions to the energy
17246 !
17247 !      implicit real(kind=8) (a-h,o-z)
17248 !      include 'DIMENSIONS'
17249 #ifndef ISNAN
17250       external proc_proc
17251 #ifdef WINPGI
17252 !MS$ATTRIBUTES C ::  proc_proc
17253 #endif
17254 #endif
17255 #ifdef MPI
17256       include "mpif.h"
17257       integer :: ierror,ierr
17258       real(kind=8),dimension(n_ene) :: weights_
17259       real(kind=8) :: time00
17260 #endif
17261 !      include 'COMMON.SETUP'
17262 !      include 'COMMON.IOUNITS'
17263 !      include 'COMMON.FFIELD'
17264 !      include 'COMMON.DERIV'
17265 !      include 'COMMON.INTERACT'
17266 !      include 'COMMON.SBRIDGE'
17267 !      include 'COMMON.CHAIN'
17268 !      include 'COMMON.VAR'
17269 !      include 'COMMON.LOCAL'
17270       real(kind=8),dimension(0:n_ene) :: energia
17271 !el local variables
17272       integer :: i,nres6
17273       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
17274       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr, &
17275                       ehomology_constr
17276       nres6=6*nres
17277
17278 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
17279 !      call flush(iout)
17280       if (modecalc.eq.12.or.modecalc.eq.14) then
17281 #ifdef MPI
17282         if (fg_rank.eq.0) call int_from_cart1(.false.)
17283 #else
17284         call int_from_cart1(.false.)
17285 #endif
17286       endif
17287 #ifdef MPI
17288 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
17289 !     & " absolute rank",myrank," nfgtasks",nfgtasks
17290 !      call flush(iout)
17291       if (nfgtasks.gt.1) then
17292         time00=MPI_Wtime()
17293 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
17294         if (fg_rank.eq.0) then
17295           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
17296 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
17297 !          call flush(iout)
17298 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
17299 ! FG slaves as WEIGHTS array.
17300           weights_(1)=wsc
17301           weights_(2)=wscp
17302           weights_(3)=welec
17303           weights_(4)=wcorr
17304           weights_(5)=wcorr5
17305           weights_(6)=wcorr6
17306           weights_(7)=wel_loc
17307           weights_(8)=wturn3
17308           weights_(9)=wturn4
17309           weights_(10)=wturn6
17310           weights_(11)=wang
17311           weights_(12)=wscloc
17312           weights_(13)=wtor
17313           weights_(14)=wtor_d
17314           weights_(15)=wstrain
17315           weights_(16)=wvdwpp
17316           weights_(17)=wbond
17317           weights_(18)=scal14
17318           weights_(21)=wsccor
17319 ! FG Master broadcasts the WEIGHTS_ array
17320           call MPI_Bcast(weights_(1),n_ene,&
17321               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17322         else
17323 ! FG slaves receive the WEIGHTS array
17324           call MPI_Bcast(weights(1),n_ene,&
17325               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
17326           wsc=weights(1)
17327           wscp=weights(2)
17328           welec=weights(3)
17329           wcorr=weights(4)
17330           wcorr5=weights(5)
17331           wcorr6=weights(6)
17332           wel_loc=weights(7)
17333           wturn3=weights(8)
17334           wturn4=weights(9)
17335           wturn6=weights(10)
17336           wang=weights(11)
17337           wscloc=weights(12)
17338           wtor=weights(13)
17339           wtor_d=weights(14)
17340           wstrain=weights(15)
17341           wvdwpp=weights(16)
17342           wbond=weights(17)
17343           scal14=weights(18)
17344           wsccor=weights(21)
17345         endif
17346 !        write (iout,*),"Processor",myrank," BROADCAST weights"
17347         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
17348           king,FG_COMM,IERR)
17349 !        write (iout,*) "Processor",myrank," BROADCAST c"
17350         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
17351           king,FG_COMM,IERR)
17352 !        write (iout,*) "Processor",myrank," BROADCAST dc"
17353         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
17354           king,FG_COMM,IERR)
17355 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
17356         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
17357           king,FG_COMM,IERR)
17358 !        write (iout,*) "Processor",myrank," BROADCAST theta"
17359         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
17360           king,FG_COMM,IERR)
17361 !        write (iout,*) "Processor",myrank," BROADCAST phi"
17362         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
17363           king,FG_COMM,IERR)
17364 !        write (iout,*) "Processor",myrank," BROADCAST alph"
17365         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
17366           king,FG_COMM,IERR)
17367 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
17368         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
17369           king,FG_COMM,IERR)
17370 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
17371         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
17372           king,FG_COMM,IERR)
17373          time_Bcast=time_Bcast+MPI_Wtime()-time00
17374 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
17375       endif
17376 !      write (iout,*) 'Processor',myrank,
17377 !     &  ' calling etotal_short ipot=',ipot
17378 !      call flush(iout)
17379 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
17380 #endif
17381 !      call int_from_cart1(.false.)
17382 !
17383 ! Compute the side-chain and electrostatic interaction energy
17384 !
17385       goto (101,102,103,104,105,106) ipot
17386 ! Lennard-Jones potential.
17387   101 call elj_short(evdw)
17388 !d    print '(a)','Exit ELJ'
17389       goto 107
17390 ! Lennard-Jones-Kihara potential (shifted).
17391   102 call eljk_short(evdw)
17392       goto 107
17393 ! Berne-Pechukas potential (dilated LJ, angular dependence).
17394   103 call ebp_short(evdw)
17395       goto 107
17396 ! Gay-Berne potential (shifted LJ, angular dependence).
17397   104 call egb_short(evdw)
17398       goto 107
17399 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
17400   105 call egbv_short(evdw)
17401       goto 107
17402 ! Soft-sphere potential - already dealt with in the long-range part
17403   106 evdw=0.0d0
17404 !  106 call e_softsphere_short(evdw)
17405 !
17406 ! Calculate electrostatic (H-bonding) energy of the main chain.
17407 !
17408   107 continue
17409 !
17410 ! Calculate the short-range part of Evdwpp
17411 !
17412       call evdwpp_short(evdw1)
17413 !
17414 ! Calculate the short-range part of ESCp
17415 !
17416       if (ipot.lt.6) then
17417        call escp_short(evdw2,evdw2_14)
17418       endif
17419 !
17420 ! Calculate the bond-stretching energy
17421 !
17422       call ebond(estr)
17423 !
17424 ! Calculate the disulfide-bridge and other energy and the contributions
17425 ! from other distance constraints.
17426 !      call edis(ehpb)
17427 !
17428 ! Calculate the virtual-bond-angle energy.
17429 !
17430 ! Calculate the SC local energy.
17431 !
17432       call vec_and_deriv
17433       call esc(escloc)
17434 !
17435       if (wang.gt.0d0) then
17436        if (tor_mode.eq.0) then
17437            call ebend(ebe)
17438        else
17439 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
17440 !C energy function
17441         call ebend_kcc(ebe)
17442        endif
17443       else
17444           ebe=0.0d0
17445       endif
17446       ethetacnstr=0.0d0
17447       if (with_theta_constr) call etheta_constr(ethetacnstr)
17448
17449 !       write(iout,*) "in etotal afer ebe",ipot
17450
17451 !      print *,"Processor",myrank," computed UB"
17452 !
17453 ! Calculate the SC local energy.
17454 !
17455       call esc(escloc)
17456 !elwrite(iout,*) "in etotal afer esc",ipot
17457 !      print *,"Processor",myrank," computed USC"
17458 !
17459 ! Calculate the virtual-bond torsional energy.
17460 !
17461 !d    print *,'nterm=',nterm
17462 !      if (wtor.gt.0) then
17463 !       call etor(etors,edihcnstr)
17464 !      else
17465 !       etors=0
17466 !       edihcnstr=0
17467 !      endif
17468       if (wtor.gt.0.0d0) then
17469          if (tor_mode.eq.0) then
17470            call etor(etors)
17471           else
17472 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
17473 !C energy function
17474         call etor_kcc(etors)
17475          endif
17476       else
17477            etors=0.0d0
17478       endif
17479       edihcnstr=0.0d0
17480       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
17481
17482 ! Calculate the virtual-bond torsional energy.
17483 !
17484 !
17485 ! 6/23/01 Calculate double-torsional energy
17486 !
17487       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
17488       call etor_d(etors_d)
17489       endif
17490 !
17491 ! Homology restraints
17492 !
17493       if (constr_homology.ge.1) then
17494         call e_modeller(ehomology_constr)
17495 !      print *,"tu"
17496       else
17497         ehomology_constr=0.0d0
17498       endif
17499
17500 !
17501 ! 21/5/07 Calculate local sicdechain correlation energy
17502 !
17503       if (wsccor.gt.0.0d0) then
17504        call eback_sc_corr(esccor)
17505       else
17506        esccor=0.0d0
17507       endif
17508 !
17509 ! Put energy components into an array
17510 !
17511       do i=1,n_ene
17512        energia(i)=0.0d0
17513       enddo
17514       energia(1)=evdw
17515 #ifdef SCP14
17516       energia(2)=evdw2-evdw2_14
17517       energia(18)=evdw2_14
17518 #else
17519       energia(2)=evdw2
17520       energia(18)=0.0d0
17521 #endif
17522 #ifdef SPLITELE
17523       energia(16)=evdw1
17524 #else
17525       energia(3)=evdw1
17526 #endif
17527       energia(11)=ebe
17528       energia(12)=escloc
17529       energia(13)=etors
17530       energia(14)=etors_d
17531       energia(15)=ehpb
17532       energia(17)=estr
17533       energia(19)=edihcnstr
17534       energia(21)=esccor
17535       energia(51)=ehomology_constr
17536 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
17537       call flush(iout)
17538       call sum_energy(energia,.true.)
17539 !      write (iout,*) "Exit ETOTAL_SHORT"
17540       call flush(iout)
17541       return
17542       end subroutine etotal_short
17543 !-----------------------------------------------------------------------------
17544 ! gnmr1.f
17545 !-----------------------------------------------------------------------------
17546       real(kind=8) function gnmr1(y,ymin,ymax)
17547 !      implicit none
17548       real(kind=8) :: y,ymin,ymax
17549       real(kind=8) :: wykl=4.0d0
17550       if (y.lt.ymin) then
17551         gnmr1=(ymin-y)**wykl/wykl
17552       else if (y.gt.ymax) then
17553        gnmr1=(y-ymax)**wykl/wykl
17554       else
17555        gnmr1=0.0d0
17556       endif
17557       return
17558       end function gnmr1
17559 !-----------------------------------------------------------------------------
17560       real(kind=8) function gnmr1prim(y,ymin,ymax)
17561 !      implicit none
17562       real(kind=8) :: y,ymin,ymax
17563       real(kind=8) :: wykl=4.0d0
17564       if (y.lt.ymin) then
17565        gnmr1prim=-(ymin-y)**(wykl-1)
17566       else if (y.gt.ymax) then
17567        gnmr1prim=(y-ymax)**(wykl-1)
17568       else
17569        gnmr1prim=0.0d0
17570       endif
17571       return
17572       end function gnmr1prim
17573 !----------------------------------------------------------------------------
17574       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
17575       real(kind=8) y,ymin,ymax,sigma
17576       real(kind=8) wykl /4.0d0/
17577       if (y.lt.ymin) then
17578         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
17579       else if (y.gt.ymax) then
17580        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
17581       else
17582         rlornmr1=0.0d0
17583       endif
17584       return
17585       end function rlornmr1
17586 !------------------------------------------------------------------------------
17587       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
17588       real(kind=8) y,ymin,ymax,sigma
17589       real(kind=8) wykl /4.0d0/
17590       if (y.lt.ymin) then
17591         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
17592         ((ymin-y)**wykl+sigma**wykl)**2
17593       else if (y.gt.ymax) then
17594          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
17595         ((y-ymax)**wykl+sigma**wykl)**2
17596       else
17597        rlornmr1prim=0.0d0
17598       endif
17599       return
17600       end function rlornmr1prim
17601
17602       real(kind=8) function harmonic(y,ymax)
17603 !      implicit none
17604       real(kind=8) :: y,ymax
17605       real(kind=8) :: wykl=2.0d0
17606       harmonic=(y-ymax)**wykl
17607       return
17608       end function harmonic
17609 !-----------------------------------------------------------------------------
17610       real(kind=8) function harmonicprim(y,ymax)
17611       real(kind=8) :: y,ymin,ymax
17612       real(kind=8) :: wykl=2.0d0
17613       harmonicprim=(y-ymax)*wykl
17614       return
17615       end function harmonicprim
17616 !-----------------------------------------------------------------------------
17617 ! gradient_p.F
17618 !-----------------------------------------------------------------------------
17619       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
17620
17621       use io_base, only:intout,briefout
17622 !      implicit real(kind=8) (a-h,o-z)
17623 !      include 'DIMENSIONS'
17624 !      include 'COMMON.CHAIN'
17625 !      include 'COMMON.DERIV'
17626 !      include 'COMMON.VAR'
17627 !      include 'COMMON.INTERACT'
17628 !      include 'COMMON.FFIELD'
17629 !      include 'COMMON.MD'
17630 !      include 'COMMON.IOUNITS'
17631       real(kind=8),external :: ufparm
17632       integer :: uiparm(1)
17633       real(kind=8) :: urparm(1)
17634       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
17635       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
17636       integer :: n,nf,ind,ind1,i,k,j
17637 !
17638 ! This subroutine calculates total internal coordinate gradient.
17639 ! Depending on the number of function evaluations, either whole energy
17640 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
17641 ! internal coordinates are reevaluated or only the cartesian-in-internal
17642 ! coordinate derivatives are evaluated. The subroutine was designed to work
17643 ! with SUMSL.
17644 !
17645 !
17646       icg=mod(nf,2)+1
17647
17648 !d      print *,'grad',nf,icg
17649       if (nf-nfl+1) 20,30,40
17650    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
17651 !    write (iout,*) 'grad 20'
17652       if (nf.eq.0) return
17653       goto 40
17654    30 call var_to_geom(n,x)
17655       call chainbuild
17656 !    write (iout,*) 'grad 30'
17657 !
17658 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
17659 !
17660    40 call cartder
17661 !     write (iout,*) 'grad 40'
17662 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
17663 !
17664 ! Convert the Cartesian gradient into internal-coordinate gradient.
17665 !
17666       ind=0
17667       ind1=0
17668       do i=1,nres-2
17669       gthetai=0.0D0
17670       gphii=0.0D0
17671       do j=i+1,nres-1
17672         ind=ind+1
17673 !         ind=indmat(i,j)
17674 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
17675        do k=1,3
17676        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
17677         enddo
17678         do k=1,3
17679         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
17680          enddo
17681        enddo
17682       do j=i+1,nres-1
17683         ind1=ind1+1
17684 !         ind1=indmat(i,j)
17685 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
17686         do k=1,3
17687           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
17688           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
17689           enddo
17690         enddo
17691       if (i.gt.1) g(i-1)=gphii
17692       if (n.gt.nphi) g(nphi+i)=gthetai
17693       enddo
17694       if (n.le.nphi+ntheta) goto 10
17695       do i=2,nres-1
17696       if (itype(i,1).ne.10) then
17697           galphai=0.0D0
17698         gomegai=0.0D0
17699         do k=1,3
17700           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17701           enddo
17702         do k=1,3
17703           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17704           enddo
17705           g(ialph(i,1))=galphai
17706         g(ialph(i,1)+nside)=gomegai
17707         endif
17708       enddo
17709 !
17710 ! Add the components corresponding to local energy terms.
17711 !
17712    10 continue
17713       do i=1,nvar
17714 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17715         g(i)=g(i)+gloc(i,icg)
17716       enddo
17717 ! Uncomment following three lines for diagnostics.
17718 !d    call intout
17719 !elwrite(iout,*) "in gradient after calling intout"
17720 !d    call briefout(0,0.0d0)
17721 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17722       return
17723       end subroutine gradient
17724 !-----------------------------------------------------------------------------
17725       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17726
17727       use comm_chu
17728 !      implicit real(kind=8) (a-h,o-z)
17729 !      include 'DIMENSIONS'
17730 !      include 'COMMON.DERIV'
17731 !      include 'COMMON.IOUNITS'
17732 !      include 'COMMON.GEO'
17733       integer :: n,nf
17734 !el      integer :: jjj
17735 !el      common /chuju/ jjj
17736       real(kind=8) :: energia(0:n_ene)
17737       integer :: uiparm(1)
17738       real(kind=8) :: urparm(1)
17739       real(kind=8) :: f
17740       real(kind=8),external :: ufparm
17741       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17742 !     if (jjj.gt.0) then
17743 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17744 !     endif
17745       nfl=nf
17746       icg=mod(nf,2)+1
17747 !d      print *,'func',nf,nfl,icg
17748       call var_to_geom(n,x)
17749       call zerograd
17750       call chainbuild
17751 !d    write (iout,*) 'ETOTAL called from FUNC'
17752       call etotal(energia)
17753       call sum_gradient
17754       f=energia(0)
17755 !     if (jjj.gt.0) then
17756 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17757 !       write (iout,*) 'f=',etot
17758 !       jjj=0
17759 !     endif
17760       return
17761       end subroutine func
17762 !-----------------------------------------------------------------------------
17763       subroutine cartgrad
17764 !      implicit real(kind=8) (a-h,o-z)
17765 !      include 'DIMENSIONS'
17766       use energy_data
17767       use MD_data, only: totT,usampl,eq_time
17768 #ifdef MPI
17769       include 'mpif.h'
17770 #endif
17771 !      include 'COMMON.CHAIN'
17772 !      include 'COMMON.DERIV'
17773 !      include 'COMMON.VAR'
17774 !      include 'COMMON.INTERACT'
17775 !      include 'COMMON.FFIELD'
17776 !      include 'COMMON.MD'
17777 !      include 'COMMON.IOUNITS'
17778 !      include 'COMMON.TIME1'
17779 !
17780       integer :: i,j
17781       real(kind=8) :: time00,time01
17782
17783 ! This subrouting calculates total Cartesian coordinate gradient.
17784 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17785 !
17786 !#define DEBUG
17787 #ifdef TIMINGtime01
17788       time00=MPI_Wtime()
17789 #endif
17790       icg=1
17791       call sum_gradient
17792 #ifdef TIMING
17793 #endif
17794 !#define DEBUG
17795 !el      write (iout,*) "After sum_gradient"
17796 #ifdef DEBUG
17797       write (iout,*) "After sum_gradient"
17798       do i=1,nres-1
17799         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17800         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17801       enddo
17802 #endif
17803 !#undef DEBUG
17804 ! If performing constraint dynamics, add the gradients of the constraint energy
17805       if(usampl.and.totT.gt.eq_time) then
17806          do i=1,nct
17807            do j=1,3
17808              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17809              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17810            enddo
17811          enddo
17812          do i=1,nres-3
17813            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17814          enddo
17815          do i=1,nres-2
17816            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17817          enddo
17818       endif
17819 !elwrite (iout,*) "After sum_gradient"
17820 #ifdef TIMING
17821       time01=MPI_Wtime()
17822 #endif
17823       call intcartderiv
17824 !elwrite (iout,*) "After sum_gradient"
17825 #ifdef TIMING
17826       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17827 #endif
17828 !     call checkintcartgrad
17829 !     write(iout,*) 'calling int_to_cart'
17830 !#define DEBUG
17831 #ifdef DEBUG
17832       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17833 #endif
17834       do i=0,nct
17835         do j=1,3
17836           gcart(j,i)=gradc(j,i,icg)
17837           gxcart(j,i)=gradx(j,i,icg)
17838 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17839         enddo
17840 #ifdef DEBUG
17841         write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),&
17842           (gxcart(j,i),j=1,3),gloc(i,icg),(gloc_sc(j,i,icg),j=1,3)
17843 #endif
17844       enddo
17845 #ifdef TIMING
17846       time01=MPI_Wtime()
17847 #endif
17848 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17849       call int_to_cart
17850 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17851
17852 #ifdef TIMING
17853             time_inttocart=time_inttocart+MPI_Wtime()-time01
17854 #endif
17855 #ifdef DEBUG
17856             write (iout,*) "gcart and gxcart after int_to_cart"
17857             do i=0,nres-1
17858             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17859             (gxcart(j,i),j=1,3)
17860             enddo
17861 #endif
17862 !#undef DEBUG
17863 #ifdef CARGRAD
17864 #ifdef DEBUG
17865             write (iout,*) "CARGRAD"
17866 #endif
17867             do i=nres,0,-1
17868             do j=1,3
17869               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17870       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17871             enddo
17872       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17873       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17874             enddo
17875       ! Correction: dummy residues
17876             if (nnt.gt.1) then
17877               do j=1,3
17878       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17879             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17880             enddo
17881           endif
17882           if (nct.lt.nres) then
17883             do j=1,3
17884       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17885             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17886             enddo
17887           endif
17888 #endif
17889 #ifdef TIMING
17890           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17891 #endif
17892 !#undef DEBUG
17893           return
17894           end subroutine cartgrad
17895
17896 #ifdef FIVEDIAG
17897       subroutine grad_transform
17898       implicit none
17899 #ifdef MPI
17900       include 'mpif.h'
17901 #endif
17902       integer i,j,kk
17903 #ifdef DEBUG
17904       write (iout,*)"Converting virtual-bond gradient to CA/SC gradient"
17905       write (iout,*) "dC/dX gradient"
17906       do i=0,nres
17907         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
17908      &      (gxcart(j,i),j=1,3)
17909       enddo
17910 #endif
17911       do i=nres,1,-1
17912         do j=1,3
17913           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17914 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17915         enddo
17916 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17917 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17918       enddo
17919 ! Correction: dummy residues
17920       do i=2,nres
17921         if (itype(i-1).eq.ntyp1 .and. itype(i).ne.ntyp1) then
17922           gcart(:,i)=gcart(:,i)+gcart(:,i-1)
17923         else if (itype(i-1).ne.ntyp1 .and. itype(i).eq.ntyp1) then
17924           gcart(:,i-1)=gcart(:,i-1)+gcart(:,i)
17925         endif
17926       enddo
17927 c      if (nnt.gt.1) then
17928 c        do j=1,3
17929 c          gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17930 c        enddo
17931 c      endif
17932 c      if (nct.lt.nres) then
17933 c        do j=1,3
17934 c!          gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17935 c          gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17936 c        enddo
17937 c      endif
17938 #ifdef DEBUG
17939       write (iout,*) "CA/SC gradient"
17940       do i=1,nres
17941         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
17942      &      (gxcart(j,i),j=1,3)
17943       enddo
17944 #endif
17945       return
17946       end subroutine grad_transform
17947 #endif
17948
17949       !-----------------------------------------------------------------------------
17950           subroutine zerograd
17951       !      implicit real(kind=8) (a-h,o-z)
17952       !      include 'DIMENSIONS'
17953       !      include 'COMMON.DERIV'
17954       !      include 'COMMON.CHAIN'
17955       !      include 'COMMON.VAR'
17956       !      include 'COMMON.MD'
17957       !      include 'COMMON.SCCOR'
17958       !
17959       !el local variables
17960           integer :: i,j,intertyp,k
17961       ! Initialize Cartesian-coordinate gradient
17962       !
17963       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17964       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17965
17966       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17967       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17968       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17969       !      allocate(gradcorr_long(3,nres))
17970       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17971       !      allocate(gcorr6_turn_long(3,nres))
17972       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17973
17974       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17975
17976       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17977       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17978
17979       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17980       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17981
17982       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17983       !      allocate(gscloc(3,nres)) !(3,maxres)
17984       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17985
17986
17987
17988       !      common /deriv_scloc/
17989       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17990       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17991       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17992       !      common /mpgrad/
17993       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17994
17995
17996
17997       !          gradc(j,i,icg)=0.0d0
17998       !          gradx(j,i,icg)=0.0d0
17999
18000       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
18001       !elwrite(iout,*) "icg",icg
18002           do i=-1,nres
18003           do j=1,3
18004             gvdwx(j,i)=0.0D0
18005             gradx_scp(j,i)=0.0D0
18006             gvdwc(j,i)=0.0D0
18007             gvdwc_scp(j,i)=0.0D0
18008             gvdwc_scpp(j,i)=0.0d0
18009             gelc(j,i)=0.0D0
18010             gelc_long(j,i)=0.0D0
18011             gradb(j,i)=0.0d0
18012             gradbx(j,i)=0.0d0
18013             gvdwpp(j,i)=0.0d0
18014             gel_loc(j,i)=0.0d0
18015             gel_loc_long(j,i)=0.0d0
18016             ghpbc(j,i)=0.0D0
18017             ghpbx(j,i)=0.0D0
18018             gcorr3_turn(j,i)=0.0d0
18019             gcorr4_turn(j,i)=0.0d0
18020             gradcorr(j,i)=0.0d0
18021             gradcorr_long(j,i)=0.0d0
18022             gradcorr5_long(j,i)=0.0d0
18023             gradcorr6_long(j,i)=0.0d0
18024             gcorr6_turn_long(j,i)=0.0d0
18025             gradcorr5(j,i)=0.0d0
18026             gradcorr6(j,i)=0.0d0
18027             gcorr6_turn(j,i)=0.0d0
18028             gsccorc(j,i)=0.0d0
18029             gsccorx(j,i)=0.0d0
18030             gradc(j,i,icg)=0.0d0
18031             gradx(j,i,icg)=0.0d0
18032             gscloc(j,i)=0.0d0
18033             gsclocx(j,i)=0.0d0
18034             gliptran(j,i)=0.0d0
18035             gliptranx(j,i)=0.0d0
18036             gliptranc(j,i)=0.0d0
18037             gshieldx(j,i)=0.0d0
18038             gshieldc(j,i)=0.0d0
18039             gshieldc_loc(j,i)=0.0d0
18040             gshieldx_ec(j,i)=0.0d0
18041             gshieldc_ec(j,i)=0.0d0
18042             gshieldc_loc_ec(j,i)=0.0d0
18043             gshieldx_t3(j,i)=0.0d0
18044             gshieldc_t3(j,i)=0.0d0
18045             gshieldc_loc_t3(j,i)=0.0d0
18046             gshieldx_t4(j,i)=0.0d0
18047             gshieldc_t4(j,i)=0.0d0
18048             gshieldc_loc_t4(j,i)=0.0d0
18049             gshieldx_ll(j,i)=0.0d0
18050             gshieldc_ll(j,i)=0.0d0
18051             gshieldc_loc_ll(j,i)=0.0d0
18052             gg_tube(j,i)=0.0d0
18053             gg_tube_sc(j,i)=0.0d0
18054             gradafm(j,i)=0.0d0
18055             gradb_nucl(j,i)=0.0d0
18056             gradbx_nucl(j,i)=0.0d0
18057             gvdwpp_nucl(j,i)=0.0d0
18058             gvdwpp(j,i)=0.0d0
18059             gelpp(j,i)=0.0d0
18060             gvdwpsb(j,i)=0.0d0
18061             gvdwpsb1(j,i)=0.0d0
18062             gvdwsbc(j,i)=0.0d0
18063             gvdwsbx(j,i)=0.0d0
18064             gelsbc(j,i)=0.0d0
18065             gradcorr_nucl(j,i)=0.0d0
18066             gradcorr3_nucl(j,i)=0.0d0
18067             gradxorr_nucl(j,i)=0.0d0
18068             gradxorr3_nucl(j,i)=0.0d0
18069             gelsbx(j,i)=0.0d0
18070             gsbloc(j,i)=0.0d0
18071             gsblocx(j,i)=0.0d0
18072             gradpepcat(j,i)=0.0d0
18073             gradpepcatx(j,i)=0.0d0
18074             gradcatcat(j,i)=0.0d0
18075             gvdwx_scbase(j,i)=0.0d0
18076             gvdwc_scbase(j,i)=0.0d0
18077             gvdwx_pepbase(j,i)=0.0d0
18078             gvdwc_pepbase(j,i)=0.0d0
18079             gvdwx_scpho(j,i)=0.0d0
18080             gvdwc_scpho(j,i)=0.0d0
18081             gvdwc_peppho(j,i)=0.0d0
18082             gradnuclcatx(j,i)=0.0d0
18083             gradnuclcat(j,i)=0.0d0
18084             gradlipbond(j,i)=0.0d0
18085             gradlipang(j,i)=0.0d0
18086             gradliplj(j,i)=0.0d0
18087             gradlipelec(j,i)=0.0d0
18088             gradcattranc(j,i)=0.0d0
18089             gradcattranx(j,i)=0.0d0
18090             gradcatangx(j,i)=0.0d0
18091             gradcatangc(j,i)=0.0d0
18092             duscdiff(j,i)=0.0d0
18093             duscdiffx(j,i)=0.0d0
18094           enddo
18095            enddo
18096           do i=0,nres
18097           do j=1,3
18098             do intertyp=1,3
18099              gloc_sc(intertyp,i,icg)=0.0d0
18100             enddo
18101           enddo
18102           enddo
18103           do i=1,nres
18104            do j=1,maxcontsshi
18105            shield_list(j,i)=0
18106           do k=1,3
18107       !C           print *,i,j,k
18108              grad_shield_side(k,j,i)=0.0d0
18109              grad_shield_loc(k,j,i)=0.0d0
18110            enddo
18111            enddo
18112            ishield_list(i)=0
18113           enddo
18114
18115       !
18116       ! Initialize the gradient of local energy terms.
18117       !
18118       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
18119       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
18120       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
18121       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
18122       !      allocate(gel_loc_turn3(nres))
18123       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
18124       !      allocate(gsccor_loc(nres))      !(maxres)
18125
18126           do i=1,4*nres
18127           gloc(i,icg)=0.0D0
18128           enddo
18129           do i=1,nres
18130           gel_loc_loc(i)=0.0d0
18131           gcorr_loc(i)=0.0d0
18132           g_corr5_loc(i)=0.0d0
18133           g_corr6_loc(i)=0.0d0
18134           gel_loc_turn3(i)=0.0d0
18135           gel_loc_turn4(i)=0.0d0
18136           gel_loc_turn6(i)=0.0d0
18137           gsccor_loc(i)=0.0d0
18138           enddo
18139       ! initialize gcart and gxcart
18140       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
18141           do i=0,nres
18142           do j=1,3
18143             gcart(j,i)=0.0d0
18144             gxcart(j,i)=0.0d0
18145           enddo
18146           enddo
18147           return
18148           end subroutine zerograd
18149       !-----------------------------------------------------------------------------
18150           real(kind=8) function fdum()
18151           fdum=0.0D0
18152           return
18153           end function fdum
18154       !-----------------------------------------------------------------------------
18155       ! intcartderiv.F
18156       !-----------------------------------------------------------------------------
18157           subroutine intcartderiv
18158       !      implicit real(kind=8) (a-h,o-z)
18159       !      include 'DIMENSIONS'
18160 #ifdef MPI
18161           include 'mpif.h'
18162 #endif
18163       !      include 'COMMON.SETUP'
18164       !      include 'COMMON.CHAIN'
18165       !      include 'COMMON.VAR'
18166       !      include 'COMMON.GEO'
18167       !      include 'COMMON.INTERACT'
18168       !      include 'COMMON.DERIV'
18169       !      include 'COMMON.IOUNITS'
18170       !      include 'COMMON.LOCAL'
18171       !      include 'COMMON.SCCOR'
18172           real(kind=8) :: pi4,pi34
18173           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
18174           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
18175                   dcosomega,dsinomega !(3,3,maxres)
18176           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
18177
18178           integer :: i,j,k
18179           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
18180                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
18181                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
18182                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
18183           integer :: nres2
18184           nres2=2*nres
18185
18186       !el from module energy-------------
18187       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
18188       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
18189       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
18190
18191       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
18192       !el      allocate(dsintau(3,3,3,0:nres2))
18193       !el      allocate(dtauangle(3,3,3,0:nres2))
18194       !el      allocate(domicron(3,2,2,0:nres2))
18195       !el      allocate(dcosomicron(3,2,2,0:nres2))
18196
18197
18198
18199 #if defined(MPI) && defined(PARINTDER)
18200           if (nfgtasks.gt.1 .and. me.eq.king) &
18201           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
18202 #endif
18203           pi4 = 0.5d0*pipol
18204           pi34 = 3*pi4
18205
18206       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
18207       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
18208
18209       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
18210           do i=1,nres
18211           do j=1,3
18212             dtheta(j,1,i)=0.0d0
18213             dtheta(j,2,i)=0.0d0
18214             dphi(j,1,i)=0.0d0
18215             dphi(j,2,i)=0.0d0
18216             dphi(j,3,i)=0.0d0
18217             dcosomicron(j,1,1,i)=0.0d0
18218             dcosomicron(j,1,2,i)=0.0d0
18219             dcosomicron(j,2,1,i)=0.0d0
18220             dcosomicron(j,2,2,i)=0.0d0
18221           enddo
18222           enddo
18223       ! Derivatives of theta's
18224 #if defined(MPI) && defined(PARINTDER)
18225       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
18226           do i=max0(ithet_start-1,3),ithet_end
18227 #else
18228           do i=3,nres
18229 #endif
18230           cost=dcos(theta(i))
18231           sint=sqrt(1-cost*cost)
18232           do j=1,3
18233             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
18234             vbld(i-1)
18235             if (((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))) &
18236              dtheta(j,1,i)=-dcostheta(j,1,i)/sint
18237             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
18238             vbld(i)
18239             if ((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))&
18240              dtheta(j,2,i)=-dcostheta(j,2,i)/sint
18241           enddo
18242           enddo
18243 #if defined(MPI) && defined(PARINTDER)
18244       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
18245           do i=max0(ithet_start-1,3),ithet_end
18246 #else
18247           do i=3,nres
18248 #endif
18249           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ge.4) then
18250           cost1=dcos(omicron(1,i))
18251           sint1=sqrt(1-cost1*cost1)
18252           cost2=dcos(omicron(2,i))
18253           sint2=sqrt(1-cost2*cost2)
18254            do j=1,3
18255       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
18256             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
18257             cost1*dc_norm(j,i-2))/ &
18258             vbld(i-1)
18259             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
18260             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
18261             +cost1*(dc_norm(j,i-1+nres)))/ &
18262             vbld(i-1+nres)
18263             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
18264       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
18265       !C Looks messy but better than if in loop
18266             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
18267             +cost2*dc_norm(j,i-1))/ &
18268             vbld(i)
18269             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
18270             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
18271              +cost2*(-dc_norm(j,i-1+nres)))/ &
18272             vbld(i-1+nres)
18273       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
18274             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
18275           enddo
18276            endif
18277           enddo
18278       !elwrite(iout,*) "after vbld write"
18279       ! Derivatives of phi:
18280       ! If phi is 0 or 180 degrees, then the formulas
18281       ! have to be derived by power series expansion of the
18282       ! conventional formulas around 0 and 180.
18283 #ifdef PARINTDER
18284           do i=iphi1_start,iphi1_end
18285 #else
18286           do i=4,nres
18287 #endif
18288       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
18289       ! the conventional case
18290           sint=dsin(theta(i))
18291           sint1=dsin(theta(i-1))
18292           sing=dsin(phi(i))
18293           cost=dcos(theta(i))
18294           cost1=dcos(theta(i-1))
18295           cosg=dcos(phi(i))
18296           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
18297           if ((sint*sint1).eq.0.0d0) then
18298           fac0=0.0d0
18299           else
18300           fac0=1.0d0/(sint1*sint)
18301           endif
18302           fac1=cost*fac0
18303           fac2=cost1*fac0
18304           if (sint1.ne.0.0d0) then
18305           fac3=cosg*cost1/(sint1*sint1)
18306           else
18307           fac3=0.0d0
18308           endif
18309           if (sint.ne.0.0d0) then
18310           fac4=cosg*cost/(sint*sint)
18311           else
18312           fac4=0.0d0
18313           endif
18314       !    Obtaining the gamma derivatives from sine derivative
18315            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
18316              phi(i).gt.pi34.and.phi(i).le.pi.or. &
18317              phi(i).ge.-pi.and.phi(i).le.-pi34) then
18318            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
18319            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
18320            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
18321            do j=1,3
18322             if (sint.ne.0.0d0) then
18323             ctgt=cost/sint
18324             else
18325             ctgt=0.0d0
18326             endif
18327             if (sint1.ne.0.0d0) then
18328             ctgt1=cost1/sint1
18329             else
18330             ctgt1=0.0d0
18331             endif
18332             cosg_inv=1.0d0/cosg
18333             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
18334             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
18335               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
18336             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
18337             dsinphi(j,2,i)= &
18338               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
18339               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18340             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
18341             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
18342               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
18343       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18344             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
18345             endif
18346 !             write(iout,*) "just after,close to pi",dphi(j,3,i),&
18347 !              sing*(ctgt1*dtheta(j,2,i-1)),ctgt*dtheta(j,1,i), &
18348 !              (fac0*vp2(j)+sing*dc_norm(j,i-2)),vbld_inv(i-1)
18349
18350       ! Bug fixed 3/24/05 (AL)
18351            enddo
18352       !   Obtaining the gamma derivatives from cosine derivative
18353           else
18354              do j=1,3
18355              if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
18356              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
18357              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
18358              dc_norm(j,i-3))/vbld(i-2)
18359              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
18360              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
18361              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
18362              dcostheta(j,1,i)
18363              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
18364              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
18365              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
18366              dc_norm(j,i-1))/vbld(i)
18367              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
18368 !#define DEBUG
18369 #ifdef DEBUG
18370              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
18371 #endif
18372 !#undef DEBUG
18373              endif
18374            enddo
18375           endif
18376           enddo
18377       !alculate derivative of Tauangle
18378 #ifdef PARINTDER
18379           do i=itau_start,itau_end
18380 #else
18381           do i=3,nres
18382       !elwrite(iout,*) " vecpr",i,nres
18383 #endif
18384            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
18385       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
18386       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
18387       !c dtauangle(j,intertyp,dervityp,residue number)
18388       !c INTERTYP=1 SC...Ca...Ca..Ca
18389       ! the conventional case
18390           sint=dsin(theta(i))
18391           sint1=dsin(omicron(2,i-1))
18392           sing=dsin(tauangle(1,i))
18393           cost=dcos(theta(i))
18394           cost1=dcos(omicron(2,i-1))
18395           cosg=dcos(tauangle(1,i))
18396       !elwrite(iout,*) " vecpr5",i,nres
18397           do j=1,3
18398       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
18399       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
18400           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
18401       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
18402           enddo
18403           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
18404       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac
18405         if ((sint*sint1).eq.0.0d0) then
18406           fac0=0.0d0
18407           else
18408           fac0=1.0d0/(sint1*sint)
18409           endif
18410           fac1=cost*fac0
18411           fac2=cost1*fac0
18412           if (sint1.ne.0.0d0) then
18413           fac3=cosg*cost1/(sint1*sint1)
18414           else
18415           fac3=0.0d0
18416           endif
18417           if (sint.ne.0.0d0) then
18418           fac4=cosg*cost/(sint*sint)
18419           else
18420           fac4=0.0d0
18421           endif
18422
18423       !    Obtaining the gamma derivatives from sine derivative
18424            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
18425              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
18426              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
18427            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
18428            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
18429            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18430           do j=1,3
18431             ctgt=cost/sint
18432             ctgt1=cost1/sint1
18433             cosg_inv=1.0d0/cosg
18434             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18435            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
18436            *vbld_inv(i-2+nres)
18437             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
18438             dsintau(j,1,2,i)= &
18439               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
18440               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18441       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
18442             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
18443       ! Bug fixed 3/24/05 (AL)
18444             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
18445               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
18446       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18447             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
18448            enddo
18449       !   Obtaining the gamma derivatives from cosine derivative
18450           else
18451              do j=1,3
18452              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18453              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
18454              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
18455              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
18456              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18457              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18458              dcostheta(j,1,i)
18459              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
18460              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
18461              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
18462              dc_norm(j,i-1))/vbld(i)
18463              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
18464       !         write (iout,*) "else",i
18465            enddo
18466           endif
18467       !        do k=1,3
18468       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
18469       !        enddo
18470           enddo
18471       !C Second case Ca...Ca...Ca...SC
18472 #ifdef PARINTDER
18473           do i=itau_start,itau_end
18474 #else
18475           do i=4,nres
18476 #endif
18477            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18478             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
18479       ! the conventional case
18480           sint=dsin(omicron(1,i))
18481           sint1=dsin(theta(i-1))
18482           sing=dsin(tauangle(2,i))
18483           cost=dcos(omicron(1,i))
18484           cost1=dcos(theta(i-1))
18485           cosg=dcos(tauangle(2,i))
18486       !        do j=1,3
18487       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18488       !        enddo
18489           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
18490         if ((sint*sint1).eq.0.0d0) then
18491           fac0=0.0d0
18492           else
18493           fac0=1.0d0/(sint1*sint)
18494           endif
18495           fac1=cost*fac0
18496           fac2=cost1*fac0
18497           if (sint1.ne.0.0d0) then
18498           fac3=cosg*cost1/(sint1*sint1)
18499           else
18500           fac3=0.0d0
18501           endif
18502           if (sint.ne.0.0d0) then
18503           fac4=cosg*cost/(sint*sint)
18504           else
18505           fac4=0.0d0
18506           endif
18507       !    Obtaining the gamma derivatives from sine derivative
18508            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
18509              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
18510              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
18511            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
18512            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
18513            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
18514           do j=1,3
18515             ctgt=cost/sint
18516             ctgt1=cost1/sint1
18517             cosg_inv=1.0d0/cosg
18518             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
18519               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
18520       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
18521       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
18522             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
18523             dsintau(j,2,2,i)= &
18524               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
18525               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18526       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
18527       !     & sing*ctgt*domicron(j,1,2,i),
18528       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18529             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
18530       ! Bug fixed 3/24/05 (AL)
18531             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18532              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
18533       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18534             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
18535            enddo
18536       !   Obtaining the gamma derivatives from cosine derivative
18537           else
18538              do j=1,3
18539              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
18540              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18541              dc_norm(j,i-3))/vbld(i-2)
18542              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
18543              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
18544              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
18545              dcosomicron(j,1,1,i)
18546              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
18547              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18548              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
18549              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18550              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
18551       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
18552            enddo
18553           endif
18554           enddo
18555
18556       !CC third case SC...Ca...Ca...SC
18557 #ifdef PARINTDER
18558
18559           do i=itau_start,itau_end
18560 #else
18561           do i=3,nres
18562 #endif
18563       ! the conventional case
18564           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18565           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
18566           sint=dsin(omicron(1,i))
18567           sint1=dsin(omicron(2,i-1))
18568           sing=dsin(tauangle(3,i))
18569           cost=dcos(omicron(1,i))
18570           cost1=dcos(omicron(2,i-1))
18571           cosg=dcos(tauangle(3,i))
18572           do j=1,3
18573           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
18574       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18575           enddo
18576           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
18577         if ((sint*sint1).eq.0.0d0) then
18578           fac0=0.0d0
18579           else
18580           fac0=1.0d0/(sint1*sint)
18581           endif
18582           fac1=cost*fac0
18583           fac2=cost1*fac0
18584           if (sint1.ne.0.0d0) then
18585           fac3=cosg*cost1/(sint1*sint1)
18586           else
18587           fac3=0.0d0
18588           endif
18589           if (sint.ne.0.0d0) then
18590           fac4=cosg*cost/(sint*sint)
18591           else
18592           fac4=0.0d0
18593           endif
18594       !    Obtaining the gamma derivatives from sine derivative
18595            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
18596              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
18597              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
18598            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
18599            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
18600            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18601           do j=1,3
18602             ctgt=cost/sint
18603             ctgt1=cost1/sint1
18604             cosg_inv=1.0d0/cosg
18605             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18606               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
18607               *vbld_inv(i-2+nres)
18608             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
18609             dsintau(j,3,2,i)= &
18610               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
18611               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18612             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
18613       ! Bug fixed 3/24/05 (AL)
18614             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18615               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
18616               *vbld_inv(i-1+nres)
18617       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18618             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
18619            enddo
18620       !   Obtaining the gamma derivatives from cosine derivative
18621           else
18622              do j=1,3
18623              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18624              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18625              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
18626              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
18627              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18628              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18629              dcosomicron(j,1,1,i)
18630              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
18631              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18632              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
18633              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18634              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
18635       !          write(iout,*) "else",i
18636            enddo
18637           endif
18638           enddo
18639
18640 #ifdef CRYST_SC
18641       !   Derivatives of side-chain angles alpha and omega
18642 #if defined(MPI) && defined(PARINTDER)
18643           do i=ibond_start,ibond_end
18644 #else
18645           do i=2,nres-1
18646 #endif
18647             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
18648              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
18649              fac6=fac5/vbld(i)
18650              fac7=fac5*fac5
18651              fac8=fac5/vbld(i+1)
18652              fac9=fac5/vbld(i+nres)
18653              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
18654              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
18655              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
18656              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
18657              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
18658              sina=sqrt(1-cosa*cosa)
18659              sino=dsin(omeg(i))
18660       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
18661              do j=1,3
18662               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
18663               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
18664               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
18665               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
18666               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
18667               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
18668               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
18669               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
18670               vbld(i+nres))
18671               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
18672             enddo
18673       ! obtaining the derivatives of omega from sines
18674             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
18675                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
18676                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
18677                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
18678                dsin(theta(i+1)))
18679                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
18680                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
18681                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
18682                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
18683                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
18684                coso_inv=1.0d0/dcos(omeg(i))
18685                do j=1,3
18686                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
18687                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
18688                (sino*dc_norm(j,i-1))/vbld(i)
18689                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
18690                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
18691                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
18692                -sino*dc_norm(j,i)/vbld(i+1)
18693                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
18694                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
18695                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
18696                vbld(i+nres)
18697                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
18698               enddo
18699              else
18700       !   obtaining the derivatives of omega from cosines
18701              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
18702              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
18703              fac12=fac10*sina
18704              fac13=fac12*fac12
18705              fac14=sina*sina
18706              do j=1,3
18707               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
18708               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
18709               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
18710               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
18711               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
18712               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
18713               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
18714               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
18715               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
18716               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
18717               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
18718               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
18719               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
18720               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
18721               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
18722             enddo
18723             endif
18724            else
18725              do j=1,3
18726              do k=1,3
18727                dalpha(k,j,i)=0.0d0
18728                domega(k,j,i)=0.0d0
18729              enddo
18730              enddo
18731            endif
18732            enddo
18733 #endif
18734 #if defined(MPI) && defined(PARINTDER)
18735           if (nfgtasks.gt.1) then
18736 #ifdef DEBUG
18737       !d      write (iout,*) "Gather dtheta"
18738       !d      call flush(iout)
18739           write (iout,*) "dtheta before gather"
18740           do i=1,nres
18741           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
18742           enddo
18743 #endif
18744           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
18745           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
18746           king,FG_COMM,IERROR)
18747 !#define DEBUG
18748 #ifdef DEBUG
18749       !d      write (iout,*) "Gather dphi"
18750       !d      call flush(iout)
18751           write (iout,*) "dphi before gather"
18752           do i=1,nres
18753           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
18754           enddo
18755 #endif
18756 !#undef DEBUG
18757           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
18758           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
18759           king,FG_COMM,IERROR)
18760       !d      write (iout,*) "Gather dalpha"
18761       !d      call flush(iout)
18762 #ifdef CRYST_SC
18763           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
18764           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18765           king,FG_COMM,IERROR)
18766       !d      write (iout,*) "Gather domega"
18767       !d      call flush(iout)
18768           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
18769           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18770           king,FG_COMM,IERROR)
18771 #endif
18772           endif
18773 #endif
18774 !#define DEBUG
18775 #ifdef DEBUG
18776           write (iout,*) "dtheta after gather"
18777           do i=1,nres
18778           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
18779           enddo
18780           write (iout,*) "dphi after gather"
18781           do i=1,nres
18782           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
18783           enddo
18784           write (iout,*) "dalpha after gather"
18785           do i=1,nres
18786           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
18787           enddo
18788           write (iout,*) "domega after gather"
18789           do i=1,nres
18790           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
18791           enddo
18792 #endif
18793 !#undef DEBUG
18794           return
18795           end subroutine intcartderiv
18796       !-----------------------------------------------------------------------------
18797           subroutine checkintcartgrad
18798       !      implicit real(kind=8) (a-h,o-z)
18799       !      include 'DIMENSIONS'
18800 #ifdef MPI
18801           include 'mpif.h'
18802 #endif
18803       !      include 'COMMON.CHAIN'
18804       !      include 'COMMON.VAR'
18805       !      include 'COMMON.GEO'
18806       !      include 'COMMON.INTERACT'
18807       !      include 'COMMON.DERIV'
18808       !      include 'COMMON.IOUNITS'
18809       !      include 'COMMON.SETUP'
18810           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
18811           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
18812           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
18813           real(kind=8),dimension(3) :: dc_norm_s
18814           real(kind=8) :: aincr=1.0d-5
18815           integer :: i,j
18816           real(kind=8) :: dcji
18817           do i=1,nres
18818           phi_s(i)=phi(i)
18819           theta_s(i)=theta(i)
18820           alph_s(i)=alph(i)
18821           omeg_s(i)=omeg(i)
18822           enddo
18823       ! Check theta gradient
18824           write (iout,*) &
18825            "Analytical (upper) and numerical (lower) gradient of theta"
18826           write (iout,*)
18827           do i=3,nres
18828           do j=1,3
18829             dcji=dc(j,i-2)
18830             dc(j,i-2)=dcji+aincr
18831             call chainbuild_cart
18832             call int_from_cart1(.false.)
18833         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18834         dc(j,i-2)=dcji
18835         dcji=dc(j,i-1)
18836         dc(j,i-1)=dc(j,i-1)+aincr
18837         call chainbuild_cart
18838         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18839         dc(j,i-1)=dcji
18840       enddo
18841 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18842 !el          (dtheta(j,2,i),j=1,3)
18843 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18844 !el          (dthetanum(j,2,i),j=1,3)
18845 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18846 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18847 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18848 !el        write (iout,*)
18849       enddo
18850 ! Check gamma gradient
18851       write (iout,*) &
18852        "Analytical (upper) and numerical (lower) gradient of gamma"
18853       do i=4,nres
18854       do j=1,3
18855         dcji=dc(j,i-3)
18856         dc(j,i-3)=dcji+aincr
18857         call chainbuild_cart
18858         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18859             dc(j,i-3)=dcji
18860         dcji=dc(j,i-2)
18861         dc(j,i-2)=dcji+aincr
18862         call chainbuild_cart
18863         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18864         dc(j,i-2)=dcji
18865         dcji=dc(j,i-1)
18866         dc(j,i-1)=dc(j,i-1)+aincr
18867         call chainbuild_cart
18868         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
18869         dc(j,i-1)=dcji
18870       enddo
18871 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
18872 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
18873 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
18874 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
18875 !el        write (iout,'(5x,3(3f10.5,5x))') &
18876 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
18877 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
18878 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
18879 !el        write (iout,*)
18880       enddo
18881 ! Check alpha gradient
18882       write (iout,*) &
18883        "Analytical (upper) and numerical (lower) gradient of alpha"
18884       do i=2,nres-1
18885        if(itype(i,1).ne.10) then
18886              do j=1,3
18887               dcji=dc(j,i-1)
18888                dc(j,i-1)=dcji+aincr
18889             call chainbuild_cart
18890             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
18891              /aincr
18892               dc(j,i-1)=dcji
18893             dcji=dc(j,i)
18894             dc(j,i)=dcji+aincr
18895             call chainbuild_cart
18896             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
18897              /aincr
18898             dc(j,i)=dcji
18899             dcji=dc(j,i+nres)
18900             dc(j,i+nres)=dc(j,i+nres)+aincr
18901             call chainbuild_cart
18902             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
18903              /aincr
18904            dc(j,i+nres)=dcji
18905           enddo
18906         endif
18907 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
18908 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
18909 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
18910 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
18911 !el        write (iout,'(5x,3(3f10.5,5x))') &
18912 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
18913 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
18914 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
18915 !el        write (iout,*)
18916       enddo
18917 !     Check omega gradient
18918       write (iout,*) &
18919        "Analytical (upper) and numerical (lower) gradient of omega"
18920       do i=2,nres-1
18921        if(itype(i,1).ne.10) then
18922              do j=1,3
18923               dcji=dc(j,i-1)
18924                dc(j,i-1)=dcji+aincr
18925             call chainbuild_cart
18926             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18927              /aincr
18928               dc(j,i-1)=dcji
18929             dcji=dc(j,i)
18930             dc(j,i)=dcji+aincr
18931             call chainbuild_cart
18932             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18933              /aincr
18934             dc(j,i)=dcji
18935             dcji=dc(j,i+nres)
18936             dc(j,i+nres)=dc(j,i+nres)+aincr
18937             call chainbuild_cart
18938             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18939              /aincr
18940            dc(j,i+nres)=dcji
18941           enddo
18942         endif
18943 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18944 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18945 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18946 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18947 !el        write (iout,'(5x,3(3f10.5,5x))') &
18948 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18949 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18950 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18951 !el        write (iout,*)
18952       enddo
18953       return
18954       end subroutine checkintcartgrad
18955 !-----------------------------------------------------------------------------
18956 ! q_measure.F
18957 !-----------------------------------------------------------------------------
18958       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18959 !      implicit real(kind=8) (a-h,o-z)
18960 !      include 'DIMENSIONS'
18961 !      include 'COMMON.IOUNITS'
18962 !      include 'COMMON.CHAIN'
18963 !      include 'COMMON.INTERACT'
18964 !      include 'COMMON.VAR'
18965       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18966       integer :: kkk,nsep=3
18967       real(kind=8) :: qm      !dist,
18968       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18969       logical :: lprn=.false.
18970       logical :: flag
18971 !      real(kind=8) :: sigm,x
18972
18973 !el      sigm(x)=0.25d0*x     ! local function
18974       qqmax=1.0d10
18975       do kkk=1,nperm
18976       qq = 0.0d0
18977       nl=0
18978        if(flag) then
18979       do il=seg1+nsep,seg2
18980         do jl=seg1,il-nsep
18981           nl=nl+1
18982           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18983                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18984                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18985           dij=dist(il,jl)
18986           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18987           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18988             nl=nl+1
18989             d0ijCM=dsqrt( &
18990                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18991                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18992                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18993             dijCM=dist(il+nres,jl+nres)
18994             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18995           endif
18996           qq = qq+qqij+qqijCM
18997         enddo
18998       enddo
18999       qq = qq/nl
19000       else
19001       do il=seg1,seg2
19002       if((seg3-il).lt.3) then
19003            secseg=il+3
19004       else
19005            secseg=seg3
19006       endif
19007         do jl=secseg,seg4
19008           nl=nl+1
19009           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
19010                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
19011                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19012           dij=dist(il,jl)
19013           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
19014           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19015             nl=nl+1
19016             d0ijCM=dsqrt( &
19017                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19018                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19019                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19020             dijCM=dist(il+nres,jl+nres)
19021             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
19022           endif
19023           qq = qq+qqij+qqijCM
19024         enddo
19025       enddo
19026       qq = qq/nl
19027       endif
19028       if (qqmax.le.qq) qqmax=qq
19029       enddo
19030       qwolynes=1.0d0-qqmax
19031       return
19032       end function qwolynes
19033 !-----------------------------------------------------------------------------
19034       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
19035 !      implicit real(kind=8) (a-h,o-z)
19036 !      include 'DIMENSIONS'
19037 !      include 'COMMON.IOUNITS'
19038 !      include 'COMMON.CHAIN'
19039 !      include 'COMMON.INTERACT'
19040 !      include 'COMMON.VAR'
19041 !      include 'COMMON.MD'
19042       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
19043       integer :: nsep=3, kkk
19044 !el      real(kind=8) :: dist
19045       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
19046       logical :: lprn=.false.
19047       logical :: flag
19048       real(kind=8) :: sim,dd0,fac,ddqij
19049 !el      sigm(x)=0.25d0*x           ! local function
19050       do kkk=1,nperm
19051       do i=0,nres
19052       do j=1,3
19053         dqwol(j,i)=0.0d0
19054         dxqwol(j,i)=0.0d0
19055       enddo
19056       enddo
19057       nl=0
19058        if(flag) then
19059       do il=seg1+nsep,seg2
19060         do jl=seg1,il-nsep
19061           nl=nl+1
19062           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
19063                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
19064                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19065           dij=dist(il,jl)
19066           sim = 1.0d0/sigm(d0ij)
19067           sim = sim*sim
19068           dd0 = dij-d0ij
19069           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
19070         do k=1,3
19071             ddqij = (c(k,il)-c(k,jl))*fac
19072             dqwol(k,il)=dqwol(k,il)+ddqij
19073             dqwol(k,jl)=dqwol(k,jl)-ddqij
19074           enddo
19075
19076           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19077             nl=nl+1
19078             d0ijCM=dsqrt( &
19079                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19080                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19081                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19082             dijCM=dist(il+nres,jl+nres)
19083             sim = 1.0d0/sigm(d0ijCM)
19084             sim = sim*sim
19085             dd0=dijCM-d0ijCM
19086             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
19087             do k=1,3
19088             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
19089             dxqwol(k,il)=dxqwol(k,il)+ddqij
19090             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
19091             enddo
19092           endif
19093         enddo
19094       enddo
19095        else
19096       do il=seg1,seg2
19097       if((seg3-il).lt.3) then
19098            secseg=il+3
19099       else
19100            secseg=seg3
19101       endif
19102         do jl=secseg,seg4
19103           nl=nl+1
19104           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
19105                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
19106                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
19107           dij=dist(il,jl)
19108           sim = 1.0d0/sigm(d0ij)
19109           sim = sim*sim
19110           dd0 = dij-d0ij
19111           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
19112           do k=1,3
19113             ddqij = (c(k,il)-c(k,jl))*fac
19114             dqwol(k,il)=dqwol(k,il)+ddqij
19115             dqwol(k,jl)=dqwol(k,jl)-ddqij
19116           enddo
19117           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
19118             nl=nl+1
19119             d0ijCM=dsqrt( &
19120                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
19121                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
19122                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
19123             dijCM=dist(il+nres,jl+nres)
19124             sim = 1.0d0/sigm(d0ijCM)
19125             sim=sim*sim
19126             dd0 = dijCM-d0ijCM
19127             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
19128             do k=1,3
19129              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
19130              dxqwol(k,il)=dxqwol(k,il)+ddqij
19131              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
19132             enddo
19133           endif
19134         enddo
19135       enddo
19136       endif
19137       enddo
19138        do i=0,nres
19139        do j=1,3
19140          dqwol(j,i)=dqwol(j,i)/nl
19141          dxqwol(j,i)=dxqwol(j,i)/nl
19142        enddo
19143        enddo
19144       return
19145       end subroutine qwolynes_prim
19146 !-----------------------------------------------------------------------------
19147       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
19148 !      implicit real(kind=8) (a-h,o-z)
19149 !      include 'DIMENSIONS'
19150 !      include 'COMMON.IOUNITS'
19151 !      include 'COMMON.CHAIN'
19152 !      include 'COMMON.INTERACT'
19153 !      include 'COMMON.VAR'
19154       integer :: seg1,seg2,seg3,seg4
19155       logical :: flag
19156       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
19157       real(kind=8),dimension(3,0:2*nres) :: cdummy
19158       real(kind=8) :: q1,q2
19159       real(kind=8) :: delta=1.0d-10
19160       integer :: i,j
19161
19162       do i=0,nres
19163       do j=1,3
19164         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
19165         cdummy(j,i)=c(j,i)
19166         c(j,i)=c(j,i)+delta
19167         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
19168         qwolan(j,i)=(q2-q1)/delta
19169         c(j,i)=cdummy(j,i)
19170       enddo
19171       enddo
19172       do i=0,nres
19173       do j=1,3
19174         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
19175         cdummy(j,i+nres)=c(j,i+nres)
19176         c(j,i+nres)=c(j,i+nres)+delta
19177         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
19178         qwolxan(j,i)=(q2-q1)/delta
19179         c(j,i+nres)=cdummy(j,i+nres)
19180       enddo
19181       enddo
19182 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
19183 !      do i=0,nct
19184 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
19185 !      enddo
19186 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
19187 !      do i=0,nct
19188 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
19189 !      enddo
19190       return
19191       end subroutine qwol_num
19192 !-----------------------------------------------------------------------------
19193       subroutine EconstrQ
19194 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
19195 !      implicit real(kind=8) (a-h,o-z)
19196 !      include 'DIMENSIONS'
19197 !      include 'COMMON.CONTROL'
19198 !      include 'COMMON.VAR'
19199 !      include 'COMMON.MD'
19200       use MD_data
19201 !#ifndef LANG0
19202 !      include 'COMMON.LANGEVIN'
19203 !#else
19204 !      include 'COMMON.LANGEVIN.lang0'
19205 !#endif
19206 !      include 'COMMON.CHAIN'
19207 !      include 'COMMON.DERIV'
19208 !      include 'COMMON.GEO'
19209 !      include 'COMMON.LOCAL'
19210 !      include 'COMMON.INTERACT'
19211 !      include 'COMMON.IOUNITS'
19212 !      include 'COMMON.NAMES'
19213 !      include 'COMMON.TIME1'
19214       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
19215       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
19216                duconst,duxconst
19217       integer :: kstart,kend,lstart,lend,idummy
19218       real(kind=8) :: delta=1.0d-7
19219       integer :: i,j,k,ii
19220       do i=0,nres
19221        do j=1,3
19222           duconst(j,i)=0.0d0
19223           dudconst(j,i)=0.0d0
19224           duxconst(j,i)=0.0d0
19225           dudxconst(j,i)=0.0d0
19226        enddo
19227       enddo
19228       Uconst=0.0d0
19229       do i=1,nfrag
19230        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
19231          idummy,idummy)
19232        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
19233 ! Calculating the derivatives of Constraint energy with respect to Q
19234        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
19235          qinfrag(i,iset))
19236 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
19237 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
19238 !         hmnum=(hm2-hm1)/delta
19239 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
19240 !     &   qinfrag(i,iset))
19241 !         write(iout,*) "harmonicnum frag", hmnum
19242 ! Calculating the derivatives of Q with respect to cartesian coordinates
19243        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
19244         idummy,idummy)
19245 !         write(iout,*) "dqwol "
19246 !         do ii=1,nres
19247 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
19248 !         enddo
19249 !         write(iout,*) "dxqwol "
19250 !         do ii=1,nres
19251 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
19252 !         enddo
19253 ! Calculating numerical gradients of dU/dQi and dQi/dxi
19254 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
19255 !     &  ,idummy,idummy)
19256 !  The gradients of Uconst in Cs
19257        do ii=0,nres
19258           do j=1,3
19259              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
19260              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
19261           enddo
19262        enddo
19263       enddo
19264       do i=1,npair
19265        kstart=ifrag(1,ipair(1,i,iset),iset)
19266        kend=ifrag(2,ipair(1,i,iset),iset)
19267        lstart=ifrag(1,ipair(2,i,iset),iset)
19268        lend=ifrag(2,ipair(2,i,iset),iset)
19269        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
19270        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
19271 !  Calculating dU/dQ
19272        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
19273 !         hm1=harmonic(qpair(i),qinpair(i,iset))
19274 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
19275 !         hmnum=(hm2-hm1)/delta
19276 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
19277 !     &   qinpair(i,iset))
19278 !         write(iout,*) "harmonicnum pair ", hmnum
19279 ! Calculating dQ/dXi
19280        call qwolynes_prim(kstart,kend,.false.,&
19281         lstart,lend)
19282 !         write(iout,*) "dqwol "
19283 !         do ii=1,nres
19284 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
19285 !         enddo
19286 !         write(iout,*) "dxqwol "
19287 !         do ii=1,nres
19288 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
19289 !        enddo
19290 ! Calculating numerical gradients
19291 !        call qwol_num(kstart,kend,.false.
19292 !     &  ,lstart,lend)
19293 ! The gradients of Uconst in Cs
19294        do ii=0,nres
19295           do j=1,3
19296              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
19297              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
19298           enddo
19299        enddo
19300       enddo
19301 !      write(iout,*) "Uconst inside subroutine ", Uconst
19302 ! Transforming the gradients from Cs to dCs for the backbone
19303       do i=0,nres
19304        do j=i+1,nres
19305          do k=1,3
19306            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
19307          enddo
19308        enddo
19309       enddo
19310 !  Transforming the gradients from Cs to dCs for the side chains
19311       do i=1,nres
19312        do j=1,3
19313          dudxconst(j,i)=duxconst(j,i)
19314        enddo
19315       enddo
19316 !      write(iout,*) "dU/ddc backbone "
19317 !       do ii=0,nres
19318 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
19319 !      enddo
19320 !      write(iout,*) "dU/ddX side chain "
19321 !      do ii=1,nres
19322 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
19323 !      enddo
19324 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
19325 !      call dEconstrQ_num
19326       return
19327       end subroutine EconstrQ
19328 !-----------------------------------------------------------------------------
19329       subroutine dEconstrQ_num
19330 ! Calculating numerical dUconst/ddc and dUconst/ddx
19331 !      implicit real(kind=8) (a-h,o-z)
19332 !      include 'DIMENSIONS'
19333 !      include 'COMMON.CONTROL'
19334 !      include 'COMMON.VAR'
19335 !      include 'COMMON.MD'
19336       use MD_data
19337 !#ifndef LANG0
19338 !      include 'COMMON.LANGEVIN'
19339 !#else
19340 !      include 'COMMON.LANGEVIN.lang0'
19341 !#endif
19342 !      include 'COMMON.CHAIN'
19343 !      include 'COMMON.DERIV'
19344 !      include 'COMMON.GEO'
19345 !      include 'COMMON.LOCAL'
19346 !      include 'COMMON.INTERACT'
19347 !      include 'COMMON.IOUNITS'
19348 !      include 'COMMON.NAMES'
19349 !      include 'COMMON.TIME1'
19350       real(kind=8) :: uzap1,uzap2
19351       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
19352       integer :: kstart,kend,lstart,lend,idummy
19353       real(kind=8) :: delta=1.0d-7
19354 !el local variables
19355       integer :: i,ii,j
19356 !     real(kind=8) ::
19357 !     For the backbone
19358       do i=0,nres-1
19359        do j=1,3
19360           dUcartan(j,i)=0.0d0
19361           cdummy(j,i)=dc(j,i)
19362           dc(j,i)=dc(j,i)+delta
19363           call chainbuild_cart
19364         uzap2=0.0d0
19365           do ii=1,nfrag
19366            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
19367             idummy,idummy)
19368              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
19369             qinfrag(ii,iset))
19370           enddo
19371           do ii=1,npair
19372              kstart=ifrag(1,ipair(1,ii,iset),iset)
19373              kend=ifrag(2,ipair(1,ii,iset),iset)
19374              lstart=ifrag(1,ipair(2,ii,iset),iset)
19375              lend=ifrag(2,ipair(2,ii,iset),iset)
19376              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19377              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
19378              qinpair(ii,iset))
19379           enddo
19380           dc(j,i)=cdummy(j,i)
19381           call chainbuild_cart
19382           uzap1=0.0d0
19383            do ii=1,nfrag
19384            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
19385             idummy,idummy)
19386              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
19387             qinfrag(ii,iset))
19388           enddo
19389           do ii=1,npair
19390              kstart=ifrag(1,ipair(1,ii,iset),iset)
19391              kend=ifrag(2,ipair(1,ii,iset),iset)
19392              lstart=ifrag(1,ipair(2,ii,iset),iset)
19393              lend=ifrag(2,ipair(2,ii,iset),iset)
19394              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19395              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
19396             qinpair(ii,iset))
19397           enddo
19398           ducartan(j,i)=(uzap2-uzap1)/(delta)
19399        enddo
19400       enddo
19401 ! Calculating numerical gradients for dU/ddx
19402       do i=0,nres-1
19403        duxcartan(j,i)=0.0d0
19404        do j=1,3
19405           cdummy(j,i)=dc(j,i+nres)
19406           dc(j,i+nres)=dc(j,i+nres)+delta
19407           call chainbuild_cart
19408         uzap2=0.0d0
19409           do ii=1,nfrag
19410            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
19411             idummy,idummy)
19412              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
19413             qinfrag(ii,iset))
19414           enddo
19415           do ii=1,npair
19416              kstart=ifrag(1,ipair(1,ii,iset),iset)
19417              kend=ifrag(2,ipair(1,ii,iset),iset)
19418              lstart=ifrag(1,ipair(2,ii,iset),iset)
19419              lend=ifrag(2,ipair(2,ii,iset),iset)
19420              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19421              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
19422             qinpair(ii,iset))
19423           enddo
19424           dc(j,i+nres)=cdummy(j,i)
19425           call chainbuild_cart
19426           uzap1=0.0d0
19427            do ii=1,nfrag
19428              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
19429             ifrag(2,ii,iset),.true.,idummy,idummy)
19430              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
19431             qinfrag(ii,iset))
19432           enddo
19433           do ii=1,npair
19434              kstart=ifrag(1,ipair(1,ii,iset),iset)
19435              kend=ifrag(2,ipair(1,ii,iset),iset)
19436              lstart=ifrag(1,ipair(2,ii,iset),iset)
19437              lend=ifrag(2,ipair(2,ii,iset),iset)
19438              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19439              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
19440             qinpair(ii,iset))
19441           enddo
19442           duxcartan(j,i)=(uzap2-uzap1)/(delta)
19443        enddo
19444       enddo
19445       write(iout,*) "Numerical dUconst/ddc backbone "
19446       do ii=0,nres
19447       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
19448       enddo
19449 !      write(iout,*) "Numerical dUconst/ddx side-chain "
19450 !      do ii=1,nres
19451 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
19452 !      enddo
19453       return
19454       end subroutine dEconstrQ_num
19455 !-----------------------------------------------------------------------------
19456 ! ssMD.F
19457 !-----------------------------------------------------------------------------
19458       subroutine check_energies
19459
19460 !      use random, only: ran_number
19461
19462 !      implicit none
19463 !     Includes
19464 !      include 'DIMENSIONS'
19465 !      include 'COMMON.CHAIN'
19466 !      include 'COMMON.VAR'
19467 !      include 'COMMON.IOUNITS'
19468 !      include 'COMMON.SBRIDGE'
19469 !      include 'COMMON.LOCAL'
19470 !      include 'COMMON.GEO'
19471
19472 !     External functions
19473 !EL      double precision ran_number
19474 !EL      external ran_number
19475
19476 !     Local variables
19477       integer :: i,j,k,l,lmax,p,pmax
19478       real(kind=8) :: rmin,rmax
19479       real(kind=8) :: eij
19480
19481       real(kind=8) :: d
19482       real(kind=8) :: wi,rij,tj,pj
19483 !      return
19484
19485       i=5
19486       j=14
19487
19488       d=dsc(1)
19489       rmin=2.0D0
19490       rmax=12.0D0
19491
19492       lmax=10000
19493       pmax=1
19494
19495       do k=1,3
19496       c(k,i)=0.0D0
19497       c(k,j)=0.0D0
19498       c(k,nres+i)=0.0D0
19499       c(k,nres+j)=0.0D0
19500       enddo
19501
19502       do l=1,lmax
19503
19504 !t        wi=ran_number(0.0D0,pi)
19505 !        wi=ran_number(0.0D0,pi/6.0D0)
19506 !        wi=0.0D0
19507 !t        tj=ran_number(0.0D0,pi)
19508 !t        pj=ran_number(0.0D0,pi)
19509 !        pj=ran_number(0.0D0,pi/6.0D0)
19510 !        pj=0.0D0
19511
19512       do p=1,pmax
19513 !t           rij=ran_number(rmin,rmax)
19514
19515          c(1,j)=d*sin(pj)*cos(tj)
19516          c(2,j)=d*sin(pj)*sin(tj)
19517          c(3,j)=d*cos(pj)
19518
19519          c(3,nres+i)=-rij
19520
19521          c(1,i)=d*sin(wi)
19522          c(3,i)=-rij-d*cos(wi)
19523
19524          do k=1,3
19525             dc(k,nres+i)=c(k,nres+i)-c(k,i)
19526             dc_norm(k,nres+i)=dc(k,nres+i)/d
19527             dc(k,nres+j)=c(k,nres+j)-c(k,j)
19528             dc_norm(k,nres+j)=dc(k,nres+j)/d
19529          enddo
19530
19531          call dyn_ssbond_ene(i,j,eij)
19532       enddo
19533       enddo
19534       call exit(1)
19535       return
19536       end subroutine check_energies
19537 !-----------------------------------------------------------------------------
19538       subroutine dyn_ssbond_ene(resi,resj,eij)
19539 !      implicit none
19540 !      Includes
19541       use calc_data
19542       use comm_sschecks
19543 !      include 'DIMENSIONS'
19544 !      include 'COMMON.SBRIDGE'
19545 !      include 'COMMON.CHAIN'
19546 !      include 'COMMON.DERIV'
19547 !      include 'COMMON.LOCAL'
19548 !      include 'COMMON.INTERACT'
19549 !      include 'COMMON.VAR'
19550 !      include 'COMMON.IOUNITS'
19551 !      include 'COMMON.CALC'
19552 #ifndef CLUST
19553 #ifndef WHAM
19554        use MD_data
19555 !      include 'COMMON.MD'
19556 !      use MD, only: totT,t_bath
19557 #endif
19558 #endif
19559 !     External functions
19560 !EL      double precision h_base
19561 !EL      external h_base
19562
19563 !     Input arguments
19564       integer :: resi,resj
19565
19566 !     Output arguments
19567       real(kind=8) :: eij
19568
19569 !     Local variables
19570       logical :: havebond
19571       integer itypi,itypj
19572       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
19573       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
19574       real(kind=8),dimension(3) :: dcosom1,dcosom2
19575       real(kind=8) :: ed
19576       real(kind=8) :: pom1,pom2
19577       real(kind=8) :: ljA,ljB,ljXs
19578       real(kind=8),dimension(1:3) :: d_ljB
19579       real(kind=8) :: ssA,ssB,ssC,ssXs
19580       real(kind=8) :: ssxm,ljxm,ssm,ljm
19581       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
19582       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
19583       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
19584 !-------FIRST METHOD
19585       real(kind=8) :: xm
19586       real(kind=8),dimension(1:3) :: d_xm
19587 !-------END FIRST METHOD
19588 !-------SECOND METHOD
19589 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
19590 !-------END SECOND METHOD
19591
19592 !-------TESTING CODE
19593 !el      logical :: checkstop,transgrad
19594 !el      common /sschecks/ checkstop,transgrad
19595
19596       integer :: icheck,nicheck,jcheck,njcheck
19597       real(kind=8),dimension(-1:1) :: echeck
19598       real(kind=8) :: deps,ssx0,ljx0
19599 !-------END TESTING CODE
19600
19601       eij=0.0d0
19602       i=resi
19603       j=resj
19604
19605 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
19606 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
19607
19608       itypi=itype(i,1)
19609       dxi=dc_norm(1,nres+i)
19610       dyi=dc_norm(2,nres+i)
19611       dzi=dc_norm(3,nres+i)
19612       dsci_inv=vbld_inv(i+nres)
19613
19614       itypj=itype(j,1)
19615       xj=c(1,nres+j)-c(1,nres+i)
19616       yj=c(2,nres+j)-c(2,nres+i)
19617       zj=c(3,nres+j)-c(3,nres+i)
19618       dxj=dc_norm(1,nres+j)
19619       dyj=dc_norm(2,nres+j)
19620       dzj=dc_norm(3,nres+j)
19621       dscj_inv=vbld_inv(j+nres)
19622
19623       chi1=chi(itypi,itypj)
19624       chi2=chi(itypj,itypi)
19625       chi12=chi1*chi2
19626       chip1=chip(itypi)
19627       chip2=chip(itypj)
19628       chip12=chip1*chip2
19629       alf1=alp(itypi)
19630       alf2=alp(itypj)
19631       alf12=0.5D0*(alf1+alf2)
19632
19633       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
19634       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19635 !     The following are set in sc_angular
19636 !      erij(1)=xj*rij
19637 !      erij(2)=yj*rij
19638 !      erij(3)=zj*rij
19639 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
19640 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
19641 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
19642       call sc_angular
19643       rij=1.0D0/rij  ! Reset this so it makes sense
19644
19645       sig0ij=sigma(itypi,itypj)
19646       sig=sig0ij*dsqrt(1.0D0/sigsq)
19647
19648       ljXs=sig-sig0ij
19649       ljA=eps1*eps2rt**2*eps3rt**2
19650       ljB=ljA*bb_aq(itypi,itypj)
19651       ljA=ljA*aa_aq(itypi,itypj)
19652       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
19653
19654       ssXs=d0cm
19655       deltat1=1.0d0-om1
19656       deltat2=1.0d0+om2
19657       deltat12=om2-om1+2.0d0
19658       cosphi=om12-om1*om2
19659       ssA=akcm
19660       ssB=akct*deltat12
19661       ssC=ss_depth &
19662          +akth*(deltat1*deltat1+deltat2*deltat2) &
19663          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
19664       ssxm=ssXs-0.5D0*ssB/ssA
19665
19666 !-------TESTING CODE
19667 !$$$c     Some extra output
19668 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
19669 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
19670 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
19671 !$$$      if (ssx0.gt.0.0d0) then
19672 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
19673 !$$$      else
19674 !$$$        ssx0=ssxm
19675 !$$$      endif
19676 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
19677 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
19678 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
19679 !$$$      return
19680 !-------END TESTING CODE
19681
19682 !-------TESTING CODE
19683 !     Stop and plot energy and derivative as a function of distance
19684       if (checkstop) then
19685       ssm=ssC-0.25D0*ssB*ssB/ssA
19686       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19687       if (ssm.lt.ljm .and. &
19688            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
19689         nicheck=1000
19690         njcheck=1
19691         deps=0.5d-7
19692       else
19693         checkstop=.false.
19694       endif
19695       endif
19696       if (.not.checkstop) then
19697       nicheck=0
19698       njcheck=-1
19699       endif
19700
19701       do icheck=0,nicheck
19702       do jcheck=-1,njcheck
19703       if (checkstop) rij=(ssxm-1.0d0)+ &
19704            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
19705 !-------END TESTING CODE
19706
19707       if (rij.gt.ljxm) then
19708       havebond=.false.
19709       ljd=rij-ljXs
19710       fac=(1.0D0/ljd)**expon
19711       e1=fac*fac*aa_aq(itypi,itypj)
19712       e2=fac*bb_aq(itypi,itypj)
19713       eij=eps1*eps2rt*eps3rt*(e1+e2)
19714       eps2der=eij*eps3rt
19715       eps3der=eij*eps2rt
19716       eij=eij*eps2rt*eps3rt
19717
19718       sigder=-sig/sigsq
19719       e1=e1*eps1*eps2rt**2*eps3rt**2
19720       ed=-expon*(e1+eij)/ljd
19721       sigder=ed*sigder
19722       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
19723       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
19724       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
19725            -2.0D0*alf12*eps3der+sigder*sigsq_om12
19726       else if (rij.lt.ssxm) then
19727       havebond=.true.
19728       ssd=rij-ssXs
19729       eij=ssA*ssd*ssd+ssB*ssd+ssC
19730
19731       ed=2*akcm*ssd+akct*deltat12
19732       pom1=akct*ssd
19733       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
19734       eom1=-2*akth*deltat1-pom1-om2*pom2
19735       eom2= 2*akth*deltat2+pom1-om1*pom2
19736       eom12=pom2
19737       else
19738       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
19739
19740       d_ssxm(1)=0.5D0*akct/ssA
19741       d_ssxm(2)=-d_ssxm(1)
19742       d_ssxm(3)=0.0D0
19743
19744       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
19745       d_ljxm(2)=d_ljxm(1)*sigsq_om2
19746       d_ljxm(3)=d_ljxm(1)*sigsq_om12
19747       d_ljxm(1)=d_ljxm(1)*sigsq_om1
19748
19749 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19750       xm=0.5d0*(ssxm+ljxm)
19751       do k=1,3
19752         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
19753       enddo
19754       if (rij.lt.xm) then
19755         havebond=.true.
19756         ssm=ssC-0.25D0*ssB*ssB/ssA
19757         d_ssm(1)=0.5D0*akct*ssB/ssA
19758         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19759         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19760         d_ssm(3)=omega
19761         f1=(rij-xm)/(ssxm-xm)
19762         f2=(rij-ssxm)/(xm-ssxm)
19763         h1=h_base(f1,hd1)
19764         h2=h_base(f2,hd2)
19765         eij=ssm*h1+Ht*h2
19766         delta_inv=1.0d0/(xm-ssxm)
19767         deltasq_inv=delta_inv*delta_inv
19768         fac=ssm*hd1-Ht*hd2
19769         fac1=deltasq_inv*fac*(xm-rij)
19770         fac2=deltasq_inv*fac*(rij-ssxm)
19771         ed=delta_inv*(Ht*hd2-ssm*hd1)
19772         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
19773         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
19774         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
19775       else
19776         havebond=.false.
19777         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19778         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
19779         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
19780         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
19781              alf12/eps3rt)
19782         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
19783         f1=(rij-ljxm)/(xm-ljxm)
19784         f2=(rij-xm)/(ljxm-xm)
19785         h1=h_base(f1,hd1)
19786         h2=h_base(f2,hd2)
19787         eij=Ht*h1+ljm*h2
19788         delta_inv=1.0d0/(ljxm-xm)
19789         deltasq_inv=delta_inv*delta_inv
19790         fac=Ht*hd1-ljm*hd2
19791         fac1=deltasq_inv*fac*(ljxm-rij)
19792         fac2=deltasq_inv*fac*(rij-xm)
19793         ed=delta_inv*(ljm*hd2-Ht*hd1)
19794         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
19795         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
19796         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
19797       endif
19798 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19799
19800 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19801 !$$$        ssd=rij-ssXs
19802 !$$$        ljd=rij-ljXs
19803 !$$$        fac1=rij-ljxm
19804 !$$$        fac2=rij-ssxm
19805 !$$$
19806 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
19807 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
19808 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
19809 !$$$
19810 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
19811 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
19812 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19813 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19814 !$$$        d_ssm(3)=omega
19815 !$$$
19816 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
19817 !$$$        do k=1,3
19818 !$$$          d_ljm(k)=ljm*d_ljB(k)
19819 !$$$        enddo
19820 !$$$        ljm=ljm*ljB
19821 !$$$
19822 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
19823 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
19824 !$$$        d_ss(2)=akct*ssd
19825 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
19826 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
19827 !$$$        d_ss(3)=omega
19828 !$$$
19829 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19830 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19831 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19832 !$$$        do k=1,3
19833 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19834 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19835 !$$$        enddo
19836 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19837 !$$$
19838 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19839 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19840 !$$$        h1=h_base(f1,hd1)
19841 !$$$        h2=h_base(f2,hd2)
19842 !$$$        eij=ss*h1+ljf*h2
19843 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19844 !$$$        deltasq_inv=delta_inv*delta_inv
19845 !$$$        fac=ljf*hd2-ss*hd1
19846 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19847 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19848 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19849 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19850 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19851 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19852 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19853 !$$$
19854 !$$$        havebond=.false.
19855 !$$$        if (ed.gt.0.0d0) havebond=.true.
19856 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19857
19858       endif
19859
19860       if (havebond) then
19861 !#ifndef CLUST
19862 !#ifndef WHAM
19863 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19864 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19865 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19866 !        endif
19867 !#endif
19868 !#endif
19869       dyn_ssbond_ij(i,j)=eij
19870       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
19871       dyn_ssbond_ij(i,j)=1.0d300
19872 !#ifndef CLUST
19873 !#ifndef WHAM
19874 !        write(iout,'(a15,f12.2,f8.1,2i5)')
19875 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
19876 !#endif
19877 !#endif
19878       endif
19879
19880 !-------TESTING CODE
19881 !el      if (checkstop) then
19882       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
19883            "CHECKSTOP",rij,eij,ed
19884       echeck(jcheck)=eij
19885 !el      endif
19886       enddo
19887       if (checkstop) then
19888       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
19889       endif
19890       enddo
19891       if (checkstop) then
19892       transgrad=.true.
19893       checkstop=.false.
19894       endif
19895 !-------END TESTING CODE
19896
19897       do k=1,3
19898       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
19899       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
19900       enddo
19901       do k=1,3
19902       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
19903       enddo
19904       do k=1,3
19905       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
19906            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
19907            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
19908       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
19909            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
19910            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
19911       enddo
19912 !grad      do k=i,j-1
19913 !grad        do l=1,3
19914 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
19915 !grad        enddo
19916 !grad      enddo
19917
19918       do l=1,3
19919       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19920       gvdwc(l,j)=gvdwc(l,j)+gg(l)
19921       enddo
19922
19923       return
19924       end subroutine dyn_ssbond_ene
19925 !--------------------------------------------------------------------------
19926        subroutine triple_ssbond_ene(resi,resj,resk,eij)
19927 !      implicit none
19928 !      Includes
19929       use calc_data
19930       use comm_sschecks
19931 !      include 'DIMENSIONS'
19932 !      include 'COMMON.SBRIDGE'
19933 !      include 'COMMON.CHAIN'
19934 !      include 'COMMON.DERIV'
19935 !      include 'COMMON.LOCAL'
19936 !      include 'COMMON.INTERACT'
19937 !      include 'COMMON.VAR'
19938 !      include 'COMMON.IOUNITS'
19939 !      include 'COMMON.CALC'
19940 #ifndef CLUST
19941 #ifndef WHAM
19942        use MD_data
19943 !      include 'COMMON.MD'
19944 !      use MD, only: totT,t_bath
19945 #endif
19946 #endif
19947       double precision h_base
19948       external h_base
19949
19950 !c     Input arguments
19951       integer resi,resj,resk,m,itypi,itypj,itypk
19952
19953 !c     Output arguments
19954       double precision eij,eij1,eij2,eij3
19955
19956 !c     Local variables
19957       logical havebond
19958 !c      integer itypi,itypj,k,l
19959       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19960       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19961       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19962       double precision sig0ij,ljd,sig,fac,e1,e2
19963       double precision dcosom1(3),dcosom2(3),ed
19964       double precision pom1,pom2
19965       double precision ljA,ljB,ljXs
19966       double precision d_ljB(1:3)
19967       double precision ssA,ssB,ssC,ssXs
19968       double precision ssxm,ljxm,ssm,ljm
19969       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19970       eij=0.0
19971       if (dtriss.eq.0) return
19972       i=resi
19973       j=resj
19974       k=resk
19975 !C      write(iout,*) resi,resj,resk
19976       itypi=itype(i,1)
19977       dxi=dc_norm(1,nres+i)
19978       dyi=dc_norm(2,nres+i)
19979       dzi=dc_norm(3,nres+i)
19980       dsci_inv=vbld_inv(i+nres)
19981       xi=c(1,nres+i)
19982       yi=c(2,nres+i)
19983       zi=c(3,nres+i)
19984       call to_box(xi,yi,zi)
19985       itypj=itype(j,1)
19986       xj=c(1,nres+j)
19987       yj=c(2,nres+j)
19988       zj=c(3,nres+j)
19989       call to_box(xj,yj,zj)
19990       dxj=dc_norm(1,nres+j)
19991       dyj=dc_norm(2,nres+j)
19992       dzj=dc_norm(3,nres+j)
19993       dscj_inv=vbld_inv(j+nres)
19994       itypk=itype(k,1)
19995       xk=c(1,nres+k)
19996       yk=c(2,nres+k)
19997       zk=c(3,nres+k)
19998        call to_box(xk,yk,zk)
19999       dxk=dc_norm(1,nres+k)
20000       dyk=dc_norm(2,nres+k)
20001       dzk=dc_norm(3,nres+k)
20002       dscj_inv=vbld_inv(k+nres)
20003       xij=xj-xi
20004       xik=xk-xi
20005       xjk=xk-xj
20006       yij=yj-yi
20007       yik=yk-yi
20008       yjk=yk-yj
20009       zij=zj-zi
20010       zik=zk-zi
20011       zjk=zk-zj
20012       rrij=(xij*xij+yij*yij+zij*zij)
20013       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
20014       rrik=(xik*xik+yik*yik+zik*zik)
20015       rik=dsqrt(rrik)
20016       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
20017       rjk=dsqrt(rrjk)
20018 !C there are three combination of distances for each trisulfide bonds
20019 !C The first case the ith atom is the center
20020 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
20021 !C distance y is second distance the a,b,c,d are parameters derived for
20022 !C this problem d parameter was set as a penalty currenlty set to 1.
20023       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
20024       eij1=0.0d0
20025       else
20026       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
20027       endif
20028 !C second case jth atom is center
20029       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
20030       eij2=0.0d0
20031       else
20032       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
20033       endif
20034 !C the third case kth atom is the center
20035       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
20036       eij3=0.0d0
20037       else
20038       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
20039       endif
20040 !C      eij2=0.0
20041 !C      eij3=0.0
20042 !C      eij1=0.0
20043       eij=eij1+eij2+eij3
20044 !C      write(iout,*)i,j,k,eij
20045 !C The energy penalty calculated now time for the gradient part
20046 !C derivative over rij
20047       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
20048       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
20049           gg(1)=xij*fac/rij
20050           gg(2)=yij*fac/rij
20051           gg(3)=zij*fac/rij
20052       do m=1,3
20053       gvdwx(m,i)=gvdwx(m,i)-gg(m)
20054       gvdwx(m,j)=gvdwx(m,j)+gg(m)
20055       enddo
20056
20057       do l=1,3
20058       gvdwc(l,i)=gvdwc(l,i)-gg(l)
20059       gvdwc(l,j)=gvdwc(l,j)+gg(l)
20060       enddo
20061 !C now derivative over rik
20062       fac=-eij1**2/dtriss* &
20063       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
20064       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
20065           gg(1)=xik*fac/rik
20066           gg(2)=yik*fac/rik
20067           gg(3)=zik*fac/rik
20068       do m=1,3
20069       gvdwx(m,i)=gvdwx(m,i)-gg(m)
20070       gvdwx(m,k)=gvdwx(m,k)+gg(m)
20071       enddo
20072       do l=1,3
20073       gvdwc(l,i)=gvdwc(l,i)-gg(l)
20074       gvdwc(l,k)=gvdwc(l,k)+gg(l)
20075       enddo
20076 !C now derivative over rjk
20077       fac=-eij2**2/dtriss* &
20078       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
20079       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
20080           gg(1)=xjk*fac/rjk
20081           gg(2)=yjk*fac/rjk
20082           gg(3)=zjk*fac/rjk
20083       do m=1,3
20084       gvdwx(m,j)=gvdwx(m,j)-gg(m)
20085       gvdwx(m,k)=gvdwx(m,k)+gg(m)
20086       enddo
20087       do l=1,3
20088       gvdwc(l,j)=gvdwc(l,j)-gg(l)
20089       gvdwc(l,k)=gvdwc(l,k)+gg(l)
20090       enddo
20091       return
20092       end subroutine triple_ssbond_ene
20093
20094
20095
20096 !-----------------------------------------------------------------------------
20097       real(kind=8) function h_base(x,deriv)
20098 !     A smooth function going 0->1 in range [0,1]
20099 !     It should NOT be called outside range [0,1], it will not work there.
20100       implicit none
20101
20102 !     Input arguments
20103       real(kind=8) :: x
20104
20105 !     Output arguments
20106       real(kind=8) :: deriv
20107
20108 !     Local variables
20109       real(kind=8) :: xsq
20110
20111
20112 !     Two parabolas put together.  First derivative zero at extrema
20113 !$$$      if (x.lt.0.5D0) then
20114 !$$$        h_base=2.0D0*x*x
20115 !$$$        deriv=4.0D0*x
20116 !$$$      else
20117 !$$$        deriv=1.0D0-x
20118 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
20119 !$$$        deriv=4.0D0*deriv
20120 !$$$      endif
20121
20122 !     Third degree polynomial.  First derivative zero at extrema
20123       h_base=x*x*(3.0d0-2.0d0*x)
20124       deriv=6.0d0*x*(1.0d0-x)
20125
20126 !     Fifth degree polynomial.  First and second derivatives zero at extrema
20127 !$$$      xsq=x*x
20128 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
20129 !$$$      deriv=x-1.0d0
20130 !$$$      deriv=deriv*deriv
20131 !$$$      deriv=30.0d0*xsq*deriv
20132
20133       return
20134       end function h_base
20135 !-----------------------------------------------------------------------------
20136       subroutine dyn_set_nss
20137 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
20138 !      implicit none
20139       use MD_data, only: totT,t_bath
20140 !     Includes
20141 !      include 'DIMENSIONS'
20142 #ifdef MPI
20143       include "mpif.h"
20144 #endif
20145 !      include 'COMMON.SBRIDGE'
20146 !      include 'COMMON.CHAIN'
20147 !      include 'COMMON.IOUNITS'
20148 !      include 'COMMON.SETUP'
20149 !      include 'COMMON.MD'
20150 !     Local variables
20151       real(kind=8) :: emin
20152       integer :: i,j,imin,ierr
20153       integer :: diff,allnss,newnss
20154       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
20155             newihpb,newjhpb
20156       logical :: found
20157       integer,dimension(0:nfgtasks) :: i_newnss
20158       integer,dimension(0:nfgtasks) :: displ
20159       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
20160       integer :: g_newnss
20161
20162       allnss=0
20163       do i=1,nres-1
20164       do j=i+1,nres
20165         if (dyn_ssbond_ij(i,j).lt.1.0d300) then
20166           allnss=allnss+1
20167           allflag(allnss)=0
20168           allihpb(allnss)=i
20169           alljhpb(allnss)=j
20170         endif
20171       enddo
20172       enddo
20173
20174 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
20175
20176  1    emin=1.0d300
20177       do i=1,allnss
20178       if (allflag(i).eq.0 .and. &
20179            dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
20180         emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
20181         imin=i
20182       endif
20183       enddo
20184       if (emin.lt.1.0d300) then
20185       allflag(imin)=1
20186       do i=1,allnss
20187         if (allflag(i).eq.0 .and. &
20188              (allihpb(i).eq.allihpb(imin) .or. &
20189              alljhpb(i).eq.allihpb(imin) .or. &
20190              allihpb(i).eq.alljhpb(imin) .or. &
20191              alljhpb(i).eq.alljhpb(imin))) then
20192           allflag(i)=-1
20193         endif
20194       enddo
20195       goto 1
20196       endif
20197
20198 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
20199
20200       newnss=0
20201       do i=1,allnss
20202       if (allflag(i).eq.1) then
20203         newnss=newnss+1
20204         newihpb(newnss)=allihpb(i)
20205         newjhpb(newnss)=alljhpb(i)
20206       endif
20207       enddo
20208
20209 #ifdef MPI
20210       if (nfgtasks.gt.1)then
20211
20212       call MPI_Reduce(newnss,g_newnss,1,&
20213         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
20214       call MPI_Gather(newnss,1,MPI_INTEGER,&
20215                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
20216       displ(0)=0
20217       do i=1,nfgtasks-1,1
20218         displ(i)=i_newnss(i-1)+displ(i-1)
20219       enddo
20220       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
20221                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
20222                    king,FG_COMM,IERR)
20223       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
20224                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
20225                    king,FG_COMM,IERR)
20226       if(fg_rank.eq.0) then
20227 !         print *,'g_newnss',g_newnss
20228 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
20229 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
20230        newnss=g_newnss
20231        do i=1,newnss
20232         newihpb(i)=g_newihpb(i)
20233         newjhpb(i)=g_newjhpb(i)
20234        enddo
20235       endif
20236       endif
20237 #endif
20238
20239       diff=newnss-nss
20240
20241 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
20242 !       print *,newnss,nss,maxdim
20243       do i=1,nss
20244       found=.false.
20245 !        print *,newnss
20246       do j=1,newnss
20247 !!          print *,j
20248         if (idssb(i).eq.newihpb(j) .and. &
20249              jdssb(i).eq.newjhpb(j)) found=.true.
20250       enddo
20251 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
20252 !        write(iout,*) "found",found,i,j
20253       if (.not.found.and.fg_rank.eq.0) &
20254           write(iout,'(a15,f12.2,f8.1,2i5)') &
20255            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
20256 #endif
20257       enddo
20258
20259       do i=1,newnss
20260       found=.false.
20261       do j=1,nss
20262 !          print *,i,j
20263         if (newihpb(i).eq.idssb(j) .and. &
20264              newjhpb(i).eq.jdssb(j)) found=.true.
20265       enddo
20266 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
20267 !        write(iout,*) "found",found,i,j
20268       if (.not.found.and.fg_rank.eq.0) &
20269           write(iout,'(a15,f12.2,f8.1,2i5)') &
20270            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
20271 #endif
20272       enddo
20273 !#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
20274       nss=newnss
20275       do i=1,nss
20276       idssb(i)=newihpb(i)
20277       jdssb(i)=newjhpb(i)
20278       enddo
20279 !#else
20280 !      nss=0
20281 !#endif
20282
20283       return
20284       end subroutine dyn_set_nss
20285 ! Lipid transfer energy function
20286       subroutine Eliptransfer(eliptran)
20287 !C this is done by Adasko
20288 !C      print *,"wchodze"
20289 !C structure of box:
20290 !C      water
20291 !C--bordliptop-- buffore starts
20292 !C--bufliptop--- here true lipid starts
20293 !C      lipid
20294 !C--buflipbot--- lipid ends buffore starts
20295 !C--bordlipbot--buffore ends
20296       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
20297       integer :: i
20298       eliptran=0.0
20299 !      print *, "I am in eliptran"
20300       do i=ilip_start,ilip_end
20301 !C       do i=1,1
20302       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
20303        cycle
20304
20305       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
20306       if (positi.le.0.0) positi=positi+boxzsize
20307 !C        print *,i
20308 !C first for peptide groups
20309 !c for each residue check if it is in lipid or lipid water border area
20310        if ((positi.gt.bordlipbot)  &
20311       .and.(positi.lt.bordliptop)) then
20312 !C the energy transfer exist
20313       if (positi.lt.buflipbot) then
20314 !C what fraction I am in
20315        fracinbuf=1.0d0-      &
20316            ((positi-bordlipbot)/lipbufthick)
20317 !C lipbufthick is thickenes of lipid buffore
20318        sslip=sscalelip(fracinbuf)
20319        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
20320        eliptran=eliptran+sslip*pepliptran
20321        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
20322        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
20323 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
20324
20325 !C        print *,"doing sccale for lower part"
20326 !C         print *,i,sslip,fracinbuf,ssgradlip
20327       elseif (positi.gt.bufliptop) then
20328        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
20329        sslip=sscalelip(fracinbuf)
20330        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
20331        eliptran=eliptran+sslip*pepliptran
20332        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
20333        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
20334 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
20335 !C          print *, "doing sscalefor top part"
20336 !C         print *,i,sslip,fracinbuf,ssgradlip
20337       else
20338        eliptran=eliptran+pepliptran
20339 !C         print *,"I am in true lipid"
20340       endif
20341 !C       else
20342 !C       eliptran=elpitran+0.0 ! I am in water
20343        endif
20344        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
20345        enddo
20346 ! here starts the side chain transfer
20347        do i=ilip_start,ilip_end
20348       if (itype(i,1).eq.ntyp1) cycle
20349       positi=(mod(c(3,i+nres),boxzsize))
20350       if (positi.le.0) positi=positi+boxzsize
20351 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20352 !c for each residue check if it is in lipid or lipid water border area
20353 !C       respos=mod(c(3,i+nres),boxzsize)
20354 !C       print *,positi,bordlipbot,buflipbot
20355        if ((positi.gt.bordlipbot) &
20356        .and.(positi.lt.bordliptop)) then
20357 !C the energy transfer exist
20358       if (positi.lt.buflipbot) then
20359        fracinbuf=1.0d0-   &
20360          ((positi-bordlipbot)/lipbufthick)
20361 !C lipbufthick is thickenes of lipid buffore
20362        sslip=sscalelip(fracinbuf)
20363        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
20364        eliptran=eliptran+sslip*liptranene(itype(i,1))
20365        gliptranx(3,i)=gliptranx(3,i) &
20366       +ssgradlip*liptranene(itype(i,1))
20367        gliptranc(3,i-1)= gliptranc(3,i-1) &
20368       +ssgradlip*liptranene(itype(i,1))
20369 !C         print *,"doing sccale for lower part"
20370       elseif (positi.gt.bufliptop) then
20371        fracinbuf=1.0d0-  &
20372       ((bordliptop-positi)/lipbufthick)
20373        sslip=sscalelip(fracinbuf)
20374        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
20375        eliptran=eliptran+sslip*liptranene(itype(i,1))
20376        gliptranx(3,i)=gliptranx(3,i)  &
20377        +ssgradlip*liptranene(itype(i,1))
20378        gliptranc(3,i-1)= gliptranc(3,i-1) &
20379       +ssgradlip*liptranene(itype(i,1))
20380 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20381       else
20382        eliptran=eliptran+liptranene(itype(i,1))
20383 !C         print *,"I am in true lipid"
20384       endif
20385       endif ! if in lipid or buffor
20386 !C       else
20387 !C       eliptran=elpitran+0.0 ! I am in water
20388       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
20389        enddo
20390        return
20391        end  subroutine Eliptransfer
20392 !----------------------------------NANO FUNCTIONS
20393 !C-----------------------------------------------------------------------
20394 !C-----------------------------------------------------------
20395 !C This subroutine is to mimic the histone like structure but as well can be
20396 !C utilizet to nanostructures (infinit) small modification has to be used to
20397 !C make it finite (z gradient at the ends has to be changes as well as the x,y
20398 !C gradient has to be modified at the ends
20399 !C The energy function is Kihara potential
20400 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
20401 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
20402 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
20403 !C simple Kihara potential
20404       subroutine calctube(Etube)
20405       real(kind=8),dimension(3) :: vectube
20406       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20407        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
20408        sc_aa_tube,sc_bb_tube
20409       integer :: i,j,iti
20410       Etube=0.0d0
20411       do i=itube_start,itube_end
20412       enetube(i)=0.0d0
20413       enetube(i+nres)=0.0d0
20414       enddo
20415 !C first we calculate the distance from tube center
20416 !C for UNRES
20417        do i=itube_start,itube_end
20418 !C lets ommit dummy atoms for now
20419        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20420 !C now calculate distance from center of tube and direction vectors
20421       xmin=boxxsize
20422       ymin=boxysize
20423 ! Find minimum distance in periodic box
20424       do j=-1,1
20425        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20426        vectube(1)=vectube(1)+boxxsize*j
20427        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20428        vectube(2)=vectube(2)+boxysize*j
20429        xminact=abs(vectube(1)-tubecenter(1))
20430        yminact=abs(vectube(2)-tubecenter(2))
20431          if (xmin.gt.xminact) then
20432           xmin=xminact
20433           xtemp=vectube(1)
20434          endif
20435          if (ymin.gt.yminact) then
20436            ymin=yminact
20437            ytemp=vectube(2)
20438           endif
20439        enddo
20440       vectube(1)=xtemp
20441       vectube(2)=ytemp
20442       vectube(1)=vectube(1)-tubecenter(1)
20443       vectube(2)=vectube(2)-tubecenter(2)
20444
20445 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20446 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20447
20448 !C as the tube is infinity we do not calculate the Z-vector use of Z
20449 !C as chosen axis
20450       vectube(3)=0.0d0
20451 !C now calculte the distance
20452        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20453 !C now normalize vector
20454       vectube(1)=vectube(1)/tub_r
20455       vectube(2)=vectube(2)/tub_r
20456 !C calculte rdiffrence between r and r0
20457       rdiff=tub_r-tubeR0
20458 !C and its 6 power
20459       rdiff6=rdiff**6.0d0
20460 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20461        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20462 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20463 !C       print *,rdiff,rdiff6,pep_aa_tube
20464 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20465 !C now we calculate gradient
20466        fac=(-12.0d0*pep_aa_tube/rdiff6- &
20467           6.0d0*pep_bb_tube)/rdiff6/rdiff
20468 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20469 !C     &rdiff,fac
20470 !C now direction of gg_tube vector
20471       do j=1,3
20472       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20473       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20474       enddo
20475       enddo
20476 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20477 !C        print *,gg_tube(1,0),"TU"
20478
20479
20480        do i=itube_start,itube_end
20481 !C Lets not jump over memory as we use many times iti
20482        iti=itype(i,1)
20483 !C lets ommit dummy atoms for now
20484        if ((iti.eq.ntyp1)  &
20485 !C in UNRES uncomment the line below as GLY has no side-chain...
20486 !C      .or.(iti.eq.10)
20487       ) cycle
20488       xmin=boxxsize
20489       ymin=boxysize
20490       do j=-1,1
20491        vectube(1)=mod((c(1,i+nres)),boxxsize)
20492        vectube(1)=vectube(1)+boxxsize*j
20493        vectube(2)=mod((c(2,i+nres)),boxysize)
20494        vectube(2)=vectube(2)+boxysize*j
20495
20496        xminact=abs(vectube(1)-tubecenter(1))
20497        yminact=abs(vectube(2)-tubecenter(2))
20498          if (xmin.gt.xminact) then
20499           xmin=xminact
20500           xtemp=vectube(1)
20501          endif
20502          if (ymin.gt.yminact) then
20503            ymin=yminact
20504            ytemp=vectube(2)
20505           endif
20506        enddo
20507       vectube(1)=xtemp
20508       vectube(2)=ytemp
20509 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20510 !C     &     tubecenter(2)
20511       vectube(1)=vectube(1)-tubecenter(1)
20512       vectube(2)=vectube(2)-tubecenter(2)
20513
20514 !C as the tube is infinity we do not calculate the Z-vector use of Z
20515 !C as chosen axis
20516       vectube(3)=0.0d0
20517 !C now calculte the distance
20518        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20519 !C now normalize vector
20520       vectube(1)=vectube(1)/tub_r
20521       vectube(2)=vectube(2)/tub_r
20522
20523 !C calculte rdiffrence between r and r0
20524       rdiff=tub_r-tubeR0
20525 !C and its 6 power
20526       rdiff6=rdiff**6.0d0
20527 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20528        sc_aa_tube=sc_aa_tube_par(iti)
20529        sc_bb_tube=sc_bb_tube_par(iti)
20530        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20531        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
20532            6.0d0*sc_bb_tube/rdiff6/rdiff
20533 !C now direction of gg_tube vector
20534        do j=1,3
20535         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20536         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20537        enddo
20538       enddo
20539       do i=itube_start,itube_end
20540         Etube=Etube+enetube(i)+enetube(i+nres)
20541       enddo
20542 !C        print *,"ETUBE", etube
20543       return
20544       end subroutine calctube
20545 !C TO DO 1) add to total energy
20546 !C       2) add to gradient summation
20547 !C       3) add reading parameters (AND of course oppening of PARAM file)
20548 !C       4) add reading the center of tube
20549 !C       5) add COMMONs
20550 !C       6) add to zerograd
20551 !C       7) allocate matrices
20552
20553
20554 !C-----------------------------------------------------------------------
20555 !C-----------------------------------------------------------
20556 !C This subroutine is to mimic the histone like structure but as well can be
20557 !C utilizet to nanostructures (infinit) small modification has to be used to
20558 !C make it finite (z gradient at the ends has to be changes as well as the x,y
20559 !C gradient has to be modified at the ends
20560 !C The energy function is Kihara potential
20561 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
20562 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
20563 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
20564 !C simple Kihara potential
20565       subroutine calctube2(Etube)
20566           real(kind=8),dimension(3) :: vectube
20567       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20568        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
20569        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
20570       integer:: i,j,iti
20571       Etube=0.0d0
20572       do i=itube_start,itube_end
20573       enetube(i)=0.0d0
20574       enetube(i+nres)=0.0d0
20575       enddo
20576 !C first we calculate the distance from tube center
20577 !C first sugare-phosphate group for NARES this would be peptide group
20578 !C for UNRES
20579        do i=itube_start,itube_end
20580 !C lets ommit dummy atoms for now
20581
20582        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20583 !C now calculate distance from center of tube and direction vectors
20584 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20585 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20586 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20587 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20588       xmin=boxxsize
20589       ymin=boxysize
20590       do j=-1,1
20591        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20592        vectube(1)=vectube(1)+boxxsize*j
20593        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20594        vectube(2)=vectube(2)+boxysize*j
20595
20596        xminact=abs(vectube(1)-tubecenter(1))
20597        yminact=abs(vectube(2)-tubecenter(2))
20598          if (xmin.gt.xminact) then
20599           xmin=xminact
20600           xtemp=vectube(1)
20601          endif
20602          if (ymin.gt.yminact) then
20603            ymin=yminact
20604            ytemp=vectube(2)
20605           endif
20606        enddo
20607       vectube(1)=xtemp
20608       vectube(2)=ytemp
20609       vectube(1)=vectube(1)-tubecenter(1)
20610       vectube(2)=vectube(2)-tubecenter(2)
20611
20612 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20613 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20614
20615 !C as the tube is infinity we do not calculate the Z-vector use of Z
20616 !C as chosen axis
20617       vectube(3)=0.0d0
20618 !C now calculte the distance
20619        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20620 !C now normalize vector
20621       vectube(1)=vectube(1)/tub_r
20622       vectube(2)=vectube(2)/tub_r
20623 !C calculte rdiffrence between r and r0
20624       rdiff=tub_r-tubeR0
20625 !C and its 6 power
20626       rdiff6=rdiff**6.0d0
20627 !C THIS FRAGMENT MAKES TUBE FINITE
20628       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20629       if (positi.le.0) positi=positi+boxzsize
20630 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20631 !c for each residue check if it is in lipid or lipid water border area
20632 !C       respos=mod(c(3,i+nres),boxzsize)
20633 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20634        if ((positi.gt.bordtubebot)  &
20635       .and.(positi.lt.bordtubetop)) then
20636 !C the energy transfer exist
20637       if (positi.lt.buftubebot) then
20638        fracinbuf=1.0d0-  &
20639          ((positi-bordtubebot)/tubebufthick)
20640 !C lipbufthick is thickenes of lipid buffore
20641        sstube=sscalelip(fracinbuf)
20642        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20643 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20644        enetube(i)=enetube(i)+sstube*tubetranenepep
20645 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20646 !C     &+ssgradtube*tubetranene(itype(i,1))
20647 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20648 !C     &+ssgradtube*tubetranene(itype(i,1))
20649 !C         print *,"doing sccale for lower part"
20650       elseif (positi.gt.buftubetop) then
20651        fracinbuf=1.0d0-  &
20652       ((bordtubetop-positi)/tubebufthick)
20653        sstube=sscalelip(fracinbuf)
20654        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20655        enetube(i)=enetube(i)+sstube*tubetranenepep
20656 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20657 !C     &+ssgradtube*tubetranene(itype(i,1))
20658 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20659 !C     &+ssgradtube*tubetranene(itype(i,1))
20660 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20661       else
20662        sstube=1.0d0
20663        ssgradtube=0.0d0
20664        enetube(i)=enetube(i)+sstube*tubetranenepep
20665 !C         print *,"I am in true lipid"
20666       endif
20667       else
20668 !C          sstube=0.0d0
20669 !C          ssgradtube=0.0d0
20670       cycle
20671       endif ! if in lipid or buffor
20672
20673 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20674        enetube(i)=enetube(i)+sstube* &
20675       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
20676 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20677 !C       print *,rdiff,rdiff6,pep_aa_tube
20678 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20679 !C now we calculate gradient
20680        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
20681            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
20682 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20683 !C     &rdiff,fac
20684
20685 !C now direction of gg_tube vector
20686        do j=1,3
20687       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20688       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20689       enddo
20690        gg_tube(3,i)=gg_tube(3,i)  &
20691        +ssgradtube*enetube(i)/sstube/2.0d0
20692        gg_tube(3,i-1)= gg_tube(3,i-1)  &
20693        +ssgradtube*enetube(i)/sstube/2.0d0
20694
20695       enddo
20696 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20697 !C        print *,gg_tube(1,0),"TU"
20698       do i=itube_start,itube_end
20699 !C Lets not jump over memory as we use many times iti
20700        iti=itype(i,1)
20701 !C lets ommit dummy atoms for now
20702        if ((iti.eq.ntyp1) &
20703 !!C in UNRES uncomment the line below as GLY has no side-chain...
20704          .or.(iti.eq.10) &
20705         ) cycle
20706         vectube(1)=c(1,i+nres)
20707         vectube(1)=mod(vectube(1),boxxsize)
20708         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20709         vectube(2)=c(2,i+nres)
20710         vectube(2)=mod(vectube(2),boxysize)
20711         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20712
20713       vectube(1)=vectube(1)-tubecenter(1)
20714       vectube(2)=vectube(2)-tubecenter(2)
20715 !C THIS FRAGMENT MAKES TUBE FINITE
20716       positi=(mod(c(3,i+nres),boxzsize))
20717       if (positi.le.0) positi=positi+boxzsize
20718 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20719 !c for each residue check if it is in lipid or lipid water border area
20720 !C       respos=mod(c(3,i+nres),boxzsize)
20721 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20722
20723        if ((positi.gt.bordtubebot)  &
20724       .and.(positi.lt.bordtubetop)) then
20725 !C the energy transfer exist
20726       if (positi.lt.buftubebot) then
20727        fracinbuf=1.0d0- &
20728           ((positi-bordtubebot)/tubebufthick)
20729 !C lipbufthick is thickenes of lipid buffore
20730        sstube=sscalelip(fracinbuf)
20731        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20732 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20733        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20734 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20735 !C     &+ssgradtube*tubetranene(itype(i,1))
20736 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20737 !C     &+ssgradtube*tubetranene(itype(i,1))
20738 !C         print *,"doing sccale for lower part"
20739       elseif (positi.gt.buftubetop) then
20740        fracinbuf=1.0d0- &
20741       ((bordtubetop-positi)/tubebufthick)
20742
20743        sstube=sscalelip(fracinbuf)
20744        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20745        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20746 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20747 !C     &+ssgradtube*tubetranene(itype(i,1))
20748 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20749 !C     &+ssgradtube*tubetranene(itype(i,1))
20750 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20751       else
20752        sstube=1.0d0
20753        ssgradtube=0.0d0
20754        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20755 !C         print *,"I am in true lipid"
20756       endif
20757       else
20758 !C          sstube=0.0d0
20759 !C          ssgradtube=0.0d0
20760       cycle
20761       endif ! if in lipid or buffor
20762 !CEND OF FINITE FRAGMENT
20763 !C as the tube is infinity we do not calculate the Z-vector use of Z
20764 !C as chosen axis
20765       vectube(3)=0.0d0
20766 !C now calculte the distance
20767        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20768 !C now normalize vector
20769       vectube(1)=vectube(1)/tub_r
20770       vectube(2)=vectube(2)/tub_r
20771 !C calculte rdiffrence between r and r0
20772       rdiff=tub_r-tubeR0
20773 !C and its 6 power
20774       rdiff6=rdiff**6.0d0
20775 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20776        sc_aa_tube=sc_aa_tube_par(iti)
20777        sc_bb_tube=sc_bb_tube_par(iti)
20778        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
20779                    *sstube+enetube(i+nres)
20780 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20781 !C now we calculate gradient
20782        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
20783           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
20784 !C now direction of gg_tube vector
20785        do j=1,3
20786         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20787         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20788        enddo
20789        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
20790        +ssgradtube*enetube(i+nres)/sstube
20791        gg_tube(3,i-1)= gg_tube(3,i-1) &
20792        +ssgradtube*enetube(i+nres)/sstube
20793
20794       enddo
20795       do i=itube_start,itube_end
20796         Etube=Etube+enetube(i)+enetube(i+nres)
20797       enddo
20798 !C        print *,"ETUBE", etube
20799       return
20800       end subroutine calctube2
20801 !=====================================================================================================================================
20802       subroutine calcnano(Etube)
20803        use MD_data, only:totTafm
20804       real(kind=8),dimension(3) :: vectube,cm
20805
20806       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20807        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
20808        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact,tubezcenter,xi,yi,zi!,&
20809 !       vecsim,vectrue
20810        real(kind=8) :: eps,sig,aa_tub_lip,bb_tub_lip
20811        integer:: i,j,iti,r,ilol,ityp
20812 !      totTafm=2.0
20813       Etube=0.0d0
20814       call to_box(tubecenter(1),tubecenter(2),tubecenter(3))
20815 !      print *,itube_start,itube_end,"poczatek"
20816       do i=itube_start,itube_end
20817       enetube(i)=0.0d0
20818       enetube(i+nres)=0.0d0
20819       enddo
20820 !C first we calculate the distance from tube center
20821 !C first sugare-phosphate group for NARES this would be peptide group
20822 !C for UNRES
20823        do i=itube_start,itube_end
20824 !C lets ommit dummy atoms for now
20825        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20826 !C now calculate distance from center of tube and direction vectors
20827
20828 !      do j=-1,1
20829        xi=(c(1,i)+c(1,i+1))/2.0d0
20830        yi=(c(2,i)+c(2,i+1))/2.0d0
20831        zi=((c(3,i)+c(3,i+1))/2.0d0)
20832        call to_box(xi,yi,zi)
20833 !       tubezcenter=totTafm*velNANOconst+tubecenter(3)
20834
20835       vectube(1)=boxshift(xi-tubecenter(1),boxxsize)
20836       vectube(2)=boxshift(yi-tubecenter(2),boxysize)
20837       vectube(3)=boxshift(zi-tubecenter(3),boxzsize)
20838
20839 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20840 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20841 !C as the tube is infinity we do not calculate the Z-vector use of Z
20842 !C as chosen axis
20843 !C      vectube(3)=0.0d0
20844 !C now calculte the distance
20845        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20846 !C now normalize vector
20847       vectube(1)=vectube(1)/tub_r
20848       vectube(2)=vectube(2)/tub_r
20849       vectube(3)=vectube(3)/tub_r
20850 !C calculte rdiffrence between r and r0
20851       rdiff=tub_r-tubeR0
20852 !C and its 6 power
20853       rdiff6=rdiff**6.0d0
20854 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20855        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20856 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20857 !C       print *,rdiff,rdiff6,pep_aa_tube
20858 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20859 !C now we calculate gradient
20860        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20861           6.0d0*pep_bb_tube)/rdiff6/rdiff
20862 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20863 !C     &rdiff,fac
20864        if (acavtubpep.eq.0.0d0) then
20865 !C go to 667
20866        enecavtube(i)=0.0
20867        faccav=0.0
20868        else
20869        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
20870        enecavtube(i)=  &
20871       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
20872       /denominator
20873        enecavtube(i)=0.0
20874        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
20875       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
20876       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
20877       /denominator**2.0d0
20878 !C         faccav=0.0
20879 !C         fac=fac+faccav
20880 !C 667     continue
20881        endif
20882         if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
20883       do j=1,3
20884       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20885       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20886       enddo
20887       enddo
20888
20889        do i=itube_start,itube_end
20890       enecavtube(i)=0.0d0
20891 !C Lets not jump over memory as we use many times iti
20892        iti=itype(i,1)
20893 !C lets ommit dummy atoms for now
20894        if ((iti.eq.ntyp1) &
20895 !C in UNRES uncomment the line below as GLY has no side-chain...
20896 !C      .or.(iti.eq.10)
20897        ) cycle
20898       xi=c(1,i+nres)
20899       yi=c(2,i+nres)
20900       zi=c(3,i+nres)
20901       call to_box(xi,yi,zi)
20902        tubezcenter=totTafm*velNANOconst+tubecenter(3)
20903
20904       vectube(1)=boxshift(xi-tubecenter(1),boxxsize)
20905       vectube(2)=boxshift(yi-tubecenter(2),boxysize)
20906       vectube(3)=boxshift(zi-tubecenter(3),boxzsize)
20907
20908
20909 !C now calculte the distance
20910        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20911 !C now normalize vector
20912       vectube(1)=vectube(1)/tub_r
20913       vectube(2)=vectube(2)/tub_r
20914       vectube(3)=vectube(3)/tub_r
20915
20916 !C calculte rdiffrence between r and r0
20917       rdiff=tub_r-tubeR0
20918 !C and its 6 power
20919       rdiff6=rdiff**6.0d0
20920        sc_aa_tube=sc_aa_tube_par(iti)
20921        sc_bb_tube=sc_bb_tube_par(iti)
20922        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20923 !C       enetube(i+nres)=0.0d0
20924 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20925 !C now we calculate gradient
20926        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20927           6.0d0*sc_bb_tube/rdiff6/rdiff
20928 !C       fac=0.0
20929 !C now direction of gg_tube vector
20930 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20931        if (acavtub(iti).eq.0.0d0) then
20932 !C go to 667
20933        enecavtube(i+nres)=0.0d0
20934        faccav=0.0d0
20935        else
20936        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20937        enecavtube(i+nres)=   &
20938       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20939       /denominator
20940 !C         enecavtube(i)=0.0
20941        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20942       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20943       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20944       /denominator**2.0d0
20945 !C         faccav=0.0
20946        fac=fac+faccav
20947 !C 667     continue
20948        endif
20949 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20950 !C     &   enecavtube(i),faccav
20951 !C         print *,"licz=",
20952 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20953 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20954        do j=1,3
20955         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20956         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20957        enddo
20958         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20959       enddo
20960
20961
20962
20963       do i=itube_start,itube_end
20964         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20965        +enecavtube(i+nres)
20966       enddo
20967
20968       do i=ilipbond_start_tub,ilipbond_end_tub
20969        ityp=itype(i,4)
20970 !       print *,"ilipbond_start",ilipbond_start,i,ityp
20971        if (ityp.gt.ntyp_molec(4)) cycle
20972 !C now calculate distance from center of tube and direction vectors
20973        eps=lip_sig(ityp,18)*4.0d0
20974        sig=lip_sig(ityp,18)
20975        aa_tub_lip=eps/(sig**12)
20976        bb_tub_lip=eps/(sig**6)
20977 !      do j=-1,1
20978        xi=c(1,i)
20979        yi=c(2,i)
20980        zi=c(3,i)
20981        call to_box(xi,yi,zi)
20982 !       tubezcenter=totTafm*velNANOconst+tubecenter(3)
20983
20984       vectube(1)=boxshift(xi-tubecenter(1),boxxsize)
20985       vectube(2)=boxshift(yi-tubecenter(2),boxysize)
20986       vectube(3)=boxshift(zi-tubecenter(3),boxzsize)
20987
20988 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20989 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20990 !C as the tube is infinity we do not calculate the Z-vector use of Z
20991 !C as chosen axis
20992 !C      vectube(3)=0.0d0
20993 !C now calculte the distance
20994        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20995 !C now normalize vector
20996       vectube(1)=vectube(1)/tub_r
20997       vectube(2)=vectube(2)/tub_r
20998       vectube(3)=vectube(3)/tub_r
20999 !C calculte rdiffrence between r and r0
21000       rdiff=tub_r-tubeR0
21001 !C and its 6 power
21002       rdiff6=rdiff**6.0d0
21003 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
21004        enetube(i)=aa_tub_lip/rdiff6**2.0d0+bb_tub_lip/rdiff6
21005        Etube=Etube+enetube(i)
21006 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
21007 !C       print *,rdiff,rdiff6,pep_aa_tube
21008 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
21009 !C now we calculate gradient
21010        fac=(-12.0d0*aa_tub_lip/rdiff6-   &
21011           6.0d0*bb_tub_lip)/rdiff6/rdiff
21012        do j=1,3
21013         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
21014        enddo
21015         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres)
21016       enddo
21017
21018
21019 !-----------------------------------------------------------------------
21020       if (fg_rank.eq.0) then
21021       if (velNANOconst.ne.0) then
21022         do j=1,3
21023          cm(j)=0.0d0
21024         enddo
21025         do i=1,inanomove
21026          ilol=inanotab(i)
21027          do j=1,3
21028           cm(j)=cm(j)+c(j,ilol)
21029          enddo
21030         enddo
21031         do j=1,3
21032          cm(j)=cm(j)/inanomove
21033         enddo
21034         vecsim=velNANOconst*totTafm+distnanoinit
21035         vectrue=cm(3)-tubecenter(3)
21036         etube=etube+0.5d0*forcenanoconst*( vectrue-vecsim)**2
21037         fac=forcenanoconst*(vectrue-vecsim)/inanomove
21038         do  i=1,inanomove
21039           ilol=inanotab(i)
21040           gg_tube(3,ilol-1)=gg_tube(3,ilol-1)+fac
21041         enddo
21042         endif
21043         endif
21044 !        do i=1,20
21045 !         print *,"begin", i,"a"
21046 !         do r=1,10000
21047 !          rdiff=r/100.0d0
21048 !          rdiff6=rdiff**6.0d0
21049 !          sc_aa_tube=sc_aa_tube_par(i)
21050 !          sc_bb_tube=sc_bb_tube_par(i)
21051 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
21052 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
21053 !          enecavtube(i)=   &
21054 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
21055 !         /denominator
21056
21057 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
21058 !         enddo
21059 !         print *,"end",i,"a"
21060 !        enddo
21061 !C        print *,"ETUBE", etube
21062       return
21063       end subroutine calcnano
21064
21065 !===============================================
21066 !--------------------------------------------------------------------------------
21067 !C first for shielding is setting of function of side-chains
21068
21069        subroutine set_shield_fac2
21070        real(kind=8) :: div77_81=0.974996043d0, &
21071       div4_81=0.2222222222d0
21072        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
21073        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
21074        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
21075        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
21076 !C the vector between center of side_chain and peptide group
21077        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
21078        pept_group,costhet_grad,cosphi_grad_long, &
21079        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
21080        sh_frac_dist_grad,pep_side
21081       integer i,j,k
21082 !C      write(2,*) "ivec",ivec_start,ivec_end
21083       do i=1,nres
21084       fac_shield(i)=0.0d0
21085       ishield_list(i)=0
21086       do j=1,3
21087       grad_shield(j,i)=0.0d0
21088       enddo
21089       enddo
21090       do i=ivec_start,ivec_end
21091 !C      do i=1,nres-1
21092 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
21093 !      ishield_list(i)=0
21094       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
21095 !Cif there two consequtive dummy atoms there is no peptide group between them
21096 !C the line below has to be changed for FGPROC>1
21097       VolumeTotal=0.0
21098       do k=1,nres
21099        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
21100        dist_pep_side=0.0
21101        dist_side_calf=0.0
21102        do j=1,3
21103 !C first lets set vector conecting the ithe side-chain with kth side-chain
21104       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
21105 !C      pep_side(j)=2.0d0
21106 !C and vector conecting the side-chain with its proper calfa
21107       side_calf(j)=c(j,k+nres)-c(j,k)
21108 !C      side_calf(j)=2.0d0
21109       pept_group(j)=c(j,i)-c(j,i+1)
21110 !C lets have their lenght
21111       dist_pep_side=pep_side(j)**2+dist_pep_side
21112       dist_side_calf=dist_side_calf+side_calf(j)**2
21113       dist_pept_group=dist_pept_group+pept_group(j)**2
21114       enddo
21115        dist_pep_side=sqrt(dist_pep_side)
21116        dist_pept_group=sqrt(dist_pept_group)
21117        dist_side_calf=sqrt(dist_side_calf)
21118       do j=1,3
21119       pep_side_norm(j)=pep_side(j)/dist_pep_side
21120       side_calf_norm(j)=dist_side_calf
21121       enddo
21122 !C now sscale fraction
21123        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
21124 !       print *,buff_shield,"buff",sh_frac_dist
21125 !C now sscale
21126       if (sh_frac_dist.le.0.0) cycle
21127 !C        print *,ishield_list(i),i
21128 !C If we reach here it means that this side chain reaches the shielding sphere
21129 !C Lets add him to the list for gradient
21130       ishield_list(i)=ishield_list(i)+1
21131 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
21132 !C this list is essential otherwise problem would be O3
21133       shield_list(ishield_list(i),i)=k
21134 !C Lets have the sscale value
21135       if (sh_frac_dist.gt.1.0) then
21136        scale_fac_dist=1.0d0
21137        do j=1,3
21138        sh_frac_dist_grad(j)=0.0d0
21139        enddo
21140       else
21141        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
21142                   *(2.0d0*sh_frac_dist-3.0d0)
21143        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
21144                    /dist_pep_side/buff_shield*0.5d0
21145        do j=1,3
21146        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
21147 !C         sh_frac_dist_grad(j)=0.0d0
21148 !C         scale_fac_dist=1.0d0
21149 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
21150 !C     &                    sh_frac_dist_grad(j)
21151        enddo
21152       endif
21153 !C this is what is now we have the distance scaling now volume...
21154       short=short_r_sidechain(itype(k,1))
21155       long=long_r_sidechain(itype(k,1))
21156       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
21157       sinthet=short/dist_pep_side*costhet
21158 !      print *,"SORT",short,long,sinthet,costhet
21159 !C now costhet_grad
21160 !C       costhet=0.6d0
21161 !C       sinthet=0.8
21162        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
21163 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
21164 !C     &             -short/dist_pep_side**2/costhet)
21165 !C       costhet_fac=0.0d0
21166        do j=1,3
21167        costhet_grad(j)=costhet_fac*pep_side(j)
21168        enddo
21169 !C remember for the final gradient multiply costhet_grad(j)
21170 !C for side_chain by factor -2 !
21171 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
21172 !C pep_side0pept_group is vector multiplication
21173       pep_side0pept_group=0.0d0
21174       do j=1,3
21175       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
21176       enddo
21177       cosalfa=(pep_side0pept_group/ &
21178       (dist_pep_side*dist_side_calf))
21179       fac_alfa_sin=1.0d0-cosalfa**2
21180       fac_alfa_sin=dsqrt(fac_alfa_sin)
21181       rkprim=fac_alfa_sin*(long-short)+short
21182 !C      rkprim=short
21183
21184 !C now costhet_grad
21185        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
21186 !C       cosphi=0.6
21187        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
21188        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
21189          dist_pep_side**2)
21190 !C       sinphi=0.8
21191        do j=1,3
21192        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
21193       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
21194       *(long-short)/fac_alfa_sin*cosalfa/ &
21195       ((dist_pep_side*dist_side_calf))* &
21196       ((side_calf(j))-cosalfa* &
21197       ((pep_side(j)/dist_pep_side)*dist_side_calf))
21198 !C       cosphi_grad_long(j)=0.0d0
21199       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
21200       *(long-short)/fac_alfa_sin*cosalfa &
21201       /((dist_pep_side*dist_side_calf))* &
21202       (pep_side(j)- &
21203       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
21204 !C       cosphi_grad_loc(j)=0.0d0
21205        enddo
21206 !C      print *,sinphi,sinthet
21207       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
21208                    /VSolvSphere_div
21209 !C     &                    *wshield
21210 !C now the gradient...
21211       do j=1,3
21212       grad_shield(j,i)=grad_shield(j,i) &
21213 !C gradient po skalowaniu
21214                  +(sh_frac_dist_grad(j)*VofOverlap &
21215 !C  gradient po costhet
21216           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
21217       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
21218           sinphi/sinthet*costhet*costhet_grad(j) &
21219          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
21220       )*wshield
21221 !C grad_shield_side is Cbeta sidechain gradient
21222       grad_shield_side(j,ishield_list(i),i)=&
21223            (sh_frac_dist_grad(j)*-2.0d0&
21224            *VofOverlap&
21225           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
21226        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
21227           sinphi/sinthet*costhet*costhet_grad(j)&
21228          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
21229           )*wshield
21230 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
21231 !            sinphi/sinthet,&
21232 !           +sinthet/sinphi,"HERE"
21233        grad_shield_loc(j,ishield_list(i),i)=   &
21234           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
21235       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
21236           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
21237            ))&
21238            *wshield
21239 !         print *,grad_shield_loc(j,ishield_list(i),i)
21240       enddo
21241       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
21242       enddo
21243       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
21244
21245 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
21246       enddo
21247       return
21248       end subroutine set_shield_fac2
21249 !----------------------------------------------------------------------------
21250 ! SOUBROUTINE FOR AFM
21251        subroutine AFMvel(Eafmforce)
21252        use MD_data, only:totTafm
21253       real(kind=8),dimension(3) :: diffafm,cbeg,cend
21254       real(kind=8) :: afmdist,Eafmforce
21255        integer :: i,j
21256 !C Only for check grad COMMENT if not used for checkgrad
21257 !C      totT=3.0d0
21258 !C--------------------------------------------------------
21259 !C      print *,"wchodze"
21260       afmdist=0.0d0
21261       Eafmforce=0.0d0
21262       cbeg=0.0d0
21263       cend=0.0d0
21264       if (afmbeg.eq.-1) then
21265         do i=1,nbegafmmat
21266          do j=1,3
21267           cbeg(j)=cbeg(j)+c(j,afmbegcentr(i))/nbegafmmat
21268          enddo
21269         enddo
21270       else
21271       do j=1,3
21272         cbeg(j)=c(j,afmend)
21273       enddo
21274       endif
21275       if (afmend.eq.-1) then
21276         do i=1,nendafmmat
21277          do j=1,3
21278           cend(j)=cend(j)+c(j,afmendcentr(i))/nendafmmat
21279          enddo
21280         enddo
21281       else
21282         cend(j)=c(j,afmend)
21283       endif
21284
21285       do i=1,3
21286       diffafm(i)=cend(i)-cbeg(i)
21287       afmdist=afmdist+diffafm(i)**2
21288       enddo
21289       afmdist=dsqrt(afmdist)
21290 !      totTafm=3.0
21291       Eafmforce=0.5d0*forceAFMconst &
21292       *(distafminit+totTafm*velAFMconst-afmdist)**2
21293 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
21294       if (afmend.eq.-1) then
21295       do i=1,nendafmmat
21296          do j=1,3
21297           gradafm(j,afmendcentr(i)-1)=-forceAFMconst* &
21298           (distafminit+totTafm*velAFMconst-afmdist) &
21299           *diffafm(j)/afmdist/nendafmmat
21300          enddo
21301       enddo
21302       else
21303       do i=1,3
21304       gradafm(i,afmend-1)=-forceAFMconst* &
21305        (distafminit+totTafm*velAFMconst-afmdist) &
21306        *diffafm(i)/afmdist
21307       enddo
21308       endif
21309        if (afmbeg.eq.-1) then
21310         do i=1,nbegafmmat
21311          do j=1,3
21312            gradafm(i,afmbegcentr(i)-1)=forceAFMconst* &
21313           (distafminit+totTafm*velAFMconst-afmdist) &
21314            *diffafm(i)/afmdist
21315          enddo
21316         enddo
21317        else
21318        do i=1,3
21319       gradafm(i,afmbeg-1)=forceAFMconst* &
21320       (distafminit+totTafm*velAFMconst-afmdist) &
21321       *diffafm(i)/afmdist
21322       enddo
21323        endif
21324 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
21325       return
21326       end subroutine AFMvel
21327 !---------------------------------------------------------
21328        subroutine AFMforce(Eafmforce)
21329
21330       real(kind=8),dimension(3) :: diffafm
21331 !      real(kind=8) ::afmdist
21332       real(kind=8) :: afmdist,Eafmforce
21333       integer :: i
21334       afmdist=0.0d0
21335       Eafmforce=0.0d0
21336       do i=1,3
21337       diffafm(i)=c(i,afmend)-c(i,afmbeg)
21338       afmdist=afmdist+diffafm(i)**2
21339       enddo
21340       afmdist=dsqrt(afmdist)
21341 !      print *,afmdist,distafminit
21342       Eafmforce=-forceAFMconst*(afmdist-distafminit)
21343       do i=1,3
21344       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
21345       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
21346       enddo
21347 !C      print *,'AFM',Eafmforce
21348       return
21349       end subroutine AFMforce
21350
21351 !-----------------------------------------------------------------------------
21352 #ifdef WHAM
21353       subroutine read_ssHist
21354 !      implicit none
21355 !      Includes
21356 !      include 'DIMENSIONS'
21357 !      include "DIMENSIONS.FREE"
21358 !      include 'COMMON.FREE'
21359 !     Local variables
21360       integer :: i,j
21361       character(len=80) :: controlcard
21362
21363       do i=1,dyn_nssHist
21364       call card_concat(controlcard,.true.)
21365       read(controlcard,*) &
21366            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
21367       enddo
21368
21369       return
21370       end subroutine read_ssHist
21371 #endif
21372 !-----------------------------------------------------------------------------
21373       integer function indmat(i,j)
21374 !el
21375 ! get the position of the jth ijth fragment of the chain coordinate system
21376 ! in the fromto array.
21377       integer :: i,j
21378
21379       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
21380       return
21381       end function indmat
21382 !-----------------------------------------------------------------------------
21383       real(kind=8) function sigm(x)
21384 !el
21385        real(kind=8) :: x
21386       sigm=0.25d0*x
21387       return
21388       end function sigm
21389 !-----------------------------------------------------------------------------
21390 !-----------------------------------------------------------------------------
21391       subroutine alloc_ener_arrays
21392 !EL Allocation of arrays used by module energy
21393       use MD_data, only: mset
21394 !el local variables
21395       integer :: i,j
21396
21397       if(nres.lt.100) then
21398       maxconts=10*nres
21399       elseif(nres.lt.200) then
21400       maxconts=10*nres      ! Max. number of contacts per residue
21401       else
21402       maxconts=10*nres ! (maxconts=maxres/4)
21403       endif
21404       maxcont=100*nres      ! Max. number of SC contacts
21405       maxvar=6*nres      ! Max. number of variables
21406 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
21407       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
21408 !----------------------
21409 ! arrays in subroutine init_int_table
21410 !el#ifdef MPI
21411 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
21412 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
21413 !el#endif
21414       allocate(nint_gr(nres))
21415       allocate(nscp_gr(nres))
21416       allocate(ielstart(nres))
21417       allocate(ielend(nres))
21418 !(maxres)
21419       allocate(istart(nres,maxint_gr))
21420       allocate(iend(nres,maxint_gr))
21421 !(maxres,maxint_gr)
21422       allocate(iscpstart(nres,maxint_gr))
21423       allocate(iscpend(nres,maxint_gr))
21424 !(maxres,maxint_gr)
21425       allocate(ielstart_vdw(nres))
21426       allocate(ielend_vdw(nres))
21427 !(maxres)
21428       allocate(nint_gr_nucl(nres))
21429       allocate(nscp_gr_nucl(nres))
21430       allocate(ielstart_nucl(nres))
21431       allocate(ielend_nucl(nres))
21432 !(maxres)
21433       allocate(istart_nucl(nres,maxint_gr))
21434       allocate(iend_nucl(nres,maxint_gr))
21435 !(maxres,maxint_gr)
21436       allocate(iscpstart_nucl(nres,maxint_gr))
21437       allocate(iscpend_nucl(nres,maxint_gr))
21438 !(maxres,maxint_gr)
21439       allocate(ielstart_vdw_nucl(nres))
21440       allocate(ielend_vdw_nucl(nres))
21441
21442       allocate(lentyp(0:nfgtasks-1))
21443 !(0:maxprocs-1)
21444 !----------------------
21445 ! commom.contacts
21446 !      common /contacts/
21447       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
21448       allocate(icont(2,maxcont))
21449 !(2,maxcont)
21450 !      common /contacts1/
21451       allocate(num_cont(0:nres+4))
21452 !(maxres)
21453       allocate(jcont(maxconts,nres))
21454 !(maxconts,maxres)
21455       allocate(facont(maxconts,nres))
21456 !(maxconts,maxres)
21457       allocate(gacont(3,maxconts,nres))
21458 !(3,maxconts,maxres)
21459 !      common /contacts_hb/
21460       allocate(gacontp_hb1(3,maxconts,nres))
21461       allocate(gacontp_hb2(3,maxconts,nres))
21462       allocate(gacontp_hb3(3,maxconts,nres))
21463       allocate(gacontm_hb1(3,maxconts,nres))
21464       allocate(gacontm_hb2(3,maxconts,nres))
21465       allocate(gacontm_hb3(3,maxconts,nres))
21466       allocate(gacont_hbr(3,maxconts,nres))
21467       allocate(grij_hb_cont(3,maxconts,nres))
21468         !(3,maxconts,maxres)
21469       allocate(facont_hb(maxconts,nres))
21470
21471       allocate(ees0p(maxconts,nres))
21472       allocate(ees0m(maxconts,nres))
21473       allocate(d_cont(maxconts,nres))
21474       allocate(ees0plist(maxconts,nres))
21475
21476 !(maxconts,maxres)
21477       allocate(num_cont_hb(nres))
21478 !(maxres)
21479       allocate(jcont_hb(maxconts,nres))
21480 !(maxconts,maxres)
21481 !      common /rotat/
21482       allocate(Ug(2,2,nres))
21483       allocate(Ugder(2,2,nres))
21484       allocate(Ug2(2,2,nres))
21485       allocate(Ug2der(2,2,nres))
21486 !(2,2,maxres)
21487       allocate(obrot(2,nres))
21488       allocate(obrot2(2,nres))
21489       allocate(obrot_der(2,nres))
21490       allocate(obrot2_der(2,nres))
21491 !(2,maxres)
21492 !      common /precomp1/
21493       allocate(mu(2,nres))
21494       allocate(muder(2,nres))
21495       allocate(Ub2(2,nres))
21496       Ub2(1,:)=0.0d0
21497       Ub2(2,:)=0.0d0
21498       allocate(Ub2der(2,nres))
21499       allocate(Ctobr(2,nres))
21500       allocate(Ctobrder(2,nres))
21501       allocate(Dtobr2(2,nres))
21502       allocate(Dtobr2der(2,nres))
21503 !(2,maxres)
21504       allocate(EUg(2,2,nres))
21505       allocate(EUgder(2,2,nres))
21506       allocate(CUg(2,2,nres))
21507       allocate(CUgder(2,2,nres))
21508       allocate(DUg(2,2,nres))
21509       allocate(Dugder(2,2,nres))
21510       allocate(DtUg2(2,2,nres))
21511       allocate(DtUg2der(2,2,nres))
21512 !(2,2,maxres)
21513 !      common /precomp2/
21514       allocate(Ug2Db1t(2,nres))
21515       allocate(Ug2Db1tder(2,nres))
21516       allocate(CUgb2(2,nres))
21517       allocate(CUgb2der(2,nres))
21518 !(2,maxres)
21519       allocate(EUgC(2,2,nres))
21520       allocate(EUgCder(2,2,nres))
21521       allocate(EUgD(2,2,nres))
21522       allocate(EUgDder(2,2,nres))
21523       allocate(DtUg2EUg(2,2,nres))
21524       allocate(Ug2DtEUg(2,2,nres))
21525 !(2,2,maxres)
21526       allocate(Ug2DtEUgder(2,2,2,nres))
21527       allocate(DtUg2EUgder(2,2,2,nres))
21528 !(2,2,2,maxres)
21529       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
21530       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
21531       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
21532       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
21533
21534       allocate(ctilde(2,2,nres))
21535       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
21536       allocate(gtb1(2,nres))
21537       allocate(gtb2(2,nres))
21538       allocate(cc(2,2,nres))
21539       allocate(dd(2,2,nres))
21540       allocate(ee(2,2,nres))
21541       allocate(gtcc(2,2,nres))
21542       allocate(gtdd(2,2,nres))
21543       allocate(gtee(2,2,nres))
21544       allocate(gUb2(2,nres))
21545       allocate(gteUg(2,2,nres))
21546
21547 !      common /rotat_old/
21548       allocate(costab(nres))
21549       allocate(sintab(nres))
21550       allocate(costab2(nres))
21551       allocate(sintab2(nres))
21552 !(maxres)
21553 !      common /dipmat/
21554       allocate(a_chuj(2,2,maxconts,nres))
21555 !(2,2,maxconts,maxres)(maxconts=maxres/4)
21556       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
21557 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
21558 !      common /contdistrib/
21559       allocate(ncont_sent(nres))
21560       allocate(ncont_recv(nres))
21561
21562       allocate(iat_sent(nres))
21563 !(maxres)
21564       allocate(iint_sent(4,nres,nres))
21565       allocate(iint_sent_local(4,nres,nres))
21566 !(4,maxres,maxres)
21567       allocate(iturn3_sent(4,0:nres+4))
21568       allocate(iturn4_sent(4,0:nres+4))
21569       allocate(iturn3_sent_local(4,nres))
21570       allocate(iturn4_sent_local(4,nres))
21571 !(4,maxres)
21572       allocate(itask_cont_from(0:nfgtasks-1))
21573       allocate(itask_cont_to(0:nfgtasks-1))
21574 !(0:max_fg_procs-1)
21575
21576
21577
21578 !----------------------
21579 ! commom.deriv;
21580 !      common /derivat/
21581       allocate(dcdv(6,maxdim))
21582       allocate(dxdv(6,maxdim))
21583 !(6,maxdim)
21584       allocate(dxds(6,nres))
21585 !(6,maxres)
21586       allocate(gradx(3,-1:nres,0:2))
21587       allocate(gradc(3,-1:nres,0:2))
21588 !(3,maxres,2)
21589       allocate(gvdwx(3,-1:nres))
21590       allocate(gvdwc(3,-1:nres))
21591       allocate(gelc(3,-1:nres))
21592       allocate(gelc_long(3,-1:nres))
21593       allocate(gvdwpp(3,-1:nres))
21594       allocate(gvdwc_scpp(3,-1:nres))
21595       allocate(gradx_scp(3,-1:nres))
21596       allocate(gvdwc_scp(3,-1:nres))
21597       allocate(ghpbx(3,-1:nres))
21598       allocate(ghpbc(3,-1:nres))
21599       allocate(gradcorr(3,-1:nres))
21600       allocate(gradcorr_long(3,-1:nres))
21601       allocate(gradcorr5_long(3,-1:nres))
21602       allocate(gradcorr6_long(3,-1:nres))
21603       allocate(gcorr6_turn_long(3,-1:nres))
21604       allocate(gradxorr(3,-1:nres))
21605       allocate(gradcorr5(3,-1:nres))
21606       allocate(gradcorr6(3,-1:nres))
21607       allocate(gliptran(3,-1:nres))
21608       allocate(gliptranc(3,-1:nres))
21609       allocate(gliptranx(3,-1:nres))
21610       allocate(gshieldx(3,-1:nres))
21611       allocate(gshieldc(3,-1:nres))
21612       allocate(gshieldc_loc(3,-1:nres))
21613       allocate(gshieldx_ec(3,-1:nres))
21614       allocate(gshieldc_ec(3,-1:nres))
21615       allocate(gshieldc_loc_ec(3,-1:nres))
21616       allocate(gshieldx_t3(3,-1:nres))
21617       allocate(gshieldc_t3(3,-1:nres))
21618       allocate(gshieldc_loc_t3(3,-1:nres))
21619       allocate(gshieldx_t4(3,-1:nres))
21620       allocate(gshieldc_t4(3,-1:nres))
21621       allocate(gshieldc_loc_t4(3,-1:nres))
21622       allocate(gshieldx_ll(3,-1:nres))
21623       allocate(gshieldc_ll(3,-1:nres))
21624       allocate(gshieldc_loc_ll(3,-1:nres))
21625       allocate(grad_shield(3,-1:nres))
21626       allocate(gg_tube_sc(3,-1:nres))
21627       allocate(gg_tube(3,-1:nres))
21628       allocate(gradafm(3,-1:nres))
21629       allocate(gradb_nucl(3,-1:nres))
21630       allocate(gradbx_nucl(3,-1:nres))
21631       allocate(gvdwpsb1(3,-1:nres))
21632       allocate(gelpp(3,-1:nres))
21633       allocate(gvdwpsb(3,-1:nres))
21634       allocate(gelsbc(3,-1:nres))
21635       allocate(gelsbx(3,-1:nres))
21636       allocate(gvdwsbx(3,-1:nres))
21637       allocate(gvdwsbc(3,-1:nres))
21638       allocate(gsbloc(3,-1:nres))
21639       allocate(gsblocx(3,-1:nres))
21640       allocate(gradcorr_nucl(3,-1:nres))
21641       allocate(gradxorr_nucl(3,-1:nres))
21642       allocate(gradcorr3_nucl(3,-1:nres))
21643       allocate(gradxorr3_nucl(3,-1:nres))
21644       allocate(gvdwpp_nucl(3,-1:nres))
21645       allocate(gradpepcat(3,-1:nres))
21646       allocate(gradpepcatx(3,-1:nres))
21647       allocate(gradcatcat(3,-1:nres))
21648       allocate(gradnuclcat(3,-1:nres))
21649       allocate(gradnuclcatx(3,-1:nres))
21650       allocate(gradlipbond(3,-1:nres))
21651       allocate(gradlipang(3,-1:nres))
21652       allocate(gradliplj(3,-1:nres))
21653       allocate(gradlipelec(3,-1:nres))
21654       allocate(gradcattranc(3,-1:nres))
21655       allocate(gradcattranx(3,-1:nres))
21656       allocate(gradcatangx(3,-1:nres))
21657       allocate(gradcatangc(3,-1:nres))
21658 !(3,maxres)
21659       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
21660       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
21661 ! grad for shielding surroing
21662       allocate(gloc(0:maxvar,0:2))
21663       allocate(gloc_x(0:maxvar,2))
21664 !(maxvar,2)
21665       allocate(gel_loc(3,-1:nres))
21666       allocate(gel_loc_long(3,-1:nres))
21667       allocate(gcorr3_turn(3,-1:nres))
21668       allocate(gcorr4_turn(3,-1:nres))
21669       allocate(gcorr6_turn(3,-1:nres))
21670       allocate(gradb(3,-1:nres))
21671       allocate(gradbx(3,-1:nres))
21672 !(3,maxres)
21673       allocate(gel_loc_loc(maxvar))
21674       allocate(gel_loc_turn3(maxvar))
21675       allocate(gel_loc_turn4(maxvar))
21676       allocate(gel_loc_turn6(maxvar))
21677       allocate(gcorr_loc(maxvar))
21678       allocate(g_corr5_loc(maxvar))
21679       allocate(g_corr6_loc(maxvar))
21680 !(maxvar)
21681       allocate(gsccorc(3,-1:nres))
21682       allocate(gsccorx(3,-1:nres))
21683 !(3,maxres)
21684       allocate(gsccor_loc(-1:nres))
21685 !(maxres)
21686       allocate(gvdwx_scbase(3,-1:nres))
21687       allocate(gvdwc_scbase(3,-1:nres))
21688       allocate(gvdwx_pepbase(3,-1:nres))
21689       allocate(gvdwc_pepbase(3,-1:nres))
21690       allocate(gvdwx_scpho(3,-1:nres))
21691       allocate(gvdwc_scpho(3,-1:nres))
21692       allocate(gvdwc_peppho(3,-1:nres))
21693
21694       allocate(dtheta(3,2,-1:nres))
21695 !(3,2,maxres)
21696       allocate(gscloc(3,-1:nres))
21697       allocate(gsclocx(3,-1:nres))
21698 !(3,maxres)
21699       allocate(dphi(3,3,-1:nres))
21700       allocate(dalpha(3,3,-1:nres))
21701       allocate(domega(3,3,-1:nres))
21702 !(3,3,maxres)
21703 !      common /deriv_scloc/
21704       allocate(dXX_C1tab(3,nres))
21705       allocate(dYY_C1tab(3,nres))
21706       allocate(dZZ_C1tab(3,nres))
21707       allocate(dXX_Ctab(3,nres))
21708       allocate(dYY_Ctab(3,nres))
21709       allocate(dZZ_Ctab(3,nres))
21710       allocate(dXX_XYZtab(3,nres))
21711       allocate(dYY_XYZtab(3,nres))
21712       allocate(dZZ_XYZtab(3,nres))
21713 !(3,maxres)
21714 !      common /mpgrad/
21715       allocate(jgrad_start(nres))
21716       allocate(jgrad_end(nres))
21717 !(maxres)
21718 !----------------------
21719
21720 !      common /indices/
21721       allocate(ibond_displ(0:nfgtasks-1))
21722       allocate(ibond_count(0:nfgtasks-1))
21723       allocate(ithet_displ(0:nfgtasks-1))
21724       allocate(ithet_count(0:nfgtasks-1))
21725       allocate(iphi_displ(0:nfgtasks-1))
21726       allocate(iphi_count(0:nfgtasks-1))
21727       allocate(iphi1_displ(0:nfgtasks-1))
21728       allocate(iphi1_count(0:nfgtasks-1))
21729       allocate(ivec_displ(0:nfgtasks-1))
21730       allocate(ivec_count(0:nfgtasks-1))
21731       allocate(iset_displ(0:nfgtasks-1))
21732       allocate(iset_count(0:nfgtasks-1))
21733       allocate(iint_count(0:nfgtasks-1))
21734       allocate(iint_displ(0:nfgtasks-1))
21735 !(0:max_fg_procs-1)
21736 !----------------------
21737 ! common.MD
21738 !      common /mdgrad/
21739       allocate(gcart(3,-1:nres))
21740       allocate(gxcart(3,-1:nres))
21741 !(3,0:MAXRES)
21742       allocate(gradcag(3,-1:nres))
21743       allocate(gradxag(3,-1:nres))
21744 !(3,MAXRES)
21745 !      common /back_constr/
21746 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
21747       allocate(dutheta(nres))
21748       allocate(dugamma(nres))
21749 !(maxres)
21750       allocate(duscdiff(3,-1:nres))
21751       allocate(duscdiffx(3,-1:nres))
21752 !(3,maxres)
21753 !el i io:read_fragments
21754 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
21755 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
21756 !      common /qmeas/
21757 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
21758 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
21759       allocate(mset(0:nprocs))  !(maxprocs/20)
21760       mset(:)=0
21761 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
21762 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
21763       allocate(dUdconst(3,0:nres))
21764       allocate(dUdxconst(3,0:nres))
21765       allocate(dqwol(3,0:nres))
21766       allocate(dxqwol(3,0:nres))
21767 !(3,0:MAXRES)
21768 !----------------------
21769 ! common.sbridge
21770 !      common /sbridge/ in io_common: read_bridge
21771 !el    allocate((:),allocatable :: iss      !(maxss)
21772 !      common /links/  in io_common: read_bridge
21773 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
21774 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
21775 !      common /dyn_ssbond/
21776 ! and side-chain vectors in theta or phi.
21777       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
21778 !(maxres,maxres)
21779 !      do i=1,nres
21780 !        do j=i+1,nres
21781       dyn_ssbond_ij(:,:)=1.0d300
21782 !        enddo
21783 !      enddo
21784
21785 !      if (nss.gt.0) then
21786       allocate(idssb(maxdim),jdssb(maxdim))
21787 !        allocate(newihpb(nss),newjhpb(nss))
21788 !(maxdim)
21789 !      endif
21790       allocate(ishield_list(-1:nres))
21791       allocate(shield_list(maxcontsshi,-1:nres))
21792       allocate(dyn_ss_mask(nres))
21793       allocate(fac_shield(-1:nres))
21794       allocate(enetube(nres*2))
21795       allocate(enecavtube(nres*2))
21796
21797 !(maxres)
21798       dyn_ss_mask(:)=.false.
21799 !----------------------
21800 ! common.sccor
21801 ! Parameters of the SCCOR term
21802 !      common/sccor/
21803 !el in io_conf: parmread
21804 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
21805 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
21806 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
21807 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
21808 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
21809 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
21810 !      allocate(vlor1sccor(maxterm_sccor,20,20))
21811 !      allocate(vlor2sccor(maxterm_sccor,20,20))
21812 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
21813 !----------------
21814       allocate(gloc_sc(3,0:2*nres,0:10))
21815 !(3,0:maxres2,10)maxres2=2*maxres
21816       allocate(dcostau(3,3,3,2*nres))
21817       allocate(dsintau(3,3,3,2*nres))
21818       allocate(dtauangle(3,3,3,2*nres))
21819       allocate(dcosomicron(3,3,3,2*nres))
21820       allocate(domicron(3,3,3,2*nres))
21821 !(3,3,3,maxres2)maxres2=2*maxres
21822 !----------------------
21823 ! common.var
21824 !      common /restr/
21825       allocate(varall(maxvar))
21826 !(maxvar)(maxvar=6*maxres)
21827       allocate(mask_theta(nres))
21828       allocate(mask_phi(nres))
21829       allocate(mask_side(nres))
21830 !(maxres)
21831 !----------------------
21832 ! common.vectors
21833 !      common /vectors/
21834       allocate(uy(3,nres))
21835       allocate(uz(3,nres))
21836 !(3,maxres)
21837       allocate(uygrad(3,3,2,nres))
21838       allocate(uzgrad(3,3,2,nres))
21839 !(3,3,2,maxres)
21840 ! allocateion of lists JPRDLA
21841       allocate(newcontlistppi(300*nres))
21842       allocate(newcontlistscpi(350*nres))
21843       allocate(newcontlisti(300*nres))
21844       allocate(newcontlistppj(300*nres))
21845       allocate(newcontlistscpj(350*nres))
21846       allocate(newcontlistj(300*nres))
21847       allocate(newcontlistcatsctrani(300*nres))
21848       allocate(newcontlistcatsctranj(300*nres))
21849       allocate(newcontlistcatptrani(300*nres))
21850       allocate(newcontlistcatptranj(300*nres))
21851       allocate(newcontlistcatscnormi(300*nres))
21852       allocate(newcontlistcatscnormj(300*nres))
21853       allocate(newcontlistcatpnormi(300*nres))
21854       allocate(newcontlistcatpnormj(300*nres))
21855
21856       allocate(newcontlistcatscangi(300*nres))
21857       allocate(newcontlistcatscangj(300*nres))
21858       allocate(newcontlistcatscangfi(300*nres))
21859       allocate(newcontlistcatscangfj(300*nres))
21860       allocate(newcontlistcatscangfk(300*nres))
21861       allocate(newcontlistcatscangti(300*nres))
21862       allocate(newcontlistcatscangtj(300*nres))
21863       allocate(newcontlistcatscangtk(300*nres))
21864       allocate(newcontlistcatscangtl(300*nres))
21865
21866
21867       return
21868       end subroutine alloc_ener_arrays
21869 !-----------------------------------------------------------------
21870       subroutine ebond_nucl(estr_nucl)
21871 !c
21872 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
21873 !c
21874
21875       real(kind=8),dimension(3) :: u,ud
21876       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
21877       real(kind=8) :: estr_nucl,diff
21878       integer :: iti,i,j,k,nbi
21879       estr_nucl=0.0d0
21880 !C      print *,"I enter ebond"
21881       if (energy_dec) &
21882       write (iout,*) "ibondp_start,ibondp_end",&
21883        ibondp_nucl_start,ibondp_nucl_end
21884       do i=ibondp_nucl_start,ibondp_nucl_end
21885
21886         if (itype(i-1,2).eq.ntyp1_molec(2)&
21887             .and.itype(i,2).eq.ntyp1_molec(2)) cycle
21888         if (itype(i-1,2).eq.ntyp1_molec(2)&
21889             .or. itype(i,2).eq.ntyp1_molec(2)) then
21890 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
21891 !C          do j=1,3
21892 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
21893 !C            *dc(j,i-1)/vbld(i)
21894 !C          enddo
21895 !C          if (energy_dec) write(iout,*) &
21896 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
21897         diff = vbld(i)-vbldpDUM
21898         else
21899         diff = vbld(i)-vbldp0_nucl
21900         endif
21901 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
21902 !          do j=1,3
21903 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
21904 !     &      *dc(j,i-1)/vbld(i)
21905 !          enddo
21906 !          if (energy_dec) write(iout,*)
21907 !     &       "estr1",i,vbld(i),distchainmax,
21908 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
21909
21910         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
21911         vbldp0_nucl,diff,AKP_nucl*diff*diff
21912         estr_nucl=estr_nucl+diff*diff
21913 !          print *,estr_nucl
21914         do j=1,3
21915           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
21916         enddo
21917 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
21918       enddo
21919       estr_nucl=0.5d0*AKP_nucl*estr_nucl
21920 !      print *,"partial sum", estr_nucl,AKP_nucl
21921
21922       if (energy_dec) &
21923       write (iout,*) "ibondp_start,ibondp_end",&
21924        ibond_nucl_start,ibond_nucl_end
21925
21926       do i=ibond_nucl_start,ibond_nucl_end
21927 !C        print *, "I am stuck",i
21928       iti=itype(i,2)
21929       if (iti.eq.ntyp1_molec(2)) cycle
21930         nbi=nbondterm_nucl(iti)
21931 !C        print *,iti,nbi
21932         if (nbi.eq.1) then
21933           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
21934
21935           if (energy_dec) &
21936          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
21937          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
21938           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
21939 !            print *,estr_nucl
21940           do j=1,3
21941             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
21942           enddo
21943         else
21944           do j=1,nbi
21945             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
21946             ud(j)=aksc_nucl(j,iti)*diff
21947             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
21948           enddo
21949           uprod=u(1)
21950           do j=2,nbi
21951             uprod=uprod*u(j)
21952           enddo
21953           usum=0.0d0
21954           usumsqder=0.0d0
21955           do j=1,nbi
21956             uprod1=1.0d0
21957             uprod2=1.0d0
21958             do k=1,nbi
21959             if (k.ne.j) then
21960               uprod1=uprod1*u(k)
21961               uprod2=uprod2*u(k)*u(k)
21962             endif
21963             enddo
21964             usum=usum+uprod1
21965             usumsqder=usumsqder+ud(j)*uprod2
21966           enddo
21967           estr_nucl=estr_nucl+uprod/usum
21968           do j=1,3
21969            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
21970           enddo
21971       endif
21972       enddo
21973 !C      print *,"I am about to leave ebond"
21974       return
21975       end subroutine ebond_nucl
21976
21977 !-----------------------------------------------------------------------------
21978       subroutine ebend_nucl(etheta_nucl)
21979       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
21980       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
21981       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
21982       logical :: lprn=.false., lprn1=.false.
21983 !el local variables
21984       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
21985       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
21986       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
21987 ! local variables for constrains
21988       real(kind=8) :: difi,thetiii
21989        integer itheta
21990       etheta_nucl=0.0D0
21991 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
21992       do i=ithet_nucl_start,ithet_nucl_end
21993       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
21994       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
21995       (itype(i,2).eq.ntyp1_molec(2))) cycle
21996       dethetai=0.0d0
21997       dephii=0.0d0
21998       dephii1=0.0d0
21999       theti2=0.5d0*theta(i)
22000       ityp2=ithetyp_nucl(itype(i-1,2))
22001       do k=1,nntheterm_nucl
22002         coskt(k)=dcos(k*theti2)
22003         sinkt(k)=dsin(k*theti2)
22004       enddo
22005       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
22006 #ifdef OSF
22007         phii=phi(i)
22008         if (phii.ne.phii) phii=150.0
22009 #else
22010         phii=phi(i)
22011 #endif
22012         ityp1=ithetyp_nucl(itype(i-2,2))
22013         do k=1,nsingle_nucl
22014           cosph1(k)=dcos(k*phii)
22015           sinph1(k)=dsin(k*phii)
22016         enddo
22017       else
22018         phii=0.0d0
22019         ityp1=nthetyp_nucl+1
22020         do k=1,nsingle_nucl
22021           cosph1(k)=0.0d0
22022           sinph1(k)=0.0d0
22023         enddo
22024       endif
22025
22026       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
22027 #ifdef OSF
22028         phii1=phi(i+1)
22029         if (phii1.ne.phii1) phii1=150.0
22030         phii1=pinorm(phii1)
22031 #else
22032         phii1=phi(i+1)
22033 #endif
22034         ityp3=ithetyp_nucl(itype(i,2))
22035         do k=1,nsingle_nucl
22036           cosph2(k)=dcos(k*phii1)
22037           sinph2(k)=dsin(k*phii1)
22038         enddo
22039       else
22040         phii1=0.0d0
22041         ityp3=nthetyp_nucl+1
22042         do k=1,nsingle_nucl
22043           cosph2(k)=0.0d0
22044           sinph2(k)=0.0d0
22045         enddo
22046       endif
22047       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
22048       do k=1,ndouble_nucl
22049         do l=1,k-1
22050           ccl=cosph1(l)*cosph2(k-l)
22051           ssl=sinph1(l)*sinph2(k-l)
22052           scl=sinph1(l)*cosph2(k-l)
22053           csl=cosph1(l)*sinph2(k-l)
22054           cosph1ph2(l,k)=ccl-ssl
22055           cosph1ph2(k,l)=ccl+ssl
22056           sinph1ph2(l,k)=scl+csl
22057           sinph1ph2(k,l)=scl-csl
22058         enddo
22059       enddo
22060       if (lprn) then
22061       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
22062        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
22063       write (iout,*) "coskt and sinkt",nntheterm_nucl
22064       do k=1,nntheterm_nucl
22065         write (iout,*) k,coskt(k),sinkt(k)
22066       enddo
22067       endif
22068       do k=1,ntheterm_nucl
22069         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
22070         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
22071          *coskt(k)
22072         if (lprn)&
22073        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
22074         " ethetai",ethetai
22075       enddo
22076       if (lprn) then
22077       write (iout,*) "cosph and sinph"
22078       do k=1,nsingle_nucl
22079         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
22080       enddo
22081       write (iout,*) "cosph1ph2 and sinph2ph2"
22082       do k=2,ndouble_nucl
22083         do l=1,k-1
22084           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
22085             sinph1ph2(l,k),sinph1ph2(k,l)
22086         enddo
22087       enddo
22088       write(iout,*) "ethetai",ethetai
22089       endif
22090       do m=1,ntheterm2_nucl
22091         do k=1,nsingle_nucl
22092           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
22093             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
22094             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
22095             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
22096           ethetai=ethetai+sinkt(m)*aux
22097           dethetai=dethetai+0.5d0*m*aux*coskt(m)
22098           dephii=dephii+k*sinkt(m)*(&
22099              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
22100              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
22101           dephii1=dephii1+k*sinkt(m)*(&
22102              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
22103              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
22104           if (lprn) &
22105          write (iout,*) "m",m," k",k," bbthet",&
22106             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
22107             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
22108             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
22109             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
22110         enddo
22111       enddo
22112       if (lprn) &
22113       write(iout,*) "ethetai",ethetai
22114       do m=1,ntheterm3_nucl
22115         do k=2,ndouble_nucl
22116           do l=1,k-1
22117             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
22118              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
22119              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
22120              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
22121             ethetai=ethetai+sinkt(m)*aux
22122             dethetai=dethetai+0.5d0*m*coskt(m)*aux
22123             dephii=dephii+l*sinkt(m)*(&
22124             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
22125              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
22126              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
22127              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
22128             dephii1=dephii1+(k-l)*sinkt(m)*( &
22129             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
22130              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
22131              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
22132              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
22133             if (lprn) then
22134             write (iout,*) "m",m," k",k," l",l," ffthet", &
22135              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
22136              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
22137              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
22138              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
22139             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
22140              cosph1ph2(k,l)*sinkt(m),&
22141              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
22142             endif
22143           enddo
22144         enddo
22145       enddo
22146 10      continue
22147       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
22148       i,theta(i)*rad2deg,phii*rad2deg, &
22149       phii1*rad2deg,ethetai
22150       etheta_nucl=etheta_nucl+ethetai
22151 !        print *,i,"partial sum",etheta_nucl
22152       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
22153       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
22154       gloc(nphi+i-2,icg)=wang_nucl*dethetai
22155       enddo
22156       return
22157       end subroutine ebend_nucl
22158 !----------------------------------------------------
22159       subroutine etor_nucl(etors_nucl)
22160 !      implicit real(kind=8) (a-h,o-z)
22161 !      include 'DIMENSIONS'
22162 !      include 'COMMON.VAR'
22163 !      include 'COMMON.GEO'
22164 !      include 'COMMON.LOCAL'
22165 !      include 'COMMON.TORSION'
22166 !      include 'COMMON.INTERACT'
22167 !      include 'COMMON.DERIV'
22168 !      include 'COMMON.CHAIN'
22169 !      include 'COMMON.NAMES'
22170 !      include 'COMMON.IOUNITS'
22171 !      include 'COMMON.FFIELD'
22172 !      include 'COMMON.TORCNSTR'
22173 !      include 'COMMON.CONTROL'
22174       real(kind=8) :: etors_nucl,edihcnstr
22175       logical :: lprn
22176 !el local variables
22177       integer :: i,j,iblock,itori,itori1
22178       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
22179                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
22180 ! Set lprn=.true. for debugging
22181       lprn=.false.
22182 !     lprn=.true.
22183       etors_nucl=0.0D0
22184 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
22185       do i=iphi_nucl_start,iphi_nucl_end
22186       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
22187            .or. itype(i-3,2).eq.ntyp1_molec(2) &
22188            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
22189       etors_ii=0.0D0
22190       itori=itortyp_nucl(itype(i-2,2))
22191       itori1=itortyp_nucl(itype(i-1,2))
22192       phii=phi(i)
22193 !         print *,i,itori,itori1
22194       gloci=0.0D0
22195 !C Regular cosine and sine terms
22196       do j=1,nterm_nucl(itori,itori1)
22197         v1ij=v1_nucl(j,itori,itori1)
22198         v2ij=v2_nucl(j,itori,itori1)
22199         cosphi=dcos(j*phii)
22200         sinphi=dsin(j*phii)
22201         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
22202         if (energy_dec) etors_ii=etors_ii+&
22203                  v1ij*cosphi+v2ij*sinphi
22204         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
22205       enddo
22206 !C Lorentz terms
22207 !C                         v1
22208 !C  E = SUM ----------------------------------- - v1
22209 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
22210 !C
22211       cosphi=dcos(0.5d0*phii)
22212       sinphi=dsin(0.5d0*phii)
22213       do j=1,nlor_nucl(itori,itori1)
22214         vl1ij=vlor1_nucl(j,itori,itori1)
22215         vl2ij=vlor2_nucl(j,itori,itori1)
22216         vl3ij=vlor3_nucl(j,itori,itori1)
22217         pom=vl2ij*cosphi+vl3ij*sinphi
22218         pom1=1.0d0/(pom*pom+1.0d0)
22219         etors_nucl=etors_nucl+vl1ij*pom1
22220         if (energy_dec) etors_ii=etors_ii+ &
22221                  vl1ij*pom1
22222         pom=-pom*pom1*pom1
22223         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
22224       enddo
22225 !C Subtract the constant term
22226       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
22227         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
22228             'etor',i,etors_ii-v0_nucl(itori,itori1)
22229       if (lprn) &
22230        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
22231        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
22232        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
22233       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
22234 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
22235       enddo
22236       return
22237       end subroutine etor_nucl
22238 !------------------------------------------------------------
22239       subroutine epp_nucl_sub(evdw1,ees)
22240 !C
22241 !C This subroutine calculates the average interaction energy and its gradient
22242 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
22243 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
22244 !C The potential depends both on the distance of peptide-group centers and on
22245 !C the orientation of the CA-CA virtual bonds.
22246 !C
22247       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
22248       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
22249                       sslipj,ssgradlipj,faclipij2
22250       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
22251              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
22252              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
22253       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22254                 dist_temp, dist_init,sss_grad,fac,evdw1ij
22255       integer xshift,yshift,zshift
22256       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
22257       real(kind=8) :: ees,eesij
22258 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
22259       real(kind=8) scal_el /0.5d0/
22260       t_eelecij=0.0d0
22261       ees=0.0D0
22262       evdw1=0.0D0
22263       ind=0
22264 !c
22265 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
22266 !c
22267 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
22268       do i=iatel_s_nucl,iatel_e_nucl
22269       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
22270       dxi=dc(1,i)
22271       dyi=dc(2,i)
22272       dzi=dc(3,i)
22273       dx_normi=dc_norm(1,i)
22274       dy_normi=dc_norm(2,i)
22275       dz_normi=dc_norm(3,i)
22276       xmedi=c(1,i)+0.5d0*dxi
22277       ymedi=c(2,i)+0.5d0*dyi
22278       zmedi=c(3,i)+0.5d0*dzi
22279         call to_box(xmedi,ymedi,zmedi)
22280         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
22281
22282       do j=ielstart_nucl(i),ielend_nucl(i)
22283         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
22284         ind=ind+1
22285         dxj=dc(1,j)
22286         dyj=dc(2,j)
22287         dzj=dc(3,j)
22288 !          xj=c(1,j)+0.5D0*dxj-xmedi
22289 !          yj=c(2,j)+0.5D0*dyj-ymedi
22290 !          zj=c(3,j)+0.5D0*dzj-zmedi
22291         xj=c(1,j)+0.5D0*dxj
22292         yj=c(2,j)+0.5D0*dyj
22293         zj=c(3,j)+0.5D0*dzj
22294      call to_box(xj,yj,zj)
22295      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22296       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
22297       xj=boxshift(xj-xmedi,boxxsize)
22298       yj=boxshift(yj-ymedi,boxysize)
22299       zj=boxshift(zj-zmedi,boxzsize)
22300         rij=xj*xj+yj*yj+zj*zj
22301 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
22302         fac=(r0pp**2/rij)**3
22303         ev1=epspp*fac*fac
22304         ev2=epspp*fac
22305         evdw1ij=ev1-2*ev2
22306         fac=(-ev1-evdw1ij)/rij
22307 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
22308         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
22309         evdw1=evdw1+evdw1ij
22310 !C
22311 !C Calculate contributions to the Cartesian gradient.
22312 !C
22313         ggg(1)=fac*xj
22314         ggg(2)=fac*yj
22315         ggg(3)=fac*zj
22316         do k=1,3
22317           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
22318           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
22319         enddo
22320 !c phoshate-phosphate electrostatic interactions
22321         rij=dsqrt(rij)
22322         fac=1.0d0/rij
22323         eesij=dexp(-BEES*rij)*fac
22324 !          write (2,*)"fac",fac," eesijpp",eesij
22325         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
22326         ees=ees+eesij
22327 !c          fac=-eesij*fac
22328         fac=-(fac+BEES)*eesij*fac
22329         ggg(1)=fac*xj
22330         ggg(2)=fac*yj
22331         ggg(3)=fac*zj
22332 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
22333 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
22334 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
22335         do k=1,3
22336           gelpp(k,i)=gelpp(k,i)-ggg(k)
22337           gelpp(k,j)=gelpp(k,j)+ggg(k)
22338         enddo
22339       enddo ! j
22340       enddo   ! i
22341 !c      ees=332.0d0*ees
22342       ees=AEES*ees
22343       do i=nnt,nct
22344 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
22345       do k=1,3
22346         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
22347 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
22348         gelpp(k,i)=AEES*gelpp(k,i)
22349       enddo
22350 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
22351       enddo
22352 !c      write (2,*) "total EES",ees
22353       return
22354       end subroutine epp_nucl_sub
22355 !---------------------------------------------------------------------
22356       subroutine epsb(evdwpsb,eelpsb)
22357 !      use comm_locel
22358 !C
22359 !C This subroutine calculates the excluded-volume interaction energy between
22360 !C peptide-group centers and side chains and its gradient in virtual-bond and
22361 !C side-chain vectors.
22362 !C
22363       real(kind=8),dimension(3):: ggg
22364       integer :: i,iint,j,k,iteli,itypj,subchap
22365       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
22366                e1,e2,evdwij,rij,evdwpsb,eelpsb
22367       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22368                 dist_temp, dist_init
22369       integer xshift,yshift,zshift
22370
22371 !cd    print '(a)','Enter ESCP'
22372 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
22373       eelpsb=0.0d0
22374       evdwpsb=0.0d0
22375 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
22376       do i=iatscp_s_nucl,iatscp_e_nucl
22377       if (itype(i,2).eq.ntyp1_molec(2) &
22378        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
22379       xi=0.5D0*(c(1,i)+c(1,i+1))
22380       yi=0.5D0*(c(2,i)+c(2,i+1))
22381       zi=0.5D0*(c(3,i)+c(3,i+1))
22382         call to_box(xi,yi,zi)
22383
22384       do iint=1,nscp_gr_nucl(i)
22385
22386       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
22387         itypj=itype(j,2)
22388         if (itypj.eq.ntyp1_molec(2)) cycle
22389 !C Uncomment following three lines for SC-p interactions
22390 !c         xj=c(1,nres+j)-xi
22391 !c         yj=c(2,nres+j)-yi
22392 !c         zj=c(3,nres+j)-zi
22393 !C Uncomment following three lines for Ca-p interactions
22394 !          xj=c(1,j)-xi
22395 !          yj=c(2,j)-yi
22396 !          zj=c(3,j)-zi
22397         xj=c(1,j)
22398         yj=c(2,j)
22399         zj=c(3,j)
22400         call to_box(xj,yj,zj)
22401       xj=boxshift(xj-xi,boxxsize)
22402       yj=boxshift(yj-yi,boxysize)
22403       zj=boxshift(zj-zi,boxzsize)
22404
22405       dist_init=xj**2+yj**2+zj**2
22406
22407         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
22408         fac=rrij**expon2
22409         e1=fac*fac*aad_nucl(itypj)
22410         e2=fac*bad_nucl(itypj)
22411         if (iabs(j-i) .le. 2) then
22412           e1=scal14*e1
22413           e2=scal14*e2
22414         endif
22415         evdwij=e1+e2
22416         evdwpsb=evdwpsb+evdwij
22417         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
22418            'evdw2',i,j,evdwij,"tu4"
22419 !C
22420 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
22421 !C
22422         fac=-(evdwij+e1)*rrij
22423         ggg(1)=xj*fac
22424         ggg(2)=yj*fac
22425         ggg(3)=zj*fac
22426         do k=1,3
22427           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
22428           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
22429         enddo
22430       enddo
22431
22432       enddo ! iint
22433       enddo ! i
22434       do i=1,nct
22435       do j=1,3
22436         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
22437         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
22438       enddo
22439       enddo
22440       return
22441       end subroutine epsb
22442
22443 !------------------------------------------------------
22444       subroutine esb_gb(evdwsb,eelsb)
22445       use comm_locel
22446       use calc_data_nucl
22447       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
22448       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22449       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
22450       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22451                 dist_temp, dist_init,aa,bb,faclip,sig0ij
22452       integer :: ii
22453       logical lprn
22454       evdw=0.0D0
22455       eelsb=0.0d0
22456       ecorr=0.0d0
22457       evdwsb=0.0D0
22458       lprn=.false.
22459       ind=0
22460 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
22461       do i=iatsc_s_nucl,iatsc_e_nucl
22462       num_conti=0
22463       num_conti2=0
22464       itypi=itype(i,2)
22465 !        PRINT *,"I=",i,itypi
22466       if (itypi.eq.ntyp1_molec(2)) cycle
22467       itypi1=itype(i+1,2)
22468       xi=c(1,nres+i)
22469       yi=c(2,nres+i)
22470       zi=c(3,nres+i)
22471       call to_box(xi,yi,zi)
22472       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22473       dxi=dc_norm(1,nres+i)
22474       dyi=dc_norm(2,nres+i)
22475       dzi=dc_norm(3,nres+i)
22476       dsci_inv=vbld_inv(i+nres)
22477 !C
22478 !C Calculate SC interaction energy.
22479 !C
22480       do iint=1,nint_gr_nucl(i)
22481 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
22482         do j=istart_nucl(i,iint),iend_nucl(i,iint)
22483           ind=ind+1
22484 !            print *,"JESTEM"
22485           itypj=itype(j,2)
22486           if (itypj.eq.ntyp1_molec(2)) cycle
22487           dscj_inv=vbld_inv(j+nres)
22488           sig0ij=sigma_nucl(itypi,itypj)
22489           chi1=chi_nucl(itypi,itypj)
22490           chi2=chi_nucl(itypj,itypi)
22491           chi12=chi1*chi2
22492           chip1=chip_nucl(itypi,itypj)
22493           chip2=chip_nucl(itypj,itypi)
22494           chip12=chip1*chip2
22495 !            xj=c(1,nres+j)-xi
22496 !            yj=c(2,nres+j)-yi
22497 !            zj=c(3,nres+j)-zi
22498          xj=c(1,nres+j)
22499          yj=c(2,nres+j)
22500          zj=c(3,nres+j)
22501      call to_box(xj,yj,zj)
22502 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22503 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22504 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22505 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22506 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22507       xj=boxshift(xj-xi,boxxsize)
22508       yj=boxshift(yj-yi,boxysize)
22509       zj=boxshift(zj-zi,boxzsize)
22510
22511           dxj=dc_norm(1,nres+j)
22512           dyj=dc_norm(2,nres+j)
22513           dzj=dc_norm(3,nres+j)
22514           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
22515           rij=dsqrt(rrij)
22516 !C Calculate angle-dependent terms of energy and contributions to their
22517 !C derivatives.
22518           erij(1)=xj*rij
22519           erij(2)=yj*rij
22520           erij(3)=zj*rij
22521           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
22522           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
22523           om12=dxi*dxj+dyi*dyj+dzi*dzj
22524           call sc_angular_nucl
22525           sigsq=1.0D0/sigsq
22526           sig=sig0ij*dsqrt(sigsq)
22527           rij_shift=1.0D0/rij-sig+sig0ij
22528 !            print *,rij_shift,"rij_shift"
22529 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
22530 !c     &       " rij_shift",rij_shift
22531           if (rij_shift.le.0.0D0) then
22532             evdw=1.0D20
22533             return
22534           endif
22535           sigder=-sig*sigsq
22536 !c---------------------------------------------------------------
22537           rij_shift=1.0D0/rij_shift
22538           fac=rij_shift**expon
22539           e1=fac*fac*aa_nucl(itypi,itypj)
22540           e2=fac*bb_nucl(itypi,itypj)
22541           evdwij=eps1*eps2rt*(e1+e2)
22542 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
22543 !c     &       " e1",e1," e2",e2," evdwij",evdwij
22544           eps2der=evdwij
22545           evdwij=evdwij*eps2rt
22546           evdwsb=evdwsb+evdwij
22547           if (lprn) then
22548           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
22549           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
22550           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
22551            restyp(itypi,2),i,restyp(itypj,2),j, &
22552            epsi,sigm,chi1,chi2,chip1,chip2, &
22553            eps1,eps2rt**2,sig,sig0ij, &
22554            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
22555           evdwij
22556           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
22557           endif
22558
22559           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
22560                        'evdw',i,j,evdwij,"tu3"
22561
22562
22563 !C Calculate gradient components.
22564           e1=e1*eps1*eps2rt**2
22565           fac=-expon*(e1+evdwij)*rij_shift
22566           sigder=fac*sigder
22567           fac=rij*fac
22568 !c            fac=0.0d0
22569 !C Calculate the radial part of the gradient
22570           gg(1)=xj*fac
22571           gg(2)=yj*fac
22572           gg(3)=zj*fac
22573 !C Calculate angular part of the gradient.
22574           call sc_grad_nucl
22575           call eelsbij(eelij,num_conti2)
22576           if (energy_dec .and. &
22577          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
22578         write (istat,'(e14.5)') evdwij
22579           eelsb=eelsb+eelij
22580         enddo      ! j
22581       enddo        ! iint
22582       num_cont_hb(i)=num_conti2
22583       enddo          ! i
22584 !c      write (iout,*) "Number of loop steps in EGB:",ind
22585 !cccc      energy_dec=.false.
22586       return
22587       end subroutine esb_gb
22588 !-------------------------------------------------------------------------------
22589       subroutine eelsbij(eesij,num_conti2)
22590       use comm_locel
22591       use calc_data_nucl
22592       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
22593       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
22594       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22595                 dist_temp, dist_init,rlocshield,fracinbuf
22596       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
22597
22598 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
22599       real(kind=8) scal_el /0.5d0/
22600       integer :: iteli,itelj,kkk,kkll,m,isubchap
22601       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
22602       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
22603       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
22604               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
22605               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
22606               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
22607               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
22608               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
22609               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
22610               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
22611       ind=ind+1
22612       itypi=itype(i,2)
22613       itypj=itype(j,2)
22614 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
22615       ael6i=ael6_nucl(itypi,itypj)
22616       ael3i=ael3_nucl(itypi,itypj)
22617       ael63i=ael63_nucl(itypi,itypj)
22618       ael32i=ael32_nucl(itypi,itypj)
22619 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
22620 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
22621       dxj=dc(1,j+nres)
22622       dyj=dc(2,j+nres)
22623       dzj=dc(3,j+nres)
22624       dx_normi=dc_norm(1,i+nres)
22625       dy_normi=dc_norm(2,i+nres)
22626       dz_normi=dc_norm(3,i+nres)
22627       dx_normj=dc_norm(1,j+nres)
22628       dy_normj=dc_norm(2,j+nres)
22629       dz_normj=dc_norm(3,j+nres)
22630 !c      xj=c(1,j)+0.5D0*dxj-xmedi
22631 !c      yj=c(2,j)+0.5D0*dyj-ymedi
22632 !c      zj=c(3,j)+0.5D0*dzj-zmedi
22633       if (ipot_nucl.ne.2) then
22634       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
22635       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
22636       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
22637       else
22638       cosa=om12
22639       cosb=om1
22640       cosg=om2
22641       endif
22642       r3ij=rij*rrij
22643       r6ij=r3ij*r3ij
22644       fac=cosa-3.0D0*cosb*cosg
22645       facfac=fac*fac
22646       fac1=3.0d0*(cosb*cosb+cosg*cosg)
22647       fac3=ael6i*r6ij
22648       fac4=ael3i*r3ij
22649       fac5=ael63i*r6ij
22650       fac6=ael32i*r6ij
22651 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
22652 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
22653       el1=fac3*(4.0D0+facfac-fac1)
22654       el2=fac4*fac
22655       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
22656       el4=fac6*facfac
22657       eesij=el1+el2+el3+el4
22658 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
22659       ees0ij=4.0D0+facfac-fac1
22660
22661       if (energy_dec) then
22662         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
22663         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
22664          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
22665          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
22666          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
22667         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
22668       endif
22669
22670 !C
22671 !C Calculate contributions to the Cartesian gradient.
22672 !C
22673       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
22674       fac1=fac
22675 !c      erij(1)=xj*rmij
22676 !c      erij(2)=yj*rmij
22677 !c      erij(3)=zj*rmij
22678 !*
22679 !* Radial derivatives. First process both termini of the fragment (i,j)
22680 !*
22681       ggg(1)=facel*xj
22682       ggg(2)=facel*yj
22683       ggg(3)=facel*zj
22684       do k=1,3
22685       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22686       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22687       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
22688       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
22689       enddo
22690 !*
22691 !* Angular part
22692 !*
22693       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
22694       fac4=-3.0D0*fac4
22695       fac3=-6.0D0*fac3
22696       fac5= 6.0d0*fac5
22697       fac6=-6.0d0*fac6
22698       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
22699        fac6*fac1*cosg
22700       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
22701        fac6*fac1*cosb
22702       do k=1,3
22703       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
22704       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
22705       enddo
22706       do k=1,3
22707       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
22708       enddo
22709       do k=1,3
22710       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
22711            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
22712            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22713       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
22714            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22715            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22716       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22717       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22718       enddo
22719 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
22720        IF ( j.gt.i+1 .and.&
22721         num_conti.le.maxcont) THEN
22722 !C
22723 !C Calculate the contact function. The ith column of the array JCONT will
22724 !C contain the numbers of atoms that make contacts with the atom I (of numbers
22725 !C greater than I). The arrays FACONT and GACONT will contain the values of
22726 !C the contact function and its derivative.
22727       r0ij=2.20D0*sigma_nucl(itypi,itypj)
22728 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
22729       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
22730 !c        write (2,*) "fcont",fcont
22731       if (fcont.gt.0.0D0) then
22732         num_conti=num_conti+1
22733         num_conti2=num_conti2+1
22734
22735         if (num_conti.gt.maxconts) then
22736           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
22737                     ' will skip next contacts for this conf.',maxconts
22738         else
22739           jcont_hb(num_conti,i)=j
22740 !c            write (iout,*) "num_conti",num_conti,
22741 !c     &        " jcont_hb",jcont_hb(num_conti,i)
22742 !C Calculate contact energies
22743           cosa4=4.0D0*cosa
22744           wij=cosa-3.0D0*cosb*cosg
22745           cosbg1=cosb+cosg
22746           cosbg2=cosb-cosg
22747           fac3=dsqrt(-ael6i)*r3ij
22748 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
22749           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
22750           if (ees0tmp.gt.0) then
22751             ees0pij=dsqrt(ees0tmp)
22752           else
22753             ees0pij=0
22754           endif
22755           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
22756           if (ees0tmp.gt.0) then
22757             ees0mij=dsqrt(ees0tmp)
22758           else
22759             ees0mij=0
22760           endif
22761           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
22762           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
22763 !c            write (iout,*) "i",i," j",j,
22764 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
22765           ees0pij1=fac3/ees0pij
22766           ees0mij1=fac3/ees0mij
22767           fac3p=-3.0D0*fac3*rrij
22768           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
22769           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
22770           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
22771           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
22772           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
22773           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
22774           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
22775           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
22776           ecosap=ecosa1+ecosa2
22777           ecosbp=ecosb1+ecosb2
22778           ecosgp=ecosg1+ecosg2
22779           ecosam=ecosa1-ecosa2
22780           ecosbm=ecosb1-ecosb2
22781           ecosgm=ecosg1-ecosg2
22782 !C End diagnostics
22783           facont_hb(num_conti,i)=fcont
22784           fprimcont=fprimcont/rij
22785           do k=1,3
22786             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
22787             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
22788           enddo
22789           gggp(1)=gggp(1)+ees0pijp*xj
22790           gggp(2)=gggp(2)+ees0pijp*yj
22791           gggp(3)=gggp(3)+ees0pijp*zj
22792           gggm(1)=gggm(1)+ees0mijp*xj
22793           gggm(2)=gggm(2)+ees0mijp*yj
22794           gggm(3)=gggm(3)+ees0mijp*zj
22795 !C Derivatives due to the contact function
22796           gacont_hbr(1,num_conti,i)=fprimcont*xj
22797           gacont_hbr(2,num_conti,i)=fprimcont*yj
22798           gacont_hbr(3,num_conti,i)=fprimcont*zj
22799           do k=1,3
22800 !c
22801 !c Gradient of the correlation terms
22802 !c
22803             gacontp_hb1(k,num_conti,i)= &
22804            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22805           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22806             gacontp_hb2(k,num_conti,i)= &
22807            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
22808           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22809             gacontp_hb3(k,num_conti,i)=gggp(k)
22810             gacontm_hb1(k,num_conti,i)= &
22811            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22812           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22813             gacontm_hb2(k,num_conti,i)= &
22814            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22815           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22816             gacontm_hb3(k,num_conti,i)=gggm(k)
22817           enddo
22818         endif
22819       endif
22820       ENDIF
22821       return
22822       end subroutine eelsbij
22823 !------------------------------------------------------------------
22824       subroutine sc_grad_nucl
22825       use comm_locel
22826       use calc_data_nucl
22827       real(kind=8),dimension(3) :: dcosom1,dcosom2
22828       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
22829       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
22830       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
22831       do k=1,3
22832       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
22833       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
22834       enddo
22835       do k=1,3
22836       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
22837       enddo
22838       do k=1,3
22839       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
22840              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
22841              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22842       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
22843              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22844              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22845       enddo
22846 !C
22847 !C Calculate the components of the gradient in DC and X
22848 !C
22849       do l=1,3
22850       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
22851       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
22852       enddo
22853       return
22854       end subroutine sc_grad_nucl
22855 !-----------------------------------------------------------------------
22856       subroutine esb(esbloc)
22857 !C Calculate the local energy of a side chain and its derivatives in the
22858 !C corresponding virtual-bond valence angles THETA and the spherical angles
22859 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
22860 !C added by Urszula Kozlowska. 07/11/2007
22861 !C
22862       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
22863       real(kind=8),dimension(9):: x
22864      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
22865       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
22866       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
22867       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
22868        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
22869        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
22870        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
22871        integer::it,nlobit,i,j,k
22872 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
22873       delta=0.02d0*pi
22874       esbloc=0.0D0
22875       do i=loc_start_nucl,loc_end_nucl
22876       if (itype(i,2).eq.ntyp1_molec(2)) cycle
22877       costtab(i+1) =dcos(theta(i+1))
22878       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
22879       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
22880       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
22881       cosfac2=0.5d0/(1.0d0+costtab(i+1))
22882       cosfac=dsqrt(cosfac2)
22883       sinfac2=0.5d0/(1.0d0-costtab(i+1))
22884       sinfac=dsqrt(sinfac2)
22885       it=itype(i,2)
22886       if (it.eq.10) goto 1
22887
22888 !c
22889 !C  Compute the axes of tghe local cartesian coordinates system; store in
22890 !c   x_prime, y_prime and z_prime
22891 !c
22892       do j=1,3
22893         x_prime(j) = 0.00
22894         y_prime(j) = 0.00
22895         z_prime(j) = 0.00
22896       enddo
22897 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
22898 !C     &   dc_norm(3,i+nres)
22899       do j = 1,3
22900         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
22901         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
22902       enddo
22903       do j = 1,3
22904         z_prime(j) = -uz(j,i-1)
22905 !           z_prime(j)=0.0
22906       enddo
22907
22908       xx=0.0d0
22909       yy=0.0d0
22910       zz=0.0d0
22911       do j = 1,3
22912         xx = xx + x_prime(j)*dc_norm(j,i+nres)
22913         yy = yy + y_prime(j)*dc_norm(j,i+nres)
22914         zz = zz + z_prime(j)*dc_norm(j,i+nres)
22915       enddo
22916
22917       xxtab(i)=xx
22918       yytab(i)=yy
22919       zztab(i)=zz
22920        it=itype(i,2)
22921       do j = 1,9
22922         x(j) = sc_parmin_nucl(j,it)
22923       enddo
22924 #ifdef CHECK_COORD
22925 !Cc diagnostics - remove later
22926       xx1 = dcos(alph(2))
22927       yy1 = dsin(alph(2))*dcos(omeg(2))
22928       zz1 = -dsin(alph(2))*dsin(omeg(2))
22929       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
22930        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
22931        xx1,yy1,zz1
22932 !C,"  --- ", xx_w,yy_w,zz_w
22933 !c end diagnostics
22934 #endif
22935       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22936       esbloc = esbloc + sumene
22937       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
22938 !        print *,"enecomp",sumene,sumene2
22939         if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22940 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22941 #ifdef DEBUG
22942       write (2,*) "x",(x(k),k=1,9)
22943 !C
22944 !C This section to check the numerical derivatives of the energy of ith side
22945 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22946 !C #define DEBUG in the code to turn it on.
22947 !C
22948       write (2,*) "sumene               =",sumene
22949       aincr=1.0d-7
22950       xxsave=xx
22951       xx=xx+aincr
22952       write (2,*) xx,yy,zz
22953       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22954       de_dxx_num=(sumenep-sumene)/aincr
22955       xx=xxsave
22956       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22957       yysave=yy
22958       yy=yy+aincr
22959       write (2,*) xx,yy,zz
22960       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22961       de_dyy_num=(sumenep-sumene)/aincr
22962       yy=yysave
22963       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22964       zzsave=zz
22965       zz=zz+aincr
22966       write (2,*) xx,yy,zz
22967       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22968       de_dzz_num=(sumenep-sumene)/aincr
22969       zz=zzsave
22970       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22971       costsave=cost2tab(i+1)
22972       sintsave=sint2tab(i+1)
22973       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22974       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22975       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22976       de_dt_num=(sumenep-sumene)/aincr
22977       write (2,*) " t+ sumene from enesc=",sumenep,sumene
22978       cost2tab(i+1)=costsave
22979       sint2tab(i+1)=sintsave
22980 !C End of diagnostics section.
22981 #endif
22982 !C
22983 !C Compute the gradient of esc
22984 !C
22985       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22986       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22987       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22988       de_dtt=0.0d0
22989 #ifdef DEBUG
22990       write (2,*) "x",(x(k),k=1,9)
22991       write (2,*) "xx",xx," yy",yy," zz",zz
22992       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22993         " de_zz   ",de_zz," de_tt   ",de_tt
22994       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22995         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22996 #endif
22997 !C
22998        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22999        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
23000        cosfac2xx=cosfac2*xx
23001        sinfac2yy=sinfac2*yy
23002        do k = 1,3
23003        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
23004          vbld_inv(i+1)
23005        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
23006          vbld_inv(i)
23007        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
23008        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
23009 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
23010 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
23011 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
23012 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
23013        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
23014        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
23015        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
23016        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
23017        dZZ_Ci1(k)=0.0d0
23018        dZZ_Ci(k)=0.0d0
23019        do j=1,3
23020          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
23021          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
23022        enddo
23023
23024        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
23025        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
23026        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
23027 !c
23028        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
23029        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
23030        enddo
23031
23032        do k=1,3
23033        dXX_Ctab(k,i)=dXX_Ci(k)
23034        dXX_C1tab(k,i)=dXX_Ci1(k)
23035        dYY_Ctab(k,i)=dYY_Ci(k)
23036        dYY_C1tab(k,i)=dYY_Ci1(k)
23037        dZZ_Ctab(k,i)=dZZ_Ci(k)
23038        dZZ_C1tab(k,i)=dZZ_Ci1(k)
23039        dXX_XYZtab(k,i)=dXX_XYZ(k)
23040        dYY_XYZtab(k,i)=dYY_XYZ(k)
23041        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
23042        enddo
23043        do k = 1,3
23044 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
23045 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
23046 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
23047 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
23048 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
23049 !c     &    dt_dci(k)
23050 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
23051 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
23052        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
23053        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
23054        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
23055        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
23056        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
23057        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
23058 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
23059        enddo
23060 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
23061 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
23062
23063 !C to check gradient call subroutine check_grad
23064
23065     1 continue
23066       enddo
23067       return
23068       end subroutine esb
23069 !=-------------------------------------------------------
23070       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
23071 !      implicit none
23072       real(kind=8),dimension(9):: x(9)
23073        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
23074       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
23075       integer i
23076 !c      write (2,*) "enesc"
23077 !c      write (2,*) "x",(x(i),i=1,9)
23078 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
23079       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
23080       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
23081       + x(9)*yy*zz
23082       enesc_nucl=sumene
23083       return
23084       end function enesc_nucl
23085 !-----------------------------------------------------------------------------
23086       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
23087 #ifdef MPI
23088       include 'mpif.h'
23089       integer,parameter :: max_cont=2000
23090       integer,parameter:: max_dim=2*(8*3+6)
23091       integer, parameter :: msglen1=max_cont*max_dim
23092       integer,parameter :: msglen2=2*msglen1
23093       integer source,CorrelType,CorrelID,Error
23094       real(kind=8) :: buffer(max_cont,max_dim)
23095       integer status(MPI_STATUS_SIZE)
23096       integer :: ierror,nbytes
23097 #endif
23098       real(kind=8),dimension(3):: gx(3),gx1(3)
23099       real(kind=8) :: time00
23100       logical lprn,ldone
23101       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
23102       real(kind=8) ecorr,ecorr3
23103       integer :: n_corr,n_corr1,mm,msglen
23104 !C Set lprn=.true. for debugging
23105       lprn=.false.
23106       n_corr=0
23107       n_corr1=0
23108 #ifdef MPI
23109       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
23110
23111       if (nfgtasks.le.1) goto 30
23112       if (lprn) then
23113       write (iout,'(a)') 'Contact function values:'
23114       do i=nnt,nct-1
23115         write (iout,'(2i3,50(1x,i2,f5.2))')  &
23116        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
23117        j=1,num_cont_hb(i))
23118       enddo
23119       endif
23120 !C Caution! Following code assumes that electrostatic interactions concerning
23121 !C a given atom are split among at most two processors!
23122       CorrelType=477
23123       CorrelID=fg_rank+1
23124       ldone=.false.
23125       do i=1,max_cont
23126       do j=1,max_dim
23127         buffer(i,j)=0.0D0
23128       enddo
23129       enddo
23130       mm=mod(fg_rank,2)
23131 !c      write (*,*) 'MyRank',MyRank,' mm',mm
23132       if (mm) 20,20,10
23133    10 continue
23134 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
23135       if (fg_rank.gt.0) then
23136 !C Send correlation contributions to the preceding processor
23137       msglen=msglen1
23138       nn=num_cont_hb(iatel_s_nucl)
23139       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
23140 !c        write (*,*) 'The BUFFER array:'
23141 !c        do i=1,nn
23142 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
23143 !c        enddo
23144       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
23145         msglen=msglen2
23146         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
23147 !C Clear the contacts of the atom passed to the neighboring processor
23148       nn=num_cont_hb(iatel_s_nucl+1)
23149 !c        do i=1,nn
23150 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
23151 !c        enddo
23152           num_cont_hb(iatel_s_nucl)=0
23153       endif
23154 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
23155 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
23156 !cd   & ' msglen=',msglen
23157 !c        write (*,*) 'Processor ',fg_rank,MyRank,
23158 !c     & ' is sending correlation contribution to processor',fg_rank-1,
23159 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
23160       time00=MPI_Wtime()
23161       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
23162        CorrelType,FG_COMM,IERROR)
23163       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
23164 !cd      write (iout,*) 'Processor ',fg_rank,
23165 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
23166 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
23167 !c        write (*,*) 'Processor ',fg_rank,
23168 !c     & ' has sent correlation contribution to processor',fg_rank-1,
23169 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
23170 !c        msglen=msglen1
23171       endif ! (fg_rank.gt.0)
23172       if (ldone) goto 30
23173       ldone=.true.
23174    20 continue
23175 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
23176       if (fg_rank.lt.nfgtasks-1) then
23177 !C Receive correlation contributions from the next processor
23178       msglen=msglen1
23179       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
23180 !cd      write (iout,*) 'Processor',fg_rank,
23181 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
23182 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
23183 !c        write (*,*) 'Processor',fg_rank,
23184 !c     &' is receiving correlation contribution from processor',fg_rank+1,
23185 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
23186       time00=MPI_Wtime()
23187       nbytes=-1
23188       do while (nbytes.le.0)
23189         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
23190         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
23191       enddo
23192 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
23193       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
23194        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
23195       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
23196 !c        write (*,*) 'Processor',fg_rank,
23197 !c     &' has received correlation contribution from processor',fg_rank+1,
23198 !c     & ' msglen=',msglen,' nbytes=',nbytes
23199 !c        write (*,*) 'The received BUFFER array:'
23200 !c        do i=1,max_cont
23201 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
23202 !c        enddo
23203       if (msglen.eq.msglen1) then
23204         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
23205       else if (msglen.eq.msglen2)  then
23206         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
23207         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
23208       else
23209         write (iout,*) &
23210       'ERROR!!!! message length changed while processing correlations.'
23211         write (*,*) &
23212       'ERROR!!!! message length changed while processing correlations.'
23213         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
23214       endif ! msglen.eq.msglen1
23215       endif ! fg_rank.lt.nfgtasks-1
23216       if (ldone) goto 30
23217       ldone=.true.
23218       goto 10
23219    30 continue
23220 #endif
23221       if (lprn) then
23222       write (iout,'(a)') 'Contact function values:'
23223       do i=nnt_molec(2),nct_molec(2)-1
23224         write (iout,'(2i3,50(1x,i2,f5.2))') &
23225        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
23226        j=1,num_cont_hb(i))
23227       enddo
23228       endif
23229       ecorr=0.0D0
23230       ecorr3=0.0d0
23231 !C Remove the loop below after debugging !!!
23232 !      do i=nnt_molec(2),nct_molec(2)
23233 !        do j=1,3
23234 !          gradcorr_nucl(j,i)=0.0D0
23235 !          gradxorr_nucl(j,i)=0.0D0
23236 !          gradcorr3_nucl(j,i)=0.0D0
23237 !          gradxorr3_nucl(j,i)=0.0D0
23238 !        enddo
23239 !      enddo
23240 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
23241 !C Calculate the local-electrostatic correlation terms
23242       do i=iatsc_s_nucl,iatsc_e_nucl
23243       i1=i+1
23244       num_conti=num_cont_hb(i)
23245       num_conti1=num_cont_hb(i+1)
23246 !        print *,i,num_conti,num_conti1
23247       do jj=1,num_conti
23248         j=jcont_hb(jj,i)
23249         do kk=1,num_conti1
23250           j1=jcont_hb(kk,i1)
23251 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
23252 !c     &         ' jj=',jj,' kk=',kk
23253           if (j1.eq.j+1 .or. j1.eq.j-1) then
23254 !C
23255 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
23256 !C The system gains extra energy.
23257 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
23258 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
23259 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
23260 !C
23261             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
23262             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
23263              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
23264             n_corr=n_corr+1
23265           else if (j1.eq.j) then
23266 !C
23267 !C Contacts I-J and I-(J+1) occur simultaneously.
23268 !C The system loses extra energy.
23269 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
23270 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
23271 !C Need to implement full formulas 32 from Liwo et al., 1998.
23272 !C
23273 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
23274 !c     &         ' jj=',jj,' kk=',kk
23275             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
23276           endif
23277         enddo ! kk
23278         do kk=1,num_conti
23279           j1=jcont_hb(kk,i)
23280 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
23281 !c     &         ' jj=',jj,' kk=',kk
23282           if (j1.eq.j+1) then
23283 !C Contacts I-J and (I+1)-J occur simultaneously.
23284 !C The system loses extra energy.
23285             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
23286           endif ! j1==j+1
23287         enddo ! kk
23288       enddo ! jj
23289       enddo ! i
23290       return
23291       end subroutine multibody_hb_nucl
23292 !-----------------------------------------------------------
23293       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
23294 !      implicit real(kind=8) (a-h,o-z)
23295 !      include 'DIMENSIONS'
23296 !      include 'COMMON.IOUNITS'
23297 !      include 'COMMON.DERIV'
23298 !      include 'COMMON.INTERACT'
23299 !      include 'COMMON.CONTACTS'
23300       real(kind=8),dimension(3) :: gx,gx1
23301       logical :: lprn
23302 !el local variables
23303       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
23304       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
23305                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
23306                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
23307                rlocshield
23308
23309       lprn=.false.
23310       eij=facont_hb(jj,i)
23311       ekl=facont_hb(kk,k)
23312       ees0pij=ees0p(jj,i)
23313       ees0pkl=ees0p(kk,k)
23314       ees0mij=ees0m(jj,i)
23315       ees0mkl=ees0m(kk,k)
23316       ekont=eij*ekl
23317       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
23318 !      print *,"ehbcorr_nucl",ekont,ees
23319 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
23320 !C Following 4 lines for diagnostics.
23321 !cd    ees0pkl=0.0D0
23322 !cd    ees0pij=1.0D0
23323 !cd    ees0mkl=0.0D0
23324 !cd    ees0mij=1.0D0
23325 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
23326 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
23327 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
23328 !C Calculate the multi-body contribution to energy.
23329 !      ecorr_nucl=ecorr_nucl+ekont*ees
23330 !C Calculate multi-body contributions to the gradient.
23331       coeffpees0pij=coeffp*ees0pij
23332       coeffmees0mij=coeffm*ees0mij
23333       coeffpees0pkl=coeffp*ees0pkl
23334       coeffmees0mkl=coeffm*ees0mkl
23335       do ll=1,3
23336       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
23337        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
23338        coeffmees0mkl*gacontm_hb1(ll,jj,i))
23339       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
23340       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
23341       coeffmees0mkl*gacontm_hb2(ll,jj,i))
23342       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
23343       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
23344       coeffmees0mij*gacontm_hb1(ll,kk,k))
23345       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
23346       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
23347       coeffmees0mij*gacontm_hb2(ll,kk,k))
23348       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
23349         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
23350         coeffmees0mkl*gacontm_hb3(ll,jj,i))
23351       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
23352       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
23353       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
23354         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
23355         coeffmees0mij*gacontm_hb3(ll,kk,k))
23356       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
23357       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
23358       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
23359       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
23360       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
23361       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
23362       enddo
23363       ehbcorr_nucl=ekont*ees
23364       return
23365       end function ehbcorr_nucl
23366 !-------------------------------------------------------------------------
23367
23368      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
23369 !      implicit real(kind=8) (a-h,o-z)
23370 !      include 'DIMENSIONS'
23371 !      include 'COMMON.IOUNITS'
23372 !      include 'COMMON.DERIV'
23373 !      include 'COMMON.INTERACT'
23374 !      include 'COMMON.CONTACTS'
23375       real(kind=8),dimension(3) :: gx,gx1
23376       logical :: lprn
23377 !el local variables
23378       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
23379       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
23380                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
23381                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
23382                rlocshield
23383
23384       lprn=.false.
23385       eij=facont_hb(jj,i)
23386       ekl=facont_hb(kk,k)
23387       ees0pij=ees0p(jj,i)
23388       ees0pkl=ees0p(kk,k)
23389       ees0mij=ees0m(jj,i)
23390       ees0mkl=ees0m(kk,k)
23391       ekont=eij*ekl
23392       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
23393 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
23394 !C Following 4 lines for diagnostics.
23395 !cd    ees0pkl=0.0D0
23396 !cd    ees0pij=1.0D0
23397 !cd    ees0mkl=0.0D0
23398 !cd    ees0mij=1.0D0
23399 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
23400 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
23401 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
23402 !C Calculate the multi-body contribution to energy.
23403 !      ecorr=ecorr+ekont*ees
23404 !C Calculate multi-body contributions to the gradient.
23405       coeffpees0pij=coeffp*ees0pij
23406       coeffmees0mij=coeffm*ees0mij
23407       coeffpees0pkl=coeffp*ees0pkl
23408       coeffmees0mkl=coeffm*ees0mkl
23409       do ll=1,3
23410       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
23411        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
23412        coeffmees0mkl*gacontm_hb1(ll,jj,i))
23413       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
23414       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
23415       coeffmees0mkl*gacontm_hb2(ll,jj,i))
23416       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
23417       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
23418       coeffmees0mij*gacontm_hb1(ll,kk,k))
23419       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
23420       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
23421       coeffmees0mij*gacontm_hb2(ll,kk,k))
23422       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
23423         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
23424         coeffmees0mkl*gacontm_hb3(ll,jj,i))
23425       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
23426       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
23427       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
23428         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
23429         coeffmees0mij*gacontm_hb3(ll,kk,k))
23430       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
23431       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
23432       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
23433       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
23434       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
23435       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
23436       enddo
23437       ehbcorr3_nucl=ekont*ees
23438       return
23439       end function ehbcorr3_nucl
23440 #ifdef MPI
23441       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
23442       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
23443       real(kind=8):: buffer(dimen1,dimen2)
23444       num_kont=num_cont_hb(atom)
23445       do i=1,num_kont
23446       do k=1,8
23447         do j=1,3
23448           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
23449         enddo ! j
23450       enddo ! k
23451       buffer(i,indx+25)=facont_hb(i,atom)
23452       buffer(i,indx+26)=ees0p(i,atom)
23453       buffer(i,indx+27)=ees0m(i,atom)
23454       buffer(i,indx+28)=d_cont(i,atom)
23455       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
23456       enddo ! i
23457       buffer(1,indx+30)=dfloat(num_kont)
23458       return
23459       end subroutine pack_buffer
23460 !c------------------------------------------------------------------------------
23461       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
23462       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
23463       real(kind=8):: buffer(dimen1,dimen2)
23464 !      double precision zapas
23465 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
23466 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
23467 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
23468 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
23469       num_kont=buffer(1,indx+30)
23470       num_kont_old=num_cont_hb(atom)
23471       num_cont_hb(atom)=num_kont+num_kont_old
23472       do i=1,num_kont
23473       ii=i+num_kont_old
23474       do k=1,8
23475         do j=1,3
23476           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
23477         enddo ! j
23478       enddo ! k
23479       facont_hb(ii,atom)=buffer(i,indx+25)
23480       ees0p(ii,atom)=buffer(i,indx+26)
23481       ees0m(ii,atom)=buffer(i,indx+27)
23482       d_cont(i,atom)=buffer(i,indx+28)
23483       jcont_hb(ii,atom)=buffer(i,indx+29)
23484       enddo ! i
23485       return
23486       end subroutine unpack_buffer
23487 !c------------------------------------------------------------------------------
23488 #endif
23489       subroutine ecatcat(ecationcation)
23490       use MD_data, only: t_bath
23491       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj,irdiff
23492       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23493       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
23494       real(kind=8) :: xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23495       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
23496       real(kind=8) :: awat,bwat,cwat,dwat,sss2min2,sss2mingrad2,rdiff,ewater
23497       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23498       gg,r
23499
23500       ecationcation=0.0d0
23501       if (nres_molec(5).le.1) return
23502       rcat0=3.472
23503       epscalc=0.05
23504       r06 = rcat0**6
23505       r012 = r06**2
23506 !        k0 = 332.0*(2.0*2.0)/80.0
23507       itmp=0
23508
23509       do i=1,4
23510       itmp=itmp+nres_molec(i)
23511       enddo
23512 !        write(iout,*) "itmp",itmp
23513       do i=itmp+1,itmp+nres_molec(5)-1
23514
23515       xi=c(1,i)
23516       yi=c(2,i)
23517       zi=c(3,i)
23518 !        write (iout,*) i,"TUTUT",c(1,i)
23519         itypi=itype(i,5)
23520       call to_box(xi,yi,zi)
23521       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23522         do j=i+1,itmp+nres_molec(5)
23523         itypj=itype(j,5)
23524 !          print *,i,j,itypi,itypj
23525         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
23526 !           print *,i,j,'catcat'
23527          xj=c(1,j)
23528          yj=c(2,j)
23529          zj=c(3,j)
23530       call to_box(xj,yj,zj)
23531 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23532 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23533 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23534 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23535 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23536       xj=boxshift(xj-xi,boxxsize)
23537       yj=boxshift(yj-yi,boxysize)
23538       zj=boxshift(zj-zi,boxzsize)
23539        rcal =xj**2+yj**2+zj**2
23540       ract=sqrt(rcal)
23541         if ((itypi.gt.1).or.(itypj.gt.1)) then
23542
23543 !        rcat0=3.472
23544 !        epscalc=0.05
23545 !        r06 = rcat0**6
23546 !        r012 = r06**2
23547 !        k0 = 332*(2*2)/80
23548       Evan1cat=epscalc*(r012/(rcal**6))
23549       Evan2cat=epscalc*2*(r06/(rcal**3))
23550       Eeleccat=k0/ract
23551       r7 = rcal**7
23552       r4 = rcal**4
23553       r(1)=xj
23554       r(2)=yj
23555       r(3)=zj
23556       do k=1,3
23557         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
23558         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
23559         dEeleccat(k)=-k0*r(k)/ract**3
23560       enddo
23561       do k=1,3
23562         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
23563         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
23564         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
23565       enddo
23566       if (energy_dec) write (iout,*) "ecatcat",i,j,Evan1cat,Evan2cat,Eeleccat,&
23567        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
23568 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
23569       ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
23570        else !this is water part and other non standard molecules
23571
23572        sss2min2=sscale2(ract,10.0d0,1.0d0)! cutoff for water interaction is 15A
23573        if (sss2min2.eq.0.0d0) cycle
23574        sss2mingrad2=sscagrad2(ract,10.0d0,1.0d0)
23575        irdiff=int((ract-2.06d0)*50.0d0)+1
23576
23577        rdiff=ract-((irdiff-1)*0.02d0+2.06d0)
23578        if (irdiff.le.0) then
23579         irdiff=0
23580         rdiff=ract
23581        endif
23582 !       print *,rdiff,ract,irdiff,sss2mingrad2
23583        awat=awaterenta(irdiff)-awaterentro(irdiff)*t_bath/1000.0d0
23584        bwat=bwaterenta(irdiff)-bwaterentro(irdiff)*t_bath/1000.0d0
23585        cwat=cwaterenta(irdiff)-cwaterentro(irdiff)*t_bath/1000.0d0
23586        dwat=dwaterenta(irdiff)-dwaterentro(irdiff)*t_bath/1000.0d0
23587        r(1)=xj
23588        r(2)=yj
23589        r(3)=zj
23590
23591        ewater=awat+bwat*rdiff+cwat*rdiff*rdiff+dwat*rdiff*rdiff*rdiff
23592        ecationcation=ecationcation+ewater*sss2min2
23593        do k=1,3
23594         gg(k)=(bwat+2.0d0*cwat*rdiff+dwat*3.0d0*rdiff*rdiff)*r(k)/ract
23595         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)*sss2min2-sss2mingrad2*ewater*r(k)/ract
23596         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)*sss2min2+sss2mingrad2*ewater*r(k)/ract
23597       enddo
23598        if (energy_dec) write(iout,'(2f10.7,f15.7,2i5)') rdiff,ract,ecationcation,i,j
23599        endif ! end water
23600        enddo
23601        enddo
23602        return
23603        end subroutine ecatcat
23604 !---------------------------------------------------------------------------
23605 ! new for K+
23606       subroutine ecats_prot_amber(evdw)
23607 !      subroutine ecat_prot2(ecation_prot)
23608       use calc_data
23609       use comm_momo
23610
23611       logical :: lprn
23612 !el local variables
23613       integer :: iint,itypi1,subchap,isel,itmp
23614       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
23615       real(kind=8) :: evdw,aa,bb
23616       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23617                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
23618                 sslipi,sslipj,faclip,alpha_sco
23619       integer :: ii
23620       real(kind=8) :: fracinbuf
23621       real (kind=8) :: escpho
23622       real (kind=8),dimension(4):: ener
23623       real(kind=8) :: b1,b2,egb
23624       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
23625        Lambf,&
23626        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
23627        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
23628        federmaus,&
23629        d1i,d1j
23630 !       real(kind=8),dimension(3,2)::erhead_tail
23631 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
23632       real(kind=8) ::  facd4, adler, Fgb, facd3
23633       integer troll,jj,istate
23634       real (kind=8) :: dcosom1(3),dcosom2(3)
23635       real(kind=8) ::locbox(3)
23636       locbox(1)=boxxsize
23637           locbox(2)=boxysize
23638       locbox(3)=boxzsize
23639
23640       evdw=0.0D0
23641       if (nres_molec(5).eq.0) return
23642       eps_out=80.0d0
23643 !      sss_ele_cut=1.0d0
23644
23645       itmp=0
23646       do i=1,4
23647       itmp=itmp+nres_molec(i)
23648       enddo
23649 !        go to 17
23650 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23651       do i=ibond_start,ibond_end
23652
23653 !        print *,"I am in EVDW",i
23654       itypi=iabs(itype(i,1))
23655
23656 !        if (i.ne.47) cycle
23657       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
23658       itypi1=iabs(itype(i+1,1))
23659       xi=c(1,nres+i)
23660       yi=c(2,nres+i)
23661       zi=c(3,nres+i)
23662       call to_box(xi,yi,zi)
23663       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23664       dxi=dc_norm(1,nres+i)
23665       dyi=dc_norm(2,nres+i)
23666       dzi=dc_norm(3,nres+i)
23667       dsci_inv=vbld_inv(i+nres)
23668        do j=itmp+1,itmp+nres_molec(5)
23669
23670 ! Calculate SC interaction energy.
23671           itypj=iabs(itype(j,5))
23672           if ((itypj.eq.ntyp1)) cycle
23673            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23674
23675           dscj_inv=0.0
23676          xj=c(1,j)
23677          yj=c(2,j)
23678          zj=c(3,j)
23679
23680       call to_box(xj,yj,zj)
23681 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
23682
23683 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23684 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23685 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23686 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23687 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23688       xj=boxshift(xj-xi,boxxsize)
23689       yj=boxshift(yj-yi,boxysize)
23690       zj=boxshift(zj-zi,boxzsize)
23691 !      write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize
23692
23693 !          dxj = dc_norm( 1, nres+j )
23694 !          dyj = dc_norm( 2, nres+j )
23695 !          dzj = dc_norm( 3, nres+j )
23696
23697         itypi = itype(i,1)
23698         itypj = itype(j,5)
23699 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23700 ! sampling performed with amber package
23701 !          alf1   = 0.0d0
23702 !          alf2   = 0.0d0
23703 !          alf12  = 0.0d0
23704 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23705         chi1 = chi1cat(itypi,itypj)
23706         chis1 = chis1cat(itypi,itypj)
23707         chip1 = chipp1cat(itypi,itypj)
23708 !          chi1=0.0d0
23709 !          chis1=0.0d0
23710 !          chip1=0.0d0
23711         chi2=0.0
23712         chip2=0.0
23713         chis2=0.0
23714 !          chis2 = chis(itypj,itypi)
23715         chis12 = chis1 * chis2
23716         sig1 = sigmap1cat(itypi,itypj)
23717         sig2=0.0d0
23718 !          sig2 = sigmap2(itypi,itypj)
23719 ! alpha factors from Fcav/Gcav
23720         b1cav = alphasurcat(1,itypi,itypj)
23721         b2cav = alphasurcat(2,itypi,itypj)
23722         b3cav = alphasurcat(3,itypi,itypj)
23723         b4cav = alphasurcat(4,itypi,itypj)
23724
23725 !        b1cav=0.0d0
23726 !        b2cav=0.0d0
23727 !        b3cav=0.0d0
23728 !        b4cav=0.0d0
23729
23730 ! used to determine whether we want to do quadrupole calculations
23731        eps_in = epsintabcat(itypi,itypj)
23732        if (eps_in.eq.0.0) eps_in=1.0
23733
23734        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23735 !       Rtail = 0.0d0
23736
23737        DO k = 1, 3
23738       ctail(k,1)=c(k,i+nres)
23739       ctail(k,2)=c(k,j)
23740        END DO
23741       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
23742       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
23743 !c! tail distances will be themselves usefull elswhere
23744 !c1 (in Gcav, for example)
23745        do k=1,3
23746        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
23747        enddo
23748        Rtail = dsqrt( &
23749         (Rtail_distance(1)*Rtail_distance(1)) &
23750       + (Rtail_distance(2)*Rtail_distance(2)) &
23751       + (Rtail_distance(3)*Rtail_distance(3)))
23752 ! tail location and distance calculations
23753 ! dhead1
23754        d1 = dheadcat(1, 1, itypi, itypj)
23755 !       d2 = dhead(2, 1, itypi, itypj)
23756        DO k = 1,3
23757 ! location of polar head is computed by taking hydrophobic centre
23758 ! and moving by a d1 * dc_norm vector
23759 ! see unres publications for very informative images
23760       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
23761       chead(k,2) = c(k, j)
23762       enddo
23763       call to_box(chead(1,1),chead(2,1),chead(3,1))
23764       call to_box(chead(1,2),chead(2,2),chead(3,2))
23765 !      write(iout,*) "TEST",chead(1,1),chead(2,1),chead(3,1),dc_norm(k, i+nres),d1
23766 ! distance
23767 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23768 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23769       do k=1,3
23770       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
23771        END DO
23772 ! pitagoras (root of sum of squares)
23773        Rhead = dsqrt( &
23774         (Rhead_distance(1)*Rhead_distance(1)) &
23775       + (Rhead_distance(2)*Rhead_distance(2)) &
23776       + (Rhead_distance(3)*Rhead_distance(3)))
23777 !-------------------------------------------------------------------
23778 ! zero everything that should be zero'ed
23779        evdwij = 0.0d0
23780        ECL = 0.0d0
23781        Elj = 0.0d0
23782        Equad = 0.0d0
23783        Epol = 0.0d0
23784        Fcav=0.0d0
23785        eheadtail = 0.0d0
23786        dGCLdOM1 = 0.0d0
23787        dGCLdOM2 = 0.0d0
23788        dGCLdOM12 = 0.0d0
23789        dPOLdOM1 = 0.0d0
23790        dPOLdOM2 = 0.0d0
23791         Fcav = 0.0d0
23792         Fisocav=0.0d0
23793         dFdR = 0.0d0
23794         dCAVdOM1  = 0.0d0
23795         dCAVdOM2  = 0.0d0
23796         dCAVdOM12 = 0.0d0
23797         dscj_inv = vbld_inv(j+nres)
23798 !          print *,i,j,dscj_inv,dsci_inv
23799 ! rij holds 1/(distance of Calpha atoms)
23800         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23801         rij  = dsqrt(rrij)
23802         CALL sc_angular
23803 ! this should be in elgrad_init but om's are calculated by sc_angular
23804 ! which in turn is used by older potentials
23805 ! om = omega, sqom = om^2
23806         sqom1  = om1 * om1
23807         sqom2  = om2 * om2
23808         sqom12 = om12 * om12
23809
23810 ! now we calculate EGB - Gey-Berne
23811 ! It will be summed up in evdwij and saved in evdw
23812         sigsq     = 1.0D0  / sigsq
23813         sig       = sig0ij * dsqrt(sigsq)
23814 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23815         rij_shift = Rtail - sig + sig0ij
23816         IF (rij_shift.le.0.0D0) THEN
23817          evdw = 1.0D20
23818       if (evdw.gt.1.0d6) then
23819       write (*,'(2(1x,a3,i3),7f7.2)') &
23820       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23821       1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij,sigsq
23822       write(*,*) facsig,faceps1_inv,om1,chiom1,chi1
23823      write(*,*) "ANISO?!",chi1
23824 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23825 !      Equad,evdwij+Fcav+eheadtail,evdw
23826       endif
23827
23828          RETURN
23829         END IF
23830         sigder = -sig * sigsq
23831         rij_shift = 1.0D0 / rij_shift
23832         fac       = rij_shift**expon
23833         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23834 !          print *,"ADAM",aa_aq(itypi,itypj)
23835
23836 !          c1        = 0.0d0
23837         c2        = fac  * bb_aq_cat(itypi,itypj)
23838 !          c2        = 0.0d0
23839         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23840         eps2der   = eps3rt * evdwij
23841         eps3der   = eps2rt * evdwij
23842 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23843         evdwij    = eps2rt * eps3rt * evdwij
23844 !#ifdef TSCSC
23845 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23846 !           evdw_p = evdw_p + evdwij
23847 !          ELSE
23848 !           evdw_m = evdw_m + evdwij
23849 !          END IF
23850 !#else
23851         evdw = evdw  &
23852             + evdwij
23853 !#endif
23854         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23855         fac    = -expon * (c1 + evdwij) * rij_shift
23856         sigder = fac * sigder
23857 ! Calculate distance derivative
23858         gg(1) =  fac
23859         gg(2) =  fac
23860         gg(3) =  fac
23861 !       print *,"GG(1),distance grad",gg(1)
23862         fac = chis1 * sqom1 + chis2 * sqom2 &
23863         - 2.0d0 * chis12 * om1 * om2 * om12
23864         pom = 1.0d0 - chis1 * chis2 * sqom12
23865         Lambf = (1.0d0 - (fac / pom))
23866         Lambf = dsqrt(Lambf)
23867         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23868         Chif = Rtail * sparrow
23869         ChiLambf = Chif * Lambf
23870         eagle = dsqrt(ChiLambf)
23871         bat = ChiLambf ** 11.0d0
23872         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23873         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23874         botsq = bot * bot
23875         Fcav = top / bot
23876
23877        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23878        dbot = 12.0d0 * b4cav * bat * Lambf
23879        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23880
23881         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23882         dbot = 12.0d0 * b4cav * bat * Chif
23883         eagle = Lambf * pom
23884         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23885         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23886         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23887             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23888
23889         dFdL = ((dtop * bot - top * dbot) / botsq)
23890         dCAVdOM1  = dFdL * ( dFdOM1 )
23891         dCAVdOM2  = dFdL * ( dFdOM2 )
23892         dCAVdOM12 = dFdL * ( dFdOM12 )
23893
23894        DO k= 1, 3
23895       ertail(k) = Rtail_distance(k)/Rtail
23896        END DO
23897        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23898        erdxj = scalar( ertail(1), dC_norm(1,j) )
23899        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
23900        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j)
23901        DO k = 1, 3
23902       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23903       gradpepcatx(k,i) = gradpepcatx(k,i) &
23904               - (( dFdR + gg(k) ) * pom)
23905       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j))
23906 !        gvdwx(k,j) = gvdwx(k,j)   &
23907 !                  + (( dFdR + gg(k) ) * pom)
23908       gradpepcat(k,i) = gradpepcat(k,i)  &
23909               - (( dFdR + gg(k) ) * ertail(k))
23910       gradpepcat(k,j) = gradpepcat(k,j) &
23911               + (( dFdR + gg(k) ) * ertail(k))
23912       gg(k) = 0.0d0
23913        ENDDO
23914 !c! Compute head-head and head-tail energies for each state
23915 !!        if (.false.) then ! turn off electrostatic
23916         if (itype(j,5).gt.0) then ! the normal cation case
23917         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
23918 !        print *,i,itype(i,1),isel
23919         IF (isel.eq.0) THEN
23920 !c! No charges - do nothing
23921          eheadtail = 0.0d0
23922
23923         ELSE IF (isel.eq.1) THEN
23924 !c! Nonpolar-charge interactions
23925         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23926           Qi=Qi*2
23927           Qij=Qij*2
23928          endif
23929
23930          CALL enq_cat(epol)
23931          eheadtail = epol
23932 !           eheadtail = 0.0d0
23933
23934         ELSE IF (isel.eq.3) THEN
23935 !c! Dipole-charge interactions
23936         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23937           Qi=Qi*2
23938           Qij=Qij*2
23939          endif
23940 !         write(iout,*) "KURWA0",d1
23941
23942          CALL edq_cat(ecl, elj, epol)
23943         eheadtail = ECL + elj + epol
23944 !           eheadtail = 0.0d0
23945
23946         ELSE IF ((isel.eq.2)) THEN
23947
23948 !c! Same charge-charge interaction ( +/+ or -/- )
23949         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23950           Qi=Qi*2
23951           Qij=Qij*2
23952          endif
23953
23954          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
23955          eheadtail = ECL + Egb + Epol + Fisocav + Elj
23956 !           eheadtail = 0.0d0
23957
23958 !          ELSE IF ((isel.eq.2.and.  &
23959 !               iabs(Qi).eq.1).and. &
23960 !               nstate(itypi,itypj).ne.1) THEN
23961 !c! Different charge-charge interaction ( +/- or -/+ )
23962 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23963 !            Qi=Qi*2
23964 !            Qij=Qij*2
23965 !           endif
23966 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23967 !            Qj=Qj*2
23968 !            Qij=Qij*2
23969 !           endif
23970 !
23971 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
23972        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
23973        else
23974        write(iout,*) "not yet implemented",j,itype(j,5)
23975        endif
23976 !!       endif ! turn off electrostatic
23977       evdw = evdw  + Fcav + eheadtail
23978 !      if (evdw.gt.1.0d6) then
23979 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23980 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23981 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23982 !      Equad,evdwij+Fcav+eheadtail,evdw
23983 !      endif
23984
23985        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23986       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23987       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23988       Equad,evdwij+Fcav+eheadtail,evdw
23989 !       evdw = evdw  + Fcav  + eheadtail
23990        if (energy_dec) write(iout,*) "FCAV", &
23991          sig1,sig2,b1cav,b2cav,b3cav,b4cav
23992 !       print *,"before sc_grad_cat", i,j, gradpepcat(1,j)
23993 !        iF (nstate(itypi,itypj).eq.1) THEN
23994       CALL sc_grad_cat
23995 !       print *,"after sc_grad_cat", i,j, gradpepcat(1,j)
23996
23997 !       END IF
23998 !c!-------------------------------------------------------------------
23999 !c! NAPISY KONCOWE
24000        END DO   ! j
24001        END DO     ! i
24002 !c      write (iout,*) "Number of loop steps in EGB:",ind
24003 !c      energy_dec=.false.
24004 !              print *,"EVDW KURW",evdw,nres
24005 !!!        return
24006    17   continue
24007 !      go to 23
24008       do i=ibond_start,ibond_end
24009
24010 !        print *,"I am in EVDW",i
24011       itypi=10 ! the peptide group parameters are for glicine
24012
24013 !        if (i.ne.47) cycle
24014       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
24015       itypi1=iabs(itype(i+1,1))
24016       xi=(c(1,i)+c(1,i+1))/2.0
24017       yi=(c(2,i)+c(2,i+1))/2.0
24018       zi=(c(3,i)+c(3,i+1))/2.0
24019         call to_box(xi,yi,zi)
24020       dxi=dc_norm(1,i)
24021       dyi=dc_norm(2,i)
24022       dzi=dc_norm(3,i)
24023       dsci_inv=vbld_inv(i+1)/2.0
24024        do j=itmp+1,itmp+nres_molec(5)
24025
24026 ! Calculate SC interaction energy.
24027           itypj=iabs(itype(j,5))
24028           if ((itypj.eq.ntyp1)) cycle
24029            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
24030
24031           dscj_inv=0.0
24032          xj=c(1,j)
24033          yj=c(2,j)
24034          zj=c(3,j)
24035         call to_box(xj,yj,zj)
24036       xj=boxshift(xj-xi,boxxsize)
24037       yj=boxshift(yj-yi,boxysize)
24038       zj=boxshift(zj-zi,boxzsize)
24039
24040         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24041
24042         dxj = 0.0d0! dc_norm( 1, nres+j )
24043         dyj = 0.0d0!dc_norm( 2, nres+j )
24044         dzj = 0.0d0! dc_norm( 3, nres+j )
24045
24046         itypi = 10
24047         itypj = itype(j,5)
24048 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
24049 ! sampling performed with amber package
24050 !          alf1   = 0.0d0
24051 !          alf2   = 0.0d0
24052 !          alf12  = 0.0d0
24053 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
24054         chi1 = chi1cat(itypi,itypj)
24055         chis1 = chis1cat(itypi,itypj)
24056         chip1 = chipp1cat(itypi,itypj)
24057 !          chi1=0.0d0
24058 !          chis1=0.0d0
24059 !          chip1=0.0d0
24060         chi2=0.0
24061         chip2=0.0
24062         chis2=0.0
24063 !          chis2 = chis(itypj,itypi)
24064         chis12 = chis1 * chis2
24065         sig1 = sigmap1cat(itypi,itypj)
24066         sig2=0.0
24067 !          sig2 = sigmap2(itypi,itypj)
24068 ! alpha factors from Fcav/Gcav
24069         b1cav = alphasurcat(1,itypi,itypj)
24070         b2cav = alphasurcat(2,itypi,itypj)
24071         b3cav = alphasurcat(3,itypi,itypj)
24072         b4cav = alphasurcat(4,itypi,itypj)
24073
24074 ! used to determine whether we want to do quadrupole calculations
24075        eps_in = epsintabcat(itypi,itypj)
24076        if (eps_in.eq.0.0) eps_in=1.0
24077
24078        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24079 !       Rtail = 0.0d0
24080
24081        DO k = 1, 3
24082       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
24083       ctail(k,2)=c(k,j)
24084        END DO
24085       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
24086       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
24087 !c! tail distances will be themselves usefull elswhere
24088 !c1 (in Gcav, for example)
24089        do k=1,3
24090        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
24091        enddo
24092
24093 !c! tail distances will be themselves usefull elswhere
24094 !c1 (in Gcav, for example)
24095        Rtail = dsqrt( &
24096         (Rtail_distance(1)*Rtail_distance(1)) &
24097       + (Rtail_distance(2)*Rtail_distance(2)) &
24098       + (Rtail_distance(3)*Rtail_distance(3)))
24099 ! tail location and distance calculations
24100 ! dhead1
24101        d1 = dheadcat(1, 1, itypi, itypj)
24102 !       print *,"d1",d1
24103 !       d1=0.0d0
24104 !       d2 = dhead(2, 1, itypi, itypj)
24105        DO k = 1,3
24106 ! location of polar head is computed by taking hydrophobic centre
24107 ! and moving by a d1 * dc_norm vector
24108 ! see unres publications for very informative images
24109       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
24110       chead(k,2) = c(k, j)
24111        ENDDO
24112 ! distance
24113 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24114 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24115       call to_box(chead(1,1),chead(2,1),chead(3,1))
24116       call to_box(chead(1,2),chead(2,2),chead(3,2))
24117
24118 ! distance
24119 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24120 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24121       do k=1,3
24122       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
24123        END DO
24124
24125 ! pitagoras (root of sum of squares)
24126        Rhead = dsqrt( &
24127         (Rhead_distance(1)*Rhead_distance(1)) &
24128       + (Rhead_distance(2)*Rhead_distance(2)) &
24129       + (Rhead_distance(3)*Rhead_distance(3)))
24130 !-------------------------------------------------------------------
24131 ! zero everything that should be zero'ed
24132        evdwij = 0.0d0
24133        ECL = 0.0d0
24134        Elj = 0.0d0
24135        Equad = 0.0d0
24136        Epol = 0.0d0
24137        Fcav=0.0d0
24138        eheadtail = 0.0d0
24139        dGCLdOM1 = 0.0d0
24140        dGCLdOM2 = 0.0d0
24141        dGCLdOM12 = 0.0d0
24142        dPOLdOM1 = 0.0d0
24143        dPOLdOM2 = 0.0d0
24144         Fcav = 0.0d0
24145         dFdR = 0.0d0
24146         dCAVdOM1  = 0.0d0
24147         dCAVdOM2  = 0.0d0
24148         dCAVdOM12 = 0.0d0
24149         dscj_inv = vbld_inv(j+nres)
24150 !          print *,i,j,dscj_inv,dsci_inv
24151 ! rij holds 1/(distance of Calpha atoms)
24152         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24153         rij  = dsqrt(rrij)
24154         CALL sc_angular
24155 ! this should be in elgrad_init but om's are calculated by sc_angular
24156 ! which in turn is used by older potentials
24157 ! om = omega, sqom = om^2
24158         sqom1  = om1 * om1
24159         sqom2  = om2 * om2
24160         sqom12 = om12 * om12
24161
24162 ! now we calculate EGB - Gey-Berne
24163 ! It will be summed up in evdwij and saved in evdw
24164         sigsq     = 1.0D0  / sigsq
24165         sig       = sig0ij * dsqrt(sigsq)
24166 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24167         rij_shift = Rtail - sig + sig0ij
24168         IF (rij_shift.le.0.0D0) THEN
24169          evdw = 1.0D20
24170 !      if (evdw.gt.1.0d6) then
24171 !      write (*,'(2(1x,a3,i3),6f6.2)') &
24172 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24173 !      1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij
24174 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24175 !      Equad,evdwij+Fcav+eheadtail,evdw
24176 !      endif
24177          RETURN
24178         END IF
24179         sigder = -sig * sigsq
24180         rij_shift = 1.0D0 / rij_shift
24181         fac       = rij_shift**expon
24182         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
24183 !          print *,"ADAM",aa_aq(itypi,itypj)
24184
24185 !          c1        = 0.0d0
24186         c2        = fac  * bb_aq_cat(itypi,itypj)
24187 !          c2        = 0.0d0
24188         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24189         eps2der   = eps3rt * evdwij
24190         eps3der   = eps2rt * evdwij
24191 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24192         evdwij    = eps2rt * eps3rt * evdwij
24193 !#ifdef TSCSC
24194 !          IF (bb_aq(itypi,itypj).gt.0) THEN
24195 !           evdw_p = evdw_p + evdwij
24196 !          ELSE
24197 !           evdw_m = evdw_m + evdwij
24198 !          END IF
24199 !#else
24200         evdw = evdw  &
24201             + evdwij
24202 !#endif
24203         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24204         fac    = -expon * (c1 + evdwij) * rij_shift
24205         sigder = fac * sigder
24206 ! Calculate distance derivative
24207         gg(1) =  fac
24208         gg(2) =  fac
24209         gg(3) =  fac
24210
24211         fac = chis1 * sqom1 + chis2 * sqom2 &
24212         - 2.0d0 * chis12 * om1 * om2 * om12
24213
24214         pom = 1.0d0 - chis1 * chis2 * sqom12
24215 !          print *,"TUT2",fac,chis1,sqom1,pom
24216         Lambf = (1.0d0 - (fac / pom))
24217         Lambf = dsqrt(Lambf)
24218         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24219         Chif = Rtail * sparrow
24220         ChiLambf = Chif * Lambf
24221         eagle = dsqrt(ChiLambf)
24222         bat = ChiLambf ** 11.0d0
24223         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
24224         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
24225         botsq = bot * bot
24226         Fcav = top / bot
24227
24228        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
24229        dbot = 12.0d0 * b4cav * bat * Lambf
24230        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24231
24232         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
24233         dbot = 12.0d0 * b4cav * bat * Chif
24234         eagle = Lambf * pom
24235         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24236         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24237         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24238             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24239
24240         dFdL = ((dtop * bot - top * dbot) / botsq)
24241         dCAVdOM1  = dFdL * ( dFdOM1 )
24242         dCAVdOM2  = dFdL * ( dFdOM2 )
24243         dCAVdOM12 = dFdL * ( dFdOM12 )
24244
24245        DO k= 1, 3
24246       ertail(k) = Rtail_distance(k)/Rtail
24247        END DO
24248        erdxi = scalar( ertail(1), dC_norm(1,i) )
24249        erdxj = scalar( ertail(1), dC_norm(1,j) )
24250        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
24251        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
24252        DO k = 1, 3
24253       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
24254 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
24255 !                  - (( dFdR + gg(k) ) * pom)
24256       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24257 !        gvdwx(k,j) = gvdwx(k,j)   &
24258 !                  + (( dFdR + gg(k) ) * pom)
24259       gradpepcat(k,i) = gradpepcat(k,i)  &
24260               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
24261       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
24262               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
24263
24264       gradpepcat(k,j) = gradpepcat(k,j) &
24265               + (( dFdR + gg(k) ) * ertail(k))
24266       gg(k) = 0.0d0
24267        ENDDO
24268       if (itype(j,5).gt.0) then
24269 !c! Compute head-head and head-tail energies for each state
24270         isel = 3
24271 !c! Dipole-charge interactions
24272          CALL edq_cat_pep(ecl, elj, epol)
24273          eheadtail = ECL + elj + epol
24274 !          print *,"i,",i,eheadtail
24275 !           eheadtail = 0.0d0
24276       else
24277 !HERE WATER and other types of molecules solvents will be added
24278       write(iout,*) "not yet implemented"
24279 !      CALL edd_cat_pep
24280       endif
24281       evdw = evdw  + Fcav + eheadtail
24282 !      if (evdw.gt.1.0d6) then
24283 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24284 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24285 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24286 !      Equad,evdwij+Fcav+eheadtail,evdw
24287 !      endif
24288        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24289       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24290       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24291       Equad,evdwij+Fcav+eheadtail,evdw
24292 !       evdw = evdw  + Fcav  + eheadtail
24293
24294 !        iF (nstate(itypi,itypj).eq.1) THEN
24295       CALL sc_grad_cat_pep
24296 !       END IF
24297 !c!-------------------------------------------------------------------
24298 !c! NAPISY KONCOWE
24299        END DO   ! j
24300        END DO     ! i
24301 !c      write (iout,*) "Number of loop steps in EGB:",ind
24302 !c      energy_dec=.false.
24303 !              print *,"EVDW KURW",evdw,nres
24304  23   continue
24305 !       print *,"before leave sc_grad_cat", i,j, gradpepcat(1,nres-1)
24306
24307       return
24308       end subroutine ecats_prot_amber
24309
24310 !---------------------------------------------------------------------------
24311 ! old for Ca2+
24312        subroutine ecat_prot(ecation_prot)
24313 !      use calc_data
24314 !      use comm_momo
24315        integer i,j,k,subchap,itmp,inum
24316       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
24317       r7,r4
24318       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
24319       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
24320       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
24321       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
24322       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
24323       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
24324       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
24325       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
24326       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
24327       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
24328       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
24329       ndiv,ndivi
24330       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
24331       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
24332       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
24333       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
24334       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
24335       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
24336       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
24337       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
24338       dEvan1Cat
24339       real(kind=8),dimension(6) :: vcatprm
24340       ecation_prot=0.0d0
24341 ! first lets calculate interaction with peptide groups
24342       if (nres_molec(5).eq.0) return
24343       itmp=0
24344       do i=1,4
24345       itmp=itmp+nres_molec(i)
24346       enddo
24347 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
24348       do i=ibond_start,ibond_end
24349 !         cycle
24350        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
24351       xi=0.5d0*(c(1,i)+c(1,i+1))
24352       yi=0.5d0*(c(2,i)+c(2,i+1))
24353       zi=0.5d0*(c(3,i)+c(3,i+1))
24354         call to_box(xi,yi,zi)
24355
24356        do j=itmp+1,itmp+nres_molec(5)
24357 !           print *,"WTF",itmp,j,i
24358 ! all parameters were for Ca2+ to approximate single charge divide by two
24359        ndiv=1.0
24360        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24361        wconst=78*ndiv
24362       wdip =1.092777950857032D2
24363       wdip=wdip/wconst
24364       wmodquad=-2.174122713004870D4
24365       wmodquad=wmodquad/wconst
24366       wquad1 = 3.901232068562804D1
24367       wquad1=wquad1/wconst
24368       wquad2 = 3
24369       wquad2=wquad2/wconst
24370       wvan1 = 0.1
24371       wvan2 = 6
24372 !        itmp=0
24373
24374          xj=c(1,j)
24375          yj=c(2,j)
24376          zj=c(3,j)
24377         call to_box(xj,yj,zj)
24378       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24379 !       enddo
24380 !       enddo
24381        rcpm = sqrt(xj**2+yj**2+zj**2)
24382        drcp_norm(1)=xj/rcpm
24383        drcp_norm(2)=yj/rcpm
24384        drcp_norm(3)=zj/rcpm
24385        dcmag=0.0
24386        do k=1,3
24387        dcmag=dcmag+dc(k,i)**2
24388        enddo
24389        dcmag=dsqrt(dcmag)
24390        do k=1,3
24391        myd_norm(k)=dc(k,i)/dcmag
24392        enddo
24393       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
24394       drcp_norm(3)*myd_norm(3)
24395       rsecp = rcpm**2
24396       Ir = 1.0d0/rcpm
24397       Irsecp = 1.0d0/rsecp
24398       Irthrp = Irsecp/rcpm
24399       Irfourp = Irthrp/rcpm
24400       Irfiftp = Irfourp/rcpm
24401       Irsistp=Irfiftp/rcpm
24402       Irseven=Irsistp/rcpm
24403       Irtwelv=Irsistp*Irsistp
24404       Irthir=Irtwelv/rcpm
24405       sin2thet = (1-costhet*costhet)
24406       sinthet=sqrt(sin2thet)
24407       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
24408            *sin2thet
24409       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
24410            2*wvan2**6*Irsistp)
24411       ecation_prot = ecation_prot+E1+E2
24412 !        print *,"ecatprot",i,j,ecation_prot,rcpm
24413       dE1dr = -2*costhet*wdip*Irthrp-&
24414        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
24415       dE2dr = 3*wquad1*wquad2*Irfourp-     &
24416         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
24417       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
24418       do k=1,3
24419         drdpep(k) = -drcp_norm(k)
24420         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
24421         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
24422         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
24423         dEddci(k) = dEdcos*dcosddci(k)
24424       enddo
24425       do k=1,3
24426       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
24427       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
24428       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
24429       enddo
24430        enddo ! j
24431        enddo ! i
24432 !------------------------------------------sidechains
24433 !        do i=1,nres_molec(1)
24434       do i=ibond_start,ibond_end
24435        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
24436 !         cycle
24437 !        print *,i,ecation_prot
24438       xi=(c(1,i+nres))
24439       yi=(c(2,i+nres))
24440       zi=(c(3,i+nres))
24441                 call to_box(xi,yi,zi)
24442         do k=1,3
24443           cm1(k)=dc(k,i+nres)
24444         enddo
24445          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
24446        do j=itmp+1,itmp+nres_molec(5)
24447        ndiv=1.0
24448        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24449
24450          xj=c(1,j)
24451          yj=c(2,j)
24452          zj=c(3,j)
24453         call to_box(xj,yj,zj)
24454       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24455 !       enddo
24456 !       enddo
24457 ! 15- Glu 16-Asp
24458        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
24459        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
24460        (itype(i,1).eq.25))) then
24461           if(itype(i,1).eq.16) then
24462           inum=1
24463           else
24464           inum=2
24465           endif
24466           do k=1,6
24467           vcatprm(k)=catprm(k,inum)
24468           enddo
24469           dASGL=catprm(7,inum)
24470 !             do k=1,3
24471 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
24472             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
24473             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
24474             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
24475
24476 !                valpha(k)=c(k,i)
24477 !                vcat(k)=c(k,j)
24478             if (subchap.eq.1) then
24479              vcat(1)=xj_temp
24480              vcat(2)=yj_temp
24481              vcat(3)=zj_temp
24482              else
24483             vcat(1)=xj_safe
24484             vcat(2)=yj_safe
24485             vcat(3)=zj_safe
24486              endif
24487             valpha(1)=xi-c(1,i+nres)+c(1,i)
24488             valpha(2)=yi-c(2,i+nres)+c(2,i)
24489             valpha(3)=zi-c(3,i+nres)+c(3,i)
24490
24491 !              enddo
24492       do k=1,3
24493         dx(k) = vcat(k)-vcm(k)
24494       enddo
24495       do k=1,3
24496         v1(k)=(vcm(k)-valpha(k))
24497         v2(k)=(vcat(k)-valpha(k))
24498       enddo
24499       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24500       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
24501       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
24502
24503 !  The weights of the energy function calculated from
24504 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
24505         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
24506           ndivi=0.5
24507         else
24508           ndivi=1.0
24509         endif
24510        ndiv=1.0
24511        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24512
24513       wh2o=78*ndivi*ndiv
24514       wc = vcatprm(1)
24515       wc=wc/wh2o
24516       wdip =vcatprm(2)
24517       wdip=wdip/wh2o
24518       wquad1 =vcatprm(3)
24519       wquad1=wquad1/wh2o
24520       wquad2 = vcatprm(4)
24521       wquad2=wquad2/wh2o
24522       wquad2p = 1.0d0-wquad2
24523       wvan1 = vcatprm(5)
24524       wvan2 =vcatprm(6)
24525       opt = dx(1)**2+dx(2)**2
24526       rsecp = opt+dx(3)**2
24527       rs = sqrt(rsecp)
24528       rthrp = rsecp*rs
24529       rfourp = rthrp*rs
24530       rsixp = rfourp*rsecp
24531       reight=rsixp*rsecp
24532       Ir = 1.0d0/rs
24533       Irsecp = 1.0d0/rsecp
24534       Irthrp = Irsecp/rs
24535       Irfourp = Irthrp/rs
24536       Irsixp = 1.0d0/rsixp
24537       Ireight=1.0d0/reight
24538       Irtw=Irsixp*Irsixp
24539       Irthir=Irtw/rs
24540       Irfourt=Irthir/rs
24541       opt1 = (4*rs*dx(3)*wdip)
24542       opt2 = 6*rsecp*wquad1*opt
24543       opt3 = wquad1*wquad2p*Irsixp
24544       opt4 = (wvan1*wvan2**12)
24545       opt5 = opt4*12*Irfourt
24546       opt6 = 2*wvan1*wvan2**6
24547       opt7 = 6*opt6*Ireight
24548       opt8 = wdip/v1m
24549       opt10 = wdip/v2m
24550       opt11 = (rsecp*v2m)**2
24551       opt12 = (rsecp*v1m)**2
24552       opt14 = (v1m*v2m*rsecp)**2
24553       opt15 = -wquad1/v2m**2
24554       opt16 = (rthrp*(v1m*v2m)**2)**2
24555       opt17 = (v1m**2*rthrp)**2
24556       opt18 = -wquad1/rthrp
24557       opt19 = (v1m**2*v2m**2)**2
24558       Ec = wc*Ir
24559       do k=1,3
24560         dEcCat(k) = -(dx(k)*wc)*Irthrp
24561         dEcCm(k)=(dx(k)*wc)*Irthrp
24562         dEcCalp(k)=0.0d0
24563       enddo
24564       Edip=opt8*(v1dpv2)/(rsecp*v2m)
24565       do k=1,3
24566         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
24567                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24568         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
24569                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24570         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
24571                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
24572                   *v1dpv2)/opt14
24573       enddo
24574       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24575       do k=1,3
24576         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
24577                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
24578                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24579         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
24580                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
24581                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24582         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24583                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
24584                   v1dpv2**2)/opt19
24585       enddo
24586       Equad2=wquad1*wquad2p*Irthrp
24587       do k=1,3
24588         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24589         dEquad2Cm(k)=3*dx(k)*rs*opt3
24590         dEquad2Calp(k)=0.0d0
24591       enddo
24592       Evan1=opt4*Irtw
24593       do k=1,3
24594         dEvan1Cat(k)=-dx(k)*opt5
24595         dEvan1Cm(k)=dx(k)*opt5
24596         dEvan1Calp(k)=0.0d0
24597       enddo
24598       Evan2=-opt6*Irsixp
24599       do k=1,3
24600         dEvan2Cat(k)=dx(k)*opt7
24601         dEvan2Cm(k)=-dx(k)*opt7
24602         dEvan2Calp(k)=0.0d0
24603       enddo
24604       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
24605 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
24606
24607       do k=1,3
24608         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
24609                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24610 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
24611         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
24612                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24613         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
24614                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24615       enddo
24616           dscmag = 0.0d0
24617           do k=1,3
24618             dscvec(k) = dc(k,i+nres)
24619             dscmag = dscmag+dscvec(k)*dscvec(k)
24620           enddo
24621           dscmag3 = dscmag
24622           dscmag = sqrt(dscmag)
24623           dscmag3 = dscmag3*dscmag
24624           constA = 1.0d0+dASGL/dscmag
24625           constB = 0.0d0
24626           do k=1,3
24627             constB = constB+dscvec(k)*dEtotalCm(k)
24628           enddo
24629           constB = constB*dASGL/dscmag3
24630           do k=1,3
24631             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24632             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24633              constA*dEtotalCm(k)-constB*dscvec(k)
24634 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
24635             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24636             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24637            enddo
24638       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
24639          if(itype(i,1).eq.14) then
24640           inum=3
24641           else
24642           inum=4
24643           endif
24644           do k=1,6
24645           vcatprm(k)=catprm(k,inum)
24646           enddo
24647           dASGL=catprm(7,inum)
24648 !             do k=1,3
24649 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
24650 !                valpha(k)=c(k,i)
24651 !                vcat(k)=c(k,j)
24652 !              enddo
24653             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
24654             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
24655             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
24656             if (subchap.eq.1) then
24657              vcat(1)=xj_temp
24658              vcat(2)=yj_temp
24659              vcat(3)=zj_temp
24660              else
24661             vcat(1)=xj_safe
24662             vcat(2)=yj_safe
24663             vcat(3)=zj_safe
24664             endif
24665             valpha(1)=xi-c(1,i+nres)+c(1,i)
24666             valpha(2)=yi-c(2,i+nres)+c(2,i)
24667             valpha(3)=zi-c(3,i+nres)+c(3,i)
24668
24669
24670       do k=1,3
24671         dx(k) = vcat(k)-vcm(k)
24672       enddo
24673       do k=1,3
24674         v1(k)=(vcm(k)-valpha(k))
24675         v2(k)=(vcat(k)-valpha(k))
24676       enddo
24677       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24678       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
24679       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
24680 !  The weights of the energy function calculated from
24681 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
24682        ndiv=1.0
24683        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24684
24685       wh2o=78*ndiv
24686       wdip =vcatprm(2)
24687       wdip=wdip/wh2o
24688       wquad1 =vcatprm(3)
24689       wquad1=wquad1/wh2o
24690       wquad2 = vcatprm(4)
24691       wquad2=wquad2/wh2o
24692       wquad2p = 1-wquad2
24693       wvan1 = vcatprm(5)
24694       wvan2 =vcatprm(6)
24695       opt = dx(1)**2+dx(2)**2
24696       rsecp = opt+dx(3)**2
24697       rs = sqrt(rsecp)
24698       rthrp = rsecp*rs
24699       rfourp = rthrp*rs
24700       rsixp = rfourp*rsecp
24701       reight=rsixp*rsecp
24702       Ir = 1.0d0/rs
24703       Irsecp = 1/rsecp
24704       Irthrp = Irsecp/rs
24705       Irfourp = Irthrp/rs
24706       Irsixp = 1/rsixp
24707       Ireight=1/reight
24708       Irtw=Irsixp*Irsixp
24709       Irthir=Irtw/rs
24710       Irfourt=Irthir/rs
24711       opt1 = (4*rs*dx(3)*wdip)
24712       opt2 = 6*rsecp*wquad1*opt
24713       opt3 = wquad1*wquad2p*Irsixp
24714       opt4 = (wvan1*wvan2**12)
24715       opt5 = opt4*12*Irfourt
24716       opt6 = 2*wvan1*wvan2**6
24717       opt7 = 6*opt6*Ireight
24718       opt8 = wdip/v1m
24719       opt10 = wdip/v2m
24720       opt11 = (rsecp*v2m)**2
24721       opt12 = (rsecp*v1m)**2
24722       opt14 = (v1m*v2m*rsecp)**2
24723       opt15 = -wquad1/v2m**2
24724       opt16 = (rthrp*(v1m*v2m)**2)**2
24725       opt17 = (v1m**2*rthrp)**2
24726       opt18 = -wquad1/rthrp
24727       opt19 = (v1m**2*v2m**2)**2
24728       Edip=opt8*(v1dpv2)/(rsecp*v2m)
24729       do k=1,3
24730         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
24731                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24732        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
24733                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24734         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
24735                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
24736                   *v1dpv2)/opt14
24737       enddo
24738       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24739       do k=1,3
24740         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
24741                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
24742                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24743         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
24744                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
24745                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24746         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24747                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
24748                   v1dpv2**2)/opt19
24749       enddo
24750       Equad2=wquad1*wquad2p*Irthrp
24751       do k=1,3
24752         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24753         dEquad2Cm(k)=3*dx(k)*rs*opt3
24754         dEquad2Calp(k)=0.0d0
24755       enddo
24756       Evan1=opt4*Irtw
24757       do k=1,3
24758         dEvan1Cat(k)=-dx(k)*opt5
24759         dEvan1Cm(k)=dx(k)*opt5
24760         dEvan1Calp(k)=0.0d0
24761       enddo
24762       Evan2=-opt6*Irsixp
24763       do k=1,3
24764         dEvan2Cat(k)=dx(k)*opt7
24765         dEvan2Cm(k)=-dx(k)*opt7
24766         dEvan2Calp(k)=0.0d0
24767       enddo
24768        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
24769       do k=1,3
24770         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
24771                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24772         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
24773                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24774         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
24775                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24776       enddo
24777           dscmag = 0.0d0
24778           do k=1,3
24779             dscvec(k) = c(k,i+nres)-c(k,i)
24780 ! TU SPRAWDZ???
24781 !              dscvec(1) = xj
24782 !              dscvec(2) = yj
24783 !              dscvec(3) = zj
24784
24785             dscmag = dscmag+dscvec(k)*dscvec(k)
24786           enddo
24787           dscmag3 = dscmag
24788           dscmag = sqrt(dscmag)
24789           dscmag3 = dscmag3*dscmag
24790           constA = 1+dASGL/dscmag
24791           constB = 0.0d0
24792           do k=1,3
24793             constB = constB+dscvec(k)*dEtotalCm(k)
24794           enddo
24795           constB = constB*dASGL/dscmag3
24796           do k=1,3
24797             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24798             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24799              constA*dEtotalCm(k)-constB*dscvec(k)
24800             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24801             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24802            enddo
24803          else
24804           rcal = 0.0d0
24805           do k=1,3
24806 !              r(k) = c(k,j)-c(k,i+nres)
24807             r(1) = xj
24808             r(2) = yj
24809             r(3) = zj
24810             rcal = rcal+r(k)*r(k)
24811           enddo
24812           ract=sqrt(rcal)
24813           rocal=1.5
24814           epscalc=0.2
24815           r0p=0.5*(rocal+sig0(itype(i,1)))
24816           r06 = r0p**6
24817           r012 = r06*r06
24818           Evan1=epscalc*(r012/rcal**6)
24819           Evan2=epscalc*2*(r06/rcal**3)
24820           r4 = rcal**4
24821           r7 = rcal**7
24822           do k=1,3
24823             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
24824             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
24825           enddo
24826           do k=1,3
24827             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
24828           enddo
24829              ecation_prot = ecation_prot+ Evan1+Evan2
24830           do  k=1,3
24831              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24832              dEtotalCm(k)
24833             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
24834             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
24835            enddo
24836        endif ! 13-16 residues
24837        enddo !j
24838        enddo !i
24839        return
24840        end subroutine ecat_prot
24841
24842 !----------------------------------------------------------------------------
24843 !---------------------------------------------------------------------------
24844        subroutine ecat_nucl(ecation_nucl)
24845        integer i,j,k,subchap,itmp,inum,itypi,itypj
24846        real(kind=8) :: xi,yi,zi,xj,yj,zj
24847        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
24848        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
24849        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
24850        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
24851        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
24852        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
24853        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
24854        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
24855        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
24856        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
24857        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
24858        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
24859        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
24860        dEcavdCm,boxik
24861        real(kind=8),dimension(14) :: vcatnuclprm
24862        ecation_nucl=0.0d0
24863        boxik(1)=boxxsize
24864        boxik(2)=boxysize
24865        boxik(3)=boxzsize
24866
24867        if (nres_molec(5).eq.0) return
24868        itmp=0
24869        do i=1,4
24870           itmp=itmp+nres_molec(i)
24871        enddo
24872 !       print *,nres_molec(2),"nres2"
24873       do i=ibond_nucl_start,ibond_nucl_end
24874 !       do i=iatsc_s_nucl,iatsc_e_nucl
24875           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
24876           xi=(c(1,i+nres))
24877           yi=(c(2,i+nres))
24878           zi=(c(3,i+nres))
24879       call to_box(xi,yi,zi)
24880       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24881           do k=1,3
24882              cm1(k)=dc(k,i+nres)
24883           enddo
24884           do j=itmp+1,itmp+nres_molec(5)
24885              xj=c(1,j)
24886              yj=c(2,j)
24887              zj=c(3,j)
24888       call to_box(xj,yj,zj)
24889 !      print *,i,j,itmp
24890 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
24891 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24892 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24893 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24894 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24895 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24896       xj=boxshift(xj-xi,boxxsize)
24897       yj=boxshift(yj-yi,boxysize)
24898       zj=boxshift(zj-zi,boxzsize)
24899 !       write(iout,*) 'after shift', xj,yj,zj
24900              dist_init=xj**2+yj**2+zj**2
24901
24902              itypi=itype(i,2)
24903              itypj=itype(j,5)
24904              do k=1,13
24905                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
24906              enddo
24907              do k=1,3
24908                 vcm(k)=c(k,i+nres)
24909                 vsug(k)=c(k,i)
24910                 vcat(k)=c(k,j)
24911              enddo
24912              call to_box(vcm(1),vcm(2),vcm(3))
24913              call to_box(vsug(1),vsug(2),vsug(3))
24914              call to_box(vcat(1),vcat(2),vcat(3))
24915              do k=1,3
24916 !                dx(k) = vcat(k)-vcm(k)
24917 !             enddo
24918                 dx(k)=boxshift(vcat(k)-vcm(k),boxik(k))
24919 !             do k=1,3
24920                 v1(k)=dc(k,i+nres)
24921                 v2(k)=boxshift(vcat(k)-vsug(k),boxik(k))
24922              enddo
24923              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24924              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
24925 !  The weights of the energy function calculated from
24926 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
24927              wh2o=78
24928              wdip1 = vcatnuclprm(1)
24929              wdip1 = wdip1/wh2o                     !w1
24930              wdip2 = vcatnuclprm(2)
24931              wdip2 = wdip2/wh2o                     !w2
24932              wvan1 = vcatnuclprm(3)
24933              wvan2 = vcatnuclprm(4)                 !pis1
24934              wgbsig = vcatnuclprm(5)                !sigma0
24935              wgbeps = vcatnuclprm(6)                !epsi0
24936              wgbchi = vcatnuclprm(7)                !chi1
24937              wgbchip = vcatnuclprm(8)               !chip1
24938              wcavsig = vcatnuclprm(9)               !sig
24939              wcav1 = vcatnuclprm(10)                !b1
24940              wcav2 = vcatnuclprm(11)                !b2
24941              wcav3 = vcatnuclprm(12)                !b3
24942              wcav4 = vcatnuclprm(13)                !b4
24943              wcavchi = vcatnuclprm(14)              !chis1
24944              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
24945              invrcs6 = 1/rcs2**3
24946              invrcs8 = invrcs6/rcs2
24947              invrcs12 = invrcs6**2
24948              invrcs14 = invrcs12/rcs2
24949              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
24950              rcb = sqrt(rcb2)
24951              invrcb = 1/rcb
24952              invrcb2 = invrcb**2
24953              invrcb4 = invrcb2**2
24954              invrcb6 = invrcb4*invrcb2
24955              cosinus = v1dpdx/(v1m*rcb)
24956              cos2 = cosinus**2
24957              dcosdcatconst = invrcb2/v1m
24958              dcosdcalpconst = invrcb/v1m**2
24959              dcosdcmconst = invrcb2/v1m**2
24960              do k=1,3
24961                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
24962                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
24963                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
24964                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
24965              enddo
24966              rcav = rcb/wcavsig
24967              rcav11 = rcav**11
24968              rcav12 = rcav11*rcav
24969              constcav1 = 1-wcavchi*cos2
24970              constcav2 = sqrt(constcav1)
24971              constgb1 = 1/sqrt(1-wgbchi*cos2)
24972              constgb2 = wgbeps*(1-wgbchip*cos2)**2
24973              constdvan1 = 12*wvan1*wvan2**12*invrcs14
24974              constdvan2 = 6*wvan1*wvan2**6*invrcs8
24975 !----------------------------------------------------------------------------
24976 !Gay-Berne term
24977 !---------------------------------------------------------------------------
24978              sgb = 1/(1-constgb1+(rcb/wgbsig))
24979              sgb6 = sgb**6
24980              sgb7 = sgb6*sgb
24981              sgb12 = sgb6**2
24982              sgb13 = sgb12*sgb
24983              Egb = constgb2*(sgb12-sgb6)
24984              do k=1,3
24985                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
24986                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
24987      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
24988                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
24989                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
24990      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
24991                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
24992                                *(12*sgb13-6*sgb7) &
24993      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
24994              enddo
24995 !----------------------------------------------------------------------------
24996 !cavity term
24997 !---------------------------------------------------------------------------
24998              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
24999              cavdenom = 1+wcav4*rcav12*constcav1**6
25000              Ecav = wcav1*cavnum/cavdenom
25001              invcavdenom2 = 1/cavdenom**2
25002              dcavnumdcos = -wcavchi*cosinus/constcav2 &
25003                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
25004              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
25005              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
25006              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
25007              do k=1,3
25008                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
25009      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
25010                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
25011      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
25012                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
25013                              *dcosdcalp(k)*wcav1*invcavdenom2
25014              enddo
25015 !----------------------------------------------------------------------------
25016 !van der Waals and dipole-charge interaction energy
25017 !---------------------------------------------------------------------------
25018              Evan1 = wvan1*wvan2**12*invrcs12
25019              do k=1,3
25020                 dEvan1Cat(k) = -v2(k)*constdvan1
25021                 dEvan1Cm(k) = 0.0d0
25022                 dEvan1Calp(k) = v2(k)*constdvan1
25023              enddo
25024              Evan2 = -wvan1*wvan2**6*invrcs6
25025              do k=1,3
25026                 dEvan2Cat(k) = v2(k)*constdvan2
25027                 dEvan2Cm(k) = 0.0d0
25028                 dEvan2Calp(k) = -v2(k)*constdvan2
25029              enddo
25030              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
25031              do k=1,3
25032                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
25033                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
25034                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
25035                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
25036                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
25037                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
25038                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
25039                                   +2*wdip2*cosinus*invrcb4)
25040              enddo
25041              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
25042          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
25043              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
25044              do k=1,3
25045                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
25046                                              +dEgbdCat(k)+dEdipCat(k)
25047                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
25048                                            +dEgbdCm(k)+dEdipCm(k)
25049                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
25050                                              +dEdipCalp(k)+dEvan2Calp(k)
25051              enddo
25052              do k=1,3
25053                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
25054                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
25055                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
25056                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
25057              enddo
25058           enddo !j
25059        enddo !i
25060        return
25061        end subroutine ecat_nucl
25062
25063 !-----------------------------------------------------------------------------
25064 !-----------------------------------------------------------------------------
25065       subroutine eprot_sc_base(escbase)
25066       use calc_data
25067 !      implicit real(kind=8) (a-h,o-z)
25068 !      include 'DIMENSIONS'
25069 !      include 'COMMON.GEO'
25070 !      include 'COMMON.VAR'
25071 !      include 'COMMON.LOCAL'
25072 !      include 'COMMON.CHAIN'
25073 !      include 'COMMON.DERIV'
25074 !      include 'COMMON.NAMES'
25075 !      include 'COMMON.INTERACT'
25076 !      include 'COMMON.IOUNITS'
25077 !      include 'COMMON.CALC'
25078 !      include 'COMMON.CONTROL'
25079 !      include 'COMMON.SBRIDGE'
25080       logical :: lprn
25081 !el local variables
25082       integer :: iint,itypi,itypi1,itypj,subchap
25083       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25084       real(kind=8) :: evdw,sig0ij
25085       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25086                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25087                 sslipi,sslipj,faclip
25088       integer :: ii
25089       real(kind=8) :: fracinbuf
25090        real (kind=8) :: escbase
25091        real (kind=8),dimension(4):: ener
25092        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25093        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25094       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
25095       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25096       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
25097       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25098       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25099       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
25100        real(kind=8),dimension(3,2)::chead,erhead_tail
25101        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25102        integer troll
25103        eps_out=80.0d0
25104        escbase=0.0d0
25105 !       do i=1,nres_molec(1)
25106       do i=ibond_start,ibond_end
25107       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25108       itypi  = itype(i,1)
25109       dxi    = dc_norm(1,nres+i)
25110       dyi    = dc_norm(2,nres+i)
25111       dzi    = dc_norm(3,nres+i)
25112       dsci_inv = vbld_inv(i+nres)
25113       xi=c(1,nres+i)
25114       yi=c(2,nres+i)
25115       zi=c(3,nres+i)
25116       call to_box(xi,yi,zi)
25117       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25118        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
25119          itypj= itype(j,2)
25120          if (itype(j,2).eq.ntyp1_molec(2))cycle
25121          xj=c(1,j+nres)
25122          yj=c(2,j+nres)
25123          zj=c(3,j+nres)
25124       call to_box(xj,yj,zj)
25125 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25126 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25127 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25128 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25129 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25130       xj=boxshift(xj-xi,boxxsize)
25131       yj=boxshift(yj-yi,boxysize)
25132       zj=boxshift(zj-zi,boxzsize)
25133
25134         dxj = dc_norm( 1, nres+j )
25135         dyj = dc_norm( 2, nres+j )
25136         dzj = dc_norm( 3, nres+j )
25137 !          print *,i,j,itypi,itypj
25138         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
25139         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
25140 !          d1i=0.0d0
25141 !          d1j=0.0d0
25142 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25143 ! Gay-berne var's
25144         sig0ij = sigma_scbase( itypi,itypj )
25145         if (sig0ij.lt.0.2) print *,"KURWA",sig0ij,itypi,itypj
25146         chi1   = chi_scbase( itypi, itypj,1 )
25147         chi2   = chi_scbase( itypi, itypj,2 )
25148 !          chi1=0.0d0
25149 !          chi2=0.0d0
25150         chi12  = chi1 * chi2
25151         chip1  = chipp_scbase( itypi, itypj,1 )
25152         chip2  = chipp_scbase( itypi, itypj,2 )
25153 !          chip1=0.0d0
25154 !          chip2=0.0d0
25155         chip12 = chip1 * chip2
25156 ! not used by momo potential, but needed by sc_angular which is shared
25157 ! by all energy_potential subroutines
25158         alf1   = 0.0d0
25159         alf2   = 0.0d0
25160         alf12  = 0.0d0
25161         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
25162 !       a12sq = a12sq * a12sq
25163 ! charge of amino acid itypi is...
25164         chis1 = chis_scbase(itypi,itypj,1)
25165         chis2 = chis_scbase(itypi,itypj,2)
25166         chis12 = chis1 * chis2
25167         sig1 = sigmap1_scbase(itypi,itypj)
25168         sig2 = sigmap2_scbase(itypi,itypj)
25169 !       write (*,*) "sig1 = ", sig1
25170 !       write (*,*) "sig2 = ", sig2
25171 ! alpha factors from Fcav/Gcav
25172         b1 = alphasur_scbase(1,itypi,itypj)
25173 !          b1=0.0d0
25174         b2 = alphasur_scbase(2,itypi,itypj)
25175         b3 = alphasur_scbase(3,itypi,itypj)
25176         b4 = alphasur_scbase(4,itypi,itypj)
25177 ! used to determine whether we want to do quadrupole calculations
25178 ! used by Fgb
25179        eps_in = epsintab_scbase(itypi,itypj)
25180        if (eps_in.eq.0.0) eps_in=1.0
25181        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25182 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25183 !-------------------------------------------------------------------
25184 ! tail location and distance calculations
25185        DO k = 1,3
25186 ! location of polar head is computed by taking hydrophobic centre
25187 ! and moving by a d1 * dc_norm vector
25188 ! see unres publications for very informative images
25189       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
25190       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
25191 ! distance
25192 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25193 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25194       Rhead_distance(k) = chead(k,2) - chead(k,1)
25195        END DO
25196 ! pitagoras (root of sum of squares)
25197        Rhead = dsqrt( &
25198         (Rhead_distance(1)*Rhead_distance(1)) &
25199       + (Rhead_distance(2)*Rhead_distance(2)) &
25200       + (Rhead_distance(3)*Rhead_distance(3)))
25201 !-------------------------------------------------------------------
25202 ! zero everything that should be zero'ed
25203        evdwij = 0.0d0
25204        ECL = 0.0d0
25205        Elj = 0.0d0
25206        Equad = 0.0d0
25207        Epol = 0.0d0
25208        Fcav=0.0d0
25209        eheadtail = 0.0d0
25210        dGCLdOM1 = 0.0d0
25211        dGCLdOM2 = 0.0d0
25212        dGCLdOM12 = 0.0d0
25213        dPOLdOM1 = 0.0d0
25214        dPOLdOM2 = 0.0d0
25215         Fcav = 0.0d0
25216         dFdR = 0.0d0
25217         dCAVdOM1  = 0.0d0
25218         dCAVdOM2  = 0.0d0
25219         dCAVdOM12 = 0.0d0
25220         dscj_inv = vbld_inv(j+nres)
25221 !          print *,i,j,dscj_inv,dsci_inv
25222 ! rij holds 1/(distance of Calpha atoms)
25223         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25224         rij  = dsqrt(rrij)
25225 !----------------------------
25226         CALL sc_angular
25227 ! this should be in elgrad_init but om's are calculated by sc_angular
25228 ! which in turn is used by older potentials
25229 ! om = omega, sqom = om^2
25230         sqom1  = om1 * om1
25231         sqom2  = om2 * om2
25232         sqom12 = om12 * om12
25233
25234 ! now we calculate EGB - Gey-Berne
25235 ! It will be summed up in evdwij and saved in evdw
25236         sigsq     = 1.0D0  / sigsq
25237         sig       = sig0ij * dsqrt(sigsq)
25238 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25239         rij_shift = 1.0/rij - sig + sig0ij
25240         IF (rij_shift.le.0.0D0) THEN
25241          evdw = 1.0D20
25242          RETURN
25243         END IF
25244         sigder = -sig * sigsq
25245         rij_shift = 1.0D0 / rij_shift
25246         fac       = rij_shift**expon
25247         c1        = fac  * fac * aa_scbase(itypi,itypj)
25248 !          c1        = 0.0d0
25249         c2        = fac  * bb_scbase(itypi,itypj)
25250 !          c2        = 0.0d0
25251         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25252         eps2der   = eps3rt * evdwij
25253         eps3der   = eps2rt * evdwij
25254 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25255         evdwij    = eps2rt * eps3rt * evdwij
25256         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25257         fac    = -expon * (c1 + evdwij) * rij_shift
25258         sigder = fac * sigder
25259 !          fac    = rij * fac
25260 ! Calculate distance derivative
25261         gg(1) =  fac
25262         gg(2) =  fac
25263         gg(3) =  fac
25264 !          if (b2.gt.0.0) then
25265         fac = chis1 * sqom1 + chis2 * sqom2 &
25266         - 2.0d0 * chis12 * om1 * om2 * om12
25267 ! we will use pom later in Gcav, so dont mess with it!
25268         pom = 1.0d0 - chis1 * chis2 * sqom12
25269         Lambf = (1.0d0 - (fac / pom))
25270         Lambf = dsqrt(Lambf)
25271         sparrow=dsqrt(sig1**2.0d0 + sig2**2.0d0)
25272         if (b1.eq.0.0d0) sparrow=1.0d0
25273         sparrow = 1.0d0 / sparrow
25274 !        write (*,*) "sparrow = ", sparrow,sig1,sig2,b1
25275         Chif = 1.0d0/rij * sparrow
25276         ChiLambf = Chif * Lambf
25277         eagle = dsqrt(ChiLambf)
25278         bat = ChiLambf ** 11.0d0
25279         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25280         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25281         botsq = bot * bot
25282         Fcav = top / bot
25283 !          print *,i,j,Fcav
25284         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25285         dbot = 12.0d0 * b4 * bat * Lambf
25286         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25287 !       dFdR = 0.0d0
25288 !      write (*,*) "dFcav/dR = ", dFdR
25289         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25290         dbot = 12.0d0 * b4 * bat * Chif
25291         eagle = Lambf * pom
25292         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25293         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25294         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25295             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25296
25297         dFdL = ((dtop * bot - top * dbot) / botsq)
25298 !       dFdL = 0.0d0
25299         dCAVdOM1  = dFdL * ( dFdOM1 )
25300         dCAVdOM2  = dFdL * ( dFdOM2 )
25301         dCAVdOM12 = dFdL * ( dFdOM12 )
25302
25303         ertail(1) = xj*rij
25304         ertail(2) = yj*rij
25305         ertail(3) = zj*rij
25306 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
25307 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
25308 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
25309 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
25310 !           print *,"EOMY",eom1,eom2,eom12
25311 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25312 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25313 ! here dtail=0.0
25314 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25315 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25316        DO k = 1, 3
25317 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25318 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25319       pom = ertail(k)
25320 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25321       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
25322               - (( dFdR + gg(k) ) * pom)
25323 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25324 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25325 !     &             - ( dFdR * pom )
25326       pom = ertail(k)
25327 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25328       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
25329               + (( dFdR + gg(k) ) * pom)
25330 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25331 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25332 !c!     &             + ( dFdR * pom )
25333
25334       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
25335               - (( dFdR + gg(k) ) * ertail(k))
25336 !c!     &             - ( dFdR * ertail(k))
25337
25338       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
25339               + (( dFdR + gg(k) ) * ertail(k))
25340 !c!     &             + ( dFdR * ertail(k))
25341
25342       gg(k) = 0.0d0
25343 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25344 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25345       END DO
25346
25347 !          else
25348
25349 !          endif
25350 !Now dipole-dipole
25351        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
25352        w1 = wdipdip_scbase(1,itypi,itypj)
25353        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
25354        w3 = wdipdip_scbase(2,itypi,itypj)
25355 !c!-------------------------------------------------------------------
25356 !c! ECL
25357        fac = (om12 - 3.0d0 * om1 * om2)
25358        c1 = (w1 / (Rhead**3.0d0)) * fac
25359        c2 = (w2 / Rhead ** 6.0d0)  &
25360        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25361        c3= (w3/ Rhead ** 6.0d0)  &
25362        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25363        ECL = c1 - c2 + c3
25364 !c!       write (*,*) "w1 = ", w1
25365 !c!       write (*,*) "w2 = ", w2
25366 !c!       write (*,*) "om1 = ", om1
25367 !c!       write (*,*) "om2 = ", om2
25368 !c!       write (*,*) "om12 = ", om12
25369 !c!       write (*,*) "fac = ", fac
25370 !c!       write (*,*) "c1 = ", c1
25371 !c!       write (*,*) "c2 = ", c2
25372 !c!       write (*,*) "Ecl = ", Ecl
25373 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
25374 !c!       write (*,*) "c2_2 = ",
25375 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25376 !c!-------------------------------------------------------------------
25377 !c! dervative of ECL is GCL...
25378 !c! dECL/dr
25379        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25380        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25381        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25382        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
25383        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25384        dGCLdR = c1 - c2 + c3
25385 !c! dECL/dom1
25386        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25387        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25388        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25389        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
25390        dGCLdOM1 = c1 - c2 + c3
25391 !c! dECL/dom2
25392        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25393        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25394        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25395        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
25396        dGCLdOM2 = c1 - c2 + c3
25397 !c! dECL/dom12
25398        c1 = w1 / (Rhead ** 3.0d0)
25399        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25400        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
25401        dGCLdOM12 = c1 - c2 + c3
25402        DO k= 1, 3
25403       erhead(k) = Rhead_distance(k)/Rhead
25404        END DO
25405        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25406        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25407        facd1 = d1i * vbld_inv(i+nres)
25408        facd2 = d1j * vbld_inv(j+nres)
25409        DO k = 1, 3
25410
25411       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25412       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
25413               - dGCLdR * pom
25414       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25415       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
25416               + dGCLdR * pom
25417
25418       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
25419               - dGCLdR * erhead(k)
25420       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
25421               + dGCLdR * erhead(k)
25422        END DO
25423        endif
25424 !now charge with dipole eg. ARG-dG
25425        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
25426       alphapol1 = alphapol_scbase(itypi,itypj)
25427        w1        = wqdip_scbase(1,itypi,itypj)
25428        w2        = wqdip_scbase(2,itypi,itypj)
25429 !       w1=0.0d0
25430 !       w2=0.0d0
25431 !       pis       = sig0head_scbase(itypi,itypj)
25432 !       eps_head   = epshead_scbase(itypi,itypj)
25433 !c!-------------------------------------------------------------------
25434 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25435        R1 = 0.0d0
25436        DO k = 1, 3
25437 !c! Calculate head-to-tail distances tail is center of side-chain
25438       R1=R1+(c(k,j+nres)-chead(k,1))**2
25439        END DO
25440 !c! Pitagoras
25441        R1 = dsqrt(R1)
25442
25443 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25444 !c!     &        +dhead(1,1,itypi,itypj))**2))
25445 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25446 !c!     &        +dhead(2,1,itypi,itypj))**2))
25447
25448 !c!-------------------------------------------------------------------
25449 !c! ecl
25450        sparrow  = w1  *  om1
25451        hawk     = w2 *  (1.0d0 - sqom2)
25452        Ecl = sparrow / Rhead**2.0d0 &
25453          - hawk    / Rhead**4.0d0
25454 !c!-------------------------------------------------------------------
25455 !c! derivative of ecl is Gcl
25456 !c! dF/dr part
25457        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25458             + 4.0d0 * hawk    / Rhead**5.0d0
25459 !c! dF/dom1
25460        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25461 !c! dF/dom2
25462        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25463 !c--------------------------------------------------------------------
25464 !c Polarization energy
25465 !c Epol
25466        MomoFac1 = (1.0d0 - chi1 * sqom2)
25467        RR1  = R1 * R1 / MomoFac1
25468        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25469        fgb1 = sqrt( RR1 + a12sq * ee1)
25470 !       eps_inout_fac=0.0d0
25471        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25472 ! derivative of Epol is Gpol...
25473        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25474             / (fgb1 ** 5.0d0)
25475        dFGBdR1 = ( (R1 / MomoFac1) &
25476            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25477            / ( 2.0d0 * fgb1 )
25478        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25479              * (2.0d0 - 0.5d0 * ee1) ) &
25480              / (2.0d0 * fgb1)
25481        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25482 !       dPOLdR1 = 0.0d0
25483        dPOLdOM1 = 0.0d0
25484        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25485        DO k = 1, 3
25486       erhead(k) = Rhead_distance(k)/Rhead
25487       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
25488        END DO
25489
25490        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25491        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25492        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25493 !       bat=0.0d0
25494        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25495        facd1 = d1i * vbld_inv(i+nres)
25496        facd2 = d1j * vbld_inv(j+nres)
25497 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25498
25499        DO k = 1, 3
25500       hawk = (erhead_tail(k,1) + &
25501       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25502 !        facd1=0.0d0
25503 !        facd2=0.0d0
25504       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25505       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
25506                - dGCLdR * pom &
25507                - dPOLdR1 *  (erhead_tail(k,1))
25508 !     &             - dGLJdR * pom
25509
25510       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25511       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
25512                + dGCLdR * pom  &
25513                + dPOLdR1 * (erhead_tail(k,1))
25514 !     &             + dGLJdR * pom
25515
25516
25517       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
25518               - dGCLdR * erhead(k) &
25519               - dPOLdR1 * erhead_tail(k,1)
25520 !     &             - dGLJdR * erhead(k)
25521
25522       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
25523               + dGCLdR * erhead(k)  &
25524               + dPOLdR1 * erhead_tail(k,1)
25525 !     &             + dGLJdR * erhead(k)
25526
25527        END DO
25528        endif
25529 !       print *,i,j,evdwij,epol,Fcav,ECL
25530        escbase=escbase+evdwij+epol+Fcav+ECL
25531        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25532       "escbase:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escbase
25533        if (energy_dec) write (iout,*) "evdwij,", evdwij, 1.0/rij, sig, sig0ij
25534        call sc_grad_scbase
25535        enddo
25536       enddo
25537
25538       return
25539       end subroutine eprot_sc_base
25540       SUBROUTINE sc_grad_scbase
25541       use calc_data
25542
25543        real (kind=8) :: dcosom1(3),dcosom2(3)
25544        eom1  =    &
25545             eps2der * eps2rt_om1   &
25546           - 2.0D0 * alf1 * eps3der &
25547           + sigder * sigsq_om1     &
25548           + dCAVdOM1               &
25549           + dGCLdOM1               &
25550           + dPOLdOM1
25551
25552        eom2  =  &
25553             eps2der * eps2rt_om2   &
25554           + 2.0D0 * alf2 * eps3der &
25555           + sigder * sigsq_om2     &
25556           + dCAVdOM2               &
25557           + dGCLdOM2               &
25558           + dPOLdOM2
25559
25560        eom12 =    &
25561             evdwij  * eps1_om12     &
25562           + eps2der * eps2rt_om12   &
25563           - 2.0D0 * alf12 * eps3der &
25564           + sigder *sigsq_om12      &
25565           + dCAVdOM12               &
25566           + dGCLdOM12
25567
25568 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25569 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25570 !               gg(1),gg(2),"rozne"
25571        DO k = 1, 3
25572       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25573       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25574       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25575       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
25576              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25577              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25578       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
25579              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25580              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25581       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
25582       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
25583        END DO
25584
25585        RETURN
25586       END SUBROUTINE sc_grad_scbase
25587
25588
25589       subroutine epep_sc_base(epepbase)
25590       use calc_data
25591       logical :: lprn
25592 !el local variables
25593       integer :: iint,itypi,itypi1,itypj,subchap
25594       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25595       real(kind=8) :: evdw,sig0ij
25596       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25597                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25598                 sslipi,sslipj,faclip
25599       integer :: ii
25600       real(kind=8) :: fracinbuf
25601        real (kind=8) :: epepbase
25602        real (kind=8),dimension(4):: ener
25603        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25604        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25605       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
25606       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25607       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
25608       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25609       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25610       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
25611        real(kind=8),dimension(3,2)::chead,erhead_tail
25612        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25613        integer troll
25614        eps_out=80.0d0
25615        epepbase=0.0d0
25616 !       do i=1,nres_molec(1)-1
25617       do i=ibond_start,ibond_end
25618       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
25619 !C        itypi  = itype(i,1)
25620       dxi    = dc_norm(1,i)
25621       dyi    = dc_norm(2,i)
25622       dzi    = dc_norm(3,i)
25623 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
25624       dsci_inv = vbld_inv(i+1)/2.0
25625       xi=(c(1,i)+c(1,i+1))/2.0
25626       yi=(c(2,i)+c(2,i+1))/2.0
25627       zi=(c(3,i)+c(3,i+1))/2.0
25628         call to_box(xi,yi,zi)
25629        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
25630          itypj= itype(j,2)
25631          if (itype(j,2).eq.ntyp1_molec(2))cycle
25632          xj=c(1,j+nres)
25633          yj=c(2,j+nres)
25634          zj=c(3,j+nres)
25635                 call to_box(xj,yj,zj)
25636       xj=boxshift(xj-xi,boxxsize)
25637       yj=boxshift(yj-yi,boxysize)
25638       zj=boxshift(zj-zi,boxzsize)
25639         dist_init=xj**2+yj**2+zj**2
25640         dxj = dc_norm( 1, nres+j )
25641         dyj = dc_norm( 2, nres+j )
25642         dzj = dc_norm( 3, nres+j )
25643 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
25644 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
25645
25646 ! Gay-berne var's
25647         sig0ij = sigma_pepbase(itypj )
25648         chi1   = chi_pepbase(itypj,1 )
25649         chi2   = chi_pepbase(itypj,2 )
25650 !          chi1=0.0d0
25651 !          chi2=0.0d0
25652         chi12  = chi1 * chi2
25653         chip1  = chipp_pepbase(itypj,1 )
25654         chip2  = chipp_pepbase(itypj,2 )
25655 !          chip1=0.0d0
25656 !          chip2=0.0d0
25657         chip12 = chip1 * chip2
25658         chis1 = chis_pepbase(itypj,1)
25659         chis2 = chis_pepbase(itypj,2)
25660         chis12 = chis1 * chis2
25661         sig1 = sigmap1_pepbase(itypj)
25662         sig2 = sigmap2_pepbase(itypj)
25663 !       write (*,*) "sig1 = ", sig1
25664 !       write (*,*) "sig2 = ", sig2
25665        DO k = 1,3
25666 ! location of polar head is computed by taking hydrophobic centre
25667 ! and moving by a d1 * dc_norm vector
25668 ! see unres publications for very informative images
25669       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
25670 ! + d1i * dc_norm(k, i+nres)
25671       chead(k,2) = c(k, j+nres)
25672 ! + d1j * dc_norm(k, j+nres)
25673 ! distance
25674 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25675 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25676       Rhead_distance(k) = chead(k,2) - chead(k,1)
25677 !        print *,gvdwc_pepbase(k,i)
25678
25679        END DO
25680        Rhead = dsqrt( &
25681         (Rhead_distance(1)*Rhead_distance(1)) &
25682       + (Rhead_distance(2)*Rhead_distance(2)) &
25683       + (Rhead_distance(3)*Rhead_distance(3)))
25684
25685 ! alpha factors from Fcav/Gcav
25686         b1 = alphasur_pepbase(1,itypj)
25687 !          b1=0.0d0
25688         b2 = alphasur_pepbase(2,itypj)
25689         b3 = alphasur_pepbase(3,itypj)
25690         b4 = alphasur_pepbase(4,itypj)
25691         alf1   = 0.0d0
25692         alf2   = 0.0d0
25693         alf12  = 0.0d0
25694         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25695 !          print *,i,j,rrij
25696         rij  = dsqrt(rrij)
25697 !----------------------------
25698        evdwij = 0.0d0
25699        ECL = 0.0d0
25700        Elj = 0.0d0
25701        Equad = 0.0d0
25702        Epol = 0.0d0
25703        Fcav=0.0d0
25704        eheadtail = 0.0d0
25705        dGCLdOM1 = 0.0d0
25706        dGCLdOM2 = 0.0d0
25707        dGCLdOM12 = 0.0d0
25708        dPOLdOM1 = 0.0d0
25709        dPOLdOM2 = 0.0d0
25710         Fcav = 0.0d0
25711         dFdR = 0.0d0
25712         dCAVdOM1  = 0.0d0
25713         dCAVdOM2  = 0.0d0
25714         dCAVdOM12 = 0.0d0
25715         dscj_inv = vbld_inv(j+nres)
25716         CALL sc_angular
25717 ! this should be in elgrad_init but om's are calculated by sc_angular
25718 ! which in turn is used by older potentials
25719 ! om = omega, sqom = om^2
25720         sqom1  = om1 * om1
25721         sqom2  = om2 * om2
25722         sqom12 = om12 * om12
25723
25724 ! now we calculate EGB - Gey-Berne
25725 ! It will be summed up in evdwij and saved in evdw
25726         sigsq     = 1.0D0  / sigsq
25727         sig       = sig0ij * dsqrt(sigsq)
25728         rij_shift = 1.0/rij - sig + sig0ij
25729         IF (rij_shift.le.0.0D0) THEN
25730          evdw = 1.0D20
25731          RETURN
25732         END IF
25733         sigder = -sig * sigsq
25734         rij_shift = 1.0D0 / rij_shift
25735         fac       = rij_shift**expon
25736         c1        = fac  * fac * aa_pepbase(itypj)
25737 !          c1        = 0.0d0
25738         c2        = fac  * bb_pepbase(itypj)
25739 !          c2        = 0.0d0
25740         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25741         eps2der   = eps3rt * evdwij
25742         eps3der   = eps2rt * evdwij
25743 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25744         evdwij    = eps2rt * eps3rt * evdwij
25745         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25746         fac    = -expon * (c1 + evdwij) * rij_shift
25747         sigder = fac * sigder
25748 !          fac    = rij * fac
25749 ! Calculate distance derivative
25750         gg(1) =  fac
25751         gg(2) =  fac
25752         gg(3) =  fac
25753         fac = chis1 * sqom1 + chis2 * sqom2 &
25754         - 2.0d0 * chis12 * om1 * om2 * om12
25755 ! we will use pom later in Gcav, so dont mess with it!
25756         pom = 1.0d0 - chis1 * chis2 * sqom12
25757         Lambf = (1.0d0 - (fac / pom))
25758         Lambf = dsqrt(Lambf)
25759         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25760 !       write (*,*) "sparrow = ", sparrow
25761         Chif = 1.0d0/rij * sparrow
25762         ChiLambf = Chif * Lambf
25763         eagle = dsqrt(ChiLambf)
25764         bat = ChiLambf ** 11.0d0
25765         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25766         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25767         botsq = bot * bot
25768         Fcav = top / bot
25769 !          print *,i,j,Fcav
25770         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25771         dbot = 12.0d0 * b4 * bat * Lambf
25772         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25773 !       dFdR = 0.0d0
25774 !      write (*,*) "dFcav/dR = ", dFdR
25775         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25776         dbot = 12.0d0 * b4 * bat * Chif
25777         eagle = Lambf * pom
25778         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25779         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25780         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25781             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25782
25783         dFdL = ((dtop * bot - top * dbot) / botsq)
25784 !       dFdL = 0.0d0
25785         dCAVdOM1  = dFdL * ( dFdOM1 )
25786         dCAVdOM2  = dFdL * ( dFdOM2 )
25787         dCAVdOM12 = dFdL * ( dFdOM12 )
25788
25789         ertail(1) = xj*rij
25790         ertail(2) = yj*rij
25791         ertail(3) = zj*rij
25792        DO k = 1, 3
25793 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25794 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25795       pom = ertail(k)
25796 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25797       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25798               - (( dFdR + gg(k) ) * pom)/2.0
25799 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
25800 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25801 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25802 !     &             - ( dFdR * pom )
25803       pom = ertail(k)
25804 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25805       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25806               + (( dFdR + gg(k) ) * pom)
25807 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25808 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25809 !c!     &             + ( dFdR * pom )
25810
25811       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25812               - (( dFdR + gg(k) ) * ertail(k))/2.0
25813 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
25814
25815 !c!     &             - ( dFdR * ertail(k))
25816
25817       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25818               + (( dFdR + gg(k) ) * ertail(k))
25819 !c!     &             + ( dFdR * ertail(k))
25820
25821       gg(k) = 0.0d0
25822 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25823 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25824       END DO
25825
25826
25827        w1 = wdipdip_pepbase(1,itypj)
25828        w2 = -wdipdip_pepbase(3,itypj)/2.0
25829        w3 = wdipdip_pepbase(2,itypj)
25830 !       w1=0.0d0
25831 !       w2=0.0d0
25832 !c!-------------------------------------------------------------------
25833 !c! ECL
25834 !       w3=0.0d0
25835        fac = (om12 - 3.0d0 * om1 * om2)
25836        c1 = (w1 / (Rhead**3.0d0)) * fac
25837        c2 = (w2 / Rhead ** 6.0d0)  &
25838        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25839        c3= (w3/ Rhead ** 6.0d0)  &
25840        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25841
25842        ECL = c1 - c2 + c3
25843
25844        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25845        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25846        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25847        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
25848        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25849
25850        dGCLdR = c1 - c2 + c3
25851 !c! dECL/dom1
25852        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25853        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25854        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25855        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
25856        dGCLdOM1 = c1 - c2 + c3
25857 !c! dECL/dom2
25858        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25859        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25860        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25861        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
25862
25863        dGCLdOM2 = c1 - c2 + c3
25864 !c! dECL/dom12
25865        c1 = w1 / (Rhead ** 3.0d0)
25866        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25867        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
25868        dGCLdOM12 = c1 - c2 + c3
25869        DO k= 1, 3
25870       erhead(k) = Rhead_distance(k)/Rhead
25871        END DO
25872        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25873        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25874 !       facd1 = d1 * vbld_inv(i+nres)
25875 !       facd2 = d2 * vbld_inv(j+nres)
25876        DO k = 1, 3
25877
25878 !        pom = erhead(k)
25879 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25880 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
25881 !                  - dGCLdR * pom
25882       pom = erhead(k)
25883 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25884       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25885               + dGCLdR * pom
25886
25887       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25888               - dGCLdR * erhead(k)/2.0d0
25889 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25890       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25891               - dGCLdR * erhead(k)/2.0d0
25892 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25893       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25894               + dGCLdR * erhead(k)
25895        END DO
25896 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
25897        epepbase=epepbase+evdwij+Fcav+ECL
25898        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25899       "epepbase:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,epepbase
25900        call sc_grad_pepbase
25901        enddo
25902        enddo
25903       END SUBROUTINE epep_sc_base
25904       SUBROUTINE sc_grad_pepbase
25905       use calc_data
25906
25907        real (kind=8) :: dcosom1(3),dcosom2(3)
25908        eom1  =    &
25909             eps2der * eps2rt_om1   &
25910           - 2.0D0 * alf1 * eps3der &
25911           + sigder * sigsq_om1     &
25912           + dCAVdOM1               &
25913           + dGCLdOM1               &
25914           + dPOLdOM1
25915
25916        eom2  =  &
25917             eps2der * eps2rt_om2   &
25918           + 2.0D0 * alf2 * eps3der &
25919           + sigder * sigsq_om2     &
25920           + dCAVdOM2               &
25921           + dGCLdOM2               &
25922           + dPOLdOM2
25923
25924        eom12 =    &
25925             evdwij  * eps1_om12     &
25926           + eps2der * eps2rt_om12   &
25927           - 2.0D0 * alf12 * eps3der &
25928           + sigder *sigsq_om12      &
25929           + dCAVdOM12               &
25930           + dGCLdOM12
25931 !        om12=0.0
25932 !        eom12=0.0
25933 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25934 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
25935 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25936 !                 *dsci_inv*2.0
25937 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25938 !               gg(1),gg(2),"rozne"
25939        DO k = 1, 3
25940       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
25941       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25942       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25943       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
25944              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25945              *dsci_inv*2.0 &
25946              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25947       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
25948              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
25949              *dsci_inv*2.0 &
25950              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25951 !         print *,eom12,eom2,om12,om2
25952 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25953 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25954       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
25955              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25956              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25957       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
25958        END DO
25959        RETURN
25960       END SUBROUTINE sc_grad_pepbase
25961       subroutine eprot_sc_phosphate(escpho)
25962       use calc_data
25963 !      implicit real(kind=8) (a-h,o-z)
25964 !      include 'DIMENSIONS'
25965 !      include 'COMMON.GEO'
25966 !      include 'COMMON.VAR'
25967 !      include 'COMMON.LOCAL'
25968 !      include 'COMMON.CHAIN'
25969 !      include 'COMMON.DERIV'
25970 !      include 'COMMON.NAMES'
25971 !      include 'COMMON.INTERACT'
25972 !      include 'COMMON.IOUNITS'
25973 !      include 'COMMON.CALC'
25974 !      include 'COMMON.CONTROL'
25975 !      include 'COMMON.SBRIDGE'
25976       logical :: lprn
25977 !el local variables
25978       integer :: iint,itypi,itypi1,itypj,subchap
25979       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25980       real(kind=8) :: evdw,sig0ij,aa,bb
25981       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25982                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25983                 sslipi,sslipj,faclip,alpha_sco
25984       integer :: ii
25985       real(kind=8) :: fracinbuf
25986        real (kind=8) :: escpho
25987        real (kind=8),dimension(4):: ener
25988        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25989        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25990       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25991       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25992       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25993       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25994       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25995       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25996        real(kind=8),dimension(3,2)::chead,erhead_tail
25997        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25998        integer troll
25999        eps_out=80.0d0
26000        escpho=0.0d0
26001 !       do i=1,nres_molec(1)
26002       do i=ibond_start,ibond_end
26003       if (itype(i,1).eq.ntyp1_molec(1)) cycle
26004       itypi  = itype(i,1)
26005       dxi    = dc_norm(1,nres+i)
26006       dyi    = dc_norm(2,nres+i)
26007       dzi    = dc_norm(3,nres+i)
26008       dsci_inv = vbld_inv(i+nres)
26009       xi=c(1,nres+i)
26010       yi=c(2,nres+i)
26011       zi=c(3,nres+i)
26012        call to_box(xi,yi,zi)
26013       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
26014        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
26015          itypj= itype(j,2)
26016          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
26017           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
26018          xj=(c(1,j)+c(1,j+1))/2.0
26019          yj=(c(2,j)+c(2,j+1))/2.0
26020          zj=(c(3,j)+c(3,j+1))/2.0
26021      call to_box(xj,yj,zj)
26022 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
26023 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26024 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26025 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26026 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26027       xj=boxshift(xj-xi,boxxsize)
26028       yj=boxshift(yj-yi,boxysize)
26029       zj=boxshift(zj-zi,boxzsize)
26030           dxj = dc_norm( 1,j )
26031         dyj = dc_norm( 2,j )
26032         dzj = dc_norm( 3,j )
26033         dscj_inv = vbld_inv(j+1)
26034
26035 ! Gay-berne var's
26036         sig0ij = sigma_scpho(itypi )
26037         chi1   = chi_scpho(itypi,1 )
26038         chi2   = chi_scpho(itypi,2 )
26039 !          chi1=0.0d0
26040 !          chi2=0.0d0
26041         chi12  = chi1 * chi2
26042         chip1  = chipp_scpho(itypi,1 )
26043         chip2  = chipp_scpho(itypi,2 )
26044 !          chip1=0.0d0
26045 !          chip2=0.0d0
26046         chip12 = chip1 * chip2
26047         chis1 = chis_scpho(itypi,1)
26048         chis2 = chis_scpho(itypi,2)
26049         chis12 = chis1 * chis2
26050         sig1 = sigmap1_scpho(itypi)
26051         sig2 = sigmap2_scpho(itypi)
26052 !       write (*,*) "sig1 = ", sig1
26053 !       write (*,*) "sig1 = ", sig1
26054 !       write (*,*) "sig2 = ", sig2
26055 ! alpha factors from Fcav/Gcav
26056         alf1   = 0.0d0
26057         alf2   = 0.0d0
26058         alf12  = 0.0d0
26059         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
26060
26061         b1 = alphasur_scpho(1,itypi)
26062 !          b1=0.0d0
26063         b2 = alphasur_scpho(2,itypi)
26064         b3 = alphasur_scpho(3,itypi)
26065         b4 = alphasur_scpho(4,itypi)
26066 ! used to determine whether we want to do quadrupole calculations
26067 ! used by Fgb
26068        eps_in = epsintab_scpho(itypi)
26069        if (eps_in.eq.0.0) eps_in=1.0
26070        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26071 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26072 !-------------------------------------------------------------------
26073 ! tail location and distance calculations
26074         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
26075         d1j = 0.0
26076        DO k = 1,3
26077 ! location of polar head is computed by taking hydrophobic centre
26078 ! and moving by a d1 * dc_norm vector
26079 ! see unres publications for very informative images
26080       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
26081       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
26082 ! distance
26083 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26084 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26085       Rhead_distance(k) = chead(k,2) - chead(k,1)
26086        END DO
26087 ! pitagoras (root of sum of squares)
26088        Rhead = dsqrt( &
26089         (Rhead_distance(1)*Rhead_distance(1)) &
26090       + (Rhead_distance(2)*Rhead_distance(2)) &
26091       + (Rhead_distance(3)*Rhead_distance(3)))
26092        Rhead_sq=Rhead**2.0
26093 !-------------------------------------------------------------------
26094 ! zero everything that should be zero'ed
26095        evdwij = 0.0d0
26096        ECL = 0.0d0
26097        Elj = 0.0d0
26098        Equad = 0.0d0
26099        Epol = 0.0d0
26100        Fcav=0.0d0
26101        eheadtail = 0.0d0
26102        dGCLdR=0.0d0
26103        dGCLdOM1 = 0.0d0
26104        dGCLdOM2 = 0.0d0
26105        dGCLdOM12 = 0.0d0
26106        dPOLdOM1 = 0.0d0
26107        dPOLdOM2 = 0.0d0
26108         Fcav = 0.0d0
26109         dFdR = 0.0d0
26110         dCAVdOM1  = 0.0d0
26111         dCAVdOM2  = 0.0d0
26112         dCAVdOM12 = 0.0d0
26113         dscj_inv = vbld_inv(j+1)/2.0
26114 !dhead_scbasej(itypi,itypj)
26115 !          print *,i,j,dscj_inv,dsci_inv
26116 ! rij holds 1/(distance of Calpha atoms)
26117         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26118         rij  = dsqrt(rrij)
26119 !----------------------------
26120         CALL sc_angular
26121 ! this should be in elgrad_init but om's are calculated by sc_angular
26122 ! which in turn is used by older potentials
26123 ! om = omega, sqom = om^2
26124         sqom1  = om1 * om1
26125         sqom2  = om2 * om2
26126         sqom12 = om12 * om12
26127
26128 ! now we calculate EGB - Gey-Berne
26129 ! It will be summed up in evdwij and saved in evdw
26130         sigsq     = 1.0D0  / sigsq
26131         sig       = sig0ij * dsqrt(sigsq)
26132 !          rij_shift = 1.0D0  / rij - sig + sig0ij
26133         rij_shift = 1.0/rij - sig + sig0ij
26134         IF (rij_shift.le.0.0D0) THEN
26135          evdw = 1.0D20
26136          RETURN
26137         END IF
26138         sigder = -sig * sigsq
26139         rij_shift = 1.0D0 / rij_shift
26140         fac       = rij_shift**expon
26141         c1        = fac  * fac * aa_scpho(itypi)
26142 !          c1        = 0.0d0
26143         c2        = fac  * bb_scpho(itypi)
26144 !          c2        = 0.0d0
26145         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
26146         eps2der   = eps3rt * evdwij
26147         eps3der   = eps2rt * evdwij
26148 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
26149         evdwij    = eps2rt * eps3rt * evdwij
26150         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
26151         fac    = -expon * (c1 + evdwij) * rij_shift
26152         sigder = fac * sigder
26153 !          fac    = rij * fac
26154 ! Calculate distance derivative
26155         gg(1) =  fac
26156         gg(2) =  fac
26157         gg(3) =  fac
26158         fac = chis1 * sqom1 + chis2 * sqom2 &
26159         - 2.0d0 * chis12 * om1 * om2 * om12
26160 ! we will use pom later in Gcav, so dont mess with it!
26161         pom = 1.0d0 - chis1 * chis2 * sqom12
26162         Lambf = (1.0d0 - (fac / pom))
26163         Lambf = dsqrt(Lambf)
26164         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
26165 !       write (*,*) "sparrow = ", sparrow
26166         Chif = 1.0d0/rij * sparrow
26167         ChiLambf = Chif * Lambf
26168         eagle = dsqrt(ChiLambf)
26169         bat = ChiLambf ** 11.0d0
26170         top = b1 * ( eagle + b2 * ChiLambf - b3 )
26171         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
26172         botsq = bot * bot
26173         Fcav = top / bot
26174         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
26175         dbot = 12.0d0 * b4 * bat * Lambf
26176         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
26177 !       dFdR = 0.0d0
26178 !      write (*,*) "dFcav/dR = ", dFdR
26179         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
26180         dbot = 12.0d0 * b4 * bat * Chif
26181         eagle = Lambf * pom
26182         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
26183         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
26184         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
26185             * (chis2 * om2 * om12 - om1) / (eagle * pom)
26186
26187         dFdL = ((dtop * bot - top * dbot) / botsq)
26188 !       dFdL = 0.0d0
26189         dCAVdOM1  = dFdL * ( dFdOM1 )
26190         dCAVdOM2  = dFdL * ( dFdOM2 )
26191         dCAVdOM12 = dFdL * ( dFdOM12 )
26192
26193         ertail(1) = xj*rij
26194         ertail(2) = yj*rij
26195         ertail(3) = zj*rij
26196        DO k = 1, 3
26197 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26198 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26199 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
26200
26201       pom = ertail(k)
26202 !        print *,pom,gg(k),dFdR
26203 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
26204       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
26205               - (( dFdR + gg(k) ) * pom)
26206 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
26207 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26208 !     &             - ( dFdR * pom )
26209 !        pom = ertail(k)
26210 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
26211 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
26212 !                  + (( dFdR + gg(k) ) * pom)
26213 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26214 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26215 !c!     &             + ( dFdR * pom )
26216
26217       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
26218               - (( dFdR + gg(k) ) * ertail(k))
26219 !c!     &             - ( dFdR * ertail(k))
26220
26221       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
26222               + (( dFdR + gg(k) ) * ertail(k))/2.0
26223
26224       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
26225               + (( dFdR + gg(k) ) * ertail(k))/2.0
26226
26227 !c!     &             + ( dFdR * ertail(k))
26228
26229       gg(k) = 0.0d0
26230       ENDDO
26231 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26232 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26233 !      alphapol1 = alphapol_scpho(itypi)
26234        if (wqq_scpho(itypi).ne.0.0) then
26235        Qij=wqq_scpho(itypi)/eps_in
26236        alpha_sco=1.d0/alphi_scpho(itypi)
26237 !       Qij=0.0
26238        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
26239 !c! derivative of Ecl is Gcl...
26240        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
26241             (Rhead*alpha_sco+1) ) / Rhead_sq
26242        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
26243        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
26244        w1        = wqdip_scpho(1,itypi)
26245        w2        = wqdip_scpho(2,itypi)
26246 !       w1=0.0d0
26247 !       w2=0.0d0
26248 !       pis       = sig0head_scbase(itypi,itypj)
26249 !       eps_head   = epshead_scbase(itypi,itypj)
26250 !c!-------------------------------------------------------------------
26251
26252 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26253 !c!     &        +dhead(1,1,itypi,itypj))**2))
26254 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26255 !c!     &        +dhead(2,1,itypi,itypj))**2))
26256
26257 !c!-------------------------------------------------------------------
26258 !c! ecl
26259        sparrow  = w1  *  om1
26260        hawk     = w2 *  (1.0d0 - sqom2)
26261        Ecl = sparrow / Rhead**2.0d0 &
26262          - hawk    / Rhead**4.0d0
26263 !c!-------------------------------------------------------------------
26264        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
26265          1.0/rij,sparrow
26266
26267 !c! derivative of ecl is Gcl
26268 !c! dF/dr part
26269        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26270             + 4.0d0 * hawk    / Rhead**5.0d0
26271 !c! dF/dom1
26272        dGCLdOM1 = (w1) / (Rhead**2.0d0)
26273 !c! dF/dom2
26274        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
26275        endif
26276
26277 !c--------------------------------------------------------------------
26278 !c Polarization energy
26279 !c Epol
26280        R1 = 0.0d0
26281        DO k = 1, 3
26282 !c! Calculate head-to-tail distances tail is center of side-chain
26283       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
26284        END DO
26285 !c! Pitagoras
26286        R1 = dsqrt(R1)
26287
26288       alphapol1 = alphapol_scpho(itypi)
26289 !      alphapol1=0.0
26290        MomoFac1 = (1.0d0 - chi2 * sqom1)
26291        RR1  = R1 * R1 / MomoFac1
26292        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26293 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
26294        fgb1 = sqrt( RR1 + a12sq * ee1)
26295 !       eps_inout_fac=0.0d0
26296        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26297 ! derivative of Epol is Gpol...
26298        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26299             / (fgb1 ** 5.0d0)
26300        dFGBdR1 = ( (R1 / MomoFac1) &
26301            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26302            / ( 2.0d0 * fgb1 )
26303        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26304              * (2.0d0 - 0.5d0 * ee1) ) &
26305              / (2.0d0 * fgb1)
26306        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26307 !       dPOLdR1 = 0.0d0
26308 !       dPOLdOM1 = 0.0d0
26309        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
26310              * (2.0d0 - 0.5d0 * ee1) ) &
26311              / (2.0d0 * fgb1)
26312
26313        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
26314        dPOLdOM2 = 0.0
26315        DO k = 1, 3
26316       erhead(k) = Rhead_distance(k)/Rhead
26317       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
26318        END DO
26319
26320        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26321        erdxj = scalar( erhead(1), dC_norm(1,j) )
26322        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26323 !       bat=0.0d0
26324        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26325        facd1 = d1i * vbld_inv(i+nres)
26326        facd2 = d1j * vbld_inv(j)
26327 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26328
26329        DO k = 1, 3
26330       hawk = (erhead_tail(k,1) + &
26331       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26332 !        facd1=0.0d0
26333 !        facd2=0.0d0
26334 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
26335 !                pom,(erhead_tail(k,1))
26336
26337 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
26338       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26339       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
26340                - dGCLdR * pom &
26341                - dPOLdR1 *  (erhead_tail(k,1))
26342 !     &             - dGLJdR * pom
26343
26344       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26345 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
26346 !                   + dGCLdR * pom  &
26347 !                   + dPOLdR1 * (erhead_tail(k,1))
26348 !     &             + dGLJdR * pom
26349
26350
26351       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
26352               - dGCLdR * erhead(k) &
26353               - dPOLdR1 * erhead_tail(k,1)
26354 !     &             - dGLJdR * erhead(k)
26355
26356       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
26357               + (dGCLdR * erhead(k)  &
26358               + dPOLdR1 * erhead_tail(k,1))/2.0
26359       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
26360               + (dGCLdR * erhead(k)  &
26361               + dPOLdR1 * erhead_tail(k,1))/2.0
26362
26363 !     &             + dGLJdR * erhead(k)
26364 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
26365
26366        END DO
26367 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
26368        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
26369       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
26370        escpho=escpho+evdwij+epol+Fcav+ECL
26371        call sc_grad_scpho
26372        enddo
26373
26374       enddo
26375
26376       return
26377       end subroutine eprot_sc_phosphate
26378       SUBROUTINE sc_grad_scpho
26379       use calc_data
26380
26381        real (kind=8) :: dcosom1(3),dcosom2(3)
26382        eom1  =    &
26383             eps2der * eps2rt_om1   &
26384           - 2.0D0 * alf1 * eps3der &
26385           + sigder * sigsq_om1     &
26386           + dCAVdOM1               &
26387           + dGCLdOM1               &
26388           + dPOLdOM1
26389
26390        eom2  =  &
26391             eps2der * eps2rt_om2   &
26392           + 2.0D0 * alf2 * eps3der &
26393           + sigder * sigsq_om2     &
26394           + dCAVdOM2               &
26395           + dGCLdOM2               &
26396           + dPOLdOM2
26397
26398        eom12 =    &
26399             evdwij  * eps1_om12     &
26400           + eps2der * eps2rt_om12   &
26401           - 2.0D0 * alf12 * eps3der &
26402           + sigder *sigsq_om12      &
26403           + dCAVdOM12               &
26404           + dGCLdOM12
26405 !        om12=0.0
26406 !        eom12=0.0
26407 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
26408 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
26409 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
26410 !                 *dsci_inv*2.0
26411 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
26412 !               gg(1),gg(2),"rozne"
26413        DO k = 1, 3
26414       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26415       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
26416       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26417       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
26418              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
26419              *dscj_inv*2.0 &
26420              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26421       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
26422              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
26423              *dscj_inv*2.0 &
26424              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26425       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
26426              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
26427              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26428
26429 !         print *,eom12,eom2,om12,om2
26430 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
26431 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
26432 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
26433 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
26434 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26435       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
26436        END DO
26437        RETURN
26438       END SUBROUTINE sc_grad_scpho
26439       subroutine eprot_pep_phosphate(epeppho)
26440       use calc_data
26441 !      implicit real(kind=8) (a-h,o-z)
26442 !      include 'DIMENSIONS'
26443 !      include 'COMMON.GEO'
26444 !      include 'COMMON.VAR'
26445 !      include 'COMMON.LOCAL'
26446 !      include 'COMMON.CHAIN'
26447 !      include 'COMMON.DERIV'
26448 !      include 'COMMON.NAMES'
26449 !      include 'COMMON.INTERACT'
26450 !      include 'COMMON.IOUNITS'
26451 !      include 'COMMON.CALC'
26452 !      include 'COMMON.CONTROL'
26453 !      include 'COMMON.SBRIDGE'
26454       logical :: lprn
26455 !el local variables
26456       integer :: iint,itypi,itypi1,itypj,subchap
26457       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
26458       real(kind=8) :: evdw,sig0ij
26459       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26460                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
26461                 sslipi,sslipj,faclip
26462       integer :: ii
26463       real(kind=8) :: fracinbuf
26464        real (kind=8) :: epeppho
26465        real (kind=8),dimension(4):: ener
26466        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
26467        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
26468       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
26469       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
26470       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
26471       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
26472       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
26473       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
26474        real(kind=8),dimension(3,2)::chead,erhead_tail
26475        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
26476        integer troll
26477        real (kind=8) :: dcosom1(3),dcosom2(3)
26478        epeppho=0.0d0
26479 !       do i=1,nres_molec(1)
26480       do i=ibond_start,ibond_end
26481       if (itype(i,1).eq.ntyp1_molec(1)) cycle
26482       itypi  = itype(i,1)
26483       dsci_inv = vbld_inv(i+1)/2.0
26484       dxi    = dc_norm(1,i)
26485       dyi    = dc_norm(2,i)
26486       dzi    = dc_norm(3,i)
26487       xi=(c(1,i)+c(1,i+1))/2.0
26488       yi=(c(2,i)+c(2,i+1))/2.0
26489       zi=(c(3,i)+c(3,i+1))/2.0
26490                call to_box(xi,yi,zi)
26491
26492         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
26493          itypj= itype(j,2)
26494          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
26495           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
26496          xj=(c(1,j)+c(1,j+1))/2.0
26497          yj=(c(2,j)+c(2,j+1))/2.0
26498          zj=(c(3,j)+c(3,j+1))/2.0
26499                 call to_box(xj,yj,zj)
26500       xj=boxshift(xj-xi,boxxsize)
26501       yj=boxshift(yj-yi,boxysize)
26502       zj=boxshift(zj-zi,boxzsize)
26503
26504         dist_init=xj**2+yj**2+zj**2
26505         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26506         rij  = dsqrt(rrij)
26507         dxj = dc_norm( 1,j )
26508         dyj = dc_norm( 2,j )
26509         dzj = dc_norm( 3,j )
26510         dscj_inv = vbld_inv(j+1)/2.0
26511 ! Gay-berne var's
26512         sig0ij = sigma_peppho
26513 !          chi1=0.0d0
26514 !          chi2=0.0d0
26515         chi12  = chi1 * chi2
26516 !          chip1=0.0d0
26517 !          chip2=0.0d0
26518         chip12 = chip1 * chip2
26519 !          chis1 = 0.0d0
26520 !          chis2 = 0.0d0
26521         chis12 = chis1 * chis2
26522         sig1 = sigmap1_peppho
26523         sig2 = sigmap2_peppho
26524 !       write (*,*) "sig1 = ", sig1
26525 !       write (*,*) "sig1 = ", sig1
26526 !       write (*,*) "sig2 = ", sig2
26527 ! alpha factors from Fcav/Gcav
26528         alf1   = 0.0d0
26529         alf2   = 0.0d0
26530         alf12  = 0.0d0
26531         b1 = alphasur_peppho(1)
26532 !          b1=0.0d0
26533         b2 = alphasur_peppho(2)
26534         b3 = alphasur_peppho(3)
26535         b4 = alphasur_peppho(4)
26536         CALL sc_angular
26537        sqom1=om1*om1
26538        evdwij = 0.0d0
26539        ECL = 0.0d0
26540        Elj = 0.0d0
26541        Equad = 0.0d0
26542        Epol = 0.0d0
26543        Fcav=0.0d0
26544        eheadtail = 0.0d0
26545        dGCLdR=0.0d0
26546        dGCLdOM1 = 0.0d0
26547        dGCLdOM2 = 0.0d0
26548        dGCLdOM12 = 0.0d0
26549        dPOLdOM1 = 0.0d0
26550        dPOLdOM2 = 0.0d0
26551         Fcav = 0.0d0
26552         dFdR = 0.0d0
26553         dCAVdOM1  = 0.0d0
26554         dCAVdOM2  = 0.0d0
26555         dCAVdOM12 = 0.0d0
26556         rij_shift = rij
26557         fac       = rij_shift**expon
26558         c1        = fac  * fac * aa_peppho
26559 !          c1        = 0.0d0
26560         c2        = fac  * bb_peppho
26561 !          c2        = 0.0d0
26562         evdwij    =  c1 + c2
26563 ! Now cavity....................
26564        eagle = dsqrt(1.0/rij_shift)
26565        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
26566         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
26567         botsq = bot * bot
26568         Fcav = top / bot
26569         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
26570         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
26571         dFdR = ((dtop * bot - top * dbot) / botsq)
26572        w1        = wqdip_peppho(1)
26573        w2        = wqdip_peppho(2)
26574 !       w1=0.0d0
26575 !       w2=0.0d0
26576 !       pis       = sig0head_scbase(itypi,itypj)
26577 !       eps_head   = epshead_scbase(itypi,itypj)
26578 !c!-------------------------------------------------------------------
26579
26580 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26581 !c!     &        +dhead(1,1,itypi,itypj))**2))
26582 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26583 !c!     &        +dhead(2,1,itypi,itypj))**2))
26584
26585 !c!-------------------------------------------------------------------
26586 !c! ecl
26587        sparrow  = w1  *  om1
26588        hawk     = w2 *  (1.0d0 - sqom1)
26589        Ecl = sparrow * rij_shift**2.0d0 &
26590          - hawk    * rij_shift**4.0d0
26591 !c!-------------------------------------------------------------------
26592 !c! derivative of ecl is Gcl
26593 !c! dF/dr part
26594 !       rij_shift=5.0
26595        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
26596             + 4.0d0 * hawk    * rij_shift**5.0d0
26597 !c! dF/dom1
26598        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
26599 !c! dF/dom2
26600        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
26601        eom1  =    dGCLdOM1+dGCLdOM2
26602        eom2  =    0.0
26603
26604         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
26605 !          fac=0.0
26606         gg(1) =  fac*xj*rij
26607         gg(2) =  fac*yj*rij
26608         gg(3) =  fac*zj*rij
26609        do k=1,3
26610        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
26611        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
26612        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
26613        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
26614        gg(k)=0.0
26615        enddo
26616
26617       DO k = 1, 3
26618       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
26619       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
26620       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
26621       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
26622 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26623       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
26624 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26625       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
26626              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26627       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
26628              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26629       enddo
26630        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
26631       "epeppho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,epeppho
26632
26633        epeppho=epeppho+evdwij+Fcav+ECL
26634 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
26635        enddo
26636        enddo
26637       end subroutine eprot_pep_phosphate
26638 !!!!!!!!!!!!!!!!-------------------------------------------------------------
26639       subroutine emomo(evdw)
26640       use calc_data
26641       use comm_momo
26642 !      implicit real(kind=8) (a-h,o-z)
26643 !      include 'DIMENSIONS'
26644 !      include 'COMMON.GEO'
26645 !      include 'COMMON.VAR'
26646 !      include 'COMMON.LOCAL'
26647 !      include 'COMMON.CHAIN'
26648 !      include 'COMMON.DERIV'
26649 !      include 'COMMON.NAMES'
26650 !      include 'COMMON.INTERACT'
26651 !      include 'COMMON.IOUNITS'
26652 !      include 'COMMON.CALC'
26653 !      include 'COMMON.CONTROL'
26654 !      include 'COMMON.SBRIDGE'
26655       logical :: lprn
26656 !el local variables
26657       integer :: iint,itypi1,subchap,isel
26658       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
26659       real(kind=8) :: evdw,aa,bb
26660       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26661                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
26662                 sslipi,sslipj,faclip,alpha_sco
26663       integer :: ii
26664       real(kind=8) :: fracinbuf
26665        real (kind=8) :: escpho
26666        real (kind=8),dimension(4):: ener
26667        real(kind=8) :: b1,b2,egb
26668        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
26669       Lambf,&
26670       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
26671       dFdOM2,dFdL,dFdOM12,&
26672       federmaus,&
26673       d1i,d1j
26674 !       real(kind=8),dimension(3,2)::erhead_tail
26675 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
26676        real(kind=8) ::  facd4, adler, Fgb, facd3
26677        integer troll,jj,istate
26678        real (kind=8) :: dcosom1(3),dcosom2(3)
26679        evdw=0.0d0
26680        eps_out=80.0d0
26681        sss_ele_cut=1.0d0
26682 !       print *,"EVDW KURW",evdw,nres
26683       do i=iatsc_s,iatsc_e
26684 !        print *,"I am in EVDW",i
26685       itypi=iabs(itype(i,1))
26686 !        if (i.ne.47) cycle
26687       if (itypi.eq.ntyp1) cycle
26688       itypi1=iabs(itype(i+1,1))
26689       xi=c(1,nres+i)
26690       yi=c(2,nres+i)
26691       zi=c(3,nres+i)
26692         call to_box(xi,yi,zi)
26693         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
26694 !       endif
26695 !       print *, sslipi,ssgradlipi
26696       dxi=dc_norm(1,nres+i)
26697       dyi=dc_norm(2,nres+i)
26698       dzi=dc_norm(3,nres+i)
26699 !        dsci_inv=dsc_inv(itypi)
26700       dsci_inv=vbld_inv(i+nres)
26701 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
26702 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
26703 !
26704 ! Calculate SC interaction energy.
26705 !
26706       do iint=1,nint_gr(i)
26707         do j=istart(i,iint),iend(i,iint)
26708 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
26709           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
26710             call dyn_ssbond_ene(i,j,evdwij)
26711             evdw=evdw+evdwij
26712             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26713                         'evdw',i,j,evdwij,' ss'
26714 !              if (energy_dec) write (iout,*) &
26715 !                              'evdw',i,j,evdwij,' ss'
26716            do k=j+1,iend(i,iint)
26717 !C search over all next residues
26718             if (dyn_ss_mask(k)) then
26719 !C check if they are cysteins
26720 !C              write(iout,*) 'k=',k
26721
26722 !c              write(iout,*) "PRZED TRI", evdwij
26723 !               evdwij_przed_tri=evdwij
26724             call triple_ssbond_ene(i,j,k,evdwij)
26725 !c               if(evdwij_przed_tri.ne.evdwij) then
26726 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
26727 !c               endif
26728
26729 !c              write(iout,*) "PO TRI", evdwij
26730 !C call the energy function that removes the artifical triple disulfide
26731 !C bond the soubroutine is located in ssMD.F
26732             evdw=evdw+evdwij
26733             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26734                       'evdw',i,j,evdwij,'tss'
26735             endif!dyn_ss_mask(k)
26736            enddo! k
26737           ELSE
26738 !el            ind=ind+1
26739           itypj=iabs(itype(j,1))
26740           if (itypj.eq.ntyp1) cycle
26741            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26742
26743 !             if (j.ne.78) cycle
26744 !            dscj_inv=dsc_inv(itypj)
26745           dscj_inv=vbld_inv(j+nres)
26746          xj=c(1,j+nres)
26747          yj=c(2,j+nres)
26748          zj=c(3,j+nres)
26749      call to_box(xj,yj,zj)
26750      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
26751 !      write(iout,*) "KRUWA", i,j
26752       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26753       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26754       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26755       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26756       xj=boxshift(xj-xi,boxxsize)
26757       yj=boxshift(yj-yi,boxysize)
26758       zj=boxshift(zj-zi,boxzsize)
26759         dxj = dc_norm( 1, nres+j )
26760         dyj = dc_norm( 2, nres+j )
26761         dzj = dc_norm( 3, nres+j )
26762 !          print *,i,j,itypi,itypj
26763 !          d1i=0.0d0
26764 !          d1j=0.0d0
26765 !          BetaT = 1.0d0 / (298.0d0 * Rb)
26766 ! Gay-berne var's
26767 !1!          sig0ij = sigma_scsc( itypi,itypj )
26768 !          chi1=0.0d0
26769 !          chi2=0.0d0
26770 !          chip1=0.0d0
26771 !          chip2=0.0d0
26772 ! not used by momo potential, but needed by sc_angular which is shared
26773 ! by all energy_potential subroutines
26774         alf1   = 0.0d0
26775         alf2   = 0.0d0
26776         alf12  = 0.0d0
26777         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26778 !       a12sq = a12sq * a12sq
26779 ! charge of amino acid itypi is...
26780         chis1 = chis(itypi,itypj)
26781         chis2 = chis(itypj,itypi)
26782         chis12 = chis1 * chis2
26783         sig1 = sigmap1(itypi,itypj)
26784         sig2 = sigmap2(itypi,itypj)
26785 !       write (*,*) "sig1 = ", sig1
26786 !          chis1=0.0
26787 !          chis2=0.0
26788 !                    chis12 = chis1 * chis2
26789 !          sig1=0.0
26790 !          sig2=0.0
26791 !       write (*,*) "sig2 = ", sig2
26792 ! alpha factors from Fcav/Gcav
26793         b1cav = alphasur(1,itypi,itypj)
26794 !          b1cav=0.0d0
26795         b2cav = alphasur(2,itypi,itypj)
26796         b3cav = alphasur(3,itypi,itypj)
26797         b4cav = alphasur(4,itypi,itypj)
26798 ! used to determine whether we want to do quadrupole calculations
26799        eps_in = epsintab(itypi,itypj)
26800        if (eps_in.eq.0.0) eps_in=1.0
26801
26802        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26803        Rtail = 0.0d0
26804 !       dtail(1,itypi,itypj)=0.0
26805 !       dtail(2,itypi,itypj)=0.0
26806
26807        DO k = 1, 3
26808       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26809       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26810        END DO
26811        call to_box (ctail(1,1),ctail(2,1),ctail(3,1))
26812        call to_box (ctail(1,2),ctail(2,2),ctail(3,2))
26813
26814 !c! tail distances will be themselves usefull elswhere
26815 !c1 (in Gcav, for example)
26816        Rtail_distance(1)=boxshift(ctail( 1, 2 ) - ctail( 1,1 ),boxxsize)
26817        Rtail_distance(2)=boxshift(ctail( 2, 2 ) - ctail( 2,1 ),boxysize)
26818        Rtail_distance(3)=boxshift(ctail( 3, 2 ) - ctail( 3,1 ),boxzsize)
26819        Rtail = dsqrt( &
26820         (Rtail_distance(1)*Rtail_distance(1)) &
26821       + (Rtail_distance(2)*Rtail_distance(2)) &
26822       + (Rtail_distance(3)*Rtail_distance(3)))
26823
26824 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26825 !-------------------------------------------------------------------
26826 ! tail location and distance calculations
26827        d1 = dhead(1, 1, itypi, itypj)
26828        d2 = dhead(2, 1, itypi, itypj)
26829
26830        DO k = 1,3
26831 ! location of polar head is computed by taking hydrophobic centre
26832 ! and moving by a d1 * dc_norm vector
26833 ! see unres publications for very informative images
26834       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26835       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26836 ! distance
26837       enddo
26838        if (energy_dec) write(iout,*) "before",chead(1,1),chead(2,1),chead(3,1)
26839        if (energy_dec) write(iout,*) "before",chead(1,2),chead(2,2),chead(3,2)
26840        call to_box (chead(1,1),chead(2,1),chead(3,1))
26841        call to_box (chead(1,2),chead(2,2),chead(3,2))
26842
26843 !c! head distances will be themselves usefull elswhere
26844 !c1 (in Gcav, for example)
26845        if (energy_dec) write(iout,*) "after",chead(1,1),chead(2,1),chead(3,1)
26846        if (energy_dec) write(iout,*) "after",chead(1,2),chead(2,2),chead(3,2)
26847
26848        Rhead_distance(1)=boxshift(chead( 1, 2 ) - chead( 1,1 ),boxxsize)
26849        Rhead_distance(2)=boxshift(chead( 2, 2 ) - chead( 2,1 ),boxysize)
26850        Rhead_distance(3)=boxshift(chead( 3, 2 ) - chead( 3,1 ),boxzsize)
26851        if (energy_dec) write(iout,*) "after,rdi",(Rhead_distance(k),k=1,3)
26852 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26853 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26854 !      Rhead_distance(k) = chead(k,2) - chead(k,1)
26855 !       END DO
26856 ! pitagoras (root of sum of squares)
26857        Rhead = dsqrt( &
26858         (Rhead_distance(1)*Rhead_distance(1)) &
26859       + (Rhead_distance(2)*Rhead_distance(2)) &
26860       + (Rhead_distance(3)*Rhead_distance(3)))
26861 !-------------------------------------------------------------------
26862 ! zero everything that should be zero'ed
26863        evdwij = 0.0d0
26864        ECL = 0.0d0
26865        Elj = 0.0d0
26866        Equad = 0.0d0
26867        Epol = 0.0d0
26868        Fcav=0.0d0
26869        eheadtail = 0.0d0
26870        dGCLdOM1 = 0.0d0
26871        dGCLdOM2 = 0.0d0
26872        dGCLdOM12 = 0.0d0
26873        dPOLdOM1 = 0.0d0
26874        dPOLdOM2 = 0.0d0
26875         Fcav = 0.0d0
26876         dFdR = 0.0d0
26877         dCAVdOM1  = 0.0d0
26878         dCAVdOM2  = 0.0d0
26879         dCAVdOM12 = 0.0d0
26880         dscj_inv = vbld_inv(j+nres)
26881 !          print *,i,j,dscj_inv,dsci_inv
26882 ! rij holds 1/(distance of Calpha atoms)
26883         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26884         rij  = dsqrt(rrij)
26885 !----------------------------
26886         CALL sc_angular
26887 ! this should be in elgrad_init but om's are calculated by sc_angular
26888 ! which in turn is used by older potentials
26889 ! om = omega, sqom = om^2
26890         sqom1  = om1 * om1
26891         sqom2  = om2 * om2
26892         sqom12 = om12 * om12
26893
26894 ! now we calculate EGB - Gey-Berne
26895 ! It will be summed up in evdwij and saved in evdw
26896         sigsq     = 1.0D0  / sigsq
26897         sig       = sig0ij * dsqrt(sigsq)
26898 !          rij_shift = 1.0D0  / rij - sig + sig0ij
26899         rij_shift = Rtail - sig + sig0ij
26900         IF (rij_shift.le.0.0D0) THEN
26901          evdw = 1.0D20
26902          RETURN
26903         END IF
26904         sigder = -sig * sigsq
26905         rij_shift = 1.0D0 / rij_shift
26906         fac       = rij_shift**expon
26907         c1        = fac  * fac * aa_aq(itypi,itypj)
26908 !          print *,"ADAM",aa_aq(itypi,itypj)
26909
26910 !          c1        = 0.0d0
26911         c2        = fac  * bb_aq(itypi,itypj)
26912 !          c2        = 0.0d0
26913         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
26914         eps2der   = eps3rt * evdwij
26915         eps3der   = eps2rt * evdwij
26916 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
26917         evdwij    = eps2rt * eps3rt * evdwij
26918 !#ifdef TSCSC
26919 !          IF (bb_aq(itypi,itypj).gt.0) THEN
26920 !           evdw_p = evdw_p + evdwij
26921 !          ELSE
26922 !           evdw_m = evdw_m + evdwij
26923 !          END IF
26924 !#else
26925         evdw = evdw  &
26926             + evdwij
26927 !#endif
26928
26929         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
26930         fac    = -expon * (c1 + evdwij) * rij_shift
26931         sigder = fac * sigder
26932 !          fac    = rij * fac
26933 ! Calculate distance derivative
26934         gg(1) =  fac
26935         gg(2) =  fac
26936         gg(3) =  fac
26937 !          if (b2.gt.0.0) then
26938         fac = chis1 * sqom1 + chis2 * sqom2 &
26939         - 2.0d0 * chis12 * om1 * om2 * om12
26940 ! we will use pom later in Gcav, so dont mess with it!
26941         pom = 1.0d0 - chis1 * chis2 * sqom12
26942         Lambf = (1.0d0 - (fac / pom))
26943 !          print *,"fac,pom",fac,pom,Lambf
26944         Lambf = dsqrt(Lambf)
26945         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
26946 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
26947 !       write (*,*) "sparrow = ", sparrow
26948         Chif = Rtail * sparrow
26949 !           print *,"rij,sparrow",rij , sparrow
26950         ChiLambf = Chif * Lambf
26951         eagle = dsqrt(ChiLambf)
26952         bat = ChiLambf ** 11.0d0
26953         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
26954         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
26955         botsq = bot * bot
26956 !          print *,top,bot,"bot,top",ChiLambf,Chif
26957         Fcav = top / bot
26958
26959        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
26960        dbot = 12.0d0 * b4cav * bat * Lambf
26961        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
26962
26963         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
26964         dbot = 12.0d0 * b4cav * bat * Chif
26965         eagle = Lambf * pom
26966         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
26967         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
26968         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
26969             * (chis2 * om2 * om12 - om1) / (eagle * pom)
26970
26971         dFdL = ((dtop * bot - top * dbot) / botsq)
26972 !       dFdL = 0.0d0
26973         dCAVdOM1  = dFdL * ( dFdOM1 )
26974         dCAVdOM2  = dFdL * ( dFdOM2 )
26975         dCAVdOM12 = dFdL * ( dFdOM12 )
26976
26977        DO k= 1, 3
26978       ertail(k) = Rtail_distance(k)/Rtail
26979        END DO
26980        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
26981        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
26982        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26983        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26984        DO k = 1, 3
26985 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26986 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26987       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
26988       gvdwx(k,i) = gvdwx(k,i) &
26989               - (( dFdR + gg(k) ) * pom)
26990 !c!     &             - ( dFdR * pom )
26991       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
26992       gvdwx(k,j) = gvdwx(k,j)   &
26993               + (( dFdR + gg(k) ) * pom)
26994 !c!     &             + ( dFdR * pom )
26995
26996       gvdwc(k,i) = gvdwc(k,i)  &
26997               - (( dFdR + gg(k) ) * ertail(k))
26998 !c!     &             - ( dFdR * ertail(k))
26999
27000       gvdwc(k,j) = gvdwc(k,j) &
27001               + (( dFdR + gg(k) ) * ertail(k))
27002 !c!     &             + ( dFdR * ertail(k))
27003
27004       gg(k) = 0.0d0
27005 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
27006 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
27007       END DO
27008
27009
27010 !c! Compute head-head and head-tail energies for each state
27011
27012         isel = iabs(Qi) + iabs(Qj)
27013 ! double charge for Phophorylated! itype - 25,27,27
27014 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
27015 !            Qi=Qi*2
27016 !            Qij=Qij*2
27017 !           endif
27018 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
27019 !            Qj=Qj*2
27020 !            Qij=Qij*2
27021 !           endif
27022
27023 !          isel=0
27024         IF (isel.eq.0) THEN
27025 !c! No charges - do nothing
27026          eheadtail = 0.0d0
27027
27028         ELSE IF (isel.eq.4) THEN
27029 !c! Calculate dipole-dipole interactions
27030          CALL edd(ecl)
27031          eheadtail = ECL
27032 !           eheadtail = 0.0d0
27033
27034         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
27035 !c! Charge-nonpolar interactions
27036         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27037           Qi=Qi*2
27038           Qij=Qij*2
27039          endif
27040         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27041           Qj=Qj*2
27042           Qij=Qij*2
27043          endif
27044
27045          CALL eqn(epol)
27046          eheadtail = epol
27047 !           eheadtail = 0.0d0
27048
27049         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
27050 !c! Nonpolar-charge interactions
27051         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27052           Qi=Qi*2
27053           Qij=Qij*2
27054          endif
27055         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27056           Qj=Qj*2
27057           Qij=Qij*2
27058          endif
27059
27060          CALL enq(epol)
27061          eheadtail = epol
27062 !           eheadtail = 0.0d0
27063
27064         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
27065 !c! Charge-dipole interactions
27066         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27067           Qi=Qi*2
27068           Qij=Qij*2
27069          endif
27070         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27071           Qj=Qj*2
27072           Qij=Qij*2
27073          endif
27074
27075          CALL eqd(ecl, elj, epol)
27076          eheadtail = ECL + elj + epol
27077 !           eheadtail = 0.0d0
27078
27079         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
27080 !c! Dipole-charge interactions
27081         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27082           Qi=Qi*2
27083           Qij=Qij*2
27084          endif
27085         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27086           Qj=Qj*2
27087           Qij=Qij*2
27088          endif
27089          CALL edq(ecl, elj, epol)
27090         eheadtail = ECL + elj + epol
27091 !           eheadtail = 0.0d0
27092
27093         ELSE IF ((isel.eq.2.and.   &
27094              iabs(Qi).eq.1).and.  &
27095              nstate(itypi,itypj).eq.1) THEN
27096 !c! Same charge-charge interaction ( +/+ or -/- )
27097         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27098           Qi=Qi*2
27099           Qij=Qij*2
27100          endif
27101         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27102           Qj=Qj*2
27103           Qij=Qij*2
27104          endif
27105
27106          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
27107          eheadtail = ECL + Egb + Epol + Fisocav + Elj
27108 !           eheadtail = 0.0d0
27109
27110         ELSE IF ((isel.eq.2.and.  &
27111              iabs(Qi).eq.1).and. &
27112              nstate(itypi,itypj).ne.1) THEN
27113 !c! Different charge-charge interaction ( +/- or -/+ )
27114         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
27115           Qi=Qi*2
27116           Qij=Qij*2
27117          endif
27118         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
27119           Qj=Qj*2
27120           Qij=Qij*2
27121          endif
27122
27123          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
27124         END IF
27125        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
27126       evdw = evdw  + Fcav + eheadtail
27127
27128        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
27129       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
27130       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
27131       Equad,evdwij+Fcav+eheadtail,evdw
27132 !       evdw = evdw  + Fcav  + eheadtail
27133
27134       iF (nstate(itypi,itypj).eq.1) THEN
27135       CALL sc_grad
27136        END IF
27137 !c!-------------------------------------------------------------------
27138 !c! NAPISY KONCOWE
27139        END DO   ! j
27140       END DO    ! iint
27141        END DO     ! i
27142 !c      write (iout,*) "Number of loop steps in EGB:",ind
27143 !c      energy_dec=.false.
27144 !              print *,"EVDW KURW",evdw,nres
27145
27146        RETURN
27147       END SUBROUTINE emomo
27148 !C------------------------------------------------------------------------------------
27149       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
27150       use calc_data
27151       use comm_momo
27152        real (kind=8) ::  facd3, facd4, federmaus, adler,&
27153        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
27154 !       integer :: k
27155 !c! Epol and Gpol analytical parameters
27156        alphapol1 = alphapol(itypi,itypj)
27157        alphapol2 = alphapol(itypj,itypi)
27158 !c! Fisocav and Gisocav analytical parameters
27159        al1  = alphiso(1,itypi,itypj)
27160        al2  = alphiso(2,itypi,itypj)
27161        al3  = alphiso(3,itypi,itypj)
27162        al4  = alphiso(4,itypi,itypj)
27163        csig = (1.0d0  &
27164          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
27165          + sigiso2(itypi,itypj)**2.0d0))
27166 !c!
27167        pis  = sig0head(itypi,itypj)
27168        eps_head = epshead(itypi,itypj)
27169        Rhead_sq = Rhead * Rhead
27170 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27171 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27172        R1 = 0.0d0
27173        R2 = 0.0d0
27174        DO k = 1, 3
27175 !c! Calculate head-to-tail distances needed by Epol
27176       R1=R1+(ctail(k,2)-chead(k,1))**2
27177       R2=R2+(chead(k,2)-ctail(k,1))**2
27178        END DO
27179 !c! Pitagoras
27180        R1 = dsqrt(R1)
27181        R2 = dsqrt(R2)
27182
27183 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27184 !c!     &        +dhead(1,1,itypi,itypj))**2))
27185 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27186 !c!     &        +dhead(2,1,itypi,itypj))**2))
27187
27188 !c!-------------------------------------------------------------------
27189 !c! Coulomb electrostatic interaction
27190        Ecl = (332.0d0 * Qij) / Rhead
27191 !c! derivative of Ecl is Gcl...
27192        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
27193        dGCLdOM1 = 0.0d0
27194        dGCLdOM2 = 0.0d0
27195        dGCLdOM12 = 0.0d0
27196        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27197        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27198        debkap=debaykap(itypi,itypj)
27199        Egb = -(332.0d0 * Qij *&
27200       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
27201 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
27202 !c! Derivative of Egb is Ggb...
27203        dGGBdFGB = -(-332.0d0 * Qij * &
27204        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
27205        -(332.0d0 * Qij *&
27206       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
27207        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
27208        dGGBdR = dGGBdFGB * dFGBdR
27209 !c!-------------------------------------------------------------------
27210 !c! Fisocav - isotropic cavity creation term
27211 !c! or "how much energy it costs to put charged head in water"
27212        pom = Rhead * csig
27213        top = al1 * (dsqrt(pom) + al2 * pom - al3)
27214        bot = (1.0d0 + al4 * pom**12.0d0)
27215        botsq = bot * bot
27216        FisoCav = top / bot
27217 !      write (*,*) "Rhead = ",Rhead
27218 !      write (*,*) "csig = ",csig
27219 !      write (*,*) "pom = ",pom
27220 !      write (*,*) "al1 = ",al1
27221 !      write (*,*) "al2 = ",al2
27222 !      write (*,*) "al3 = ",al3
27223 !      write (*,*) "al4 = ",al4
27224 !        write (*,*) "top = ",top
27225 !        write (*,*) "bot = ",bot
27226 !c! Derivative of Fisocav is GCV...
27227        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27228        dbot = 12.0d0 * al4 * pom ** 11.0d0
27229        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
27230 !c!-------------------------------------------------------------------
27231 !c! Epol
27232 !c! Polarization energy - charged heads polarize hydrophobic "neck"
27233        MomoFac1 = (1.0d0 - chi1 * sqom2)
27234        MomoFac2 = (1.0d0 - chi2 * sqom1)
27235        RR1  = ( R1 * R1 ) / MomoFac1
27236        RR2  = ( R2 * R2 ) / MomoFac2
27237        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27238        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27239        fgb1 = sqrt( RR1 + a12sq * ee1 )
27240        fgb2 = sqrt( RR2 + a12sq * ee2 )
27241        epol = 332.0d0 * eps_inout_fac * ( &
27242       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27243 !c!       epol = 0.0d0
27244        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27245              / (fgb1 ** 5.0d0)
27246        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27247              / (fgb2 ** 5.0d0)
27248        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
27249            / ( 2.0d0 * fgb1 )
27250        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
27251            / ( 2.0d0 * fgb2 )
27252        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
27253             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
27254        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
27255             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
27256        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27257 !c!       dPOLdR1 = 0.0d0
27258        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27259 !c!       dPOLdR2 = 0.0d0
27260        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27261 !c!       dPOLdOM1 = 0.0d0
27262        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27263 !c!       dPOLdOM2 = 0.0d0
27264 !c!-------------------------------------------------------------------
27265 !c! Elj
27266 !c! Lennard-Jones 6-12 interaction between heads
27267        pom = (pis / Rhead)**6.0d0
27268        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27269 !c! derivative of Elj is Glj
27270        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
27271            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27272 !c!-------------------------------------------------------------------
27273 !c! Return the results
27274 !c! These things do the dRdX derivatives, that is
27275 !c! allow us to change what we see from function that changes with
27276 !c! distance to function that changes with LOCATION (of the interaction
27277 !c! site)
27278        DO k = 1, 3
27279       erhead(k) = Rhead_distance(k)/Rhead
27280       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27281       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27282        END DO
27283
27284        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27285        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27286        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27287        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27288        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27289        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27290        facd1 = d1 * vbld_inv(i+nres)
27291        facd2 = d2 * vbld_inv(j+nres)
27292        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27293        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27294
27295 !c! Now we add appropriate partial derivatives (one in each dimension)
27296        DO k = 1, 3
27297       hawk   = (erhead_tail(k,1) + &
27298       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
27299       condor = (erhead_tail(k,2) + &
27300       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27301
27302       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27303       gvdwx(k,i) = gvdwx(k,i) &
27304               - dGCLdR * pom&
27305               - dGGBdR * pom&
27306               - dGCVdR * pom&
27307               - dPOLdR1 * hawk&
27308               - dPOLdR2 * (erhead_tail(k,2)&
27309       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27310               - dGLJdR * pom
27311
27312       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27313       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
27314                + dGGBdR * pom+ dGCVdR * pom&
27315               + dPOLdR1 * (erhead_tail(k,1)&
27316       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
27317               + dPOLdR2 * condor + dGLJdR * pom
27318
27319       gvdwc(k,i) = gvdwc(k,i)  &
27320               - dGCLdR * erhead(k)&
27321               - dGGBdR * erhead(k)&
27322               - dGCVdR * erhead(k)&
27323               - dPOLdR1 * erhead_tail(k,1)&
27324               - dPOLdR2 * erhead_tail(k,2)&
27325               - dGLJdR * erhead(k)
27326
27327       gvdwc(k,j) = gvdwc(k,j)         &
27328               + dGCLdR * erhead(k) &
27329               + dGGBdR * erhead(k) &
27330               + dGCVdR * erhead(k) &
27331               + dPOLdR1 * erhead_tail(k,1) &
27332               + dPOLdR2 * erhead_tail(k,2)&
27333               + dGLJdR * erhead(k)
27334
27335        END DO
27336        RETURN
27337       END SUBROUTINE eqq
27338
27339       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
27340       use calc_data
27341       use comm_momo
27342        real (kind=8) ::  facd3, facd4, federmaus, adler,&
27343        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
27344 !       integer :: k
27345 !c! Epol and Gpol analytical parameters
27346        alphapol1 = alphapolcat(itypi,itypj)
27347        alphapol2 = alphapolcat2(itypj,itypi)
27348 !c! Fisocav and Gisocav analytical parameters
27349        al1  = alphisocat(1,itypi,itypj)
27350        al2  = alphisocat(2,itypi,itypj)
27351        al3  = alphisocat(3,itypi,itypj)
27352        al4  = alphisocat(4,itypi,itypj)
27353        csig = (1.0d0  &
27354          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
27355          + sigiso2cat(itypi,itypj)**2.0d0))
27356 !c!
27357        pis  = sig0headcat(itypi,itypj)
27358        eps_head = epsheadcat(itypi,itypj)
27359        Rhead_sq = Rhead * Rhead
27360 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27361 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27362        R1 = 0.0d0
27363        R2 = 0.0d0
27364        DO k = 1, 3
27365 !c! Calculate head-to-tail distances needed by Epol
27366       R1=R1+(ctail(k,2)-chead(k,1))**2
27367       R2=R2+(chead(k,2)-ctail(k,1))**2
27368        END DO
27369 !c! Pitagoras
27370        R1 = dsqrt(R1)
27371        R2 = dsqrt(R2)
27372
27373 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27374 !c!     &        +dhead(1,1,itypi,itypj))**2))
27375 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27376 !c!     &        +dhead(2,1,itypi,itypj))**2))
27377
27378 !c!-------------------------------------------------------------------
27379 !c! Coulomb electrostatic interaction
27380        Ecl = (332.0d0 * Qij) / Rhead
27381 !c! derivative of Ecl is Gcl...
27382        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
27383        dGCLdOM1 = 0.0d0
27384        dGCLdOM2 = 0.0d0
27385        dGCLdOM12 = 0.0d0
27386
27387        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27388        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27389        debkap=debaykapcat(itypi,itypj)
27390        if (energy_dec) write(iout,*) "egb",Qij,debkap,Fgb,a12sq,ee0
27391        Egb = -(332.0d0 * Qij *&
27392       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
27393 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
27394 !c! Derivative of Egb is Ggb...
27395        dGGBdFGB = -(-332.0d0 * Qij * &
27396        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
27397        -(332.0d0 * Qij *&
27398       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
27399        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
27400        dGGBdR = dGGBdFGB * dFGBdR
27401 !c!-------------------------------------------------------------------
27402 !c! Fisocav - isotropic cavity creation term
27403 !c! or "how much energy it costs to put charged head in water"
27404        pom = Rhead * csig
27405        top = al1 * (dsqrt(pom) + al2 * pom - al3)
27406        bot = (1.0d0 + al4 * pom**12.0d0)
27407        botsq = bot * bot
27408        FisoCav = top / bot
27409 !      write (*,*) "Rhead = ",Rhead
27410 !      write (*,*) "csig = ",csig
27411 !      write (*,*) "pom = ",pom
27412 !      write (*,*) "al1 = ",al1
27413 !      write (*,*) "al2 = ",al2
27414 !      write (*,*) "al3 = ",al3
27415 !      write (*,*) "al4 = ",al4
27416 !        write (*,*) "top = ",top
27417 !        write (*,*) "bot = ",bot
27418 !c! Derivative of Fisocav is GCV...
27419        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27420        dbot = 12.0d0 * al4 * pom ** 11.0d0
27421        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
27422 !c!-------------------------------------------------------------------
27423 !c! Epol
27424 !c! Polarization energy - charged heads polarize hydrophobic "neck"
27425        MomoFac1 = (1.0d0 - chi1 * sqom2)
27426        MomoFac2 = (1.0d0 - chi2 * sqom1)
27427        RR1  = ( R1 * R1 ) / MomoFac1
27428        RR2  = ( R2 * R2 ) / MomoFac2
27429        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27430        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27431        fgb1 = sqrt( RR1 + a12sq * ee1 )
27432        fgb2 = sqrt( RR2 + a12sq * ee2 )
27433        epol = 332.0d0 * eps_inout_fac * ( &
27434       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27435 !c!       epol = 0.0d0
27436        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27437              / (fgb1 ** 5.0d0)
27438        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27439              / (fgb2 ** 5.0d0)
27440        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
27441            / ( 2.0d0 * fgb1 )
27442        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
27443            / ( 2.0d0 * fgb2 )
27444        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
27445             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
27446        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
27447             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
27448        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27449 !c!       dPOLdR1 = 0.0d0
27450        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27451 !c!       dPOLdR2 = 0.0d0
27452        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27453 !c!       dPOLdOM1 = 0.0d0
27454        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27455 !c!       dPOLdOM2 = 0.0d0
27456 !c!-------------------------------------------------------------------
27457 !c! Elj
27458 !c! Lennard-Jones 6-12 interaction between heads
27459        pom = (pis / Rhead)**6.0d0
27460        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27461 !c! derivative of Elj is Glj
27462        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
27463            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27464 !c!-------------------------------------------------------------------
27465 !c! Return the results
27466 !c! These things do the dRdX derivatives, that is
27467 !c! allow us to change what we see from function that changes with
27468 !c! distance to function that changes with LOCATION (of the interaction
27469 !c! site)
27470        DO k = 1, 3
27471       erhead(k) = Rhead_distance(k)/Rhead
27472       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27473       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27474        END DO
27475
27476        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27477        erdxj = scalar( erhead(1), dC_norm(1,j) )
27478        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27479        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
27480        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27481        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27482        facd1 = d1 * vbld_inv(i+nres)
27483        facd2 = d2 * vbld_inv(j)
27484        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27485        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
27486
27487 !c! Now we add appropriate partial derivatives (one in each dimension)
27488        DO k = 1, 3
27489       hawk   = (erhead_tail(k,1) + &
27490       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
27491       condor = (erhead_tail(k,2) + &
27492       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27493
27494       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27495       gradpepcatx(k,i) = gradpepcatx(k,i) &
27496               - dGCLdR * pom&
27497               - dGGBdR * pom&
27498               - dGCVdR * pom&
27499               - dPOLdR1 * hawk&
27500               - dPOLdR2 * (erhead_tail(k,2)&
27501       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27502               - dGLJdR * pom
27503
27504       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27505 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
27506 !                   + dGGBdR * pom+ dGCVdR * pom&
27507 !                  + dPOLdR1 * (erhead_tail(k,1)&
27508 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
27509 !                  + dPOLdR2 * condor + dGLJdR * pom
27510
27511       gradpepcat(k,i) = gradpepcat(k,i)  &
27512               - dGCLdR * erhead(k)&
27513               - dGGBdR * erhead(k)&
27514               - dGCVdR * erhead(k)&
27515               - dPOLdR1 * erhead_tail(k,1)&
27516               - dPOLdR2 * erhead_tail(k,2)&
27517               - dGLJdR * erhead(k)
27518
27519       gradpepcat(k,j) = gradpepcat(k,j)         &
27520               + dGCLdR * erhead(k) &
27521               + dGGBdR * erhead(k) &
27522               + dGCVdR * erhead(k) &
27523               + dPOLdR1 * erhead_tail(k,1) &
27524               + dPOLdR2 * erhead_tail(k,2)&
27525               + dGLJdR * erhead(k)
27526
27527        END DO
27528        RETURN
27529       END SUBROUTINE eqq_cat
27530 !c!-------------------------------------------------------------------
27531       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
27532       use comm_momo
27533       use calc_data
27534
27535        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
27536        double precision ener(4)
27537        double precision dcosom1(3),dcosom2(3)
27538 !c! used in Epol derivatives
27539        double precision facd3, facd4
27540        double precision federmaus, adler
27541        integer istate,ii,jj
27542        real (kind=8) :: Fgb
27543 !       print *,"CALLING EQUAD"
27544 !c! Epol and Gpol analytical parameters
27545        alphapol1 = alphapol(itypi,itypj)
27546        alphapol2 = alphapol(itypj,itypi)
27547 !c! Fisocav and Gisocav analytical parameters
27548        al1  = alphiso(1,itypi,itypj)
27549        al2  = alphiso(2,itypi,itypj)
27550        al3  = alphiso(3,itypi,itypj)
27551        al4  = alphiso(4,itypi,itypj)
27552        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
27553           + sigiso2(itypi,itypj)**2.0d0))
27554 !c!
27555        w1   = wqdip(1,itypi,itypj)
27556        w2   = wqdip(2,itypi,itypj)
27557        pis  = sig0head(itypi,itypj)
27558        eps_head = epshead(itypi,itypj)
27559 !c! First things first:
27560 !c! We need to do sc_grad's job with GB and Fcav
27561        eom1  = eps2der * eps2rt_om1 &
27562            - 2.0D0 * alf1 * eps3der&
27563            + sigder * sigsq_om1&
27564            + dCAVdOM1
27565        eom2  = eps2der * eps2rt_om2 &
27566            + 2.0D0 * alf2 * eps3der&
27567            + sigder * sigsq_om2&
27568            + dCAVdOM2
27569        eom12 =  evdwij  * eps1_om12 &
27570            + eps2der * eps2rt_om12 &
27571            - 2.0D0 * alf12 * eps3der&
27572            + sigder *sigsq_om12&
27573            + dCAVdOM12
27574 !c! now some magical transformations to project gradient into
27575 !c! three cartesian vectors
27576        DO k = 1, 3
27577       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
27578       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27579       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
27580 !c! this acts on hydrophobic center of interaction
27581       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
27582               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
27583               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
27584       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
27585               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
27586               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
27587 !c! this acts on Calpha
27588       gvdwc(k,i)=gvdwc(k,i)-gg(k)
27589       gvdwc(k,j)=gvdwc(k,j)+gg(k)
27590        END DO
27591 !c! sc_grad is done, now we will compute
27592        eheadtail = 0.0d0
27593        eom1 = 0.0d0
27594        eom2 = 0.0d0
27595        eom12 = 0.0d0
27596        DO istate = 1, nstate(itypi,itypj)
27597 !c*************************************************************
27598       IF (istate.ne.1) THEN
27599        IF (istate.lt.3) THEN
27600         ii = 1
27601        ELSE
27602         ii = 2
27603        END IF
27604       jj = istate/ii
27605       d1 = dhead(1,ii,itypi,itypj)
27606       d2 = dhead(2,jj,itypi,itypj)
27607       do k=1,3
27608       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27609       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27610 ! distance
27611       enddo
27612        call to_box (chead(1,1),chead(2,1),chead(3,1))
27613        call to_box (chead(1,2),chead(2,2),chead(3,2))
27614
27615 !c! head distances will be themselves usefull elswhere
27616 !c1 (in Gcav, for example)
27617
27618        Rhead_distance(1)=boxshift(chead( 1, 2 ) - chead( 1,1 ),boxxsize)
27619        Rhead_distance(2)=boxshift(chead( 2, 2 ) - chead( 2,1 ),boxysize)
27620        Rhead_distance(3)=boxshift(chead( 3, 2 ) - chead( 3,1 ),boxzsize)
27621 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27622 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27623 !      Rhead_distance(k) = chead(k,2) - chead(k,1)
27624 !       END DO
27625 ! pitagoras (root of sum of squares)
27626        Rhead = dsqrt( &
27627         (Rhead_distance(1)*Rhead_distance(1)) &
27628       + (Rhead_distance(2)*Rhead_distance(2)) &
27629       + (Rhead_distance(3)*Rhead_distance(3)))
27630
27631 !      DO k = 1,3
27632 !       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27633 !       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27634 !       Rhead_distance(k) = chead(k,2) - chead(k,1)
27635 !      END DO
27636 !c! pitagoras (root of sum of squares)
27637 !      Rhead = dsqrt( &
27638 !             (Rhead_distance(1)*Rhead_distance(1))  &
27639 !           + (Rhead_distance(2)*Rhead_distance(2))  &
27640 !           + (Rhead_distance(3)*Rhead_distance(3)))
27641       END IF
27642       Rhead_sq = Rhead * Rhead
27643
27644 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27645 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27646       R1 = 0.0d0
27647       R2 = 0.0d0
27648       DO k = 1, 3
27649 !c! Calculate head-to-tail distances
27650        R1=R1+(ctail(k,2)-chead(k,1))**2
27651        R2=R2+(chead(k,2)-ctail(k,1))**2
27652       END DO
27653 !c! Pitagoras
27654       R1 = dsqrt(R1)
27655       R2 = dsqrt(R2)
27656       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
27657 !c!        Ecl = 0.0d0
27658 !c!        write (*,*) "Ecl = ", Ecl
27659 !c! derivative of Ecl is Gcl...
27660       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
27661 !c!        dGCLdR = 0.0d0
27662       dGCLdOM1 = 0.0d0
27663       dGCLdOM2 = 0.0d0
27664       dGCLdOM12 = 0.0d0
27665 !c!-------------------------------------------------------------------
27666 !c! Generalised Born Solvent Polarization
27667       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27668       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27669       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
27670 !c!        Egb = 0.0d0
27671 !c!      write (*,*) "a1*a2 = ", a12sq
27672 !c!      write (*,*) "Rhead = ", Rhead
27673 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
27674 !c!      write (*,*) "ee = ", ee
27675 !c!      write (*,*) "Fgb = ", Fgb
27676 !c!      write (*,*) "fac = ", eps_inout_fac
27677 !c!      write (*,*) "Qij = ", Qij
27678 !c!      write (*,*) "Egb = ", Egb
27679 !c! Derivative of Egb is Ggb...
27680 !c! dFGBdR is used by Quad's later...
27681       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
27682       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
27683              / ( 2.0d0 * Fgb )
27684       dGGBdR = dGGBdFGB * dFGBdR
27685 !c!        dGGBdR = 0.0d0
27686 !c!-------------------------------------------------------------------
27687 !c! Fisocav - isotropic cavity creation term
27688       pom = Rhead * csig
27689       top = al1 * (dsqrt(pom) + al2 * pom - al3)
27690       bot = (1.0d0 + al4 * pom**12.0d0)
27691       botsq = bot * bot
27692       FisoCav = top / bot
27693       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27694       dbot = 12.0d0 * al4 * pom ** 11.0d0
27695       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
27696 !c!        dGCVdR = 0.0d0
27697 !c!-------------------------------------------------------------------
27698 !c! Polarization energy
27699 !c! Epol
27700       MomoFac1 = (1.0d0 - chi1 * sqom2)
27701       MomoFac2 = (1.0d0 - chi2 * sqom1)
27702       RR1  = ( R1 * R1 ) / MomoFac1
27703       RR2  = ( R2 * R2 ) / MomoFac2
27704       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27705       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27706       fgb1 = sqrt( RR1 + a12sq * ee1 )
27707       fgb2 = sqrt( RR2 + a12sq * ee2 )
27708       epol = 332.0d0 * eps_inout_fac * (&
27709       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27710 !c!        epol = 0.0d0
27711 !c! derivative of Epol is Gpol...
27712       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27713               / (fgb1 ** 5.0d0)
27714       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27715               / (fgb2 ** 5.0d0)
27716       dFGBdR1 = ( (R1 / MomoFac1) &
27717             * ( 2.0d0 - (0.5d0 * ee1) ) )&
27718             / ( 2.0d0 * fgb1 )
27719       dFGBdR2 = ( (R2 / MomoFac2) &
27720             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27721             / ( 2.0d0 * fgb2 )
27722       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27723              * ( 2.0d0 - 0.5d0 * ee1) ) &
27724              / ( 2.0d0 * fgb1 )
27725       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27726              * ( 2.0d0 - 0.5d0 * ee2) ) &
27727              / ( 2.0d0 * fgb2 )
27728       dPOLdR1 = dPOLdFGB1 * dFGBdR1
27729 !c!        dPOLdR1 = 0.0d0
27730       dPOLdR2 = dPOLdFGB2 * dFGBdR2
27731 !c!        dPOLdR2 = 0.0d0
27732       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27733 !c!        dPOLdOM1 = 0.0d0
27734       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27735       pom = (pis / Rhead)**6.0d0
27736       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27737 !c!        Elj = 0.0d0
27738 !c! derivative of Elj is Glj
27739       dGLJdR = 4.0d0 * eps_head &
27740           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27741           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27742 !c!        dGLJdR = 0.0d0
27743 !c!-------------------------------------------------------------------
27744 !c! Equad
27745        IF (Wqd.ne.0.0d0) THEN
27746       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
27747            - 37.5d0  * ( sqom1 + sqom2 ) &
27748            + 157.5d0 * ( sqom1 * sqom2 ) &
27749            - 45.0d0  * om1*om2*om12
27750       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
27751       Equad = fac * Beta1
27752 !c!        Equad = 0.0d0
27753 !c! derivative of Equad...
27754       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
27755 !c!        dQUADdR = 0.0d0
27756       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
27757 !c!        dQUADdOM1 = 0.0d0
27758       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
27759 !c!        dQUADdOM2 = 0.0d0
27760       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
27761        ELSE
27762        Beta1 = 0.0d0
27763        Equad = 0.0d0
27764       END IF
27765 !c!-------------------------------------------------------------------
27766 !c! Return the results
27767 !c! Angular stuff
27768       eom1 = dPOLdOM1 + dQUADdOM1
27769       eom2 = dPOLdOM2 + dQUADdOM2
27770       eom12 = dQUADdOM12
27771 !c! now some magical transformations to project gradient into
27772 !c! three cartesian vectors
27773       DO k = 1, 3
27774        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
27775        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27776        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
27777       END DO
27778 !c! Radial stuff
27779       DO k = 1, 3
27780        erhead(k) = Rhead_distance(k)/Rhead
27781        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27782        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27783       END DO
27784       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27785       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27786       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27787       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27788       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27789       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27790       facd1 = d1 * vbld_inv(i+nres)
27791       facd2 = d2 * vbld_inv(j+nres)
27792       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27793       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27794       DO k = 1, 3
27795        hawk   = erhead_tail(k,1) + &
27796        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
27797        condor = erhead_tail(k,2) + &
27798        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
27799
27800        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27801 !c! this acts on hydrophobic center of interaction
27802        gheadtail(k,1,1) = gheadtail(k,1,1) &
27803                    - dGCLdR * pom &
27804                    - dGGBdR * pom &
27805                    - dGCVdR * pom &
27806                    - dPOLdR1 * hawk &
27807                    - dPOLdR2 * (erhead_tail(k,2) &
27808       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27809                    - dGLJdR * pom &
27810                    - dQUADdR * pom&
27811                    - tuna(k) &
27812              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
27813              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
27814
27815        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27816 !c! this acts on hydrophobic center of interaction
27817        gheadtail(k,2,1) = gheadtail(k,2,1)  &
27818                    + dGCLdR * pom      &
27819                    + dGGBdR * pom      &
27820                    + dGCVdR * pom      &
27821                    + dPOLdR1 * (erhead_tail(k,1) &
27822       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27823                    + dPOLdR2 * condor &
27824                    + dGLJdR * pom &
27825                    + dQUADdR * pom &
27826                    + tuna(k) &
27827              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
27828              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
27829
27830 !c! this acts on Calpha
27831        gheadtail(k,3,1) = gheadtail(k,3,1)  &
27832                    - dGCLdR * erhead(k)&
27833                    - dGGBdR * erhead(k)&
27834                    - dGCVdR * erhead(k)&
27835                    - dPOLdR1 * erhead_tail(k,1)&
27836                    - dPOLdR2 * erhead_tail(k,2)&
27837                    - dGLJdR * erhead(k) &
27838                    - dQUADdR * erhead(k)&
27839                    - tuna(k)
27840 !c! this acts on Calpha
27841        gheadtail(k,4,1) = gheadtail(k,4,1)   &
27842                     + dGCLdR * erhead(k) &
27843                     + dGGBdR * erhead(k) &
27844                     + dGCVdR * erhead(k) &
27845                     + dPOLdR1 * erhead_tail(k,1) &
27846                     + dPOLdR2 * erhead_tail(k,2) &
27847                     + dGLJdR * erhead(k) &
27848                     + dQUADdR * erhead(k)&
27849                     + tuna(k)
27850       END DO
27851       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
27852       eheadtail = eheadtail &
27853               + wstate(istate, itypi, itypj) &
27854               * dexp(-betaT * ener(istate))
27855 !c! foreach cartesian dimension
27856       DO k = 1, 3
27857 !c! foreach of two gvdwx and gvdwc
27858        DO l = 1, 4
27859         gheadtail(k,l,2) = gheadtail(k,l,2)  &
27860                      + wstate( istate, itypi, itypj ) &
27861                      * dexp(-betaT * ener(istate)) &
27862                      * gheadtail(k,l,1)
27863         gheadtail(k,l,1) = 0.0d0
27864        END DO
27865       END DO
27866        END DO
27867 !c! Here ended the gigantic DO istate = 1, 4, which starts
27868 !c! at the beggining of the subroutine
27869
27870        DO k = 1, 3
27871       DO l = 1, 4
27872        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
27873       END DO
27874       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
27875       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
27876       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
27877       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
27878       DO l = 1, 4
27879        gheadtail(k,l,1) = 0.0d0
27880        gheadtail(k,l,2) = 0.0d0
27881       END DO
27882        END DO
27883        eheadtail = (-dlog(eheadtail)) / betaT
27884        dPOLdOM1 = 0.0d0
27885        dPOLdOM2 = 0.0d0
27886        dQUADdOM1 = 0.0d0
27887        dQUADdOM2 = 0.0d0
27888        dQUADdOM12 = 0.0d0
27889        RETURN
27890       END SUBROUTINE energy_quad
27891 !!-----------------------------------------------------------
27892       SUBROUTINE eqn(Epol)
27893       use comm_momo
27894       use calc_data
27895
27896       double precision  facd4, federmaus,epol
27897       alphapol1 = alphapol(itypi,itypj)
27898 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27899        R1 = 0.0d0
27900        DO k = 1, 3
27901 !c! Calculate head-to-tail distances
27902       R1=R1+(ctail(k,2)-chead(k,1))**2
27903        END DO
27904 !c! Pitagoras
27905        R1 = dsqrt(R1)
27906
27907 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27908 !c!     &        +dhead(1,1,itypi,itypj))**2))
27909 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27910 !c!     &        +dhead(2,1,itypi,itypj))**2))
27911 !c--------------------------------------------------------------------
27912 !c Polarization energy
27913 !c Epol
27914        MomoFac1 = (1.0d0 - chi1 * sqom2)
27915        RR1  = R1 * R1 / MomoFac1
27916        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27917        fgb1 = sqrt( RR1 + a12sq * ee1)
27918        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27919        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27920              / (fgb1 ** 5.0d0)
27921        dFGBdR1 = ( (R1 / MomoFac1) &
27922             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27923             / ( 2.0d0 * fgb1 )
27924        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27925             * (2.0d0 - 0.5d0 * ee1) ) &
27926             / (2.0d0 * fgb1)
27927        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27928 !c!       dPOLdR1 = 0.0d0
27929        dPOLdOM1 = 0.0d0
27930        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27931        DO k = 1, 3
27932       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27933        END DO
27934        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27935        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27936        facd1 = d1 * vbld_inv(i+nres)
27937        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27938
27939        DO k = 1, 3
27940       hawk = (erhead_tail(k,1) + &
27941       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27942
27943       gvdwx(k,i) = gvdwx(k,i) &
27944                - dPOLdR1 * hawk
27945       gvdwx(k,j) = gvdwx(k,j) &
27946                + dPOLdR1 * (erhead_tail(k,1) &
27947        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
27948
27949       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
27950       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
27951
27952        END DO
27953        RETURN
27954       END SUBROUTINE eqn
27955       SUBROUTINE enq(Epol)
27956       use calc_data
27957       use comm_momo
27958        double precision facd3, adler,epol
27959        alphapol2 = alphapol(itypj,itypi)
27960 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27961        R2 = 0.0d0
27962        DO k = 1, 3
27963 !c! Calculate head-to-tail distances
27964       R2=R2+(chead(k,2)-ctail(k,1))**2
27965        END DO
27966 !c! Pitagoras
27967        R2 = dsqrt(R2)
27968
27969 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27970 !c!     &        +dhead(1,1,itypi,itypj))**2))
27971 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27972 !c!     &        +dhead(2,1,itypi,itypj))**2))
27973 !c------------------------------------------------------------------------
27974 !c Polarization energy
27975        MomoFac2 = (1.0d0 - chi2 * sqom1)
27976        RR2  = R2 * R2 / MomoFac2
27977        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27978        fgb2 = sqrt(RR2  + a12sq * ee2)
27979        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27980        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27981             / (fgb2 ** 5.0d0)
27982        dFGBdR2 = ( (R2 / MomoFac2)  &
27983             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27984             / (2.0d0 * fgb2)
27985        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27986             * (2.0d0 - 0.5d0 * ee2) ) &
27987             / (2.0d0 * fgb2)
27988        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27989 !c!       dPOLdR2 = 0.0d0
27990        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27991 !c!       dPOLdOM1 = 0.0d0
27992        dPOLdOM2 = 0.0d0
27993 !c!-------------------------------------------------------------------
27994 !c! Return the results
27995 !c! (See comments in Eqq)
27996        DO k = 1, 3
27997       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27998        END DO
27999        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
28000        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28001        facd2 = d2 * vbld_inv(j+nres)
28002        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
28003        DO k = 1, 3
28004       condor = (erhead_tail(k,2) &
28005        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
28006
28007       gvdwx(k,i) = gvdwx(k,i) &
28008                - dPOLdR2 * (erhead_tail(k,2) &
28009        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
28010       gvdwx(k,j) = gvdwx(k,j)   &
28011                + dPOLdR2 * condor
28012
28013       gvdwc(k,i) = gvdwc(k,i) &
28014                - dPOLdR2 * erhead_tail(k,2)
28015       gvdwc(k,j) = gvdwc(k,j) &
28016                + dPOLdR2 * erhead_tail(k,2)
28017
28018        END DO
28019       RETURN
28020       END SUBROUTINE enq
28021
28022       SUBROUTINE enq_cat(Epol)
28023       use calc_data
28024       use comm_momo
28025        double precision facd3, adler,epol
28026        alphapol2 = alphapolcat(itypi,itypj)
28027 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28028        R2 = 0.0d0
28029        DO k = 1, 3
28030 !c! Calculate head-to-tail distances
28031       R2=R2+(chead(k,2)-ctail(k,1))**2
28032        END DO
28033 !c! Pitagoras
28034        R2 = dsqrt(R2)
28035
28036 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28037 !c!     &        +dhead(1,1,itypi,itypj))**2))
28038 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28039 !c!     &        +dhead(2,1,itypi,itypj))**2))
28040 !c------------------------------------------------------------------------
28041 !c Polarization energy
28042        MomoFac2 = (1.0d0 - chi2 * sqom1)
28043        RR2  = R2 * R2 / MomoFac2
28044        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28045        fgb2 = sqrt(RR2  + a12sq * ee2)
28046        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28047        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28048             / (fgb2 ** 5.0d0)
28049        dFGBdR2 = ( (R2 / MomoFac2)  &
28050             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28051             / (2.0d0 * fgb2)
28052        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28053             * (2.0d0 - 0.5d0 * ee2) ) &
28054             / (2.0d0 * fgb2)
28055        dPOLdR2 = dPOLdFGB2 * dFGBdR2
28056 !c!       dPOLdR2 = 0.0d0
28057        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28058 !c!       dPOLdOM1 = 0.0d0
28059        dPOLdOM2 = 0.0d0
28060
28061 !c!-------------------------------------------------------------------
28062 !c! Return the results
28063 !c! (See comments in Eqq)
28064        DO k = 1, 3
28065       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28066        END DO
28067        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
28068        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28069        facd2 = d2 * vbld_inv(j+nres)
28070        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
28071        DO k = 1, 3
28072       condor = (erhead_tail(k,2) &
28073        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
28074
28075       gradpepcatx(k,i) = gradpepcatx(k,i) &
28076                - dPOLdR2 * (erhead_tail(k,2) &
28077        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
28078 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
28079 !                   + dPOLdR2 * condor
28080
28081       gradpepcat(k,i) = gradpepcat(k,i) &
28082                - dPOLdR2 * erhead_tail(k,2)
28083       gradpepcat(k,j) = gradpepcat(k,j) &
28084                + dPOLdR2 * erhead_tail(k,2)
28085
28086        END DO
28087       RETURN
28088       END SUBROUTINE enq_cat
28089
28090       SUBROUTINE eqd(Ecl,Elj,Epol)
28091       use calc_data
28092       use comm_momo
28093        double precision  facd4, federmaus,ecl,elj,epol
28094        alphapol1 = alphapol(itypi,itypj)
28095        w1        = wqdip(1,itypi,itypj)
28096        w2        = wqdip(2,itypi,itypj)
28097        pis       = sig0head(itypi,itypj)
28098        eps_head   = epshead(itypi,itypj)
28099 !c!-------------------------------------------------------------------
28100 !c! R1 - distance between head of ith side chain and tail of jth sidechain
28101        R1 = 0.0d0
28102        DO k = 1, 3
28103 !c! Calculate head-to-tail distances
28104       R1=R1+(ctail(k,2)-chead(k,1))**2
28105        END DO
28106 !c! Pitagoras
28107        R1 = dsqrt(R1)
28108
28109 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28110 !c!     &        +dhead(1,1,itypi,itypj))**2))
28111 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28112 !c!     &        +dhead(2,1,itypi,itypj))**2))
28113
28114 !c!-------------------------------------------------------------------
28115 !c! ecl
28116        sparrow  = w1 * Qi * om1
28117        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
28118        Ecl = sparrow / Rhead**2.0d0 &
28119          - hawk    / Rhead**4.0d0
28120        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
28121              + 4.0d0 * hawk    / Rhead**5.0d0
28122 !c! dF/dom1
28123        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
28124 !c! dF/dom2
28125        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
28126 !c--------------------------------------------------------------------
28127 !c Polarization energy
28128 !c Epol
28129        MomoFac1 = (1.0d0 - chi1 * sqom2)
28130        RR1  = R1 * R1 / MomoFac1
28131        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
28132        fgb1 = sqrt( RR1 + a12sq * ee1)
28133        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
28134 !c!       epol = 0.0d0
28135 !c!------------------------------------------------------------------
28136 !c! derivative of Epol is Gpol...
28137        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
28138              / (fgb1 ** 5.0d0)
28139        dFGBdR1 = ( (R1 / MomoFac1)  &
28140            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
28141            / ( 2.0d0 * fgb1 )
28142        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
28143              * (2.0d0 - 0.5d0 * ee1) ) &
28144              / (2.0d0 * fgb1)
28145        dPOLdR1 = dPOLdFGB1 * dFGBdR1
28146 !c!       dPOLdR1 = 0.0d0
28147        dPOLdOM1 = 0.0d0
28148        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
28149 !c!       dPOLdOM2 = 0.0d0
28150 !c!-------------------------------------------------------------------
28151 !c! Elj
28152        pom = (pis / Rhead)**6.0d0
28153        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28154 !c! derivative of Elj is Glj
28155        dGLJdR = 4.0d0 * eps_head &
28156         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28157         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
28158        DO k = 1, 3
28159       erhead(k) = Rhead_distance(k)/Rhead
28160       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
28161        END DO
28162
28163        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28164        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
28165        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
28166        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
28167        facd1 = d1 * vbld_inv(i+nres)
28168        facd2 = d2 * vbld_inv(j+nres)
28169        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
28170
28171        DO k = 1, 3
28172       hawk = (erhead_tail(k,1) +  &
28173       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
28174
28175       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28176       gvdwx(k,i) = gvdwx(k,i)  &
28177                - dGCLdR * pom&
28178                - dPOLdR1 * hawk &
28179                - dGLJdR * pom
28180
28181       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28182       gvdwx(k,j) = gvdwx(k,j)    &
28183                + dGCLdR * pom  &
28184                + dPOLdR1 * (erhead_tail(k,1) &
28185        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
28186                + dGLJdR * pom
28187
28188
28189       gvdwc(k,i) = gvdwc(k,i)          &
28190                - dGCLdR * erhead(k)  &
28191                - dPOLdR1 * erhead_tail(k,1) &
28192                - dGLJdR * erhead(k)
28193
28194       gvdwc(k,j) = gvdwc(k,j)          &
28195                + dGCLdR * erhead(k)  &
28196                + dPOLdR1 * erhead_tail(k,1) &
28197                + dGLJdR * erhead(k)
28198
28199        END DO
28200        RETURN
28201       END SUBROUTINE eqd
28202       SUBROUTINE edq(Ecl,Elj,Epol)
28203 !       IMPLICIT NONE
28204        use comm_momo
28205       use calc_data
28206
28207       double precision  facd3, adler,ecl,elj,epol
28208        alphapol2 = alphapol(itypj,itypi)
28209        w1        = wqdip(1,itypi,itypj)
28210        w2        = wqdip(2,itypi,itypj)
28211        pis       = sig0head(itypi,itypj)
28212        eps_head  = epshead(itypi,itypj)
28213 !c!-------------------------------------------------------------------
28214 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28215        R2 = 0.0d0
28216        DO k = 1, 3
28217 !c! Calculate head-to-tail distances
28218       R2=R2+(chead(k,2)-ctail(k,1))**2
28219        END DO
28220 !c! Pitagoras
28221        R2 = dsqrt(R2)
28222
28223 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28224 !c!     &        +dhead(1,1,itypi,itypj))**2))
28225 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28226 !c!     &        +dhead(2,1,itypi,itypj))**2))
28227
28228
28229 !c!-------------------------------------------------------------------
28230 !c! ecl
28231        sparrow  = w1 * Qj * om1
28232        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
28233        ECL = sparrow / Rhead**2.0d0 &
28234          - hawk    / Rhead**4.0d0
28235 !c!-------------------------------------------------------------------
28236 !c! derivative of ecl is Gcl
28237 !c! dF/dr part
28238        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
28239              + 4.0d0 * hawk    / Rhead**5.0d0
28240 !c! dF/dom1
28241        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
28242 !c! dF/dom2
28243        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
28244 !c--------------------------------------------------------------------
28245 !c Polarization energy
28246 !c Epol
28247        MomoFac2 = (1.0d0 - chi2 * sqom1)
28248        RR2  = R2 * R2 / MomoFac2
28249        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28250        fgb2 = sqrt(RR2  + a12sq * ee2)
28251        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28252        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28253              / (fgb2 ** 5.0d0)
28254        dFGBdR2 = ( (R2 / MomoFac2)  &
28255              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28256              / (2.0d0 * fgb2)
28257        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28258             * (2.0d0 - 0.5d0 * ee2) ) &
28259             / (2.0d0 * fgb2)
28260        dPOLdR2 = dPOLdFGB2 * dFGBdR2
28261 !c!       dPOLdR2 = 0.0d0
28262        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28263 !c!       dPOLdOM1 = 0.0d0
28264        dPOLdOM2 = 0.0d0
28265 !c!-------------------------------------------------------------------
28266 !c! Elj
28267        pom = (pis / Rhead)**6.0d0
28268        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28269 !c! derivative of Elj is Glj
28270        dGLJdR = 4.0d0 * eps_head &
28271          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28272          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
28273 !c!-------------------------------------------------------------------
28274 !c! Return the results
28275 !c! (see comments in Eqq)
28276        DO k = 1, 3
28277       erhead(k) = Rhead_distance(k)/Rhead
28278       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28279        END DO
28280        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28281        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
28282        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
28283        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28284        facd1 = d1 * vbld_inv(i+nres)
28285        facd2 = d2 * vbld_inv(j+nres)
28286        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
28287        DO k = 1, 3
28288       condor = (erhead_tail(k,2) &
28289        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
28290
28291       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28292       gvdwx(k,i) = gvdwx(k,i) &
28293               - dGCLdR * pom &
28294               - dPOLdR2 * (erhead_tail(k,2) &
28295        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
28296               - dGLJdR * pom
28297
28298       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28299       gvdwx(k,j) = gvdwx(k,j) &
28300               + dGCLdR * pom &
28301               + dPOLdR2 * condor &
28302               + dGLJdR * pom
28303
28304
28305       gvdwc(k,i) = gvdwc(k,i) &
28306               - dGCLdR * erhead(k) &
28307               - dPOLdR2 * erhead_tail(k,2) &
28308               - dGLJdR * erhead(k)
28309
28310       gvdwc(k,j) = gvdwc(k,j) &
28311               + dGCLdR * erhead(k) &
28312               + dPOLdR2 * erhead_tail(k,2) &
28313               + dGLJdR * erhead(k)
28314
28315        END DO
28316        RETURN
28317       END SUBROUTINE edq
28318
28319       SUBROUTINE edq_cat(Ecl,Elj,Epol)
28320       use comm_momo
28321       use calc_data
28322
28323       double precision  facd3, adler,ecl,elj,epol
28324        alphapol2 = alphapolcat(itypi,itypj)
28325        w1        = wqdipcat(1,itypi,itypj)
28326        w2        = wqdipcat(2,itypi,itypj)
28327        pis       = sig0headcat(itypi,itypj)
28328        eps_head  = epsheadcat(itypi,itypj)
28329 !c!-------------------------------------------------------------------
28330 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28331        R2 = 0.0d0
28332        DO k = 1, 3
28333 !c! Calculate head-to-tail distances
28334       R2=R2+(chead(k,2)-ctail(k,1))**2
28335        END DO
28336 !c! Pitagoras
28337        R2 = dsqrt(R2)
28338
28339 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28340 !c!     &        +dhead(1,1,itypi,itypj))**2))
28341 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28342 !c!     &        +dhead(2,1,itypi,itypj))**2))
28343
28344
28345 !c!-------------------------------------------------------------------
28346 !c! ecl
28347 !       write(iout,*) "KURWA2",Rhead
28348        sparrow  = w1 * Qj * om1
28349        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
28350        ECL = sparrow / Rhead**2.0d0 &
28351          - hawk    / Rhead**4.0d0
28352 !c!-------------------------------------------------------------------
28353 !c! derivative of ecl is Gcl
28354 !c! dF/dr part
28355        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
28356              + 4.0d0 * hawk    / Rhead**5.0d0
28357 !c! dF/dom1
28358        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
28359 !c! dF/dom2
28360        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
28361 !c--------------------------------------------------------------------
28362 !c--------------------------------------------------------------------
28363 !c Polarization energy
28364 !c Epol
28365        MomoFac2 = (1.0d0 - chi2 * sqom1)
28366        RR2  = R2 * R2 / MomoFac2
28367        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28368        fgb2 = sqrt(RR2  + a12sq * ee2)
28369        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28370        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28371              / (fgb2 ** 5.0d0)
28372        dFGBdR2 = ( (R2 / MomoFac2)  &
28373              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28374              / (2.0d0 * fgb2)
28375        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28376             * (2.0d0 - 0.5d0 * ee2) ) &
28377             / (2.0d0 * fgb2)
28378        dPOLdR2 = dPOLdFGB2 * dFGBdR2
28379 !c!       dPOLdR2 = 0.0d0
28380        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28381 !c!       dPOLdOM1 = 0.0d0
28382        dPOLdOM2 = 0.0d0
28383 !c!-------------------------------------------------------------------
28384 !c! Elj
28385        pom = (pis / Rhead)**6.0d0
28386        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28387 !c! derivative of Elj is Glj
28388        dGLJdR = 4.0d0 * eps_head &
28389          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28390          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
28391 !c!-------------------------------------------------------------------
28392
28393 !c! Return the results
28394 !c! (see comments in Eqq)
28395        DO k = 1, 3
28396       erhead(k) = Rhead_distance(k)/Rhead
28397       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28398        END DO
28399        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28400        erdxj = scalar( erhead(1), dC_norm(1,j) )
28401        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
28402        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
28403        facd1 = d1 * vbld_inv(i+nres)
28404        facd2 = d2 * vbld_inv(j)
28405        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
28406        DO k = 1, 3
28407       condor = (erhead_tail(k,2) &
28408        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
28409
28410       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28411       gradpepcatx(k,i) = gradpepcatx(k,i) &
28412               - dGCLdR * pom &
28413               - dPOLdR2 * (erhead_tail(k,2) &
28414        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
28415               - dGLJdR * pom
28416
28417       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
28418 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
28419 !                  + dGCLdR * pom &
28420 !                  + dPOLdR2 * condor &
28421 !                  + dGLJdR * pom
28422
28423
28424       gradpepcat(k,i) = gradpepcat(k,i) &
28425               - dGCLdR * erhead(k) &
28426               - dPOLdR2 * erhead_tail(k,2) &
28427               - dGLJdR * erhead(k)
28428
28429       gradpepcat(k,j) = gradpepcat(k,j) &
28430               + dGCLdR * erhead(k) &
28431               + dPOLdR2 * erhead_tail(k,2) &
28432               + dGLJdR * erhead(k)
28433
28434        END DO
28435        RETURN
28436       END SUBROUTINE edq_cat
28437
28438       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
28439       use comm_momo
28440       use calc_data
28441
28442       double precision  facd3, adler,ecl,elj,epol
28443        alphapol2 = alphapolcat(itypi,itypj)
28444        w1        = wqdipcat(1,itypi,itypj)
28445        w2        = wqdipcat(2,itypi,itypj)
28446        pis       = sig0headcat(itypi,itypj)
28447        eps_head  = epsheadcat(itypi,itypj)
28448 !c!-------------------------------------------------------------------
28449 !c! R2 - distance between head of jth side chain and tail of ith sidechain
28450        R2 = 0.0d0
28451        DO k = 1, 3
28452 !c! Calculate head-to-tail distances
28453       R2=R2+(chead(k,2)-ctail(k,1))**2
28454        END DO
28455 !c! Pitagoras
28456        R2 = dsqrt(R2)
28457
28458 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
28459 !c!     &        +dhead(1,1,itypi,itypj))**2))
28460 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
28461 !c!     &        +dhead(2,1,itypi,itypj))**2))
28462
28463
28464 !c!-------------------------------------------------------------------
28465 !c! ecl
28466        sparrow  = w1 * Qj * om1
28467        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
28468 !       print *,"CO2", itypi,itypj
28469 !       print *,"CO?!.", w1,w2,Qj,om1
28470        ECL = sparrow / Rhead**2.0d0 &
28471          - hawk    / Rhead**4.0d0
28472 !c!-------------------------------------------------------------------
28473 !c! derivative of ecl is Gcl
28474 !c! dF/dr part
28475        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
28476              + 4.0d0 * hawk    / Rhead**5.0d0
28477 !c! dF/dom1
28478        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
28479 !c! dF/dom2
28480        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
28481 !c--------------------------------------------------------------------
28482 !c--------------------------------------------------------------------
28483 !c Polarization energy
28484 !c Epol
28485        MomoFac2 = (1.0d0 - chi2 * sqom1)
28486        RR2  = R2 * R2 / MomoFac2
28487        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
28488        fgb2 = sqrt(RR2  + a12sq * ee2)
28489        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
28490        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
28491              / (fgb2 ** 5.0d0)
28492        dFGBdR2 = ( (R2 / MomoFac2)  &
28493              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
28494              / (2.0d0 * fgb2)
28495        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
28496             * (2.0d0 - 0.5d0 * ee2) ) &
28497             / (2.0d0 * fgb2)
28498        dPOLdR2 = dPOLdFGB2 * dFGBdR2
28499 !c!       dPOLdR2 = 0.0d0
28500        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
28501 !c!       dPOLdOM1 = 0.0d0
28502        dPOLdOM2 = 0.0d0
28503 !c!-------------------------------------------------------------------
28504 !c! Elj
28505        pom = (pis / Rhead)**6.0d0
28506        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
28507 !c! derivative of Elj is Glj
28508        dGLJdR = 4.0d0 * eps_head &
28509          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
28510          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
28511 !c!-------------------------------------------------------------------
28512
28513 !c! Return the results
28514 !c! (see comments in Eqq)
28515        DO k = 1, 3
28516       erhead(k) = Rhead_distance(k)/Rhead
28517       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
28518        END DO
28519        erdxi = scalar( erhead(1), dC_norm(1,i) )
28520        erdxj = scalar( erhead(1), dC_norm(1,j) )
28521        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
28522        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
28523        facd1 = d1 * vbld_inv(i+1)/2.0
28524        facd2 = d2 * vbld_inv(j)
28525        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
28526        DO k = 1, 3
28527       condor = (erhead_tail(k,2) &
28528        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
28529
28530       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
28531 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
28532 !                  - dGCLdR * pom &
28533 !                  - dPOLdR2 * (erhead_tail(k,2) &
28534 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
28535 !                  - dGLJdR * pom
28536
28537       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
28538 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
28539 !                  + dGCLdR * pom &
28540 !                  + dPOLdR2 * condor &
28541 !                  + dGLJdR * pom
28542
28543
28544       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
28545               - dGCLdR * erhead(k) &
28546               - dPOLdR2 * erhead_tail(k,2) &
28547               - dGLJdR * erhead(k))
28548       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
28549               - dGCLdR * erhead(k) &
28550               - dPOLdR2 * erhead_tail(k,2) &
28551               - dGLJdR * erhead(k))
28552
28553
28554       gradpepcat(k,j) = gradpepcat(k,j) &
28555               + dGCLdR * erhead(k) &
28556               + dPOLdR2 * erhead_tail(k,2) &
28557               + dGLJdR * erhead(k)
28558
28559        END DO
28560        RETURN
28561       END SUBROUTINE edq_cat_pep
28562
28563       SUBROUTINE edd(ECL)
28564 !       IMPLICIT NONE
28565        use comm_momo
28566       use calc_data
28567
28568        double precision ecl
28569 !c!       csig = sigiso(itypi,itypj)
28570        w1 = wqdip(1,itypi,itypj)
28571        w2 = wqdip(2,itypi,itypj)
28572 !c!-------------------------------------------------------------------
28573 !c! ECL
28574        fac = (om12 - 3.0d0 * om1 * om2)
28575        c1 = (w1 / (Rhead**3.0d0)) * fac
28576        c2 = (w2 / Rhead ** 6.0d0) &
28577         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
28578        ECL = c1 - c2
28579 !c!       write (*,*) "w1 = ", w1
28580 !c!       write (*,*) "w2 = ", w2
28581 !c!       write (*,*) "om1 = ", om1
28582 !c!       write (*,*) "om2 = ", om2
28583 !c!       write (*,*) "om12 = ", om12
28584 !c!       write (*,*) "fac = ", fac
28585 !c!       write (*,*) "c1 = ", c1
28586 !c!       write (*,*) "c2 = ", c2
28587 !c!       write (*,*) "Ecl = ", Ecl
28588 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
28589 !c!       write (*,*) "c2_2 = ",
28590 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
28591 !c!-------------------------------------------------------------------
28592 !c! dervative of ECL is GCL...
28593 !c! dECL/dr
28594        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
28595        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
28596         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
28597        dGCLdR = c1 - c2
28598 !c! dECL/dom1
28599        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
28600        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
28601         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
28602        dGCLdOM1 = c1 - c2
28603 !c! dECL/dom2
28604        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
28605        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
28606         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
28607        dGCLdOM2 = c1 - c2
28608 !c! dECL/dom12
28609        c1 = w1 / (Rhead ** 3.0d0)
28610        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
28611        dGCLdOM12 = c1 - c2
28612 !c!-------------------------------------------------------------------
28613 !c! Return the results
28614 !c! (see comments in Eqq)
28615        DO k= 1, 3
28616       erhead(k) = Rhead_distance(k)/Rhead
28617        END DO
28618        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
28619        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
28620        facd1 = d1 * vbld_inv(i+nres)
28621        facd2 = d2 * vbld_inv(j+nres)
28622        DO k = 1, 3
28623
28624       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
28625       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
28626       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
28627       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
28628
28629       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
28630       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
28631        END DO
28632        RETURN
28633       END SUBROUTINE edd
28634       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28635 !       IMPLICIT NONE
28636        use comm_momo
28637       use calc_data
28638
28639        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28640        eps_out=80.0d0
28641        itypi = itype(i,1)
28642        itypj = itype(j,1)
28643 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28644 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28645 !c!       t_bath = 300
28646 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28647        Rb=0.001986d0
28648        BetaT = 1.0d0 / (298.0d0 * Rb)
28649 !c! Gay-berne var's
28650        sig0ij = sigma( itypi,itypj )
28651        chi1   = chi( itypi, itypj )
28652        chi2   = chi( itypj, itypi )
28653        chi12  = chi1 * chi2
28654        chip1  = chipp( itypi, itypj )
28655        chip2  = chipp( itypj, itypi )
28656        chip12 = chip1 * chip2
28657 !       chi1=0.0
28658 !       chi2=0.0
28659 !       chi12=0.0
28660 !       chip1=0.0
28661 !       chip2=0.0
28662 !       chip12=0.0
28663 !c! not used by momo potential, but needed by sc_angular which is shared
28664 !c! by all energy_potential subroutines
28665        alf1   = 0.0d0
28666        alf2   = 0.0d0
28667        alf12  = 0.0d0
28668 !c! location, location, location
28669 !       xj  = c( 1, nres+j ) - xi
28670 !       yj  = c( 2, nres+j ) - yi
28671 !       zj  = c( 3, nres+j ) - zi
28672        dxj = dc_norm( 1, nres+j )
28673        dyj = dc_norm( 2, nres+j )
28674        dzj = dc_norm( 3, nres+j )
28675 !c! distance from center of chain(?) to polar/charged head
28676 !c!       write (*,*) "istate = ", 1
28677 !c!       write (*,*) "ii = ", 1
28678 !c!       write (*,*) "jj = ", 1
28679        d1 = dhead(1, 1, itypi, itypj)
28680        d2 = dhead(2, 1, itypi, itypj)
28681 !c! ai*aj from Fgb
28682        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
28683 !c!       a12sq = a12sq * a12sq
28684 !c! charge of amino acid itypi is...
28685        Qi  = icharge(itypi)
28686        Qj  = icharge(itypj)
28687        Qij = Qi * Qj
28688 !c! chis1,2,12
28689        chis1 = chis(itypi,itypj)
28690        chis2 = chis(itypj,itypi)
28691        chis12 = chis1 * chis2
28692        sig1 = sigmap1(itypi,itypj)
28693        sig2 = sigmap2(itypi,itypj)
28694 !c!       write (*,*) "sig1 = ", sig1
28695 !c!       write (*,*) "sig2 = ", sig2
28696 !c! alpha factors from Fcav/Gcav
28697        b1cav = alphasur(1,itypi,itypj)
28698 !       b1cav=0.0
28699        b2cav = alphasur(2,itypi,itypj)
28700        b3cav = alphasur(3,itypi,itypj)
28701        b4cav = alphasur(4,itypi,itypj)
28702        wqd = wquad(itypi, itypj)
28703 !c! used by Fgb
28704        eps_in = epsintab(itypi,itypj)
28705        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28706 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
28707 !c!-------------------------------------------------------------------
28708 !c! tail location and distance calculations
28709        Rtail = 0.0d0
28710        DO k = 1, 3
28711       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
28712       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
28713        END DO
28714 !c! tail distances will be themselves usefull elswhere
28715 !c1 (in Gcav, for example)
28716        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28717        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28718        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28719        Rtail = dsqrt(  &
28720         (Rtail_distance(1)*Rtail_distance(1))  &
28721       + (Rtail_distance(2)*Rtail_distance(2))  &
28722       + (Rtail_distance(3)*Rtail_distance(3)))
28723 !c!-------------------------------------------------------------------
28724 !c! Calculate location and distance between polar heads
28725 !c! distance between heads
28726 !c! for each one of our three dimensional space...
28727        d1 = dhead(1, 1, itypi, itypj)
28728        d2 = dhead(2, 1, itypi, itypj)
28729
28730        DO k = 1,3
28731 !c! location of polar head is computed by taking hydrophobic centre
28732 !c! and moving by a d1 * dc_norm vector
28733 !c! see unres publications for very informative images
28734       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28735       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
28736 !c! distance
28737 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28738 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28739       Rhead_distance(k) = chead(k,2) - chead(k,1)
28740        END DO
28741 !c! pitagoras (root of sum of squares)
28742        Rhead = dsqrt(   &
28743         (Rhead_distance(1)*Rhead_distance(1)) &
28744       + (Rhead_distance(2)*Rhead_distance(2)) &
28745       + (Rhead_distance(3)*Rhead_distance(3)))
28746 !c!-------------------------------------------------------------------
28747 !c! zero everything that should be zero'ed
28748        Egb = 0.0d0
28749        ECL = 0.0d0
28750        Elj = 0.0d0
28751        Equad = 0.0d0
28752        Epol = 0.0d0
28753        eheadtail = 0.0d0
28754        dGCLdOM1 = 0.0d0
28755        dGCLdOM2 = 0.0d0
28756        dGCLdOM12 = 0.0d0
28757        dPOLdOM1 = 0.0d0
28758        dPOLdOM2 = 0.0d0
28759        RETURN
28760       END SUBROUTINE elgrad_init
28761
28762
28763       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28764       use comm_momo
28765       use calc_data
28766        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28767        eps_out=80.0d0
28768        itypi = itype(i,1)
28769        itypj = itype(j,5)
28770 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28771 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28772 !c!       t_bath = 300
28773 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28774        Rb=0.001986d0
28775        BetaT = 1.0d0 / (298.0d0 * Rb)
28776 !c! Gay-berne var's
28777        sig0ij = sigmacat( itypi,itypj )
28778        chi1   = chi1cat( itypi, itypj )
28779        chi2   = 0.0d0
28780        chi12  = 0.0d0
28781        chip1  = chipp1cat( itypi, itypj )
28782        chip2  = 0.0d0
28783        chip12 = 0.0d0
28784 !c! not used by momo potential, but needed by sc_angular which is shared
28785 !c! by all energy_potential subroutines
28786        alf1   = 0.0d0
28787        alf2   = 0.0d0
28788        alf12  = 0.0d0
28789        dxj = 0.0d0 !dc_norm( 1, nres+j )
28790        dyj = 0.0d0 !dc_norm( 2, nres+j )
28791        dzj = 0.0d0 !dc_norm( 3, nres+j )
28792 !c! distance from center of chain(?) to polar/charged head
28793        d1 = dheadcat(1, 1, itypi, itypj)
28794        d2 = dheadcat(2, 1, itypi, itypj)
28795 !c! ai*aj from Fgb
28796        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28797 !c!       a12sq = a12sq * a12sq
28798 !c! charge of amino acid itypi is...
28799        Qi  = icharge(itypi)
28800        Qj  = ichargecat(itypj)
28801        Qij = Qi * Qj
28802 !c! chis1,2,12
28803        chis1 = chis1cat(itypi,itypj)
28804        chis2 = 0.0d0
28805        chis12 = 0.0d0
28806        sig1 = sigmap1cat(itypi,itypj)
28807        sig2 = sigmap2cat(itypi,itypj)
28808 !c! alpha factors from Fcav/Gcav
28809        b1cav = alphasurcat(1,itypi,itypj)
28810        b2cav = alphasurcat(2,itypi,itypj)
28811        b3cav = alphasurcat(3,itypi,itypj)
28812        b4cav = alphasurcat(4,itypi,itypj)
28813        wqd = wquadcat(itypi, itypj)
28814 !c! used by Fgb
28815        eps_in = epsintabcat(itypi,itypj)
28816        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28817 !c!-------------------------------------------------------------------
28818 !c! tail location and distance calculations
28819        Rtail = 0.0d0
28820        DO k = 1, 3
28821       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
28822       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28823        END DO
28824 !c! tail distances will be themselves usefull elswhere
28825 !c1 (in Gcav, for example)
28826        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28827        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28828        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28829        Rtail = dsqrt(  &
28830         (Rtail_distance(1)*Rtail_distance(1))  &
28831       + (Rtail_distance(2)*Rtail_distance(2))  &
28832       + (Rtail_distance(3)*Rtail_distance(3)))
28833 !c!-------------------------------------------------------------------
28834 !c! Calculate location and distance between polar heads
28835 !c! distance between heads
28836 !c! for each one of our three dimensional space...
28837        d1 = dheadcat(1, 1, itypi, itypj)
28838        d2 = dheadcat(2, 1, itypi, itypj)
28839
28840        DO k = 1,3
28841 !c! location of polar head is computed by taking hydrophobic centre
28842 !c! and moving by a d1 * dc_norm vector
28843 !c! see unres publications for very informative images
28844       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28845       chead(k,2) = c(k, j)
28846 !c! distance
28847 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28848 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28849       Rhead_distance(k) = chead(k,2) - chead(k,1)
28850        END DO
28851 !c! pitagoras (root of sum of squares)
28852        Rhead = dsqrt(   &
28853         (Rhead_distance(1)*Rhead_distance(1)) &
28854       + (Rhead_distance(2)*Rhead_distance(2)) &
28855       + (Rhead_distance(3)*Rhead_distance(3)))
28856 !c!-------------------------------------------------------------------
28857 !c! zero everything that should be zero'ed
28858        Egb = 0.0d0
28859        ECL = 0.0d0
28860        Elj = 0.0d0
28861        Equad = 0.0d0
28862        Epol = 0.0d0
28863        eheadtail = 0.0d0
28864        dGCLdOM1 = 0.0d0
28865        dGCLdOM2 = 0.0d0
28866        dGCLdOM12 = 0.0d0
28867        dPOLdOM1 = 0.0d0
28868        dPOLdOM2 = 0.0d0
28869        RETURN
28870       END SUBROUTINE elgrad_init_cat
28871
28872       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28873       use comm_momo
28874       use calc_data
28875        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28876        eps_out=80.0d0
28877        itypi = 10
28878        itypj = itype(j,5)
28879 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28880 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28881 !c!       t_bath = 300
28882 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28883        Rb=0.001986d0
28884        BetaT = 1.0d0 / (298.0d0 * Rb)
28885 !c! Gay-berne var's
28886        sig0ij = sigmacat( itypi,itypj )
28887        chi1   = chi1cat( itypi, itypj )
28888        chi2   = 0.0d0
28889        chi12  = 0.0d0
28890        chip1  = chipp1cat( itypi, itypj )
28891        chip2  = 0.0d0
28892        chip12 = 0.0d0
28893 !c! not used by momo potential, but needed by sc_angular which is shared
28894 !c! by all energy_potential subroutines
28895        alf1   = 0.0d0
28896        alf2   = 0.0d0
28897        alf12  = 0.0d0
28898        dxj = 0.0d0 !dc_norm( 1, nres+j )
28899        dyj = 0.0d0 !dc_norm( 2, nres+j )
28900        dzj = 0.0d0 !dc_norm( 3, nres+j )
28901 !c! distance from center of chain(?) to polar/charged head
28902        d1 = dheadcat(1, 1, itypi, itypj)
28903        d2 = dheadcat(2, 1, itypi, itypj)
28904 !c! ai*aj from Fgb
28905        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28906 !c!       a12sq = a12sq * a12sq
28907 !c! charge of amino acid itypi is...
28908        Qi  = 0
28909        Qj  = ichargecat(itypj)
28910 !       Qij = Qi * Qj
28911 !c! chis1,2,12
28912        chis1 = chis1cat(itypi,itypj)
28913        chis2 = 0.0d0
28914        chis12 = 0.0d0
28915        sig1 = sigmap1cat(itypi,itypj)
28916        sig2 = sigmap2cat(itypi,itypj)
28917 !c! alpha factors from Fcav/Gcav
28918        b1cav = alphasurcat(1,itypi,itypj)
28919        b2cav = alphasurcat(2,itypi,itypj)
28920        b3cav = alphasurcat(3,itypi,itypj)
28921        b4cav = alphasurcat(4,itypi,itypj)
28922        wqd = wquadcat(itypi, itypj)
28923 !c! used by Fgb
28924        eps_in = epsintabcat(itypi,itypj)
28925        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28926 !c!-------------------------------------------------------------------
28927 !c! tail location and distance calculations
28928        Rtail = 0.0d0
28929        DO k = 1, 3
28930       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
28931       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28932        END DO
28933 !c! tail distances will be themselves usefull elswhere
28934 !c1 (in Gcav, for example)
28935        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28936        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28937        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28938        Rtail = dsqrt(  &
28939         (Rtail_distance(1)*Rtail_distance(1))  &
28940       + (Rtail_distance(2)*Rtail_distance(2))  &
28941       + (Rtail_distance(3)*Rtail_distance(3)))
28942 !c!-------------------------------------------------------------------
28943 !c! Calculate location and distance between polar heads
28944 !c! distance between heads
28945 !c! for each one of our three dimensional space...
28946        d1 = dheadcat(1, 1, itypi, itypj)
28947        d2 = dheadcat(2, 1, itypi, itypj)
28948
28949        DO k = 1,3
28950 !c! location of polar head is computed by taking hydrophobic centre
28951 !c! and moving by a d1 * dc_norm vector
28952 !c! see unres publications for very informative images
28953       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
28954       chead(k,2) = c(k, j)
28955 !c! distance
28956 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28957 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28958       Rhead_distance(k) = chead(k,2) - chead(k,1)
28959        END DO
28960 !c! pitagoras (root of sum of squares)
28961        Rhead = dsqrt(   &
28962         (Rhead_distance(1)*Rhead_distance(1)) &
28963       + (Rhead_distance(2)*Rhead_distance(2)) &
28964       + (Rhead_distance(3)*Rhead_distance(3)))
28965 !c!-------------------------------------------------------------------
28966 !c! zero everything that should be zero'ed
28967        Egb = 0.0d0
28968        ECL = 0.0d0
28969        Elj = 0.0d0
28970        Equad = 0.0d0
28971        Epol = 0.0d0
28972        eheadtail = 0.0d0
28973        dGCLdOM1 = 0.0d0
28974        dGCLdOM2 = 0.0d0
28975        dGCLdOM12 = 0.0d0
28976        dPOLdOM1 = 0.0d0
28977        dPOLdOM2 = 0.0d0
28978        RETURN
28979       END SUBROUTINE elgrad_init_cat_pep
28980
28981       double precision function tschebyshev(m,n,x,y)
28982       implicit none
28983       integer i,m,n
28984       double precision x(n),y,yy(0:maxvar),aux
28985 !c Tschebyshev polynomial. Note that the first term is omitted
28986 !c m=0: the constant term is included
28987 !c m=1: the constant term is not included
28988       yy(0)=1.0d0
28989       yy(1)=y
28990       do i=2,n
28991       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
28992       enddo
28993       aux=0.0d0
28994       do i=m,n
28995       aux=aux+x(i)*yy(i)
28996       enddo
28997       tschebyshev=aux
28998       return
28999       end function tschebyshev
29000 !C--------------------------------------------------------------------------
29001       double precision function gradtschebyshev(m,n,x,y)
29002       implicit none
29003       integer i,m,n
29004       double precision x(n+1),y,yy(0:maxvar),aux
29005 !c Tschebyshev polynomial. Note that the first term is omitted
29006 !c m=0: the constant term is included
29007 !c m=1: the constant term is not included
29008       yy(0)=1.0d0
29009       yy(1)=2.0d0*y
29010       do i=2,n
29011       yy(i)=2*y*yy(i-1)-yy(i-2)
29012       enddo
29013       aux=0.0d0
29014       do i=m,n
29015       aux=aux+x(i+1)*yy(i)*(i+1)
29016 !C        print *, x(i+1),yy(i),i
29017       enddo
29018       gradtschebyshev=aux
29019       return
29020       end function gradtschebyshev
29021 !!!!!!!!!--------------------------------------------------------------
29022       subroutine lipid_bond(elipbond)
29023       real(kind=8) :: elipbond,fac,dist_sub,sumdist
29024       real(kind=8), dimension(3):: dist
29025       integer(kind=8) :: i,j,k,ibra,ityp,jtyp,ityp1
29026       elipbond=0.0d0
29027 !      print *,"before",ilipbond_start,ilipbond_end
29028       do i=ilipbond_start,ilipbond_end
29029 !       print *,i,i+1,"i,i+1"
29030        ityp=itype(i,4)
29031        ityp1=itype(i+1,4)
29032 !       print *,ityp,ityp1,"itype"
29033        j=i+1
29034        if (ityp.eq.12) ibra=i
29035        if ((ityp.eq.ntyp1_molec(4)).or.(ityp1.ge.ntyp1_molec(4)-1)) cycle
29036        if (ityp.eq.(ntyp1_molec(4)-1)) then
29037        !cofniecie do ostatnie GL1
29038 !       i=ibra
29039        j=ibra
29040        else
29041        j=i
29042        endif
29043        jtyp=itype(j,4)
29044        do k=1,3
29045         dist(k)=c(k,j)-c(k,i+1)
29046        enddo
29047        sumdist=0.0d0
29048        do k=1,3
29049        sumdist=sumdist+dist(k)**2
29050        enddo
29051        dist_sub=sqrt(sumdist)
29052 !       print *,"before",i,j,ityp1,ityp,jtyp
29053        elipbond=elipbond+kbondlip*((dist_sub-lip_bond(jtyp,ityp1))**2)
29054        fac=kbondlip*(dist_sub-lip_bond(jtyp,ityp1))
29055        do k=1,3
29056         gradlipbond(k,i+1)= gradlipbond(k,i+1)-fac*dist(k)/dist_sub
29057         gradlipbond(k,j)=gradlipbond(k,j)+fac*dist(k)/dist_sub
29058        enddo
29059       if (energy_dec) write(iout,*) "lipbond",j,i+1,dist_sub,lip_bond(jtyp,ityp1),kbondlip,fac
29060       enddo
29061       elipbond=elipbond*0.5d0
29062       return
29063       end subroutine lipid_bond
29064 !---------------------------------------------------------------------------------------
29065       subroutine lipid_angle(elipang)
29066       real(kind=8) :: elipang,alfa,xa(3),xb(3),alfaact,alfa0,force,fac,&
29067       scalara,vnorm,wnorm,sss,sss_grad,eangle
29068       integer :: i,j,k,l,m,ibra,ityp1,itypm1,itypp1
29069       elipang=0.0d0
29070 !      print *,"ilipang_start,ilipang_end",ilipang_start,ilipang_end
29071       do i=ilipang_start,ilipang_end
29072 !       do i=4,4
29073
29074 ! the loop is centered on the central residue
29075       itypm1=itype(i-1,4)
29076       ityp1=itype(i,4)
29077       itypp1=itype(i+1,4)
29078 !         print *,i,i,j,"processor",fg_rank
29079       j=i-1
29080       k=i
29081       l=i+1
29082       if (ityp1.eq.12) ibra=i
29083       if ((itypm1.eq.ntyp1_molec(4)).or.(ityp1.eq.ntyp1_molec(4))&
29084          .or.(itypp1.eq.ntyp1_molec(4))) cycle !cycle if any of the angles is dummy
29085       if ((itypm1.eq.ntyp1_molec(4)-1).or.(itypp1.eq.ntyp1_molec(4)-1)) cycle
29086      ! branching is only to one angle
29087       if (ityp1.eq.ntyp1_molec(4)-1) then
29088       k=ibra
29089       j=ibra-1
29090       endif
29091       itypm1=itype(j,4)
29092       ityp1=itype(k,4)
29093       do m=1,3
29094       xa(m)=c(m,j)-c(m,k)
29095       xb(m)=c(m,l)-c(m,k)
29096 !      xb(m)=1.0d0
29097       enddo
29098       vnorm=dsqrt(xa(1)*xa(1)+xa(2)*xa(2)+xa(3)*xa(3))
29099       wnorm=dsqrt(xb(1)*xb(1)+xb(2)*xb(2)+xb(3)*xb(3))
29100       scalara=(xa(1)*xb(1)+xa(2)*xb(2)+xa(3)*xb(3))/(vnorm*wnorm)
29101 !      if (((scalar*scalar).gt.0.99999999d0).and.(alfa0.eq.180.0d0)) cycle
29102
29103       alfaact=scalara
29104 !      sss=sscale_martini_angle(alfaact)
29105 !      sss_grad=sscale_grad_martini_angle(alfaact)
29106 !      print *,sss_grad,"sss_grad",sss
29107 !      if (sss.le.0.0) cycle
29108 !      if (sss_grad.ne.0.0) print *,sss_grad,"sss_grad"
29109       force=lip_angle_force(itypm1,ityp1,itypp1)
29110       alfa0=lip_angle_angle(itypm1,ityp1,itypp1)
29111       eangle=force*(alfaact-dcos(alfa0))*(alfaact-dcos(alfa0))*0.5d0
29112       elipang=elipang+eangle!*(1001.0d0-1000.0d0*sss)
29113       fac=force*(alfaact-dcos(alfa0))!*(1001.0d0-1000.0d0*sss)-sss_grad*eangle*1000.0d0
29114       do m=1,3
29115       gradlipang(m,j)=gradlipang(m,j)+(fac &!/dsqrt(1.0d0-scalar*scalar)&
29116         *(xb(m)-scalara*wnorm*xa(m)/vnorm)&
29117        /(vnorm*wnorm))!-sss_grad*eangle*xa(m)/vnorm
29118
29119       gradlipang(m,l)=gradlipang(m,l)+(fac & !/dsqrt(1.0d0-scalar*scalar)&
29120        *(xa(m)-scalara*vnorm*xb(m)/wnorm)&
29121        /(vnorm*wnorm))!+sss_grad*eangle*xb(m)/wnorm
29122
29123       gradlipang(m,k)=gradlipang(m,k)-(fac)&  !/dsqrt(1.0d0-scalar*scalar)&
29124         *(xb(m)-scalara*wnorm*xa(m)/vnorm)&
29125        /((vnorm*wnorm))-(fac & !/dsqrt(1.0d0-scalar*scalar)&
29126        *(xa(m)-scalara*vnorm*xb(m)/wnorm)&
29127        /(vnorm*wnorm))!-sss_grad*eangle*xa(m)/vnorm&
29128                       !-sss_grad*eangle*xb(m)/wnorm
29129
29130
29131 !        *(xb(m)*vnorm*wnorm)&
29132
29133 !-xa(m)*xa(m)*xb(m)*wnorm/vnorm)&
29134       enddo
29135       if (energy_dec) write(iout,*) "elipang",j,k,l,force,alfa0,alfaact,elipang
29136       enddo
29137       return
29138       end subroutine lipid_angle
29139 !--------------------------------------------------------------------
29140       subroutine lipid_lj(eliplj)
29141       real(kind=8) :: eliplj,fac,sumdist,dist_sub,LJ1,LJ2,LJ,&
29142                       xj,yj,zj,xi,yi,zi,sss,sss_grad
29143       real(kind=8), dimension(3):: dist
29144       integer :: i,j,k,inum,ityp,jtyp
29145         eliplj=0.0d0
29146         do inum=iliplj_start,iliplj_end
29147         i=mlipljlisti(inum)
29148         j=mlipljlistj(inum)
29149 !         print *,inum,i,j,"processor",fg_rank
29150         ityp=itype(i,4)
29151         jtyp=itype(j,4)
29152         xi=c(1,i)
29153         yi=c(2,i)
29154         zi=c(3,i)
29155         call to_box(xi,yi,zi)
29156         xj=c(1,j)
29157         yj=c(2,j)
29158         zj=c(3,j)
29159       call to_box(xj,yj,zj)
29160       xj=boxshift(xj-xi,boxxsize)
29161       yj=boxshift(yj-yi,boxysize)
29162       zj=boxshift(zj-zi,boxzsize)
29163          dist(1)=xj
29164          dist(2)=yj
29165          dist(3)=zj
29166        !  do k=1,3
29167        !   dist(k)=c(k,j)-c(k,i)
29168        !  enddo
29169          sumdist=0.0d0
29170          do k=1,3
29171           sumdist=sumdist+dist(k)**2
29172          enddo
29173
29174          dist_sub=sqrt(sumdist)
29175          sss=sscale_martini(dist_sub)
29176          if (energy_dec) write(iout,*) "LJ LIP bef",i,j,ityp,jtyp,dist_sub
29177          if (sss.le.0.0) cycle
29178          sss_grad=sscale_grad_martini(dist_sub)
29179           LJ1 = (lip_sig(ityp,jtyp)/dist_sub)**6
29180           LJ2 = LJ1**2
29181           LJ = LJ2 - LJ1
29182           LJ = 4.0d0*lip_eps(ityp,jtyp)*LJ
29183           eliplj = eliplj + LJ*sss
29184           fac=4.0d0*lip_eps(ityp,jtyp)*(-6.0d0*LJ1/dist_sub+12.0d0*LJ2/dist_sub)
29185          do k=1,3
29186          gradliplj(k,i)=gradliplj(k,i)+fac*dist(k)/dist_sub*sss-sss_grad*LJ*dist(k)/dist_sub
29187          gradliplj(k,j)=gradliplj(k,j)-fac*dist(k)/dist_sub*sss+sss_grad*LJ*dist(k)/dist_sub
29188          enddo
29189          if (energy_dec) write(iout,'(a7,4i5,2f8.3)') "LJ LIP",i,j,ityp,jtyp,LJ,dist_sub
29190         enddo
29191       return
29192       end subroutine lipid_lj
29193 !--------------------------------------------------------------------------------------
29194       subroutine lipid_elec(elipelec)
29195       real(kind=8) :: elipelec,fac,sumdist,dist_sub,xj,yj,zj,xi,yi,zi,EQ,&
29196       sss,sss_grad
29197       real(kind=8), dimension(3):: dist
29198       integer :: i,j,k,inum,ityp,jtyp
29199         elipelec=0.0d0
29200 !        print *,"processor",fg_rank,ilip_elec_start,ilipelec_end
29201         do inum=ilip_elec_start,ilipelec_end
29202          i=mlipeleclisti(inum)
29203          j=mlipeleclistj(inum)
29204 !         print *,inum,i,j,"processor",fg_rank
29205          ityp=itype(i,4)
29206          jtyp=itype(j,4)
29207         xi=c(1,i)
29208         yi=c(2,i)
29209         zi=c(3,i)
29210         call to_box(xi,yi,zi)
29211         xj=c(1,j)
29212         yj=c(2,j)
29213         zj=c(3,j)
29214       call to_box(xj,yj,zj)
29215       xj=boxshift(xj-xi,boxxsize)
29216       yj=boxshift(yj-yi,boxysize)
29217       zj=boxshift(zj-zi,boxzsize)
29218          dist(1)=xj
29219          dist(2)=yj
29220          dist(3)=zj
29221 !         do k=1,3
29222 !          dist(k)=c(k,j)-c(k,i)
29223 !         enddo
29224          sumdist=0.0d0
29225          do k=1,3
29226           sumdist=sumdist+dist(k)**2
29227          enddo
29228          dist_sub=sqrt(sumdist)
29229          sss=sscale_martini(dist_sub)
29230 !         print *,sss,dist_sub
29231           if (energy_dec) write(iout,*) "EQ LIP",sss,dist_sub,i,j
29232          if (sss.le.0.0) cycle
29233          sss_grad=sscale_grad_martini(dist_sub)
29234 !         print *,"sss",sss,sss_grad
29235          EQ=k_coulomb_lip*(ichargelipid(ityp)*ichargelipid(jtyp)/dist_sub)
29236               elipelec=elipelec+EQ*sss
29237          fac=k_coulomb_lip*(ichargelipid(ityp)*ichargelipid(jtyp)/sumdist)*sss
29238          do k=1,3
29239          gradlipelec(k,i)=gradlipelec(k,i)+fac*dist(k)/dist_sub&
29240                                           -sss_grad*EQ*dist(k)/dist_sub
29241          gradlipelec(k,j)=gradlipelec(k,j)-fac*dist(k)/dist_sub&
29242                                           +sss_grad*EQ*dist(k)/dist_sub
29243          enddo
29244           if (energy_dec) write(iout,*) "EQ LIP",i,j,ityp,jtyp,EQ,dist_sub,elipelec
29245         enddo
29246       return
29247       end subroutine lipid_elec
29248 !-------------------------------------------------------------------------
29249       subroutine make_SCSC_inter_list
29250       include 'mpif.h'
29251       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29252       real(kind=8) :: dist_init, dist_temp,r_buff_list
29253       integer:: contlisti(250*nres),contlistj(250*nres)
29254 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
29255       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
29256       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
29257 !            print *,"START make_SC"
29258         r_buff_list=5.0
29259           ilist_sc=0
29260           do i=iatsc_s,iatsc_e
29261            itypi=iabs(itype(i,1))
29262            if (itypi.eq.ntyp1) cycle
29263            xi=c(1,nres+i)
29264            yi=c(2,nres+i)
29265            zi=c(3,nres+i)
29266           call to_box(xi,yi,zi)
29267            do iint=1,nint_gr(i)
29268 !           print *,"is it wrong", iint,i
29269             do j=istart(i,iint),iend(i,iint)
29270              itypj=iabs(itype(j,1))
29271              if (energy_dec) write(iout,*) "LISTA ZAKRES",istart(i,iint),iend(i,iint),iatsc_s,iatsc_e
29272              if (itypj.eq.ntyp1) cycle
29273              xj=c(1,nres+j)
29274              yj=c(2,nres+j)
29275              zj=c(3,nres+j)
29276              call to_box(xj,yj,zj)
29277 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
29278 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
29279           xj=boxshift(xj-xi,boxxsize)
29280           yj=boxshift(yj-yi,boxysize)
29281           zj=boxshift(zj-zi,boxzsize)
29282           dist_init=xj**2+yj**2+zj**2
29283 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
29284 ! r_buff_list is a read value for a buffer
29285              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29286 ! Here the list is created
29287              ilist_sc=ilist_sc+1
29288 ! this can be substituted by cantor and anti-cantor
29289              contlisti(ilist_sc)=i
29290              contlistj(ilist_sc)=j
29291
29292              endif
29293            enddo
29294            enddo
29295            enddo
29296 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
29297 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29298 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
29299 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
29300 #ifdef DEBUG
29301       write (iout,*) "before MPIREDUCE",ilist_sc
29302       do i=1,ilist_sc
29303       write (iout,*) i,contlisti(i),contlistj(i)
29304       enddo
29305 #endif
29306       if (nfgtasks.gt.1)then
29307
29308       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
29309         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29310 !        write(iout,*) "before bcast",g_ilist_sc
29311       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
29312                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
29313       displ(0)=0
29314       do i=1,nfgtasks-1,1
29315         displ(i)=i_ilist_sc(i-1)+displ(i-1)
29316       enddo
29317 !        write(iout,*) "before gather",displ(0),displ(1)
29318       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
29319                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
29320                    king,FG_COMM,IERR)
29321       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
29322                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
29323                    king,FG_COMM,IERR)
29324       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
29325 !        write(iout,*) "before bcast",g_ilist_sc
29326 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29327       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
29328       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
29329
29330 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29331
29332       else
29333       g_ilist_sc=ilist_sc
29334
29335       do i=1,ilist_sc
29336       newcontlisti(i)=contlisti(i)
29337       newcontlistj(i)=contlistj(i)
29338       enddo
29339       endif
29340
29341 #ifdef DEBUG
29342       write (iout,*) "after MPIREDUCE",g_ilist_sc
29343       do i=1,g_ilist_sc
29344       write (iout,*) i,newcontlisti(i),newcontlistj(i)
29345       enddo
29346 #endif
29347       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
29348       return
29349       end subroutine make_SCSC_inter_list
29350 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
29351
29352       subroutine make_SCp_inter_list
29353       use MD_data,  only: itime_mat
29354
29355       include 'mpif.h'
29356       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29357       real(kind=8) :: dist_init, dist_temp,r_buff_list
29358       integer:: contlistscpi(350*nres),contlistscpj(350*nres)
29359 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
29360       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
29361       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
29362 !            print *,"START make_SC"
29363       r_buff_list=5.0
29364           ilist_scp=0
29365       do i=iatscp_s,iatscp_e
29366       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
29367       xi=0.5D0*(c(1,i)+c(1,i+1))
29368       yi=0.5D0*(c(2,i)+c(2,i+1))
29369       zi=0.5D0*(c(3,i)+c(3,i+1))
29370         call to_box(xi,yi,zi)
29371       do iint=1,nscp_gr(i)
29372
29373       do j=iscpstart(i,iint),iscpend(i,iint)
29374         itypj=iabs(itype(j,1))
29375         if (itypj.eq.ntyp1) cycle
29376 ! Uncomment following three lines for SC-p interactions
29377 !         xj=c(1,nres+j)-xi
29378 !         yj=c(2,nres+j)-yi
29379 !         zj=c(3,nres+j)-zi
29380 ! Uncomment following three lines for Ca-p interactions
29381 !          xj=c(1,j)-xi
29382 !          yj=c(2,j)-yi
29383 !          zj=c(3,j)-zi
29384         xj=c(1,j)
29385         yj=c(2,j)
29386         zj=c(3,j)
29387         call to_box(xj,yj,zj)
29388       xj=boxshift(xj-xi,boxxsize)
29389       yj=boxshift(yj-yi,boxysize)
29390       zj=boxshift(zj-zi,boxzsize)
29391       dist_init=xj**2+yj**2+zj**2
29392 #ifdef DEBUG
29393             ! r_buff_list is a read value for a buffer
29394              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
29395 ! Here the list is created
29396              ilist_scp_first=ilist_scp_first+1
29397 ! this can be substituted by cantor and anti-cantor
29398              contlistscpi_f(ilist_scp_first)=i
29399              contlistscpj_f(ilist_scp_first)=j
29400             endif
29401 #endif
29402 ! r_buff_list is a read value for a buffer
29403              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29404 ! Here the list is created
29405              ilist_scp=ilist_scp+1
29406 ! this can be substituted by cantor and anti-cantor
29407              contlistscpi(ilist_scp)=i
29408              contlistscpj(ilist_scp)=j
29409             endif
29410            enddo
29411            enddo
29412            enddo
29413 #ifdef DEBUG
29414       write (iout,*) "before MPIREDUCE",ilist_scp
29415       do i=1,ilist_scp
29416       write (iout,*) i,contlistscpi(i),contlistscpj(i)
29417       enddo
29418 #endif
29419       if (nfgtasks.gt.1)then
29420
29421       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
29422         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29423 !        write(iout,*) "before bcast",g_ilist_sc
29424       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
29425                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
29426       displ(0)=0
29427       do i=1,nfgtasks-1,1
29428         displ(i)=i_ilist_scp(i-1)+displ(i-1)
29429       enddo
29430 !        write(iout,*) "before gather",displ(0),displ(1)
29431       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
29432                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
29433                    king,FG_COMM,IERR)
29434       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
29435                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
29436                    king,FG_COMM,IERR)
29437       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
29438 !        write(iout,*) "before bcast",g_ilist_sc
29439 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29440       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
29441       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
29442
29443 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29444
29445       else
29446       g_ilist_scp=ilist_scp
29447
29448       do i=1,ilist_scp
29449       newcontlistscpi(i)=contlistscpi(i)
29450       newcontlistscpj(i)=contlistscpj(i)
29451       enddo
29452       endif
29453
29454 #ifdef DEBUG
29455       write (iout,*) "after MPIREDUCE",g_ilist_scp
29456       do i=1,g_ilist_scp
29457       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
29458       enddo
29459
29460 !      if (ifirstrun.eq.0) ifirstrun=1
29461 !      do i=1,ilist_scp_first
29462 !       do j=1,g_ilist_scp
29463 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
29464 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
29465 !        enddo
29466 !       print *,itime_mat,"ERROR matrix needs updating"
29467 !       print *,contlistscpi_f(i),contlistscpj_f(i)
29468 !  126  continue
29469 !      enddo
29470 #endif
29471       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
29472
29473       return
29474       end subroutine make_SCp_inter_list
29475
29476 !-----------------------------------------------------------------------------
29477 !-----------------------------------------------------------------------------
29478
29479
29480       subroutine make_pp_inter_list
29481       include 'mpif.h'
29482       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29483       real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
29484       real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
29485       real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
29486       integer:: contlistppi(250*nres),contlistppj(250*nres)
29487 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
29488       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
29489       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
29490 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
29491             ilist_pp=0
29492       r_buff_list=5.0
29493       do i=iatel_s,iatel_e
29494         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
29495         dxi=dc(1,i)
29496         dyi=dc(2,i)
29497         dzi=dc(3,i)
29498         dx_normi=dc_norm(1,i)
29499         dy_normi=dc_norm(2,i)
29500         dz_normi=dc_norm(3,i)
29501         xmedi=c(1,i)+0.5d0*dxi
29502         ymedi=c(2,i)+0.5d0*dyi
29503         zmedi=c(3,i)+0.5d0*dzi
29504
29505         call to_box(xmedi,ymedi,zmedi)
29506         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
29507 !          write (iout,*) i,j,itype(i,1),itype(j,1)
29508 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
29509
29510 ! 1,j)
29511              do j=ielstart(i),ielend(i)
29512 !          write (iout,*) i,j,itype(i,1),itype(j,1)
29513           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
29514           dxj=dc(1,j)
29515           dyj=dc(2,j)
29516           dzj=dc(3,j)
29517           dx_normj=dc_norm(1,j)
29518           dy_normj=dc_norm(2,j)
29519           dz_normj=dc_norm(3,j)
29520 !          xj=c(1,j)+0.5D0*dxj-xmedi
29521 !          yj=c(2,j)+0.5D0*dyj-ymedi
29522 !          zj=c(3,j)+0.5D0*dzj-zmedi
29523           xj=c(1,j)+0.5D0*dxj
29524           yj=c(2,j)+0.5D0*dyj
29525           zj=c(3,j)+0.5D0*dzj
29526           call to_box(xj,yj,zj)
29527 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
29528 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
29529           xj=boxshift(xj-xmedi,boxxsize)
29530           yj=boxshift(yj-ymedi,boxysize)
29531           zj=boxshift(zj-zmedi,boxzsize)
29532           dist_init=xj**2+yj**2+zj**2
29533       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29534 ! Here the list is created
29535                  ilist_pp=ilist_pp+1
29536 ! this can be substituted by cantor and anti-cantor
29537                  contlistppi(ilist_pp)=i
29538                  contlistppj(ilist_pp)=j
29539               endif
29540 !             enddo
29541              enddo
29542              enddo
29543 #ifdef DEBUG
29544       write (iout,*) "before MPIREDUCE",ilist_pp
29545       do i=1,ilist_pp
29546       write (iout,*) i,contlistppi(i),contlistppj(i)
29547       enddo
29548 #endif
29549       if (nfgtasks.gt.1)then
29550
29551         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
29552           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29553 !        write(iout,*) "before bcast",g_ilist_sc
29554         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
29555                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
29556         displ(0)=0
29557         do i=1,nfgtasks-1,1
29558           displ(i)=i_ilist_pp(i-1)+displ(i-1)
29559         enddo
29560 !        write(iout,*) "before gather",displ(0),displ(1)
29561         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
29562                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
29563                          king,FG_COMM,IERR)
29564         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
29565                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
29566                          king,FG_COMM,IERR)
29567         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
29568 !        write(iout,*) "before bcast",g_ilist_sc
29569 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29570         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
29571         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
29572
29573 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29574
29575         else
29576         g_ilist_pp=ilist_pp
29577
29578         do i=1,ilist_pp
29579         newcontlistppi(i)=contlistppi(i)
29580         newcontlistppj(i)=contlistppj(i)
29581         enddo
29582         endif
29583         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
29584 #ifdef DEBUG
29585       write (iout,*) "after MPIREDUCE",g_ilist_pp
29586       do i=1,g_ilist_pp
29587       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
29588       enddo
29589 #endif
29590       return
29591       end subroutine make_pp_inter_list
29592 !---------------------------------------------------------------------------
29593       subroutine make_cat_pep_list
29594       include 'mpif.h'
29595       real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
29596       real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
29597       real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
29598       real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
29599       real(kind=8) :: xja,yja,zja
29600       integer:: contlistcatpnormi(250*nres),contlistcatpnormj(250*nres)
29601       integer:: contlistcatscnormi(250*nres),contlistcatscnormj(250*nres)
29602       integer:: contlistcatptrani(250*nres),contlistcatptranj(250*nres)
29603       integer:: contlistcatsctrani(250*nres),contlistcatsctranj(250*nres)
29604       integer:: contlistcatscangi(250*nres),contlistcatscangj(250*nres)
29605       integer:: contlistcatscangfi(250*nres),contlistcatscangfj(250*nres),&
29606                 contlistcatscangfk(250*nres)
29607       integer:: contlistcatscangti(250*nres),contlistcatscangtj(250*nres)
29608       integer:: contlistcatscangtk(250*nres),contlistcatscangtl(250*nres)
29609
29610
29611 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
29612       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_catscnorm,&
29613               ilist_catsctran,ilist_catpnorm,ilist_catptran,itmp,ilist_catscang,&
29614               ilist_catscangf,ilist_catscangt,k
29615       integer displ(0:nprocs),i_ilist_catscnorm(0:nprocs),ierr,&
29616              i_ilist_catpnorm(0:nprocs),i_ilist_catsctran(0:nprocs),&
29617              i_ilist_catptran(0:nprocs),i_ilist_catscang(0:nprocs),&
29618              i_ilist_catscangf(0:nprocs),i_ilist_catscangt(0:nprocs)
29619 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
29620             ilist_catpnorm=0
29621             ilist_catscnorm=0
29622             ilist_catptran=0
29623             ilist_catsctran=0
29624             ilist_catscang=0
29625
29626
29627       r_buff_list=6.0
29628       itmp=0
29629       do i=1,4
29630       itmp=itmp+nres_molec(i)
29631       enddo
29632 !        go to 17
29633 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
29634       do i=ibond_start,ibond_end
29635
29636 !        print *,"I am in EVDW",i
29637       itypi=iabs(itype(i,1))
29638
29639 !        if (i.ne.47) cycle
29640       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
29641 !      itypi1=iabs(itype(i+1,1))
29642       xi=c(1,nres+i)
29643       yi=c(2,nres+i)
29644       zi=c(3,nres+i)
29645       call to_box(xi,yi,zi)
29646       dxi=dc_norm(1,nres+i)
29647       dyi=dc_norm(2,nres+i)
29648       dzi=dc_norm(3,nres+i)
29649         xmedi=c(1,i)+0.5d0*dxi
29650         ymedi=c(2,i)+0.5d0*dyi
29651         zmedi=c(3,i)+0.5d0*dzi
29652         call to_box(xmedi,ymedi,zmedi)
29653
29654 !      dsci_inv=vbld_inv(i+nres)
29655        do j=itmp+1,itmp+nres_molec(5)
29656           dxj=dc(1,j)
29657           dyj=dc(2,j)
29658           dzj=dc(3,j)
29659           dx_normj=dc_norm(1,j)
29660           dy_normj=dc_norm(2,j)
29661           dz_normj=dc_norm(3,j)
29662           xj=c(1,j)
29663           yj=c(2,j)
29664           zj=c(3,j)
29665           call to_box(xj,yj,zj)
29666 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
29667 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
29668           xja=boxshift(xj-xmedi,boxxsize)
29669           yja=boxshift(yj-ymedi,boxysize)
29670           zja=boxshift(zj-zmedi,boxzsize)
29671           dist_init=xja**2+yja**2+zja**2
29672       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29673 ! Here the list is created
29674               if (itype(j,5).le.5) then
29675                  ilist_catpnorm=ilist_catpnorm+1
29676 ! this can be substituted by cantor and anti-cantor
29677                  contlistcatpnormi(ilist_catpnorm)=i
29678                  contlistcatpnormj(ilist_catpnorm)=j
29679               else
29680                  ilist_catptran=ilist_catptran+1
29681 ! this can be substituted by cantor and anti-cantor
29682                  contlistcatptrani(ilist_catptran)=i
29683                  contlistcatptranj(ilist_catptran)=j
29684               endif
29685        endif
29686           xja=boxshift(xj-xi,boxxsize)
29687           yja=boxshift(yj-yi,boxysize)
29688           zja=boxshift(zj-zi,boxzsize)
29689           dist_init=xja**2+yja**2+zja**2
29690       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
29691 ! Here the list is created
29692               if (itype(j,5).le.5) then
29693                  ilist_catscnorm=ilist_catscnorm+1
29694 ! this can be substituted by cantor and anti-cantor
29695                  contlistcatscnormi(ilist_catscnorm)=i
29696                  contlistcatscnormj(ilist_catscnorm)=j
29697               else
29698                  ilist_catsctran=ilist_catsctran+1
29699 ! this can be substituted by cantor and anti-cantor
29700                  contlistcatsctrani(ilist_catsctran)=i
29701                  contlistcatsctranj(ilist_catsctran)=j
29702 !                 print *,"KUR**",i,j,itype(i,1)
29703                if (((itype(i,1).eq.1).or.(itype(i,1).eq.15).or.&
29704                    (itype(i,1).eq.16).or.(itype(i,1).eq.17)).and.&
29705                    ((sqrt(dist_init).le.(r_cut_ang+r_buff_list)))) then
29706 !                   print *,"KUR**2",i,j,itype(i,1),ilist_catscang+1
29707
29708                    ilist_catscang=ilist_catscang+1
29709                    contlistcatscangi(ilist_catscang)=i
29710                    contlistcatscangj(ilist_catscang)=j
29711                 endif
29712
29713               endif
29714       endif
29715 !             enddo
29716              enddo
29717              enddo
29718 #ifdef DEBUG
29719       write (iout,*) "before MPIREDUCE",ilist_catsctran,ilist_catptran,&
29720       ilist_catscnorm,ilist_catpnorm,ilist_catscang
29721
29722       do i=1,ilist_catsctran
29723       write (iout,*) i,contlistcatsctrani(i),contlistcatsctranj(i)
29724       enddo
29725       do i=1,ilist_catptran
29726       write (iout,*) i,contlistcatptrani(i),contlistcatsctranj(i)
29727       enddo
29728       do i=1,ilist_catscnorm
29729       write (iout,*) i,contlistcatscnormi(i),contlistcatsctranj(i)
29730       enddo
29731       do i=1,ilist_catpnorm
29732       write (iout,*) i,contlistcatpnormi(i),contlistcatsctranj(i)
29733       enddo
29734       do i=1,ilist_catscang
29735       write (iout,*) i,contlistcatscangi(i),contlistcatscangi(i)
29736       enddo
29737
29738
29739 #endif
29740       if (nfgtasks.gt.1)then
29741
29742         call MPI_Reduce(ilist_catsctran,g_ilist_catsctran,1,&
29743           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29744 !        write(iout,*) "before bcast",g_ilist_sc
29745         call MPI_Gather(ilist_catsctran,1,MPI_INTEGER,&
29746                         i_ilist_catsctran,1,MPI_INTEGER,king,FG_COMM,IERR)
29747         displ(0)=0
29748         do i=1,nfgtasks-1,1
29749           displ(i)=i_ilist_catsctran(i-1)+displ(i-1)
29750         enddo
29751 !        write(iout,*) "before gather",displ(0),displ(1)
29752         call MPI_Gatherv(contlistcatsctrani,ilist_catsctran,MPI_INTEGER,&
29753                          newcontlistcatsctrani,i_ilist_catsctran,displ,MPI_INTEGER,&
29754                          king,FG_COMM,IERR)
29755         call MPI_Gatherv(contlistcatsctranj,ilist_catsctran,MPI_INTEGER,&
29756                          newcontlistcatsctranj,i_ilist_catsctran,displ,MPI_INTEGER,&
29757                          king,FG_COMM,IERR)
29758         call MPI_Bcast(g_ilist_catsctran,1,MPI_INT,king,FG_COMM,IERR)
29759 !        write(iout,*) "before bcast",g_ilist_sc
29760 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29761         call MPI_Bcast(newcontlistcatsctrani,g_ilist_catsctran,MPI_INT,king,FG_COMM,IERR)
29762         call MPI_Bcast(newcontlistcatsctranj,g_ilist_catsctran,MPI_INT,king,FG_COMM,IERR)
29763
29764
29765         call MPI_Reduce(ilist_catptran,g_ilist_catptran,1,&
29766           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29767 !        write(iout,*) "before bcast",g_ilist_sc
29768         call MPI_Gather(ilist_catptran,1,MPI_INTEGER,&
29769                         i_ilist_catptran,1,MPI_INTEGER,king,FG_COMM,IERR)
29770         displ(0)=0
29771         do i=1,nfgtasks-1,1
29772           displ(i)=i_ilist_catptran(i-1)+displ(i-1)
29773         enddo
29774 !        write(iout,*) "before gather",displ(0),displ(1)
29775         call MPI_Gatherv(contlistcatptrani,ilist_catptran,MPI_INTEGER,&
29776                          newcontlistcatptrani,i_ilist_catptran,displ,MPI_INTEGER,&
29777                          king,FG_COMM,IERR)
29778         call MPI_Gatherv(contlistcatptranj,ilist_catptran,MPI_INTEGER,&
29779                          newcontlistcatptranj,i_ilist_catptran,displ,MPI_INTEGER,&
29780                          king,FG_COMM,IERR)
29781         call MPI_Bcast(g_ilist_catptran,1,MPI_INT,king,FG_COMM,IERR)
29782 !        write(iout,*) "before bcast",g_ilist_sc
29783 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29784         call MPI_Bcast(newcontlistcatptrani,g_ilist_catptran,MPI_INT,king,FG_COMM,IERR)
29785         call MPI_Bcast(newcontlistcatptranj,g_ilist_catptran,MPI_INT,king,FG_COMM,IERR)
29786
29787 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29788
29789         call MPI_Reduce(ilist_catscnorm,g_ilist_catscnorm,1,&
29790           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29791 !        write(iout,*) "before bcast",g_ilist_sc
29792         call MPI_Gather(ilist_catscnorm,1,MPI_INTEGER,&
29793                         i_ilist_catscnorm,1,MPI_INTEGER,king,FG_COMM,IERR)
29794         displ(0)=0
29795         do i=1,nfgtasks-1,1
29796           displ(i)=i_ilist_catscnorm(i-1)+displ(i-1)
29797         enddo
29798 !        write(iout,*) "before gather",displ(0),displ(1)
29799         call MPI_Gatherv(contlistcatscnormi,ilist_catscnorm,MPI_INTEGER,&
29800                          newcontlistcatscnormi,i_ilist_catscnorm,displ,MPI_INTEGER,&
29801                          king,FG_COMM,IERR)
29802         call MPI_Gatherv(contlistcatscnormj,ilist_catscnorm,MPI_INTEGER,&
29803                          newcontlistcatscnormj,i_ilist_catscnorm,displ,MPI_INTEGER,&
29804                          king,FG_COMM,IERR)
29805         call MPI_Bcast(g_ilist_catscnorm,1,MPI_INT,king,FG_COMM,IERR)
29806 !        write(iout,*) "before bcast",g_ilist_sc
29807 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29808         call MPI_Bcast(newcontlistcatscnormi,g_ilist_catscnorm,MPI_INT,king,FG_COMM,IERR)
29809         call MPI_Bcast(newcontlistcatscnormj,g_ilist_catscnorm,MPI_INT,king,FG_COMM,IERR)
29810
29811
29812
29813         call MPI_Reduce(ilist_catpnorm,g_ilist_catpnorm,1,&
29814           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29815 !        write(iout,*) "before bcast",g_ilist_sc
29816         call MPI_Gather(ilist_catpnorm,1,MPI_INTEGER,&
29817                         i_ilist_catpnorm,1,MPI_INTEGER,king,FG_COMM,IERR)
29818         displ(0)=0
29819         do i=1,nfgtasks-1,1
29820           displ(i)=i_ilist_catpnorm(i-1)+displ(i-1)
29821         enddo
29822 !        write(iout,*) "before gather",displ(0),displ(1)
29823         call MPI_Gatherv(contlistcatpnormi,ilist_catpnorm,MPI_INTEGER,&
29824                          newcontlistcatpnormi,i_ilist_catpnorm,displ,MPI_INTEGER,&
29825                          king,FG_COMM,IERR)
29826         call MPI_Gatherv(contlistcatpnormj,ilist_catpnorm,MPI_INTEGER,&
29827                          newcontlistcatpnormj,i_ilist_catpnorm,displ,MPI_INTEGER,&
29828                          king,FG_COMM,IERR)
29829         call MPI_Bcast(g_ilist_catpnorm,1,MPI_INT,king,FG_COMM,IERR)
29830 !        write(iout,*) "before bcast",g_ilist_sc
29831 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29832         call MPI_Bcast(newcontlistcatpnormi,g_ilist_catpnorm,MPI_INT,king,FG_COMM,IERR)
29833         call MPI_Bcast(newcontlistcatpnormj,g_ilist_catpnorm,MPI_INT,king,FG_COMM,IERR)
29834
29835
29836
29837         call MPI_Reduce(ilist_catscang,g_ilist_catscang,1,&
29838           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29839 !        write(iout,*) "before bcast",g_ilist_sc
29840         call MPI_Gather(ilist_catscang,1,MPI_INTEGER,&
29841                         i_ilist_catscang,1,MPI_INTEGER,king,FG_COMM,IERR)
29842         displ(0)=0
29843         do i=1,nfgtasks-1,1
29844           displ(i)=i_ilist_catscang(i-1)+displ(i-1)
29845         enddo
29846 !        write(iout,*) "before gather",displ(0),displ(1)
29847         call MPI_Gatherv(contlistcatscangi,ilist_catscang,MPI_INTEGER,&
29848                          newcontlistcatscangi,i_ilist_catscang,displ,MPI_INTEGER,&
29849                          king,FG_COMM,IERR)
29850         call MPI_Gatherv(contlistcatscangj,ilist_catscang,MPI_INTEGER,&
29851                          newcontlistcatscangj,i_ilist_catscang,displ,MPI_INTEGER,&
29852                          king,FG_COMM,IERR)
29853         call MPI_Bcast(g_ilist_catscang,1,MPI_INT,king,FG_COMM,IERR)
29854 !        write(iout,*) "before bcast",g_ilist_sc
29855 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29856         call MPI_Bcast(newcontlistcatscangi,g_ilist_catscang,MPI_INT,king,FG_COMM,IERR)
29857         call MPI_Bcast(newcontlistcatscangj,g_ilist_catscang,MPI_INT,king,FG_COMM,IERR)
29858
29859
29860         else
29861         g_ilist_catscnorm=ilist_catscnorm
29862         g_ilist_catsctran=ilist_catsctran
29863         g_ilist_catpnorm=ilist_catpnorm
29864         g_ilist_catptran=ilist_catptran
29865         g_ilist_catscang=ilist_catscang
29866
29867
29868         do i=1,ilist_catscnorm
29869         newcontlistcatscnormi(i)=contlistcatscnormi(i)
29870         newcontlistcatscnormj(i)=contlistcatscnormj(i)
29871         enddo
29872         do i=1,ilist_catpnorm
29873         newcontlistcatpnormi(i)=contlistcatpnormi(i)
29874         newcontlistcatpnormj(i)=contlistcatpnormj(i)
29875         enddo
29876         do i=1,ilist_catsctran
29877         newcontlistcatsctrani(i)=contlistcatsctrani(i)
29878         newcontlistcatsctranj(i)=contlistcatsctranj(i)
29879         enddo
29880         do i=1,ilist_catptran
29881         newcontlistcatptrani(i)=contlistcatptrani(i)
29882         newcontlistcatptranj(i)=contlistcatptranj(i)
29883         enddo
29884
29885         do i=1,ilist_catscang
29886         newcontlistcatscangi(i)=contlistcatscangi(i)
29887         newcontlistcatscangj(i)=contlistcatscangj(i)
29888         enddo
29889
29890
29891         endif
29892         call int_bounds(g_ilist_catsctran,g_listcatsctran_start,g_listcatsctran_end)
29893         call int_bounds(g_ilist_catptran,g_listcatptran_start,g_listcatptran_end)
29894         call int_bounds(g_ilist_catscnorm,g_listcatscnorm_start,g_listcatscnorm_end)
29895         call int_bounds(g_ilist_catpnorm,g_listcatpnorm_start,g_listcatpnorm_end)
29896         call int_bounds(g_ilist_catscang,g_listcatscang_start,g_listcatscang_end)
29897 ! make new ang list
29898         ilist_catscangf=0
29899         do i=g_listcatscang_start,g_listcatscang_end
29900          do j=2,g_ilist_catscang
29901 !          print *,"RWA",i,j,contlistcatscangj(i),contlistcatscangj(j)
29902           if (j.le.i) cycle
29903           if (newcontlistcatscangj(i).ne.newcontlistcatscangj(j)) cycle
29904                    ilist_catscangf=ilist_catscangf+1
29905                    contlistcatscangfi(ilist_catscangf)=newcontlistcatscangi(i)
29906                    contlistcatscangfj(ilist_catscangf)=newcontlistcatscangj(i)
29907                    contlistcatscangfk(ilist_catscangf)=newcontlistcatscangi(j)
29908 !          print *,"TUTU",g_listcatscang_start,g_listcatscang_end,i,j,g_ilist_catscangf,myrank
29909          enddo
29910         enddo
29911       if (nfgtasks.gt.1)then
29912
29913         call MPI_Reduce(ilist_catscangf,g_ilist_catscangf,1,&
29914           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29915 !        write(iout,*) "before bcast",g_ilist_sc
29916         call MPI_Gather(ilist_catscangf,1,MPI_INTEGER,&
29917                         i_ilist_catscangf,1,MPI_INTEGER,king,FG_COMM,IERR)
29918         displ(0)=0
29919         do i=1,nfgtasks-1,1
29920           displ(i)=i_ilist_catscangf(i-1)+displ(i-1)
29921         enddo
29922 !        write(iout,*) "before gather",displ(0),displ(1)
29923         call MPI_Gatherv(contlistcatscangfi,ilist_catscangf,MPI_INTEGER,&
29924                          newcontlistcatscangfi,i_ilist_catscangf,displ,MPI_INTEGER,&
29925                          king,FG_COMM,IERR)
29926         call MPI_Gatherv(contlistcatscangfj,ilist_catscangf,MPI_INTEGER,&
29927                          newcontlistcatscangfj,i_ilist_catscangf,displ,MPI_INTEGER,&
29928                          king,FG_COMM,IERR)
29929         call MPI_Gatherv(contlistcatscangfk,ilist_catscangf,MPI_INTEGER,&
29930                          newcontlistcatscangfk,i_ilist_catscangf,displ,MPI_INTEGER,&
29931                          king,FG_COMM,IERR)
29932
29933         call MPI_Bcast(g_ilist_catscangf,1,MPI_INT,king,FG_COMM,IERR)
29934 !        write(iout,*) "before bcast",g_ilist_sc
29935 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
29936         call MPI_Bcast(newcontlistcatscangfi,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR)
29937         call MPI_Bcast(newcontlistcatscangfj,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR)
29938         call MPI_Bcast(newcontlistcatscangfk,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR)
29939         else
29940         g_ilist_catscangf=ilist_catscangf
29941         do i=1,ilist_catscangf
29942         newcontlistcatscangfi(i)=contlistcatscangfi(i)
29943         newcontlistcatscangfj(i)=contlistcatscangfj(i)
29944         newcontlistcatscangfk(i)=contlistcatscangfk(i)
29945         enddo
29946         endif
29947         call int_bounds(g_ilist_catscangf,g_listcatscangf_start,g_listcatscangf_end)
29948
29949
29950         ilist_catscangt=0
29951         do i=g_listcatscang_start,g_listcatscang_end
29952          do j=1,g_ilist_catscang
29953          do k=1,g_ilist_catscang
29954 !          print *,"TUTU1",g_listcatscang_start,g_listcatscang_end,i,j
29955
29956           if (newcontlistcatscangj(i).ne.newcontlistcatscangj(j)) cycle
29957           if (newcontlistcatscangj(i).ne.newcontlistcatscangj(k)) cycle
29958           if (newcontlistcatscangj(k).ne.newcontlistcatscangj(j)) cycle
29959           if (newcontlistcatscangi(i).eq.newcontlistcatscangi(j)) cycle
29960           if (newcontlistcatscangi(i).eq.newcontlistcatscangi(k)) cycle
29961           if (newcontlistcatscangi(k).eq.newcontlistcatscangi(j)) cycle
29962 !          print *,"TUTU2",g_listcatscang_start,g_listcatscang_end,i,j
29963
29964                    ilist_catscangt=ilist_catscangt+1
29965                    contlistcatscangti(ilist_catscangt)=newcontlistcatscangi(i)
29966                    contlistcatscangtj(ilist_catscangt)=newcontlistcatscangj(i)
29967                    contlistcatscangtk(ilist_catscangt)=newcontlistcatscangi(j)
29968                    contlistcatscangtl(ilist_catscangt)=newcontlistcatscangi(k)
29969
29970          enddo
29971         enddo
29972        enddo
29973       if (nfgtasks.gt.1)then
29974
29975         call MPI_Reduce(ilist_catscangt,g_ilist_catscangt,1,&
29976           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
29977 !        write(iout,*) "before bcast",g_ilist_sc
29978         call MPI_Gather(ilist_catscangt,1,MPI_INTEGER,&
29979                         i_ilist_catscangt,1,MPI_INTEGER,king,FG_COMM,IERR)
29980         displ(0)=0
29981         do i=1,nfgtasks-1,1
29982           displ(i)=i_ilist_catscangt(i-1)+displ(i-1)
29983         enddo
29984 !        write(iout,*) "before gather",displ(0),displ(1)
29985         call MPI_Gatherv(contlistcatscangti,ilist_catscangt,MPI_INTEGER,&
29986                          newcontlistcatscangti,i_ilist_catscangt,displ,MPI_INTEGER,&
29987                          king,FG_COMM,IERR)
29988         call MPI_Gatherv(contlistcatscangtj,ilist_catscangt,MPI_INTEGER,&
29989                          newcontlistcatscangtj,i_ilist_catscangt,displ,MPI_INTEGER,&
29990                          king,FG_COMM,IERR)
29991         call MPI_Gatherv(contlistcatscangtk,ilist_catscangt,MPI_INTEGER,&
29992                          newcontlistcatscangtk,i_ilist_catscangt,displ,MPI_INTEGER,&
29993                          king,FG_COMM,IERR)
29994         call MPI_Gatherv(contlistcatscangtl,ilist_catscangt,MPI_INTEGER,&
29995                          newcontlistcatscangtl,i_ilist_catscangt,displ,MPI_INTEGER,&
29996                          king,FG_COMM,IERR)
29997
29998         call MPI_Bcast(g_ilist_catscangt,1,MPI_INT,king,FG_COMM,IERR)
29999 !        write(iout,*) "before bcast",g_ilist_sc
30000 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
30001         call MPI_Bcast(newcontlistcatscangti,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30002         call MPI_Bcast(newcontlistcatscangtj,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30003         call MPI_Bcast(newcontlistcatscangtk,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30004         call MPI_Bcast(newcontlistcatscangtl,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR)
30005
30006         else
30007         g_ilist_catscangt=ilist_catscangt
30008         do i=1,ilist_catscangt
30009         newcontlistcatscangti(i)=contlistcatscangti(i)
30010         newcontlistcatscangtj(i)=contlistcatscangtj(i)
30011         newcontlistcatscangtk(i)=contlistcatscangtk(i)
30012         newcontlistcatscangtl(i)=contlistcatscangtl(i)
30013         enddo
30014         endif
30015         call int_bounds(g_ilist_catscangt,g_listcatscangt_start,g_listcatscangt_end)
30016
30017
30018
30019
30020
30021 #ifdef DEBUG
30022       write (iout,*) "after MPIREDUCE",ilist_catsctran,ilist_catptran, &
30023       ilist_catscnorm,ilist_catpnorm
30024
30025       do i=1,g_ilist_catsctran
30026       write (iout,*) i,newcontlistcatsctrani(i),newcontlistcatsctranj(i)
30027       enddo
30028       do i=1,g_ilist_catptran
30029       write (iout,*) i,newcontlistcatptrani(i),newcontlistcatsctranj(i)
30030       enddo
30031       do i=1,g_ilist_catscnorm
30032       write (iout,*) i,newcontlistcatscnormi(i),newcontlistcatscnormj(i)
30033       enddo
30034       do i=1,g_ilist_catpnorm
30035       write (iout,*) i,newcontlistcatpnormi(i),newcontlistcatscnormj(i)
30036       enddo
30037       do i=1,g_ilist_catscang
30038       write (iout,*) i,newcontlistcatscangi(i),newcontlistcatscangj(i)
30039       enddo
30040 #endif
30041       return
30042       end subroutine make_cat_pep_list
30043
30044
30045
30046 !-----------------------------------------------------------------------------
30047       double precision function boxshift(x,boxsize)
30048       implicit none
30049       double precision x,boxsize
30050       double precision xtemp
30051       xtemp=dmod(x,boxsize)
30052       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
30053         boxshift=xtemp-boxsize
30054       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
30055         boxshift=xtemp+boxsize
30056       else
30057         boxshift=xtemp
30058       endif
30059       return
30060       end function boxshift
30061 !-----------------------------------------------------------------------------
30062       subroutine to_box(xi,yi,zi)
30063       implicit none
30064 !      include 'DIMENSIONS'
30065 !      include 'COMMON.CHAIN'
30066       double precision xi,yi,zi
30067       xi=dmod(xi,boxxsize)
30068       if (xi.lt.0.0d0) xi=xi+boxxsize
30069       yi=dmod(yi,boxysize)
30070       if (yi.lt.0.0d0) yi=yi+boxysize
30071       zi=dmod(zi,boxzsize)
30072       if (zi.lt.0.0d0) zi=zi+boxzsize
30073       return
30074       end subroutine to_box
30075 !--------------------------------------------------------------------------
30076       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
30077       implicit none
30078 !      include 'DIMENSIONS'
30079 !      include 'COMMON.IOUNITS'
30080 !      include 'COMMON.CHAIN'
30081       double precision xi,yi,zi,sslipi,ssgradlipi
30082       double precision fracinbuf
30083 !      double precision sscalelip,sscagradlip
30084 #ifdef DEBUG
30085       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
30086       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
30087       write (iout,*) "xi yi zi",xi,yi,zi
30088 #endif
30089       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
30090 ! the energy transfer exist
30091         if (zi.lt.buflipbot) then
30092 ! what fraction I am in
30093           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
30094 ! lipbufthick is thickenes of lipid buffore
30095           sslipi=sscalelip(fracinbuf)
30096           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
30097         elseif (zi.gt.bufliptop) then
30098           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
30099           sslipi=sscalelip(fracinbuf)
30100           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
30101         else
30102           sslipi=1.0d0
30103           ssgradlipi=0.0
30104         endif
30105       else
30106         sslipi=0.0d0
30107         ssgradlipi=0.0
30108       endif
30109 #ifdef DEBUG
30110       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
30111 #endif
30112       return
30113       end subroutine lipid_layer
30114 !-------------------------------------------------------------
30115       subroutine ecat_prot_transition(ecation_prottran)
30116       integer:: itypi,itypj,ityptrani,ityptranj,k,l,i,j
30117       real(kind=8),dimension(3):: cjtemp,citemp,diff,dsctemp,vecsc,&
30118                   diffnorm,boxx,r,dEvan1Cm,dEvan2Cm,dEtotalCm
30119       real(kind=8):: ecation_prottran,dista,sdist,De,ene,x0left,&
30120                     alphac,grad,sumvec,simplesum,pom,erdxi,facd1,&
30121                     sss_ele_cut,sss_ele_cut_grad,sss2min,sss2mingrad,&
30122                     ene1,ene2,grad1,grad2,evan1,evan2,rcal,r4,r7,r0p,&
30123                     r06,r012,epscalc,rocal,ract
30124       ecation_prottran=0.0d0
30125       boxx(1)=boxxsize
30126       boxx(2)=boxysize
30127       boxx(3)=boxzsize
30128       do k=g_listcatsctran_start,g_listcatsctran_end
30129         i=newcontlistcatsctrani(k)
30130         j=newcontlistcatsctranj(k)
30131 !        print *,i,j,"in new tran"
30132         do  l=1,3
30133           citemp(l)=c(l,i+nres)
30134           cjtemp(l)=c(l,j)
30135          enddo
30136
30137          itypi=itype(i,1) !as the first is the protein part
30138          itypj=itype(j,5) !as the second part is always cation
30139 ! remapping to internal types
30140 !       read (iiontran,*,err=123,end=123) (agamacattran(k,j,i),k=1,3),&
30141 !       (athetacattran(k,j,i),k=1,6),acatshiftdsc(j,i),bcatshiftdsc(j,i),&
30142 !       demorsecat(j,i),alphamorsecat(j,i),x0catleft(j,i),x0catright(j,i),&
30143 !       x0cattrans(j,i)
30144
30145          if (itypj.eq.6) then
30146           ityptranj=1 !as now only Zn2+ is this needs to be modified for other ions
30147          endif
30148          if (itypi.eq.16) then
30149           ityptrani=1
30150          elseif (itypi.eq.1)  then
30151           ityptrani=2
30152          elseif (itypi.eq.15) then
30153           ityptrani=3
30154          elseif (itypi.eq.17) then
30155           ityptrani=4
30156          elseif (itypi.eq.2)  then
30157           ityptrani=5
30158          else
30159           ityptrani=6
30160          endif
30161
30162          if (ityptrani.gt.ntrantyp(ityptranj)) then
30163 !         do l=1,3
30164 !         write(iout,*),gradcattranc(l,j),gradcattranx(l,i)
30165 !         enddo
30166 !volume excluded
30167          call to_box(cjtemp(1),cjtemp(2),cjtemp(3))
30168          call to_box(citemp(1),citemp(2),citemp(3))
30169          rcal=0.0d0
30170          do l=1,3
30171          r(l)=boxshift(cjtemp(l)-citemp(l),boxx(l))
30172          rcal=rcal+r(l)*r(l)
30173          enddo
30174          ract=sqrt(rcal)
30175          if (ract.gt.r_cut_ele) cycle
30176          sss_ele_cut=sscale_ele(ract)
30177          sss_ele_cut_grad=sscagrad_ele(ract)
30178           rocal=1.5
30179           epscalc=0.2
30180           r0p=0.5*(rocal+sig0(itype(i,1)))
30181           r06 = r0p**6
30182           r012 = r06*r06
30183           Evan1=epscalc*(r012/rcal**6)
30184           Evan2=epscalc*2*(r06/rcal**3)
30185           r4 = rcal**4
30186           r7 = rcal**7
30187           do l=1,3
30188             dEvan1Cm(l) = 12*r(l)*epscalc*r012/r7
30189             dEvan2Cm(l) = 12*r(l)*epscalc*r06/r4
30190           enddo
30191           do l=1,3
30192             dEtotalCm(l)=(dEvan1Cm(l)+dEvan2Cm(l))*sss_ele_cut-&
30193                          (Evan1+Evan2)*sss_ele_cut_grad*r(l)/ract
30194           enddo
30195              ecation_prottran = ecation_prottran+&
30196              (Evan1+Evan2)*sss_ele_cut
30197           do  l=1,3
30198             gradcattranx(l,i)=gradcattranx(l,i)+dEtotalCm(l)
30199             gradcattranc(l,i)=gradcattranc(l,i)+dEtotalCm(l)
30200             gradcattranc(l,j)=gradcattranc(l,j)-dEtotalCm(l)
30201            enddo
30202
30203          ene=0.0d0
30204          else
30205 !         cycle
30206          sumvec=0.0d0
30207          simplesum=0.0d0
30208          do l=1,3
30209          vecsc(l)=citemp(l)-c(l,i)
30210          sumvec=sumvec+vecsc(l)**2
30211          simplesum=simplesum+vecsc(l)
30212          enddo
30213          sumvec=dsqrt(sumvec)
30214          call to_box(cjtemp(1),cjtemp(2),cjtemp(3))
30215          call to_box(citemp(1),citemp(2),citemp(3))
30216 !         sumvec=2.0d0
30217          do l=1,3
30218          dsctemp(l)=c(l,i+nres)&
30219                     +(acatshiftdsc(ityptrani,ityptranj)-1.0d0)*vecsc(l)&
30220                     +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec
30221          enddo
30222          call to_box(dsctemp(1),dsctemp(2),dsctemp(3))
30223          sdist=0.0d0
30224          do l=1,3
30225             diff(l)=boxshift(dsctemp(l)-cjtemp(l),boxx(l))
30226            sdist=sdist+diff(l)*diff(l)
30227          enddo
30228          dista=sqrt(sdist)
30229          if (dista.gt.r_cut_ele) cycle
30230
30231          sss_ele_cut=sscale_ele(dista)
30232          sss_ele_cut_grad=sscagrad_ele(dista)
30233          sss2min=sscale2(dista,x0cattrans(ityptrani,ityptranj)-0.1d0,0.2d0)
30234          De=demorsecat(ityptrani,ityptranj)
30235          alphac=alphamorsecat(ityptrani,ityptranj)
30236          if (sss2min.eq.1.0d0) then
30237 !         print *,"ityptrani",ityptrani,ityptranj
30238          x0left=x0catleft(ityptrani,ityptranj) ! to mn
30239          ene=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30240          grad=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30241               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30242               +ene/sss_ele_cut*sss_ele_cut_grad
30243           else if (sss2min.eq.0.0d0) then
30244          x0left=x0catright(ityptrani,ityptranj)
30245          ene=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30246          grad=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30247               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30248               +ene/sss_ele_cut*sss_ele_cut_grad
30249           else
30250          sss2mingrad=sscagrad2(dista,x0cattrans(ityptrani,ityptranj)-0.1d0,0.2d0)
30251          x0left=x0catleft(ityptrani,ityptranj)
30252          ene1=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30253          grad1=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30254               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30255               +ene/sss_ele_cut*sss_ele_cut_grad
30256          x0left=x0catright(ityptrani,ityptranj)
30257          ene2=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2)
30258          grad2=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*&
30259               (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut&
30260               +ene/sss_ele_cut*sss_ele_cut_grad
30261          ene=sss2min*ene1+(1.0d0-sss2min)*ene2
30262          grad=sss2min*grad1+(1.0d0-sss2min)*grad2+sss2mingrad*(ene1-ene2)
30263          endif
30264          do l=1,3
30265            diffnorm(l)= diff(l)/dista
30266           enddo
30267           erdxi=scalar(diffnorm(1),dc_norm(1,i+nres))
30268           facd1=bcatshiftdsc(ityptrani,ityptranj)/sumvec
30269
30270          do l=1,3
30271 !       DO k= 1, 3
30272 !      ertail(k) = Rtail_distance(k)/Rtail
30273 !       END DO
30274 !       erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
30275 !       erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
30276 !      facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
30277 !       facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
30278 !       DO k = 1, 3
30279 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
30280 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
30281 !      pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
30282 !      gvdwx(k,i) = gvdwx(k,i) &
30283 !              - (( dFdR + gg(k) ) * pom)
30284          pom=diffnorm(l)+facd1*(diffnorm(l)-erdxi*dc_norm(l,i+nres))
30285 !         write(iout,*),gradcattranc(l,j),gradcattranx(l,i),grad*diff(l)/dista
30286
30287          gradcattranx(l,i)=gradcattranx(l,i)+grad*pom&
30288          +grad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0)
30289 !         *( bcatshiftdsc(ityptrani,ityptranj)*&
30290 !          (1.0d0/sumvec-(vecsc(l)*simplesum)*(sumvec**(-3.0d0))))
30291          gradcattranc(l,i)=gradcattranc(l,i)+grad*diff(l)/dista
30292 !                          +sss_ele_cut_grad*ene*diff(l)/dista/sss_ele_cut
30293          gradcattranc(l,j)=gradcattranc(l,j)-grad*diff(l)/dista
30294 !         -sss_ele_cut_grad*ene*diff(l)/dista/sss_ele_cut
30295          enddo
30296          ecation_prottran=ecation_prottran+ene
30297          if (energy_dec) write(iout,*) "etrancat",i,j,ene,x0left,De,dista,&
30298          alphac
30299          endif
30300       enddo
30301 !      do k=g_listcatptran_start,g_listcatptran_end
30302 !      ene=0.0d0 this will be used if peptide group interaction is needed
30303 !      enddo
30304
30305
30306       return
30307       end subroutine
30308       subroutine ecat_prot_ang(ecation_protang)
30309       integer:: itypi,itypj,ityptrani,ityptranj,k,l,i,j,n,m,&
30310                 ityptrani1,ityptranj1,ityptrani2,ityptranj2,&
30311                 i1,i2,j1,j2,k1,k2,k3,i3,j3,ityptrani3,ityptranj3
30312
30313       real(kind=8),dimension(3):: cjtemp,citemp,diff,dsctemp,vecsc,&
30314                   diffnorm,boxx,dscvec,dscvecnorm,diffnorm2,&
30315                   dscvec2,dscvecnorm2,cjtemp2,citemp2,diff2,dsctemp2,&
30316                   vecsc2,diff1,diffnorm1,diff3,mindiffnorm2
30317       real(kind=8),dimension(3):: dscvec1,dscvecnorm1,cjtemp1,citemp1,vecsc1,dsctemp1,&
30318                   dscvec3,dscvecnorm3,cjtemp3,citemp3,vecsc3,dsctemp3,&
30319                   diffnorm3,diff4,diffnorm4
30320
30321       real(kind=8):: ecation_protang,dista,sdist,De,ene,x0left,&
30322                     alphac,grad,sumvec,sumdscvec,pom,erdxi,facd1,&
30323                     sss_ele_cut,sss_ele_cut_grad,sss2min,sss2mingrad,&
30324                     simplesum,cosval,part1,part2a,part2,part2b,part3,&
30325                     part4a,part4b,part4,bottom,dista2,sdist2,sumvec2,&
30326                     sumdscvec2,simplesum2,dista1,sdist1,sumvec1,simplesum1,&
30327                     sumdscvec1,facd2,scal1a,scal1b,scal2a,scal2b,&
30328                     sss2mingrad1,sss2mingrad2,sss2min1,sss2min2,pom1,pom2,&
30329                     det1ij,det2ij,cosom1,cosom2,cosom12,cosphij,dista3,&
30330                     sumvec3
30331       real(kind=8):: sinom1,sinom2,sinaux,dephiij,sumdscvec3,sumscvec3,&
30332                      cosphi,sdist3,simplesum3,det1t2ij,sss2mingrad3,sss2min3,&
30333                      scal1c,scal2c,scal3a,scal3b,scal3c,facd3,facd2b,scal3d,&
30334                      scal3e,dista4,sdist4,pom3,sssmintot
30335
30336       ecation_protang=0.0d0
30337       boxx(1)=boxxsize
30338       boxx(2)=boxysize
30339       boxx(3)=boxzsize
30340 !      print *,"KUR**3",g_listcatscang_start,g_listcatscang_end
30341 !      go to 19
30342 !      go to 21
30343       do k=g_listcatscang_start,g_listcatscang_end
30344         ene=0.0d0
30345         i=newcontlistcatscangi(k)
30346         j=newcontlistcatscangj(k)
30347          itypi=itype(i,1) !as the first is the protein part
30348          itypj=itype(j,5) !as the second part is always cation
30349 !         print *,"KUR**4",i,j,itypi,itypj
30350 ! remapping to internal types
30351 !       read (iiontran,*,err=123,end=123) (agamacattran(k,j,i),k=1,3),&
30352 !       (athetacattran(k,j,i),k=1,6),acatshiftdsc(j,i),bcatshiftdsc(j,i),&
30353 !       demorsecat(j,i),alphamorsecat(j,i),x0catleft(j,i),x0catright(j,i),&
30354 !       x0cattrans(j,i)
30355          if (itypj.eq.6) then
30356           ityptranj=1 !as now only Zn2+ is this needs to be modified for other ions
30357          endif
30358          if (itypi.eq.16) then
30359           ityptrani=1
30360          elseif (itypi.eq.1)  then
30361           ityptrani=2
30362          elseif (itypi.eq.15) then
30363           ityptrani=3
30364          elseif (itypi.eq.17) then
30365           ityptrani=4
30366          elseif (itypi.eq.2)  then
30367           ityptrani=5
30368          else
30369           ityptrani=6
30370          endif
30371          if (ityptrani.gt.ntrantyp(ityptranj)) cycle
30372          do  l=1,3
30373           citemp(l)=c(l,i+nres)
30374           cjtemp(l)=c(l,j)
30375          enddo
30376          sumvec=0.0d0
30377          simplesum=0.0d0
30378          do l=1,3
30379          vecsc(l)=citemp(l)-c(l,i)
30380          sumvec=sumvec+vecsc(l)**2
30381          simplesum=simplesum+vecsc(l)
30382          enddo
30383          sumvec=dsqrt(sumvec)
30384          sumdscvec=0.0d0
30385         do l=1,3
30386           dsctemp(l)=c(l,i)&
30387 !                     +1.0d0
30388                     +(acatshiftdsc(ityptrani,ityptranj))*vecsc(l)&
30389                     +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec
30390           dscvec(l)= &
30391 !1.0d0
30392                      (acatshiftdsc(ityptrani,ityptranj))*vecsc(l)&
30393                     +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec
30394           sumdscvec=sumdscvec+dscvec(l)**2
30395          enddo
30396          sumdscvec=dsqrt(sumdscvec)
30397          do l=1,3
30398          dscvecnorm(l)=dscvec(l)/sumdscvec
30399          enddo
30400          call to_box(dsctemp(1),dsctemp(2),dsctemp(3))
30401          call to_box(cjtemp(1),cjtemp(2),cjtemp(3))
30402          sdist=0.0d0
30403           do l=1,3
30404             diff(l)=boxshift(dsctemp(l)-cjtemp(l),boxx(l))
30405             sdist=sdist+diff(l)*diff(l)
30406          enddo
30407          dista=sqrt(sdist)
30408          do l=1,3
30409          diffnorm(l)= diff(l)/dista
30410          enddo
30411          cosval=scalar(diffnorm(1),dc_norm(1,i+nres))
30412          grad=0.0d0
30413          sss2min=sscale2(dista,r_cut_ang,1.0d0)
30414          sss2mingrad=sscagrad2(dista,r_cut_ang,1.0d0)
30415          ene=ene&
30416          +tschebyshev(1,6,athetacattran(1,ityptrani,ityptranj),cosval)
30417          grad=gradtschebyshev(0,5,athetacattran(1,ityptrani,ityptranj),cosval)*sss2min
30418
30419          facd1=bcatshiftdsc(ityptrani,ityptranj)/sumvec
30420          erdxi=scalar(diffnorm(1),dc_norm(1,i+nres))
30421          part1=0.0d0
30422          part2=0.0d0
30423          part3=0.0d0
30424          part4=0.0d0
30425          do l=1,3
30426          bottom=sumvec**2*sdist
30427          part1=diff(l)*sumvec*dista
30428          part2a=(acatshiftdsc(ityptrani,ityptranj))*vecsc(l)
30429          part2b=0.0d0
30430          !bcatshiftdsc(ityptrani,ityptranj)/sumvec*&
30431          !(vecsc(l)-cosval*dista*dc_norm(l,i+nres))
30432          part2=(part2a+part2b)*sumvec*dista
30433          part3=cosval*sumvec*dista*dc_norm(l,i+nres)*dista
30434          part4a=diff(l)*acatshiftdsc(ityptrani,ityptranj)
30435          part4b=bcatshiftdsc(ityptrani,ityptranj)/sumvec*&
30436          (diff(l)-cosval*dista*dc_norm(l,i+nres))
30437          part4=cosval*sumvec*(part4a+part4b)*sumvec
30438 !      gradlipang(m,l)=gradlipang(m,l)+(fac &
30439 !       *(xa(m)-scalar*vnorm*xb(m)/wnorm)&
30440 !       /(vnorm*wnorm))
30441
30442 !       DO k= 1, 3
30443 !      ertail(k) = Rtail_distance(k)/Rtail
30444 !       END DO
30445 !       erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
30446 !       erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
30447 !      facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
30448 !       facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
30449 !       DO k = 1, 3
30450 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
30451 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
30452 !      pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
30453 !      gvdwx(k,i) = gvdwx(k,i) &
30454 !              - (( dFdR + gg(k) ) * pom)
30455          pom=diffnorm(l)+facd1*(diffnorm(l)-erdxi*dc_norm(l,i+nres))
30456
30457          gradcatangc(l,j)=gradcatangc(l,j)-grad*&
30458          (dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)-&
30459          ene*sss2mingrad*diffnorm(l)
30460
30461          gradcatangc(l,i)=gradcatangc(l,i)+grad*&
30462          (dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)+&
30463          ene*sss2mingrad*diffnorm(l)
30464
30465          gradcatangx(l,i)=gradcatangx(l,i)+grad*&
30466          (part1+part2-part3-part4)/bottom+&
30467          ene*sss2mingrad*pom+&
30468          ene*sss2mingrad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0)
30469 !         +grad*(dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)&
30470 !         +grad*pom+grad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0)
30471 !&
30472 !         (diff(l)-cosval*dscvecnorm(l)*dista)/(sumdscvec*dista)
30473
30474
30475
30476
30477
30478         enddo
30479 !       print *,i,j,cosval,tschebyshev(1,3,aomicattr(1,ityptranj),cosval)&
30480 !              ,aomicattr(0,ityptranj),ene
30481        if (energy_dec) write(iout,*) i,j,ityptrani,ityptranj,ene,cosval
30482        ecation_protang=ecation_protang+ene*sss2min
30483       enddo
30484  19   continue
30485 !         print *,"KUR**",g_listcatscangf_start,g_listcatscangf_end
30486             do k=g_listcatscangf_start,g_listcatscangf_end
30487         ene=0.0d0
30488         i1=newcontlistcatscangfi(k)
30489         j1=newcontlistcatscangfj(k)
30490          itypi=itype(i1,1) !as the first is the protein part
30491          itypj=itype(j1,5) !as the second part is always cation
30492          if (itypj.eq.6) then
30493           ityptranj1=1 !as now only Zn2+ is this needs to be modified for other ions
30494          endif
30495          if (itypi.eq.16) then
30496           ityptrani1=1
30497          elseif (itypi.eq.1)  then
30498           ityptrani1=2
30499          elseif (itypi.eq.15) then
30500           ityptrani1=3
30501          elseif (itypi.eq.17) then
30502           ityptrani1=4
30503          elseif (itypi.eq.2)  then
30504           ityptrani1=5
30505          else
30506           ityptrani1=6
30507          endif
30508          do  l=1,3
30509           citemp1(l)=c(l,i1+nres)
30510           cjtemp1(l)=c(l,j1)
30511          enddo
30512          sumvec1=0.0d0
30513          simplesum1=0.0d0
30514          do l=1,3
30515          vecsc1(l)=citemp1(l)-c(l,i1)
30516          sumvec1=sumvec1+vecsc1(l)**2
30517          simplesum1=simplesum1+vecsc1(l)
30518          enddo
30519          sumvec1=dsqrt(sumvec1)
30520          sumdscvec1=0.0d0
30521         do l=1,3
30522           dsctemp1(l)=c(l,i1)&
30523 !                     +1.0d0
30524                     +(acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
30525                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
30526           dscvec1(l)= &
30527 !1.0d0
30528                      (acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
30529                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
30530           sumdscvec1=sumdscvec1+dscvec1(l)**2
30531          enddo
30532          sumdscvec1=dsqrt(sumdscvec1)
30533          do l=1,3
30534          dscvecnorm1(l)=dscvec1(l)/sumdscvec1
30535          enddo
30536          call to_box(dsctemp1(1),dsctemp1(2),dsctemp1(3))
30537          call to_box(cjtemp1(1),cjtemp1(2),cjtemp1(3))
30538          sdist1=0.0d0
30539           do l=1,3
30540             diff1(l)=boxshift(dsctemp1(l)-cjtemp1(l),boxx(l))
30541             sdist1=sdist1+diff1(l)*diff1(l)
30542          enddo
30543          dista1=sqrt(sdist1)
30544          do l=1,3
30545          diffnorm1(l)= diff1(l)/dista1
30546          enddo
30547          sss2min1=sscale2(dista1,r_cut_ang,1.0d0)
30548          sss2mingrad1=sscagrad2(dista1,r_cut_ang,1.0d0)
30549          if (ityptrani1.gt.ntrantyp(ityptranj1)) cycle
30550
30551 !-----------------------------------------------------------------
30552 !             do m=k+1,g_listcatscang_end
30553              ene=0.0d0
30554              i2=newcontlistcatscangfk(k)
30555              j2=j1
30556               if (j1.ne.j2) cycle
30557                itypi=itype(i2,1) !as the first is the protein part
30558                itypj=itype(j2,5) !as the second part is always cation
30559               if (itypj.eq.6) then
30560               ityptranj2=1 !as now only Zn2+ is this needs to be modified for other ions
30561               endif
30562              if (itypi.eq.16) then
30563               ityptrani2=1
30564              elseif (itypi.eq.1)  then
30565               ityptrani2=2
30566              elseif (itypi.eq.15) then
30567               ityptrani2=3
30568              elseif (itypi.eq.17) then
30569               ityptrani2=4
30570              elseif (itypi.eq.2)  then
30571               ityptrani2=5
30572              else
30573               ityptrani2=6
30574              endif
30575          if (ityptrani2.gt.ntrantyp(ityptranj2)) cycle
30576
30577            do  l=1,3
30578           citemp2(l)=c(l,i2+nres)
30579           cjtemp2(l)=c(l,j2)
30580          enddo
30581          sumvec2=0.0d0
30582          simplesum2=0.0d0
30583          do l=1,3
30584          vecsc2(l)=citemp2(l)-c(l,i2)
30585          sumvec2=sumvec2+vecsc2(l)**2
30586          simplesum2=simplesum2+vecsc2(l)
30587          enddo
30588          sumvec2=dsqrt(sumvec2)
30589          sumdscvec2=0.0d0
30590         do l=1,3
30591           dsctemp2(l)=c(l,i2)&
30592 !                     +1.0d0
30593                     +(acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
30594                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
30595           dscvec2(l)= &
30596 !1.0d0
30597                      (acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
30598                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
30599           sumdscvec2=sumdscvec2+dscvec2(l)**2
30600          enddo
30601          sumdscvec2=dsqrt(sumdscvec2)
30602          do l=1,3
30603          dscvecnorm2(l)=dscvec2(l)/sumdscvec2
30604          enddo
30605          call to_box(dsctemp2(1),dsctemp2(2),dsctemp2(3))
30606          call to_box(cjtemp2(1),cjtemp2(2),cjtemp2(3))
30607          sdist2=0.0d0
30608           do l=1,3
30609             diff2(l)=boxshift(dsctemp2(l)-cjtemp2(l),boxx(l))
30610 !            diff2(l)=1.0d0
30611             sdist2=sdist2+diff2(l)*diff2(l)
30612          enddo
30613          dista2=sqrt(sdist2)
30614          do l=1,3
30615          diffnorm2(l)= diff2(l)/dista2
30616          enddo
30617 !         print *,i1,i2,diffnorm2(1)
30618          cosval=scalar(diffnorm1(1),diffnorm2(1))
30619          grad=0.0d0
30620          sss2min2=sscale2(dista2,r_cut_ang,1.0d0)
30621          sss2mingrad2=sscagrad2(dista2,r_cut_ang,1.0d0)
30622          ene=ene+tschebyshev(1,3,aomicattr(1,ityptranj1),cosval)
30623          grad=gradtschebyshev(0,2,aomicattr(1,ityptranj1),cosval)*sss2min2*sss2min1
30624          part1=0.0d0
30625          part2=0.0d0
30626          part3=0.0d0
30627          part4=0.0d0
30628          ecation_protang=ecation_protang+ene*sss2min2*sss2min1
30629          facd1=bcatshiftdsc(ityptrani1,ityptranj1)/sumvec1
30630          facd2=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec2
30631          scal1a=scalar(diffnorm1(1),dc_norm(1,i1+nres))
30632          scal1b=scalar(diffnorm2(1),dc_norm(1,i1+nres))
30633          scal2a=scalar(diffnorm1(1),dc_norm(1,i2+nres))
30634          scal2b=scalar(diffnorm2(1),dc_norm(1,i2+nres))
30635
30636        if (energy_dec) write(iout,*) "omi", i,j,ityptrani,ityptranj,ene,cosval,aomicattr(1,ityptranj1),&
30637              aomicattr(2,ityptranj1),aomicattr(3,ityptranj1),tschebyshev(1,3,aomicattr(1,ityptranj1),cosval)
30638
30639 !*sss2min
30640          do l=1,3
30641          pom1=diffnorm1(l)+facd1*(diffnorm1(l)-scal1a*dc_norm(l,i1+nres))
30642          pom2=diffnorm2(l)+facd2*(diffnorm2(l)-scal2b*dc_norm(l,i2+nres))
30643
30644
30645          gradcatangc(l,i1)=gradcatangc(l,i1)+grad*(diff2(l)-&
30646          cosval*diffnorm1(l)*dista2)/(dista2*dista1)+&
30647           ene*sss2mingrad1*diffnorm1(l)*sss2min2
30648
30649
30650          gradcatangx(l,i1)=gradcatangx(l,i1)+grad/(dista2*dista1)*&
30651          (acatshiftdsc(ityptrani1,ityptranj1)*diff2(l)+&
30652          facd1*(diff2(l)-scal1b*dc_norm(l,i1+nres)*dista2)-&
30653          cosval*dista2/dista1*&
30654          (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+&
30655          facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1)))+&
30656          ene*sss2mingrad1*sss2min2*(pom1+&
30657          diffnorm1(l)*(acatshiftdsc(ityptrani1,ityptranj1)-1.0d0))
30658
30659
30660          gradcatangx(l,i2)=gradcatangx(l,i2)+grad/(dista2*dista1)*&
30661          (acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)+&
30662          facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1)-&
30663          cosval*dista1/dista2*&
30664          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&
30665          facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)))+&
30666          ene*sss2mingrad2*sss2min1*(pom2+&
30667          diffnorm2(l)*(acatshiftdsc(ityptrani2,ityptranj2)-1.0d0))
30668
30669
30670          gradcatangx(l,i2)=gradcatangx(l,i2)
30671          gradcatangc(l,i2)=gradcatangc(l,i2)+grad*(diff1(l)-&
30672          cosval*diffnorm2(l)*dista1)/(dista2*dista1)+&
30673           ene*sss2mingrad2*diffnorm2(l)*sss2min1
30674
30675          gradcatangc(l,j2)=gradcatangc(l,j2)-grad*(diff2(l)/dista2/dista1-&
30676          cosval*diff1(l)/dista1/dista1+diff1(l)/dista2/dista1-&
30677          cosval*diff2(l)/dista2/dista2)-&
30678          ene*sss2mingrad1*diffnorm1(l)*sss2min2-&
30679          ene*sss2mingrad2*diffnorm2(l)*sss2min1
30680
30681
30682          enddo
30683
30684               enddo
30685 !            enddo
30686 !#ifdef DUBUG
30687   21  continue
30688 !       do k1=g_listcatscang_start,g_listcatscang_end
30689 !        print *,"KURNA",g_listcatscangt_start,g_listcatscangt_end
30690         do k1=g_listcatscangt_start,g_listcatscangt_end
30691         i1=newcontlistcatscangti(k1)
30692         j1=newcontlistcatscangtj(k1)
30693         itypi=itype(i1,1) !as the first is the protein part
30694         itypj=itype(j1,5) !as the second part is always cation
30695         if (itypj.eq.6) then
30696          ityptranj1=1 !as now only Zn2+ is this needs to be modified for other ions
30697         endif
30698         if (itypi.eq.16) then
30699          ityptrani1=1
30700         elseif (itypi.eq.1)  then
30701          ityptrani1=2
30702         elseif (itypi.eq.15) then
30703          ityptrani1=3
30704         elseif (itypi.eq.17) then
30705          ityptrani1=4
30706         elseif (itypi.eq.2)  then
30707          ityptrani1=5
30708         else
30709          ityptrani1=6
30710         endif
30711         do  l=1,3
30712           citemp1(l)=c(l,i1+nres)
30713           cjtemp1(l)=c(l,j1)
30714         enddo
30715         sumvec1=0.0d0
30716         simplesum1=0.0d0
30717         do l=1,3
30718          vecsc1(l)=citemp1(l)-c(l,i1)
30719          sumvec1=sumvec1+vecsc1(l)**2
30720          simplesum1=simplesum1+vecsc1(l)
30721         enddo
30722         sumvec1=dsqrt(sumvec1)
30723         sumdscvec1=0.0d0
30724         do l=1,3
30725           dsctemp1(l)=c(l,i1)&
30726                     +(acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
30727                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
30728           dscvec1(l)= &
30729                      (acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)&
30730                     +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1
30731           sumdscvec1=sumdscvec1+dscvec1(l)**2
30732         enddo
30733         sumdscvec1=dsqrt(sumdscvec1)
30734         do l=1,3
30735         dscvecnorm1(l)=dscvec1(l)/sumdscvec1
30736         enddo
30737         call to_box(dsctemp1(1),dsctemp1(2),dsctemp1(3))
30738         call to_box(cjtemp1(1),cjtemp1(2),cjtemp1(3))
30739         sdist1=0.0d0
30740           do l=1,3
30741             diff1(l)=boxshift(dsctemp1(l)-cjtemp1(l),boxx(l))
30742             sdist1=sdist1+diff1(l)*diff1(l)
30743          enddo
30744          dista1=sqrt(sdist1)
30745          do l=1,3
30746          diffnorm1(l)= diff1(l)/dista1
30747          enddo
30748          sss2min1=sscale2(dista1,r_cut_ang,1.0d0)
30749          sss2mingrad1=sscagrad2(dista1,r_cut_ang,1.0d0)
30750          if (ityptrani1.gt.ntrantyp(ityptranj1)) cycle
30751 !---------------before second loop
30752 !        do k2=k1+1,g_listcatscang_end
30753          i2=newcontlistcatscangtk(k1)
30754          j2=j1
30755 !         print *,"TUTU3",i1,i2,j1,j2
30756          if (i2.eq.i1) cycle
30757          if (j2.ne.j1) cycle
30758          itypi=itype(i2,1) !as the first is the protein part
30759          itypj=itype(j2,5) !as the second part is always cation
30760          if (itypj.eq.6) then
30761            ityptranj2=1 !as now only Zn2+ is this needs to be modified for other ions
30762           endif
30763           if (itypi.eq.16) then
30764            ityptrani2=1
30765           elseif (itypi.eq.1)  then
30766            ityptrani2=2
30767           elseif (itypi.eq.15) then
30768            ityptrani2=3
30769           elseif (itypi.eq.17) then
30770            ityptrani2=4
30771           elseif (itypi.eq.2)  then
30772            ityptrani2=5
30773           else
30774            ityptrani2=6
30775           endif
30776           if (ityptrani2.gt.ntrantyp(ityptranj2)) cycle
30777           do  l=1,3
30778            citemp2(l)=c(l,i2+nres)
30779            cjtemp2(l)=c(l,j2)
30780           enddo
30781           sumvec2=0.0d0
30782           simplesum2=0.0d0
30783           do l=1,3
30784            vecsc2(l)=citemp2(l)-c(l,i2)
30785            sumvec2=sumvec2+vecsc2(l)**2
30786            simplesum2=simplesum2+vecsc2(l)
30787           enddo
30788           sumvec2=dsqrt(sumvec2)
30789           sumdscvec2=0.0d0
30790           do l=1,3
30791            dsctemp2(l)=c(l,i2)&
30792                     +(acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
30793                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
30794            dscvec2(l)= &
30795                      (acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)&
30796                     +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2
30797            sumdscvec2=sumdscvec2+dscvec2(l)**2
30798           enddo
30799           sumdscvec2=dsqrt(sumdscvec2)
30800           do l=1,3
30801            dscvecnorm2(l)=dscvec2(l)/sumdscvec2
30802           enddo
30803           call to_box(dsctemp2(1),dsctemp2(2),dsctemp2(3))
30804           call to_box(cjtemp2(1),cjtemp2(2),cjtemp2(3))
30805          sdist2=0.0d0
30806           do l=1,3
30807             diff2(l)=boxshift(dsctemp2(l)-cjtemp2(l),boxx(l))
30808 !            diff2(l)=1.0d0
30809             sdist2=sdist2+diff2(l)*diff2(l)
30810          enddo
30811          dista2=sqrt(sdist2)
30812          do l=1,3
30813          diffnorm2(l)= diff2(l)/dista2
30814          mindiffnorm2(l)=-diffnorm2(l)
30815          enddo
30816 !         print *,i1,i2,diffnorm2(1)
30817          cosom1=scalar(diffnorm1(1),diffnorm2(1))
30818          sss2min2=sscale2(dista2,r_cut_ang,1.0d0)
30819          sss2mingrad2=sscagrad2(dista2,r_cut_ang,1.0d0)
30820
30821 !---------------- before third loop
30822 !          do k3=g_listcatscang_start,g_listcatscang_end
30823            ene=0.0d0
30824            i3=newcontlistcatscangtl(k1)
30825            j3=j1
30826 !            print *,"TUTU4",i1,i2,i3,j1,j2,j3
30827
30828            if (i3.eq.i2) cycle
30829            if (i3.eq.i1) cycle
30830            if (j3.ne.j1) cycle
30831            itypi=itype(i3,1) !as the first is the protein part
30832            itypj=itype(j3,5) !as the second part is always cation
30833            if (itypj.eq.6) then
30834             ityptranj3=1 !as now only Zn2+ is this needs to be modified for other ions
30835            endif
30836            if (itypi.eq.16) then
30837             ityptrani3=1
30838            elseif (itypi.eq.1)  then
30839             ityptrani3=2
30840            elseif (itypi.eq.15) then
30841             ityptrani3=3
30842            elseif (itypi.eq.17) then
30843             ityptrani3=4
30844            elseif (itypi.eq.2)  then
30845             ityptrani3=5
30846            else
30847             ityptrani3=6
30848            endif
30849            if (ityptrani3.gt.ntrantyp(ityptranj3)) cycle
30850            do  l=1,3
30851             citemp3(l)=c(l,i3+nres)
30852             cjtemp3(l)=c(l,j3)
30853           enddo
30854           sumvec3=0.0d0
30855           simplesum3=0.0d0
30856           do l=1,3
30857            vecsc3(l)=citemp3(l)-c(l,i3)
30858            sumvec3=sumvec3+vecsc3(l)**2
30859            simplesum3=simplesum3+vecsc3(l)
30860           enddo
30861           sumvec3=dsqrt(sumvec3)
30862           sumdscvec3=0.0d0
30863           do l=1,3
30864            dsctemp3(l)=c(l,i3)&
30865                     +(acatshiftdsc(ityptrani3,ityptranj3))*vecsc3(l)&
30866                     +bcatshiftdsc(ityptrani3,ityptranj3)*vecsc3(l)/sumvec3
30867            dscvec3(l)= &
30868                      (acatshiftdsc(ityptrani3,ityptranj3))*vecsc3(l)&
30869                     +bcatshiftdsc(ityptrani3,ityptranj3)*vecsc3(l)/sumvec3
30870            sumdscvec3=sumdscvec3+dscvec3(l)**2
30871           enddo
30872           sumdscvec3=dsqrt(sumdscvec3)
30873           do l=1,3
30874            dscvecnorm3(l)=dscvec3(l)/sumdscvec3
30875           enddo
30876           call to_box(dsctemp3(1),dsctemp3(2),dsctemp3(3))
30877           call to_box(cjtemp3(1),cjtemp3(2),cjtemp3(3))
30878           sdist3=0.0d0
30879           do l=1,3
30880             diff3(l)=boxshift(dsctemp3(l)-dsctemp2(l),boxx(l))
30881             sdist3=sdist3+diff3(l)*diff3(l)
30882          enddo
30883          dista3=sqrt(sdist3)
30884          do l=1,3
30885          diffnorm3(l)= diff3(l)/dista3
30886          enddo
30887          sdist4=0.0d0
30888           do l=1,3
30889             diff4(l)=boxshift(dsctemp3(l)-cjtemp2(l),boxx(l))
30890 !            diff2(l)=1.0d0
30891             sdist4=sdist4+diff4(l)*diff4(l)
30892          enddo
30893          dista4=sqrt(sdist4)
30894          do l=1,3
30895          diffnorm4(l)= diff4(l)/dista4
30896          enddo
30897
30898          sss2min3=sscale2(dista4,r_cut_ang,1.0d0)
30899          sss2mingrad3=sscagrad2(dista4,r_cut_ang,1.0d0)
30900          sssmintot=sss2min3*sss2min2*sss2min1
30901          if (ityptrani3.gt.ntrantyp(ityptranj3)) cycle
30902          cosom12=scalar(diffnorm3(1),diffnorm1(1))
30903          cosom2=scalar(diffnorm3(1),mindiffnorm2(1))
30904          sinom1=dsqrt(1.0d0-cosom1*cosom1)
30905          sinom2=dsqrt(1.0d0-cosom2*cosom2)
30906          cosphi=cosom12-cosom1*cosom2
30907          sinaux=sinom1*sinom2
30908          ene=ene+mytschebyshev(1,3,agamacattran(1,ityptrani2,ityptranj2),cosphi,sinaux)
30909          call mygradtschebyshev(1,3,agamacattran(1,ityptrani2,ityptranj2)&
30910           ,cosphi,sinaux,dephiij,det1t2ij)
30911
30912           det1ij=-det1t2ij*sinom2*cosom1/sinom1-dephiij*cosom2
30913           det2ij=-det1t2ij*sinom1*cosom2/sinom2-dephiij*cosom1
30914           facd1=bcatshiftdsc(ityptrani1,ityptranj1)/sumvec1
30915           facd2=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec2
30916 !          facd2b=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec3
30917           facd3=bcatshiftdsc(ityptrani3,ityptranj3)/sumvec3
30918           scal1a=scalar(diffnorm1(1),dc_norm(1,i1+nres))
30919           scal1b=scalar(diffnorm2(1),dc_norm(1,i1+nres))
30920           scal1c=scalar(diffnorm3(1),dc_norm(1,i1+nres))
30921           scal2a=scalar(diffnorm1(1),dc_norm(1,i2+nres))
30922           scal2b=scalar(diffnorm2(1),dc_norm(1,i2+nres))
30923           scal2c=scalar(diffnorm3(1),dc_norm(1,i2+nres))
30924           scal3a=scalar(diffnorm1(1),dc_norm(1,i3+nres))
30925           scal3b=scalar(mindiffnorm2(1),dc_norm(1,i3+nres))
30926           scal3d=scalar(diffnorm2(1),dc_norm(1,i3+nres))
30927           scal3c=scalar(diffnorm3(1),dc_norm(1,i3+nres))
30928           scal3e=scalar(diffnorm4(1),dc_norm(1,i3+nres))
30929
30930
30931           do l=1,3
30932          pom1=diffnorm1(l)+facd1*(diffnorm1(l)-scal1a*dc_norm(l,i1+nres))
30933          pom2=diffnorm2(l)+facd2*(diffnorm2(l)-scal2b*dc_norm(l,i2+nres))
30934          pom3=diffnorm4(l)+facd3*(diffnorm4(l)-scal3e*dc_norm(l,i3+nres))
30935
30936           gradcatangc(l,i1)=gradcatangc(l,i1)&
30937           +det1ij*sssmintot*(diff2(l)-diffnorm1(l)*cosom1*dista2)/(dista2*dista1)+&
30938           dephiij*sssmintot*(diff3(l)-diffnorm1(l)*cosom12*dista3)/(dista3*dista1)&
30939          +ene*sss2mingrad1*diffnorm1(l)*sss2min2*sss2min3
30940
30941
30942           gradcatangc(l,i2)=gradcatangc(l,i2)+(&
30943           det1ij*(diff1(l)-diffnorm2(l)*cosom1*dista1)/(dista2*dista1)+&
30944           det2ij*(-diff3(l)+mindiffnorm2(l)*cosom2*dista3)/(dista3*dista2)&
30945           -det2ij*(-diff2(l)-diffnorm3(l)*cosom2*dista2)/(dista3*dista2)&
30946           -dephiij*(diff1(l)-diffnorm3(l)*cosom12*dista1)/(dista3*dista1))*sssmintot&
30947          +ene*sss2mingrad2*diffnorm2(l)*sss2min1*sss2min3
30948
30949
30950
30951           gradcatangc(l,i3)=gradcatangc(l,i3)&
30952           +det2ij*(-diff2(l)-diffnorm3(l)*cosom2*dista2)/(dista3*dista2)*sssmintot&
30953           +dephiij*(diff1(l)-diffnorm3(l)*cosom12*dista1)/(dista3*dista1)*sssmintot&
30954          +ene*sss2mingrad3*diffnorm4(l)*sss2min1*sss2min2
30955
30956
30957           gradcatangc(l,j1)=gradcatangc(l,j1)-&
30958           sssmintot*(det1ij*(diff2(l)-diffnorm1(l)*cosom1*dista2)/(dista2*dista1)+&
30959           dephiij*(diff3(l)-diffnorm1(l)*cosom12*dista3)/(dista3*dista1))&
30960           -(det1ij*(diff1(l)-diffnorm2(l)*cosom1*dista1)/(dista1*dista2)+&
30961           det2ij*(-diff3(l)+mindiffnorm2(l)*cosom2*dista3)/(dista3*dista2))*sssmintot&
30962          -ene*sss2mingrad1*diffnorm1(l)*sss2min2*sss2min3&
30963          -ene*sss2mingrad2*diffnorm2(l)*sss2min1*sss2min3&
30964          -ene*sss2mingrad3*diffnorm4(l)*sss2min1*sss2min2
30965
30966
30967          gradcatangx(l,i1)=gradcatangx(l,i1)+(det1ij/(dista2*dista1)*&
30968          (acatshiftdsc(ityptrani1,ityptranj1)*diff2(l)+&
30969          facd1*(diff2(l)-scal1b*dc_norm(l,i1+nres)*dista2)-&
30970          cosom1*dista2/dista1*&
30971          (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+&
30972          facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1)))&
30973          +dephiij/(dista3*dista1)*&
30974          (acatshiftdsc(ityptrani1,ityptranj1)*diff3(l)+&
30975          facd1*(diff3(l)-scal1c*dc_norm(l,i1+nres)*dista3)-&
30976          cosom12*dista3/dista1*&
30977          (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+&
30978          facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1))))*sssmintot&
30979          +ene*sss2mingrad1*sss2min2*sss2min3*(pom1+&
30980           diffnorm1(l)*(acatshiftdsc(ityptrani1,ityptranj1)-1.0d0))
30981
30982
30983          gradcatangx(l,i3)=gradcatangx(l,i3)+(&
30984          det2ij/(dista3*dista2)*&
30985          (acatshiftdsc(ityptrani3,ityptranj3)*(-diff2(l))+&
30986          facd3*(-diff2(l)-scal3b*dc_norm(l,i3+nres)*dista2)-&
30987          cosom2*dista2/dista3*&
30988          (acatshiftdsc(ityptrani3,ityptranj3)*diff3(l)+&
30989          facd3*(diff3(l)-scal3c*dc_norm(l,i3+nres)*dista3)))&
30990          +dephiij/(dista3*dista1)*&
30991          (acatshiftdsc(ityptrani3,ityptranj3)*diff1(l)+&
30992          facd3*(diff1(l)-scal3a*dc_norm(l,i3+nres)*dista1)-&
30993          cosom12*dista1/dista3*&
30994          (acatshiftdsc(ityptrani3,ityptranj3)*diff3(l)+&
30995          facd3*(diff3(l)-scal3c*dc_norm(l,i3+nres)*dista3))))*sssmintot&
30996          +ene*sss2mingrad3*sss2min2*sss2min1*(pom3+&
30997           diffnorm4(l)*(acatshiftdsc(ityptrani3,ityptranj3)-1.0d0))
30998
30999
31000          gradcatangx(l,i2)=gradcatangx(l,i2)+(&!
31001          det1ij/(dista2*dista1)*&!
31002          (acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)&!
31003          +facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1)&
31004          -cosom1*dista1/dista2*&!
31005          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&!
31006          facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)))+&
31007          det2ij/(dista3*dista2)*&!
31008          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&!
31009          facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)&
31010          -(acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&!
31011           facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3))&
31012          -cosom2*dista3/dista2*&!
31013          (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&!
31014           facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2))&
31015          +cosom2*dista2/dista3*&!
31016          (acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&!
31017          facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3)))&
31018          +dephiij/(dista3*dista1)*&!
31019          (-(acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)+&!
31020          facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1))+&
31021          cosom12*dista1/dista3*&!
31022          (acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&!
31023           facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3))))*sssmintot&
31024          +ene*sss2mingrad2*sss2min3*sss2min1*(pom2+&
31025           diffnorm2(l)*(acatshiftdsc(ityptrani2,ityptranj2)-1.0d0))
31026
31027
31028           enddo
31029 !          print *,i1,i2,i3,j1,j2,j3,"tors",ene,sinaux,cosphi
31030 !          print *,"param",agamacattran(1,ityptrani2,ityptranj2),ityptranj2,ityptrani2
31031           ecation_protang=ecation_protang+ene*sssmintot
31032          enddo
31033 !        enddo
31034 !       enddo
31035 !#endif
31036       return
31037       end subroutine
31038 !--------------------------------------------------------------------------
31039 !c------------------------------------------------------------------------------
31040       double precision function mytschebyshev(m,n,x,y,yt)
31041       implicit none
31042       integer i,m,n
31043       double precision x(n),y,yt,yy(0:100),aux
31044 !c Tschebyshev polynomial in y multiplied by sin(t1)sin(t2) (yt).
31045 !c Note that the first term is omitted
31046 !c m=0: the constant term is included
31047 !c m=1: the constant term is not included
31048       yy(0)=1.0d0
31049       yy(1)=y
31050       do i=2,n
31051         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)*yt*yt
31052       enddo
31053       aux=0.0d0
31054       do i=m,n
31055         aux=aux+x(i)*yy(i)
31056       enddo
31057 !c      print *,(yy(i),i=1,n)
31058       mytschebyshev=aux
31059       return
31060       end function
31061 !C--------------------------------------------------------------------------
31062 !C--------------------------------------------------------------------------
31063       subroutine mygradtschebyshev(m,n,x,y,yt,fy,fyt)
31064       implicit none
31065       integer i,m,n
31066       double precision x(n+1),y,yt,fy,fyt,yy(0:100),yb(0:100), &
31067       ybt(0:100)
31068 !c Derivative of Tschebyshev polynomial in y multiplied by sin(t1)sin(t2) (yt).
31069 !c Note that the first term is omitted
31070 !c m=0: the constant term is included
31071 !c m=1: the constant term is not included
31072       yy(0)=1.0d0
31073       yy(1)=y
31074       yb(0)=0.0d0
31075       yb(1)=1.0d0
31076       ybt(0)=0.0d0
31077       ybt(1)=0.0d0
31078       do i=2,n
31079         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)*yt*yt
31080         yb(i)=2*yy(i-1)+2*yy(1)*yb(i-1)-yb(i-2)*yt*yt
31081         ybt(i)=2*yy(1)*ybt(i-1)-ybt(i-2)*yt*yt-2*yy(i-2)*yt
31082       enddo
31083       fy=0.0d0
31084       fyt=0.0d0
31085       do i=m,n
31086         fy=fy+x(i)*yb(i)
31087         fyt=fyt+x(i)*ybt(i)
31088       enddo
31089       return
31090       end subroutine
31091        subroutine fodstep(nsteps)
31092        use geometry_data, only: c, nres, theta, alph
31093        use geometry, only:alpha,beta,dist
31094        integer, intent(in) :: nsteps
31095        integer idxtomod, j, i
31096       double precision RD0, RD1, fi
31097 !      double precision alpha
31098 !      double precision beta
31099 !      double precision dist
31100 !      double precision compute_RD
31101       double precision TT
31102       real :: r21(5)
31103 !c    ! Założenia: dla łańcucha zapisanego w tablicy c zawierającego
31104 !c    ! nres elementów CA i CB da się wyznaczyć kąty płaskie
31105 !c    ! theta (procedura Alpha) i kąty torsyjne (procedura beta),
31106 !c    ! zapisywane w tablicach theta i alph.
31107 !c    ! Na podstawie danych z tych tablic da się odtworzyć
31108 !c    ! strukturę 3D łańcucha procedurą chainbuild.
31109 !c    !
31110 !      print *,"fodstep: nres=",nres
31111       RD0 = compute_RD()
31112 !      print *, "RD0before step: ",RD0
31113       do j=1,nsteps
31114 !c      ! Wyznaczenie kątów theta na podstawie struktury
31115 !c      ! zapisanej w tablicy c
31116       do i=3,nres
31117         TT=alpha(i-2,i-1,i)
31118         theta(i)=TT
31119 !c       print *,"TT=",TT
31120       end do
31121 !c      ! Wyznaczenie kątów phi na podstawie struktury
31122 !c      ! zapisanej w tablicy c
31123       do i=4,nres
31124         phi(i)=beta(i-3,i-2,i-1,i)
31125       end do
31126 !c      ! Wyznaczenie odległości między atomami
31127 !c      ! vbld(i)=dist(i-1,i)
31128       do i=2,nres
31129         vbld(i)=dist(i-1,i)
31130       end do
31131 !c      ! losujemy kilka liczb
31132       call random_number(r21)
31133 !c          ! r21(1): indeks pozycji do zmiany
31134 !c          ! r21(2): kąt (r21(2)/20.0-1/40.0)
31135 !c          ! r21(3): wybór tablicy
31136       RD0 = compute_RD()
31137 !c     print *, "RD before step: ",RD0
31138       fi = (r21(2)/20.0-1.0/40.0) ! o tyle radianów zmienimy losowy kąt
31139       if (r21(3) .le. 0.5) then
31140           idxtomod = 3+r21(1)*(nres - 2)
31141           theta(idxtomod) = theta(idxtomod)+fi
31142 !          print *,"Zmiana kąta theta(",&
31143 !         idxtomod,") o fi = ",fi
31144       else
31145           idxtomod = 4+r21(1)*(nres - 3)
31146           phi(idxtomod) = phi(idxtomod)+fi
31147 !          print *,"Zmiana kąta phi(",&
31148 !         idxtomod,") o fi = ",fi
31149       end if
31150 !c     ! odtwarzamy łańcuch
31151       call chainbuild
31152 !c     ! czy coś się polepszyło?
31153       RD1 = compute_RD()
31154       if (RD1 .gt. RD0) then  ! nie, wycofujemy zmianę
31155 !           print *, "RD  after step: ",RD1," rejected"
31156            if (r21(3) .le. 0.5) then
31157                theta(idxtomod) = theta(idxtomod)-fi
31158            else
31159                phi(idxtomod) = phi(idxtomod)-fi
31160            end if
31161            call chainbuild    ! odtworzenie pierwotnej wersji (bez zmienionego kąta)
31162       else
31163 !           print *, "RD  after step: ",RD1," accepted"
31164       continue
31165       end if
31166       end do
31167       end subroutine
31168 !c-----------------------------------------------------------------------------------------
31169       subroutine orientation_matrix(res) ! obliczenie macierzy oraz przygotowanie ea z tymi przeksztalceniami
31170       use geometry_data, only: c, nres
31171       use energy_data, only: itype
31172       double precision, intent(out) :: res(4,4)
31173       double precision resM(4,4)
31174       double precision M(4,4)
31175       double precision M2(4,4)
31176       integer i, j, maxi, maxj
31177 !      double precision sq
31178       double precision maxd, dd
31179       double precision v1(3)
31180       double precision v2(3)
31181       double precision vecnea(3)
31182       double precision mean_ea(3)
31183       double precision fi
31184 !c    ! liczymy atomy efektywne i zapisujemy w tablicy ea
31185       do i=1,nres
31186 !c         if (itype(i,1) .ne. 10) then
31187           if (itype(i,1) .ne. 10) then
31188               ea(1,i) =  c(1,i+nres)
31189               ea(2,i) =  c(2,i+nres)
31190               ea(3,i) =  c(3,i+nres)
31191           else
31192               ea(1,i) = c(1,i)
31193               ea(2,i) = c(2,i)
31194               ea(3,i) = c(3,i)
31195           end if
31196       end do
31197       call IdentityM(resM)
31198       if (nres .le. 2) then
31199           print *, "nres too small (should be at least 2), stopping"
31200           stop
31201       end if
31202       do i=1,3
31203           v1(i)=ea(i,1)
31204           v2(i)=ea(i,2)
31205       end do
31206 !c     ! szukamy najwiekszej odleglosci miedzy atomami efektywnymi ea
31207       call Dist3d(maxd,v1,v2)
31208 !c       ! odleglosc miedzy pierwsza para atomow efektywnych
31209       maxi = 1
31210       maxj = 2
31211       do i=1,nres-1
31212           do j=i+1,nres
31213               v1(1)=ea(1,i)
31214               v1(2)=ea(2,i)
31215               v1(3)=ea(3,i)
31216               v2(1)=ea(1,j)
31217               v2(2)=ea(2,j)
31218               v2(3)=ea(3,j)
31219               call Dist3d(dd,v1,v2)
31220               if (dd .gt. maxd) then
31221                   maxd = dd
31222                   maxi = i
31223                   maxj = j
31224               end if
31225           end do
31226       end do
31227       vecnea(1)=ea(1,maxi)-ea(1,maxj)
31228       vecnea(2)=ea(2,maxi)-ea(2,maxj)
31229       vecnea(3)=ea(3,maxi)-ea(3,maxj)
31230       if (vecnea(1) .lt. 0) then
31231           vecnea(1) = -vecnea(1)
31232           vecnea(2) = -vecnea(2)
31233           vecnea(3) = -vecnea(3)
31234       end if
31235 !c     ! obliczenie kata obrotu wokol osi Z
31236       fi = -atan2(vecnea(2),vecnea(1))
31237       call RotateZ(M,fi)
31238 !c     ! obliczenie kata obrotu wokol osi Y
31239       fi = atan2(vecnea(3), sqrt(sq(vecnea(1))+sq(vecnea(2))))
31240       call RotateY(M2,fi)
31241       M = matmul(M2,M)
31242 !c    ! Przeksztalcamy wszystkie atomy efektywne
31243 !c    ! uzyskujac najwieksza odleglosc ulożona wzdluz OX
31244 !c    ! ea = transform_eatoms(ea,M)
31245       do i=1,nres
31246           v1(1)=ea(1,i)
31247           v1(2)=ea(2,i)
31248           v1(3)=ea(3,i)
31249           call tranform_point(v2,v1,M)
31250           ea(1,i)=v2(1)
31251           ea(2,i)=v2(2)
31252           ea(3,i)=v2(3)
31253       end do
31254       resM = M
31255 !c      ! Teraz szukamy najdluzszego rzutu na plaszczyzne YZ
31256 !c      ! (czyli w liczeniu odleglosci bierzemy pod uwage tylko wsp. y, z)
31257       maxd = sqrt( sq(ea(2,1)-ea(2,2)) + sq(ea(3,1)-ea(3,2))) ! aktualnie max odl
31258       maxi = 1  ! indeksy atomow
31259       maxj = 2  ! miedzy ktorymi jest max odl (chwilowe)
31260       do i=1,nres-1
31261         do j=i+1,nres
31262             dd = sqrt( (ea(2,i)-ea(2,j))**2 + (ea(3,i)-ea(3,j))**2)
31263             if (dd .gt. maxd) then
31264                 maxd = dd
31265                 maxi = i
31266                 maxj = j
31267             end if
31268         end do
31269       end do
31270 !c   ! Teraz obrocimy wszystko wokol OX tak, zeby znaleziony rzut
31271 !c   ! byl rownolegly do OY
31272       vecnea(1) = ea(1,maxi)-ea(1,maxj)
31273       vecnea(2) = ea(2,maxi)-ea(2,maxj)
31274       vecnea(3) = ea(3,maxi)-ea(3,maxj)
31275 !c   ! jeśli współrzędna vecnea.y < 0, to robimy odwrotnie
31276       if (vecnea(2) .lt. 0) then
31277          vecnea(1) = -vecnea(1)
31278          vecnea(2) = -vecnea(2)
31279          vecnea(3) = -vecnea(3)
31280       end if
31281 !c     ! obliczenie kąta obrotu wokół osi X
31282       fi = -atan2(vecnea(3),vecnea(2))
31283       call RotateX(M,fi)
31284 !c    ! Przeksztalcamy wszystkie atomy efektywne
31285       do i=1,nres
31286          v1(1)=ea(1,i)
31287          v1(2)=ea(2,i)
31288          v1(3)=ea(3,i)
31289          call tranform_point(v2,v1,M)
31290          ea(1,i)=v2(1)
31291          ea(2,i)=v2(2)
31292          ea(3,i)=v2(3)
31293       end do
31294       resM = matmul(M,resM)  ! zbieramy wynik (sprawdzic kolejnosc M,resM)
31295 !c     ! centrujemy
31296       mean_ea(1) = 0
31297       mean_ea(2) = 0
31298       mean_ea(3) = 0
31299       do i=1,nres
31300          mean_ea(1) = mean_ea(1) + ea(1,i)
31301          mean_ea(2) = mean_ea(2) + ea(2,i)
31302          mean_ea(3) = mean_ea(3) + ea(3,i)
31303       end do
31304       v1(1) = -mean_ea(1)/nres
31305       v1(2) = -mean_ea(2)/nres
31306       v1(3) = -mean_ea(3)/nres
31307       call TranslateV(M,v1)
31308       resM = matmul(M,resM)
31309 !c     ! przesuwamy
31310       do i=1,nres
31311          ea(1,i) = ea(1,i) + v1(1)
31312          ea(2,i) = ea(2,i) + v1(2)
31313          ea(3,i) = ea(3,i) + v1(3)
31314       end do
31315       res = resM
31316 !c     ! wynikowa macierz przeksztalcenia lancucha
31317 !c     ! (ale lancuch w ea juz mamy przeksztalcony)
31318       return
31319       end subroutine
31320       double precision function compute_rd
31321       use geometry_data, only: nres
31322       use energy_data, only: itype
31323       implicit none
31324       double precision or_mat(4,4)
31325 !      double precision hydrophobicity
31326       integer neatoms
31327       double precision cutoff
31328       double precision ho(70000)
31329       double precision ht(70000)
31330       double precision hosum, htsum
31331       double precision marg, sigmax, sigmay, sigmaz
31332       integer i, j
31333       double precision v1(3)
31334       double precision v2(3)
31335       double precision rijdivc, coll, tmpkwadrat, tmppotega, dist
31336       double precision OdivT, OdivR, ot_one, or_one, RD_classic
31337       call orientation_matrix(or_mat)
31338 !c     ! tam juz liczy sie tablica ea
31339       neatoms = nres
31340       cutoff = 8.99d0
31341 !c     ! granica oddzialywania w A (powyzej ignorujemy oddzialywanie)
31342 !c     ! Najpierw liczymy "obserwowana hydrofobowosc"
31343       hosum = 0.0d0  ! na sume pol ho, do celow pozniejszej normalizacji
31344       do j=1,neatoms
31345         ho(j)=0.0d0
31346         do i=1,neatoms
31347           if (j .eq. i) then ! nie uwzgledniamy oddzialywania atomu z samym soba
31348              cycle
31349           end if
31350           v1(1)=ea(1,i)
31351           v1(2)=ea(2,i)
31352           v1(3)=ea(3,i)
31353           v2(1)=ea(1,j)
31354           v2(2)=ea(2,j)
31355           v2(3)=ea(3,j)
31356           call Dist3d(dist,v1,v2) ! odleglosc miedzy atomami
31357           if (dist .gt. cutoff) then  ! za daleko, nie uwzgledniamy
31358             cycle
31359           end if
31360           rijdivc = dist / cutoff
31361           coll = 0.0d0
31362           tmppotega = rijdivc*rijdivc
31363           tmpkwadrat = tmppotega
31364           coll = coll + 7*tmpkwadrat
31365           tmppotega = tmppotega * tmpkwadrat  ! do potęgi 4
31366           coll = coll - 9*tmppotega
31367           tmppotega = tmppotega * tmpkwadrat  ! do potęgi 6
31368           coll = coll + 5*tmppotega
31369           tmppotega = tmppotega * tmpkwadrat  ! do potęgi 8
31370           coll = coll - tmppotega
31371 !c        ! Wersja: Bryliński 2007
31372 !c        ! EAtoms[j].collectedhp += EAtoms[i].hyphob*(1 - 0.5 * coll);
31373 !c        ! ea$ho[j] = ea$ho[j] + hydrophobicity(ea$resid[i])*(1-0.5*coll)
31374 !c        ! Wersja: Banach Konieczny Roterman 2014
31375 !c        ! EAtoms[j].collectedhp += (EAtoms[i].hyphob+EAtoms[j].hyphob)*(1 - 0.5 * coll);
31376 !c        ponizej bylo itype(i,1) w miejscu itype(i)  oraz itype(j,1) w miejscu itype(j)
31377          ho(j) = ho(j) + (hydrophobicity(itype(i,1))+&
31378         hydrophobicity(itype(j,1)))*(1.0d0-0.5_8*coll)
31379       end do
31380       hosum = hosum + ho(j)
31381       end do
31382 !c     ! Normalizujemy
31383       do i=1,neatoms
31384       ho(i) = ho(i) / hosum
31385       end do
31386 !c     ! Koniec liczenia hydrofobowosci obserwowanej (profil ho)
31387 !c     ! Teraz liczymy "teoretyczna hydrofobowosc", wedlug kropli i rozkladu Gaussa
31388       htsum = 0.0d0
31389 !c     ! tu zbieramy sume ht, uzyjemy potem do normalizacji
31390 !c  ! Ustalimy teraz parametry rozkladu Gaussa, czyli sigmy (srodek jest w (0,0,0)).
31391 !c  ! To bedzie (max odl od srodka + margines) / 3, oddzielnie dla kazdej wspolrzednej.
31392       marg  = 9.0d0
31393       htsum = 0.0d0
31394 !c  ! jeszcze raz zerujemy
31395 !c  ! szukamy ekstremalnej wartosci wspolrzednej x (max wart bezwzgl)
31396       sigmax = ea(1,1)
31397       do i=2,neatoms
31398       if (abs(ea(1,i))>sigmax) then
31399           sigmax = abs(ea(1,i))
31400       end if
31401       end do
31402       sigmax = (marg + sigmax) / 3.0d0
31403 !c  ! szukamy ekstremalnej wartosci wspolrzednej y (max wart bezwzgl)
31404       sigmay = ea(2,1)
31405       do i=2,neatoms
31406       if (abs(ea(2,i))>sigmay) then
31407          sigmay = abs(ea(2,i))
31408       end if
31409       end do
31410       sigmay = (marg + sigmay) / 3.0d0
31411 !c  ! szukamy ekstremalnej wartosci wspolrzednej z (max wart bezwzgl)
31412       sigmaz = ea(3,1)
31413       do i=2,neatoms
31414       if (abs(ea(3,i))>sigmaz) then
31415         sigmaz = abs(ea(3,i))
31416       end if
31417       end do
31418       sigmaz = (marg + sigmaz) / 3.0d0
31419 !c  !sigmax = (marg + max(abs(max(ea$acoor[,1])), abs(min(ea$acoor[,1]))))/3.0
31420 !c  !sigmay = (marg + max(abs(max(ea$acoor[,2])), abs(min(ea$acoor[,2]))))/3.0
31421 !c  !sigmaz = (marg + max(abs(max(ea$acoor[,3])), abs(min(ea$acoor[,3]))))/3.0
31422 !c  ! print *,"sigmax =",sigmax,"  sigmay =",sigmay," sigmaz = ",sigmaz
31423       do j=1,neatoms
31424       ht(j)= exp(-(ea(1,j))**2/(2*sigmax**2))&
31425       * exp(-(ea(2,j))**2/(2*sigmay**2)) &
31426       * exp(-(ea(3,j))**2/(2*sigmaz**2))
31427       htsum = htsum + ht(j)
31428       end do
31429 !c  ! Normalizujemy
31430       do i=1, neatoms
31431         ht(i) = ht(i) / htsum
31432       end do
31433 !c  ! Teraz liczymy RD
31434       OdivT = 0.0d0
31435       OdivR = 0.0d0
31436       do j=1,neatoms
31437         if (ho(j) .ne. 0) then
31438            ot_one = ho(j) * log(ho(j)/ht(j)) / log(2.0d0)
31439            OdivT  = OdivT + ot_one
31440            or_one = ho(j) * log(ho(j)/ (1.0d0/neatoms)) / log(2.0_8)
31441            OdivR  = OdivR + or_one
31442         endif
31443       end do
31444       RD_classic = OdivT / (OdivT+OdivR)
31445       compute_rd = RD_classic
31446       return
31447       end function
31448       function hydrophobicity(id)  ! do przepisania (bylo: identyfikowanie aa po nazwach)
31449       integer id
31450       double precision hydrophobicity
31451       hydrophobicity = 0.0d0
31452       if (id .eq. 1) then
31453          hydrophobicity = 1.000d0  ! CYS
31454          return
31455       endif
31456       if (id .eq. 2) then
31457          hydrophobicity = 0.828d0  ! MET
31458          return
31459       endif
31460       if (id .eq. 3) then
31461          hydrophobicity = 0.906d0  ! PHE
31462          return
31463       endif
31464       if (id .eq. 4) then
31465          hydrophobicity = 0.883d0  ! ILE
31466          return
31467       endif
31468       if (id .eq. 5) then
31469          hydrophobicity = 0.783d0  ! LEU
31470          return
31471       endif
31472       if (id .eq. 6) then
31473          hydrophobicity = 0.811d0  ! VAL
31474          return
31475       endif
31476       if (id .eq. 7) then
31477          hydrophobicity = 0.856d0  ! TRP
31478          return
31479       endif
31480       if (id .eq. 8) then
31481          hydrophobicity = 0.700d0  ! TYR
31482          return
31483       endif
31484       if (id .eq. 9) then
31485          hydrophobicity = 0.572d0  ! ALA
31486          return
31487       endif
31488       if (id .eq. 10) then
31489          hydrophobicity = 0.550d0  ! GLY
31490          return
31491       endif
31492       if (id .eq. 11) then
31493          hydrophobicity = 0.478d0  ! THR
31494          return
31495       endif
31496       if (id .eq. 12) then
31497          hydrophobicity = 0.422d0  ! SER
31498          return
31499       endif
31500       if (id .eq. 13) then
31501          hydrophobicity = 0.250d0  ! GLN
31502          return
31503       endif
31504       if (id .eq. 14) then
31505          hydrophobicity = 0.278d0  ! ASN
31506          return
31507       endif
31508       if (id .eq. 15) then
31509          hydrophobicity = 0.083d0  ! GLU
31510          return
31511       endif
31512       if (id .eq. 16) then
31513          hydrophobicity = 0.167d0  ! ASP
31514          return
31515       endif
31516       if (id .eq. 17) then
31517          hydrophobicity = 0.628d0  ! HIS
31518          return
31519       endif
31520       if (id .eq. 18) then
31521          hydrophobicity = 0.272d0  ! ARG
31522          return
31523       endif
31524       if (id .eq. 19) then
31525          hydrophobicity = 0.000d0  ! LYS
31526          return
31527       endif
31528       if (id .eq. 20) then
31529          hydrophobicity = 0.300d0  ! PRO
31530          return
31531       endif
31532       return
31533       end function hydrophobicity
31534       subroutine mycrossprod(res,b,c)
31535         implicit none
31536         double precision, intent(out) ::  res(3)
31537         double precision, intent(in)  ::  b(3)
31538         double precision, intent(in)  ::  c(3)
31539 !c       ! Tylko dla wektorów trójwymiarowych, ale nie sprawdzamy tego tutaj
31540         res(1) = b(2)*c(3)-b(3)*c(2)
31541         res(2) = b(3)*c(1)-b(1)*c(3)
31542         res(3) = b(1)*c(2)-b(2)*c(1)
31543       return
31544       end subroutine
31545       subroutine mydotprod(res,b,c)
31546         implicit none
31547         double precision, intent(out) ::  res
31548         double precision, intent(in)  ::  b(3)
31549         double precision, intent(in)  ::  c(3)
31550 !c    ! Tylko dla wektorów trójwymiarowych, ale nie sprawdzamy tego tutaj
31551         res = b(1)*c(1)+b(2)*c(2)+b(3)*c(3)
31552        return
31553       end subroutine
31554 !c ! cosinus k¹ta miêdzy wektorami trójwymiarowymi
31555       subroutine cosfi(res, x, y)
31556         implicit none
31557         double precision, intent(out) ::  res
31558         double precision, intent(in)  ::  x(3)
31559         double precision, intent(in)  ::  y(3)
31560         double precision LxLy
31561         LxLy=sqrt(x(1)*x(1)+x(2)*x(2)+x(3)*x(3)) *&
31562             sqrt(y(1)*y(1)+y(2)*y(2)+y(3)*y(3))
31563         if (LxLy==0.0) then
31564           res = 0.0d0
31565         else
31566           call mydotprod(res,x,y)
31567           res = res / LxLy
31568         end if
31569       return
31570       end subroutine
31571
31572
31573       subroutine Dist3d(res,v1,v2)
31574         implicit none
31575         double precision, intent(out) ::  res
31576         double precision, intent(in)  ::  v1(3)
31577         double precision, intent(in)  ::  v2(3)
31578 !        double precision sq
31579         res = sqrt( sq(v1(1)-v2(1)) + sq(v1(2)-v2(2)) + sq(v1(3)-v2(3)))
31580       return
31581       end subroutine
31582 !c ! Przeksztalca wsp. 3d uzywajac macierzy przeksztalcenia M (4x4)
31583       subroutine tranform_point(res,v3d,M)
31584         implicit none
31585         double precision, intent(out) ::  res(3)
31586         double precision, intent(in)  ::  v3d(3)
31587         double precision, intent(in)  ::  M(4,4)
31588
31589         res(1) = M(1,1)*v3d(1) + M(1,2)*v3d(2) + M(1,3)*v3d(3) + M(1,4)
31590         res(2) = M(2,1)*v3d(1) + M(2,2)*v3d(2) + M(2,3)*v3d(3) + M(2,4)
31591         res(3) = M(3,1)*v3d(1) + M(3,2)*v3d(2) + M(3,3)*v3d(3) + M(3,4)
31592       return
31593       end subroutine
31594 !c ! TranslateV: macierz translacji o wektor V
31595       subroutine TranslateV(res,V)
31596         implicit none
31597         double precision, intent(out) ::  res(4,4)
31598         double precision, intent(in)  ::  v(3)
31599         res(1,1) = 1.0d0
31600         res(1,2) = 0
31601         res(1,3) = 0
31602         res(1,4) = v(1)
31603         res(2,1) = 0
31604         res(2,2) = 1.0d0
31605         res(2,3) = 0
31606         res(2,4) = v(2)
31607         res(3,1) = 0
31608         res(3,2) = 0
31609         res(3,3) = 1.0d0
31610         res(3,4) = v(3)
31611         res(4,1) = 0
31612         res(4,2) = 0
31613         res(4,3) = 0
31614         res(4,4) = 1.0d0
31615       return
31616       end subroutine
31617 !c ! RotateX: macierz obrotu wokol osi OX o kat fi
31618       subroutine RotateX(res,fi)
31619         implicit none
31620         double precision, intent(out) ::  res(4,4)
31621         double precision, intent(in)  ::  fi
31622         res(1,1) = 1.0d0
31623         res(1,2) = 0
31624         res(1,3) = 0
31625         res(1,4) = 0
31626         res(2,1) = 0
31627         res(2,2) = cos(fi)
31628         res(2,3) = -sin(fi)
31629         res(2,4) = 0
31630         res(3,1) = 0
31631         res(3,2) = sin(fi)
31632         res(3,3) = cos(fi)
31633         res(3,4) = 0
31634         res(4,1) = 0
31635         res(4,2) = 0
31636         res(4,3) = 0
31637         res(4,4) = 1.0d0
31638       return
31639       end subroutine
31640 !c ! RotateY: macierz obrotu wokol osi OY o kat fi
31641       subroutine RotateY(res,fi)
31642         implicit none
31643         double precision, intent(out) ::  res(4,4)
31644         double precision, intent(in)  ::  fi
31645         res(1,1) = cos(fi)
31646         res(1,2) = 0
31647         res(1,3) = sin(fi)
31648         res(1,4) = 0
31649         res(2,1) = 0
31650         res(2,2) = 1.0d0
31651         res(2,3) = 0
31652         res(2,4) = 0
31653         res(3,1) = -sin(fi)
31654         res(3,2) = 0
31655         res(3,3) = cos(fi)
31656         res(3,4) = 0
31657         res(4,1) = 0
31658         res(4,2) = 0
31659         res(4,3) = 0
31660         res(4,4) = 1.0d0
31661       return
31662       end subroutine
31663 !c ! RotateZ: macierz obrotu wokol osi OZ o kat fi
31664       subroutine RotateZ(res,fi)
31665         implicit none
31666         double precision, intent(out) ::  res(4,4)
31667         double precision, intent(in)  ::  fi
31668         res(1,1) = cos(fi)
31669         res(1,2) = -sin(fi)
31670         res(1,3) = 0
31671         res(1,4) = 0
31672         res(2,1) = sin(fi)
31673         res(2,2) = cos(fi)
31674         res(2,3) = 0
31675         res(2,4) = 0
31676         res(3,1) = 0
31677         res(3,2) = 0
31678         res(3,3) = 1.0d0
31679         res(3,4) = 0
31680         res(4,1) = 0
31681         res(4,2) = 0
31682         res(4,3) = 0
31683         res(4,4) = 1.0d0
31684       return
31685       end subroutine
31686 !c ! IdentityM
31687       subroutine IdentityM(res)
31688         implicit none
31689         double precision, intent(out) ::  res(4,4)
31690         res(1,1) = 1.0d0
31691         res(1,2) = 0
31692         res(1,3) = 0
31693         res(1,4) = 0
31694         res(2,1) = 0
31695         res(2,2) = 1.0d0
31696         res(2,3) = 0
31697         res(2,4) = 0
31698         res(3,1) = 0
31699         res(3,2) = 0
31700         res(3,3) = 1.0d0
31701         res(3,4) = 0
31702         res(4,1) = 0
31703         res(4,2) = 0
31704         res(4,3) = 0
31705         res(4,4) = 1.0d0
31706       return
31707       end subroutine
31708       double precision function sq(x)
31709         double precision x
31710         sq = x*x
31711       return
31712       end function sq
31713
31714 !--------------------------------------------------------------------------
31715       end module energy