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  !(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(:),allocatable :: costab,sintab,&
  91        costab2,sintab2  !(maxres)
  92 ! This common block contains dipole-interaction matrices and their
  93 ! Cartesian derivatives.
  94 !      common /dipmat/
  95       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj     !(2,2,maxconts,maxres)
  96       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der     !(2,2,3,5,maxconts,maxres)
  97 !      common /diploc/
  98       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  99        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 100       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 101        ADtEA1derg,AEAb2derg
 102       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 103        AECAderx,ADtEAderx,ADtEA1derx
 104       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 105       real(kind=8),dimension(3,2) :: g_contij
 106       real(kind=8) :: ekont
 107 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 108 !   RE: Parallelization of 4th and higher order loc-el correlations
 109 !      common /contdistrib/
 110       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 111 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 112 !-----------------------------------------------------------------------------
 113 ! commom.deriv;
 114 !      common /derivat/
 115 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 116 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 117 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 118       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 119         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 120         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 121         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 122         gliptranx, &
 123         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 124         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 125         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 126         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 127         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 128 !-----------------------------NUCLEIC GRADIENT
 129       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 130         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,&
 131         gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,&
 132         gvdwpp_nucl
 133 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 134       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 135         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 136       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 137         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 138         g_corr6_loc     !(maxvar)
 139       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 140       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 141 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 142       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 143 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 144       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 145          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 146 !      integer :: nfl,icg
 147 !      common /deriv_loc/
 148       real(kind=8), dimension(:),allocatable :: fac_shield
 149       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 150 !      common /deriv_scloc/
 151       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 152        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 153        dZZ_XYZtab       !(3,maxres)
 154 !-----------------------------------------------------------------------------
 155 ! common.maxgrad
 156 !      common /maxgrad/
 157       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 158        gradb_max,ghpbc_max,&
 159        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 160        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 161        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 162        gsccorx_max,gsclocx_max
 163 !-----------------------------------------------------------------------------
 164 ! common.MD
 165 !      common /back_constr/
 166       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 167       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 168 !      common /qmeas/
 169       real(kind=8) :: Ucdfrag,Ucdpair
 170       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 171        dqwol,dxqwol     !(3,0:MAXRES)
 172 !-----------------------------------------------------------------------------
 173 ! common.sbridge
 174 !      common /dyn_ssbond/
 175       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 176 !-----------------------------------------------------------------------------
 177 ! common.sccor
 178 ! Parameters of the SCCOR term
 179 !      common/sccor/
 180       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 181        dcosomicron,domicron     !(3,3,3,maxres2)
 182 !-----------------------------------------------------------------------------
 183 ! common.vectors
 184 !      common /vectors/
 185       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 186       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 187 !-----------------------------------------------------------------------------
 188 ! common /przechowalnia/
 189       real(kind=8),dimension(:,:,:),allocatable :: zapas
 190       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 191       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 192 !-----------------------------------------------------------------------------
 193 !-----------------------------------------------------------------------------
 194 !
 195 !
 196 !-----------------------------------------------------------------------------
 197       contains
 198 !-----------------------------------------------------------------------------
 199 ! energy_p_new_barrier.F
 200 !-----------------------------------------------------------------------------
 201       subroutine etotal(energia)
 202 !      implicit real*8 (a-h,o-z)
 203 !      include 'DIMENSIONS'
 204       use MD_data
 205 #ifndef ISNAN
 206       external proc_proc
 207 #ifdef WINPGI
 208 !MS$ATTRIBUTES C ::  proc_proc
 209 #endif
 210 #endif
 211 #ifdef MPI
 212       include "mpif.h"
 213 #endif
 214 !      include 'COMMON.SETUP'
 215 !      include 'COMMON.IOUNITS'
 216       real(kind=8),dimension(0:n_ene) :: energia
 217 !      include 'COMMON.LOCAL'
 218 !      include 'COMMON.FFIELD'
 219 !      include 'COMMON.DERIV'
 220 !      include 'COMMON.INTERACT'
 221 !      include 'COMMON.SBRIDGE'
 222 !      include 'COMMON.CHAIN'
 223 !      include 'COMMON.VAR'
 224 !      include 'COMMON.MD'
 225 !      include 'COMMON.CONTROL'
 226 !      include 'COMMON.TIME1'
 227       real(kind=8) :: time00
 228 !el local variables
 229       integer :: n_corr,n_corr1,ierror
 230       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 231       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 232       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 233                       Eafmforce,ethetacnstr
 234       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 235 ! now energies for nulceic alone parameters
 236       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 237                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 238                       ecorr3_nucl
 239 #ifdef MPI
 240       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 241 ! shielding effect varibles for MPI
 242 !      real(kind=8)   fac_shieldbuf(maxres),
 243 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 244 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 245 !     & grad_shieldbuf(3,-1:maxres)
 246 !       integer ishield_listbuf(maxres),
 247 !     &shield_listbuf(maxcontsshi,maxres)
 248
 249 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 250 !     & " nfgtasks",nfgtasks
 251       if (nfgtasks.gt.1) then
 252         time00=MPI_Wtime()
 253 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 254         if (fg_rank.eq.0) then
 255           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 256 !          print *,"Processor",myrank," BROADCAST iorder"
 257 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 258 ! FG slaves as WEIGHTS array.
 259           weights_(1)=wsc
 260           weights_(2)=wscp
 261           weights_(3)=welec
 262           weights_(4)=wcorr
 263           weights_(5)=wcorr5
 264           weights_(6)=wcorr6
 265           weights_(7)=wel_loc
 266           weights_(8)=wturn3
 267           weights_(9)=wturn4
 268           weights_(10)=wturn6
 269           weights_(11)=wang
 270           weights_(12)=wscloc
 271           weights_(13)=wtor
 272           weights_(14)=wtor_d
 273           weights_(15)=wstrain
 274           weights_(16)=wvdwpp
 275           weights_(17)=wbond
 276           weights_(18)=scal14
 277           weights_(21)=wsccor
 278           weights_(26)=wvdwpp_nucl
 279           weights_(27)=welpp
 280           weights_(28)=wvdwpsb
 281           weights_(29)=welpsb
 282           weights_(30)=wvdwsb
 283           weights_(31)=welsb
 284           weights_(32)=wbond_nucl
 285           weights_(33)=wang_nucl
 286           weights_(34)=wsbloc
 287           weights_(35)=wtor_nucl
 288           weights_(36)=wtor_d_nucl
 289           weights_(37)=wcorr_nucl
 290           weights_(38)=wcorr3_nucl
 291
 292 ! FG Master broadcasts the WEIGHTS_ array
 293           call MPI_Bcast(weights_(1),n_ene,&
 294              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 295         else
 296 ! FG slaves receive the WEIGHTS array
 297           call MPI_Bcast(weights(1),n_ene,&
 298               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 299           wsc=weights(1)
 300           wscp=weights(2)
 301           welec=weights(3)
 302           wcorr=weights(4)
 303           wcorr5=weights(5)
 304           wcorr6=weights(6)
 305           wel_loc=weights(7)
 306           wturn3=weights(8)
 307           wturn4=weights(9)
 308           wturn6=weights(10)
 309           wang=weights(11)
 310           wscloc=weights(12)
 311           wtor=weights(13)
 312           wtor_d=weights(14)
 313           wstrain=weights(15)
 314           wvdwpp=weights(16)
 315           wbond=weights(17)
 316           scal14=weights(18)
 317           wsccor=weights(21)
 318           wvdwpp_nucl =weights(26)
 319           welpp  =weights(27)
 320           wvdwpsb=weights(28)
 321           welpsb =weights(29)
 322           wvdwsb =weights(30)
 323           welsb  =weights(31)
 324           wbond_nucl  =weights(32)
 325           wang_nucl   =weights(33)
 326           wsbloc =weights(34)
 327           wtor_nucl   =weights(35)
 328           wtor_d_nucl =weights(36)
 329           wcorr_nucl  =weights(37)
 330           wcorr3_nucl =weights(38)
 331
 332         endif
 333         time_Bcast=time_Bcast+MPI_Wtime()-time00
 334         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 335 !        call chainbuild_cart
 336       endif
 337 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 338 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 339 #else
 340 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 341 !        call int_from_cart1(.false.)
 342 !      endif
 343 #endif
 344 #ifdef TIMING
 345       time00=MPI_Wtime()
 346 #endif
 347 !
 348 ! Compute the side-chain and electrostatic interaction energy
 349 !        print *, "Before EVDW"
 350 !      goto (101,102,103,104,105,106) ipot
 351       select case(ipot)
 352 ! Lennard-Jones potential.
 353 !  101 call elj(evdw)
 354        case (1)
 355          call elj(evdw)
 356 !d    print '(a)','Exit ELJcall el'
 357 !      goto 107
 358 ! Lennard-Jones-Kihara potential (shifted).
 359 !  102 call eljk(evdw)
 360        case (2)
 361          call eljk(evdw)
 362 !      goto 107
 363 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 364 !  103 call ebp(evdw)
 365        case (3)
 366          call ebp(evdw)
 367 !      goto 107
 368 ! Gay-Berne potential (shifted LJ, angular dependence).
 369 !  104 call egb(evdw)
 370        case (4)
 371          call egb(evdw)
 372 !      goto 107
 373 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 374 !  105 call egbv(evdw)
 375        case (5)
 376          call egbv(evdw)
 377 !      goto 107
 378 ! Soft-sphere potential
 379 !  106 call e_softsphere(evdw)
 380        case (6)
 381          call e_softsphere(evdw)
 382 !
 383 ! Calculate electrostatic (H-bonding) energy of the main chain.
 384 !
 385 !  107 continue
 386        case default
 387          write(iout,*)"Wrong ipot"
 388 !         return
 389 !   50 continue
 390       end select
 391 !      continue
 392 !        print *,"after EGB"
 393 ! shielding effect
 394        if (shield_mode.eq.2) then
 395                  call set_shield_fac2
 396        endif
 397 !       print *,"AFTER EGB",ipot,evdw
 398 !mc
 399 !mc Sep-06: egb takes care of dynamic ss bonds too
 400 !mc
 401 !      if (dyn_ss) call dyn_set_nss
 402 !      print *,"Processor",myrank," computed USCSC"
 403 #ifdef TIMING
 404       time01=MPI_Wtime()
 405 #endif
 406       call vec_and_deriv
 407 #ifdef TIMING
 408       time_vec=time_vec+MPI_Wtime()-time01
 409 #endif
 410 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 411       if (ipot.lt.6) then
 412 #ifdef SPLITELE
 413 !         print *,"after ipot if", ipot
 414          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 415              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 416              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 417              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 418 #else
 419          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 420              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 421              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 422              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 423 #endif
 424 !            print *,"just befor eelec call"
 425             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 426 !         write (iout,*) "ELEC calc"
 427          else
 428             ees=0.0d0
 429             evdw1=0.0d0
 430             eel_loc=0.0d0
 431             eello_turn3=0.0d0
 432             eello_turn4=0.0d0
 433          endif
 434       else
 435 !        write (iout,*) "Soft-spheer ELEC potential"
 436         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 437          eello_turn4)
 438       endif
 439 !      print *,"Processor",myrank," computed UELEC"
 440 !
 441 ! Calculate excluded-volume interaction energy between peptide groups
 442 ! and side chains.
 443 !
 444 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 445
 446       if (ipot.lt.6) then
 447        if(wscp.gt.0d0) then
 448         call escp(evdw2,evdw2_14)
 449        else
 450         evdw2=0
 451         evdw2_14=0
 452        endif
 453       else
 454 !        write (iout,*) "Soft-sphere SCP potential"
 455         call escp_soft_sphere(evdw2,evdw2_14)
 456       endif
 457 !       write(iout,*) "in etotal before ebond",ipot
 458
 459 !
 460 ! Calculate the bond-stretching energy
 461 !
 462       call ebond(estr)
 463 !       print *,"EBOND",estr
 464 !       write(iout,*) "in etotal afer ebond",ipot
 465
 466 !
 467 ! Calculate the disulfide-bridge and other energy and the contributions
 468 ! from other distance constraints.
 469 !      print *,'Calling EHPB'
 470       call edis(ehpb)
 471 !elwrite(iout,*) "in etotal afer edis",ipot
 472 !      print *,'EHPB exitted succesfully.'
 473 !
 474 ! Calculate the virtual-bond-angle energy.
 475 !
 476       if (wang.gt.0d0) then
 477         call ebend(ebe,ethetacnstr)
 478       else
 479         ebe=0
 480         ethetacnstr=0
 481       endif
 482 !      print *,"Processor",myrank," computed UB"
 483 !
 484 ! Calculate the SC local energy.
 485 !
 486       call esc(escloc)
 487 !elwrite(iout,*) "in etotal afer esc",ipot
 488 !      print *,"Processor",myrank," computed USC"
 489 !
 490 ! Calculate the virtual-bond torsional energy.
 491 !
 492 !d    print *,'nterm=',nterm
 493       if (wtor.gt.0) then
 494        call etor(etors,edihcnstr)
 495       else
 496        etors=0
 497        edihcnstr=0
 498       endif
 499 !      print *,"Processor",myrank," computed Utor"
 500 !
 501 ! 6/23/01 Calculate double-torsional energy
 502 !
 503 !elwrite(iout,*) "in etotal",ipot
 504       if (wtor_d.gt.0) then
 505        call etor_d(etors_d)
 506       else
 507        etors_d=0
 508       endif
 509 !      print *,"Processor",myrank," computed Utord"
 510 !
 511 ! 21/5/07 Calculate local sicdechain correlation energy
 512 !
 513       if (wsccor.gt.0.0d0) then
 514         call eback_sc_corr(esccor)
 515       else
 516         esccor=0.0d0
 517       endif
 518 !      print *,"Processor",myrank," computed Usccorr"
 519 !
 520 ! 12/1/95 Multi-body terms
 521 !
 522       n_corr=0
 523       n_corr1=0
 524       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 525           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 526          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 527 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 528 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 529       else
 530          ecorr=0.0d0
 531          ecorr5=0.0d0
 532          ecorr6=0.0d0
 533          eturn6=0.0d0
 534       endif
 535 !elwrite(iout,*) "in etotal",ipot
 536       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 537          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 538 !d         write (iout,*) "multibody_hb ecorr",ecorr
 539       endif
 540 !elwrite(iout,*) "afeter  multibody hb"
 541
 542 !      print *,"Processor",myrank," computed Ucorr"
 543 !
 544 ! If performing constraint dynamics, call the constraint energy
 545 !  after the equilibration time
 546       if(usampl.and.totT.gt.eq_time) then
 547 !elwrite(iout,*) "afeter  multibody hb"
 548          call EconstrQ
 549 !elwrite(iout,*) "afeter  multibody hb"
 550          call Econstr_back
 551 !elwrite(iout,*) "afeter  multibody hb"
 552       else
 553          Uconst=0.0d0
 554          Uconst_back=0.0d0
 555       endif
 556       call flush(iout)
 557 !         write(iout,*) "after Econstr"
 558
 559       if (wliptran.gt.0) then
 560 !        print *,"PRZED WYWOLANIEM"
 561         call Eliptransfer(eliptran)
 562       else
 563        eliptran=0.0d0
 564       endif
 565       if (fg_rank.eq.0) then
 566       if (AFMlog.gt.0) then
 567         call AFMforce(Eafmforce)
 568       else if (selfguide.gt.0) then
 569         call AFMvel(Eafmforce)
 570       endif
 571       endif
 572       if (tubemode.eq.1) then
 573        call calctube(etube)
 574       else if (tubemode.eq.2) then
 575        call calctube2(etube)
 576       elseif (tubemode.eq.3) then
 577        call calcnano(etube)
 578       else
 579        etube=0.0d0
 580       endif
 581 !--------------------------------------------------------
 582 !      print *,"before",ees,evdw1,ecorr
 583       call ebond_nucl(estr_nucl)
 584       call ebend_nucl(ebe_nucl)
 585       call etor_nucl(etors_nucl)
 586       call esb_gb(evdwsb,eelsb)
 587       call epp_nucl_sub(evdwpp,eespp)
 588       call epsb(evdwpsb,eelpsb)
 589       call esb(esbloc)
 590       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 591
 592 !      print *,"after ebend", ebe_nucl
 593 #ifdef TIMING
 594       time_enecalc=time_enecalc+MPI_Wtime()-time00
 595 #endif
 596 !      print *,"Processor",myrank," computed Uconstr"
 597 #ifdef TIMING
 598       time00=MPI_Wtime()
 599 #endif
 600 !
 601 ! Sum the energies
 602 !
 603       energia(1)=evdw
 604 #ifdef SCP14
 605       energia(2)=evdw2-evdw2_14
 606       energia(18)=evdw2_14
 607 #else
 608       energia(2)=evdw2
 609       energia(18)=0.0d0
 610 #endif
 611 #ifdef SPLITELE
 612       energia(3)=ees
 613       energia(16)=evdw1
 614 #else
 615       energia(3)=ees+evdw1
 616       energia(16)=0.0d0
 617 #endif
 618       energia(4)=ecorr
 619       energia(5)=ecorr5
 620       energia(6)=ecorr6
 621       energia(7)=eel_loc
 622       energia(8)=eello_turn3
 623       energia(9)=eello_turn4
 624       energia(10)=eturn6
 625       energia(11)=ebe
 626       energia(12)=escloc
 627       energia(13)=etors
 628       energia(14)=etors_d
 629       energia(15)=ehpb
 630       energia(19)=edihcnstr
 631       energia(17)=estr
 632       energia(20)=Uconst+Uconst_back
 633       energia(21)=esccor
 634       energia(22)=eliptran
 635       energia(23)=Eafmforce
 636       energia(24)=ethetacnstr
 637       energia(25)=etube
 638 !---------------------------------------------------------------
 639       energia(26)=evdwpp
 640       energia(27)=eespp
 641       energia(28)=evdwpsb
 642       energia(29)=eelpsb
 643       energia(30)=evdwsb
 644       energia(31)=eelsb
 645       energia(32)=estr_nucl
 646       energia(33)=ebe_nucl
 647       energia(34)=esbloc
 648       energia(35)=etors_nucl
 649       energia(36)=etors_d_nucl
 650       energia(37)=ecorr_nucl
 651       energia(38)=ecorr3_nucl
 652 !----------------------------------------------------------------------
 653 !    Here are the energies showed per procesor if the are more processors
 654 !    per molecule then we sum it up in sum_energy subroutine
 655 !      print *," Processor",myrank," calls SUM_ENERGY"
 656       call sum_energy(energia,.true.)
 657       if (dyn_ss) call dyn_set_nss
 658 !      print *," Processor",myrank," left SUM_ENERGY"
 659 #ifdef TIMING
 660       time_sumene=time_sumene+MPI_Wtime()-time00
 661 #endif
 662 !el        call enerprint(energia)
 663 !elwrite(iout,*)"finish etotal"
 664       return
 665       end subroutine etotal
 666 !-----------------------------------------------------------------------------
 667       subroutine sum_energy(energia,reduce)
 668 !      implicit real*8 (a-h,o-z)
 669 !      include 'DIMENSIONS'
 670 #ifndef ISNAN
 671       external proc_proc
 672 #ifdef WINPGI
 673 !MS$ATTRIBUTES C ::  proc_proc
 674 #endif
 675 #endif
 676 #ifdef MPI
 677       include "mpif.h"
 678 #endif
 679 !      include 'COMMON.SETUP'
 680 !      include 'COMMON.IOUNITS'
 681       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 682 !      include 'COMMON.FFIELD'
 683 !      include 'COMMON.DERIV'
 684 !      include 'COMMON.INTERACT'
 685 !      include 'COMMON.SBRIDGE'
 686 !      include 'COMMON.CHAIN'
 687 !      include 'COMMON.VAR'
 688 !      include 'COMMON.CONTROL'
 689 !      include 'COMMON.TIME1'
 690       logical :: reduce
 691       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 692       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 693       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 694         eliptran,etube, Eafmforce,ethetacnstr
 695       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 696                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 697                       ecorr3_nucl
 698
 699       integer :: i
 700 #ifdef MPI
 701       integer :: ierr
 702       real(kind=8) :: time00
 703       if (nfgtasks.gt.1 .and. reduce) then
 704
 705 #ifdef DEBUG
 706         write (iout,*) "energies before REDUCE"
 707         call enerprint(energia)
 708         call flush(iout)
 709 #endif
 710         do i=0,n_ene
 711           enebuff(i)=energia(i)
 712         enddo
 713         time00=MPI_Wtime()
 714         call MPI_Barrier(FG_COMM,IERR)
 715         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 716         time00=MPI_Wtime()
 717         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 718           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 719 #ifdef DEBUG
 720         write (iout,*) "energies after REDUCE"
 721         call enerprint(energia)
 722         call flush(iout)
 723 #endif
 724         time_Reduce=time_Reduce+MPI_Wtime()-time00
 725       endif
 726       if (fg_rank.eq.0) then
 727 #endif
 728       evdw=energia(1)
 729 #ifdef SCP14
 730       evdw2=energia(2)+energia(18)
 731       evdw2_14=energia(18)
 732 #else
 733       evdw2=energia(2)
 734 #endif
 735 #ifdef SPLITELE
 736       ees=energia(3)
 737       evdw1=energia(16)
 738 #else
 739       ees=energia(3)
 740       evdw1=0.0d0
 741 #endif
 742       ecorr=energia(4)
 743       ecorr5=energia(5)
 744       ecorr6=energia(6)
 745       eel_loc=energia(7)
 746       eello_turn3=energia(8)
 747       eello_turn4=energia(9)
 748       eturn6=energia(10)
 749       ebe=energia(11)
 750       escloc=energia(12)
 751       etors=energia(13)
 752       etors_d=energia(14)
 753       ehpb=energia(15)
 754       edihcnstr=energia(19)
 755       estr=energia(17)
 756       Uconst=energia(20)
 757       esccor=energia(21)
 758       eliptran=energia(22)
 759       Eafmforce=energia(23)
 760       ethetacnstr=energia(24)
 761       etube=energia(25)
 762       evdwpp=energia(26)
 763       eespp=energia(27)
 764       evdwpsb=energia(28)
 765       eelpsb=energia(29)
 766       evdwsb=energia(30)
 767       eelsb=energia(31)
 768       estr_nucl=energia(32)
 769       ebe_nucl=energia(33)
 770       esbloc=energia(34)
 771       etors_nucl=energia(35)
 772       etors_d_nucl=energia(36)
 773       ecorr_nucl=energia(37)
 774       ecorr3_nucl=energia(38)
 775
 776
 777 #ifdef SPLITELE
 778       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 779        +wang*ebe+wtor*etors+wscloc*escloc &
 780        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 781        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 782        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 783        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 784        +Eafmforce+ethetacnstr  &
 785        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 786        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 787        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 788        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl
 789 #else
 790       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 791        +wang*ebe+wtor*etors+wscloc*escloc &
 792        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 793        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 794        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 795        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 796        +Eafmforce+ethetacnstr &
 797        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 798        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 799        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 800        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl
 801 #endif
 802       energia(0)=etot
 803 ! detecting NaNQ
 804 #ifdef ISNAN
 805 #ifdef AIX
 806       if (isnan(etot).ne.0) energia(0)=1.0d+99
 807 #else
 808       if (isnan(etot)) energia(0)=1.0d+99
 809 #endif
 810 #else
 811       i=0
 812 #ifdef WINPGI
 813       idumm=proc_proc(etot,i)
 814 #else
 815       call proc_proc(etot,i)
 816 #endif
 817       if(i.eq.1)energia(0)=1.0d+99
 818 #endif
 819 #ifdef MPI
 820       endif
 821 #endif
 822 !      call enerprint(energia)
 823       call flush(iout)
 824       return
 825       end subroutine sum_energy
 826 !-----------------------------------------------------------------------------
 827       subroutine rescale_weights(t_bath)
 828 !      implicit real*8 (a-h,o-z)
 829 #ifdef MPI
 830       include 'mpif.h'
 831 #endif
 832 !      include 'DIMENSIONS'
 833 !      include 'COMMON.IOUNITS'
 834 !      include 'COMMON.FFIELD'
 835 !      include 'COMMON.SBRIDGE'
 836       real(kind=8) :: kfac=2.4d0
 837       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 838 !el local variables
 839       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 840       real(kind=8) :: T0=3.0d2
 841       integer :: ierror
 842 !      facT=temp0/t_bath
 843 !      facT=2*temp0/(t_bath+temp0)
 844       if (rescale_mode.eq.0) then
 845         facT(1)=1.0d0
 846         facT(2)=1.0d0
 847         facT(3)=1.0d0
 848         facT(4)=1.0d0
 849         facT(5)=1.0d0
 850         facT(6)=1.0d0
 851       else if (rescale_mode.eq.1) then
 852         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 853         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 854         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 855         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 856         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 857 #ifdef WHAM_RUN
 858 !#if defined(WHAM_RUN) || defined(CLUSTER)
 859 #if defined(FUNCTH)
 860 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 861         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 862 #elif defined(FUNCT)
 863         facT(6)=t_bath/T0
 864 #else
 865         facT(6)=1.0d0
 866 #endif
 867 #endif
 868       else if (rescale_mode.eq.2) then
 869         x=t_bath/temp0
 870         x2=x*x
 871         x3=x2*x
 872         x4=x3*x
 873         x5=x4*x
 874         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 875         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 876         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 877         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 878         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 879 #ifdef WHAM_RUN
 880 !#if defined(WHAM_RUN) || defined(CLUSTER)
 881 #if defined(FUNCTH)
 882         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 883 #elif defined(FUNCT)
 884         facT(6)=t_bath/T0
 885 #else
 886         facT(6)=1.0d0
 887 #endif
 888 #endif
 889       else
 890         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 891         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 892 #ifdef MPI
 893        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 894 #endif
 895        stop 555
 896       endif
 897       welec=weights(3)*fact(1)
 898       wcorr=weights(4)*fact(3)
 899       wcorr5=weights(5)*fact(4)
 900       wcorr6=weights(6)*fact(5)
 901       wel_loc=weights(7)*fact(2)
 902       wturn3=weights(8)*fact(2)
 903       wturn4=weights(9)*fact(3)
 904       wturn6=weights(10)*fact(5)
 905       wtor=weights(13)*fact(1)
 906       wtor_d=weights(14)*fact(2)
 907       wsccor=weights(21)*fact(1)
 908
 909       return
 910       end subroutine rescale_weights
 911 !-----------------------------------------------------------------------------
 912       subroutine enerprint(energia)
 913 !      implicit real*8 (a-h,o-z)
 914 !      include 'DIMENSIONS'
 915 !      include 'COMMON.IOUNITS'
 916 !      include 'COMMON.FFIELD'
 917 !      include 'COMMON.SBRIDGE'
 918 !      include 'COMMON.MD'
 919       real(kind=8) :: energia(0:n_ene)
 920 !el local variables
 921       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 922       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 923       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 924        etube,ethetacnstr,Eafmforce
 925       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 926                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 927                       ecorr3_nucl
 928
 929       etot=energia(0)
 930       evdw=energia(1)
 931       evdw2=energia(2)
 932 #ifdef SCP14
 933       evdw2=energia(2)+energia(18)
 934 #else
 935       evdw2=energia(2)
 936 #endif
 937       ees=energia(3)
 938 #ifdef SPLITELE
 939       evdw1=energia(16)
 940 #endif
 941       ecorr=energia(4)
 942       ecorr5=energia(5)
 943       ecorr6=energia(6)
 944       eel_loc=energia(7)
 945       eello_turn3=energia(8)
 946       eello_turn4=energia(9)
 947       eello_turn6=energia(10)
 948       ebe=energia(11)
 949       escloc=energia(12)
 950       etors=energia(13)
 951       etors_d=energia(14)
 952       ehpb=energia(15)
 953       edihcnstr=energia(19)
 954       estr=energia(17)
 955       Uconst=energia(20)
 956       esccor=energia(21)
 957       eliptran=energia(22)
 958       Eafmforce=energia(23)
 959       ethetacnstr=energia(24)
 960       etube=energia(25)
 961       evdwpp=energia(26)
 962       eespp=energia(27)
 963       evdwpsb=energia(28)
 964       eelpsb=energia(29)
 965       evdwsb=energia(30)
 966       eelsb=energia(31)
 967       estr_nucl=energia(32)
 968       ebe_nucl=energia(33)
 969       esbloc=energia(34)
 970       etors_nucl=energia(35)
 971       etors_d_nucl=energia(36)
 972       ecorr_nucl=energia(37)
 973       ecorr3_nucl=energia(38)
 974
 975 #ifdef SPLITELE
 976       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 977         estr,wbond,ebe,wang,&
 978         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 979         ecorr,wcorr,&
 980         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 981         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 982         edihcnstr,ethetacnstr,ebr*nss,&
 983         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
 984         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
 985         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
 986         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
 987         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
 988         ecorr3_nucl,wcorr3_nucl, &
 989         etot
 990    10 format (/'Virtual-chain energies:'// &
 991        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 992        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 993        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 994        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 995        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 996        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 997        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 998        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 999        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1000        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1001        ' (SS bridges & dist. cnstr.)'/ &
1002        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1003        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1004        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1005        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1006        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1007        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1008        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1009        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1010        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1011        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1012        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1013        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1014        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1015        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1016        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1017        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1018        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1019        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1020        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1021        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1022        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1023        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1024        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1025        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1026        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1027        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1028        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1029        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1030        'ETOT=  ',1pE16.6,' (total)')
1031 #else
1032       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1033         estr,wbond,ebe,wang,&
1034         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1035         ecorr,wcorr,&
1036         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1037         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1038         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1039         etube,wtube, &
1040         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1041         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1042         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1043         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1044         ecorr3_nucl,wcorr3_nucl, &
1045         etot
1046    10 format (/'Virtual-chain energies:'// &
1047        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1048        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1049        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1050        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1051        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1052        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1053        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1054        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1055        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1056        ' (SS bridges & dist. cnstr.)'/ &
1057        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1058        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1059        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1060        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1061        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1062        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1063        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1064        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1065        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1066        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1067        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1068        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1069        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1070        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1071        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1072        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1073        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1074        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1075        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1076        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1077        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1078        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1079        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1080        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1081        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1082        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1083        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1084        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1085        'ETOT=  ',1pE16.6,' (total)')
1086 #endif
1087       return
1088       end subroutine enerprint
1089 !-----------------------------------------------------------------------------
1090       subroutine elj(evdw)
1091 !
1092 ! This subroutine calculates the interaction energy of nonbonded side chains
1093 ! assuming the LJ potential of interaction.
1094 !
1095 !      implicit real*8 (a-h,o-z)
1096 !      include 'DIMENSIONS'
1097       real(kind=8),parameter :: accur=1.0d-10
1098 !      include 'COMMON.GEO'
1099 !      include 'COMMON.VAR'
1100 !      include 'COMMON.LOCAL'
1101 !      include 'COMMON.CHAIN'
1102 !      include 'COMMON.DERIV'
1103 !      include 'COMMON.INTERACT'
1104 !      include 'COMMON.TORSION'
1105 !      include 'COMMON.SBRIDGE'
1106 !      include 'COMMON.NAMES'
1107 !      include 'COMMON.IOUNITS'
1108 !      include 'COMMON.CONTACTS'
1109       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1110       integer :: num_conti
1111 !el local variables
1112       integer :: i,itypi,iint,j,itypi1,itypj,k
1113       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1114       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1115       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1116
1117 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1118       evdw=0.0D0
1119 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1120 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1121 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
1122 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
1123
1124       do i=iatsc_s,iatsc_e
1125         itypi=iabs(itype(i,1))
1126         if (itypi.eq.ntyp1) cycle
1127         itypi1=iabs(itype(i+1,1))
1128         xi=c(1,nres+i)
1129         yi=c(2,nres+i)
1130         zi=c(3,nres+i)
1131 ! Change 12/1/95
1132         num_conti=0
1133 !
1134 ! Calculate SC interaction energy.
1135 !
1136         do iint=1,nint_gr(i)
1137 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1138 !d   &                  'iend=',iend(i,iint)
1139           do j=istart(i,iint),iend(i,iint)
1140             itypj=iabs(itype(j,1))
1141             if (itypj.eq.ntyp1) cycle
1142             xj=c(1,nres+j)-xi
1143             yj=c(2,nres+j)-yi
1144             zj=c(3,nres+j)-zi
1145 ! Change 12/1/95 to calculate four-body interactions
1146             rij=xj*xj+yj*yj+zj*zj
1147             rrij=1.0D0/rij
1148 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1149             eps0ij=eps(itypi,itypj)
1150             fac=rrij**expon2
1151             e1=fac*fac*aa_aq(itypi,itypj)
1152             e2=fac*bb_aq(itypi,itypj)
1153             evdwij=e1+e2
1154 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1155 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1156 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1157 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1158 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1159 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1160             evdw=evdw+evdwij
1161 !
1162 ! Calculate the components of the gradient in DC and X
1163 !
1164             fac=-rrij*(e1+evdwij)
1165             gg(1)=xj*fac
1166             gg(2)=yj*fac
1167             gg(3)=zj*fac
1168             do k=1,3
1169               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1170               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1171               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1172               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1173             enddo
1174 !grad            do k=i,j-1
1175 !grad              do l=1,3
1176 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1177 !grad              enddo
1178 !grad            enddo
1179 !
1180 ! 12/1/95, revised on 5/20/97
1181 !
1182 ! Calculate the contact function. The ith column of the array JCONT will
1183 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1184 ! greater than I). The arrays FACONT and GACONT will contain the values of
1185 ! the contact function and its derivative.
1186 !
1187 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1188 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1189 ! Uncomment next line, if the correlation interactions are contact function only
1190             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1191               rij=dsqrt(rij)
1192               sigij=sigma(itypi,itypj)
1193               r0ij=rs0(itypi,itypj)
1194 !
1195 ! Check whether the SC's are not too far to make a contact.
1196 !
1197               rcut=1.5d0*r0ij
1198               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1199 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1200 !
1201               if (fcont.gt.0.0D0) then
1202 ! If the SC-SC distance if close to sigma, apply spline.
1203 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1204 !Adam &             fcont1,fprimcont1)
1205 !Adam           fcont1=1.0d0-fcont1
1206 !Adam           if (fcont1.gt.0.0d0) then
1207 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1208 !Adam             fcont=fcont*fcont1
1209 !Adam           endif
1210 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1211 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1212 !ga             do k=1,3
1213 !ga               gg(k)=gg(k)*eps0ij
1214 !ga             enddo
1215 !ga             eps0ij=-evdwij*eps0ij
1216 ! Uncomment for AL's type of SC correlation interactions.
1217 !adam           eps0ij=-evdwij
1218                 num_conti=num_conti+1
1219                 jcont(num_conti,i)=j
1220                 facont(num_conti,i)=fcont*eps0ij
1221                 fprimcont=eps0ij*fprimcont/rij
1222                 fcont=expon*fcont
1223 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1224 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1225 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1226 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1227                 gacont(1,num_conti,i)=-fprimcont*xj
1228                 gacont(2,num_conti,i)=-fprimcont*yj
1229                 gacont(3,num_conti,i)=-fprimcont*zj
1230 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1231 !d              write (iout,'(2i3,3f10.5)')
1232 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1233               endif
1234             endif
1235           enddo      ! j
1236         enddo        ! iint
1237 ! Change 12/1/95
1238         num_cont(i)=num_conti
1239       enddo          ! i
1240       do i=1,nct
1241         do j=1,3
1242           gvdwc(j,i)=expon*gvdwc(j,i)
1243           gvdwx(j,i)=expon*gvdwx(j,i)
1244         enddo
1245       enddo
1246 !******************************************************************************
1247 !
1248 !                              N O T E !!!
1249 !
1250 ! To save time, the factor of EXPON has been extracted from ALL components
1251 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1252 ! use!
1253 !
1254 !******************************************************************************
1255       return
1256       end subroutine elj
1257 !-----------------------------------------------------------------------------
1258       subroutine eljk(evdw)
1259 !
1260 ! This subroutine calculates the interaction energy of nonbonded side chains
1261 ! assuming the LJK potential of interaction.
1262 !
1263 !      implicit real*8 (a-h,o-z)
1264 !      include 'DIMENSIONS'
1265 !      include 'COMMON.GEO'
1266 !      include 'COMMON.VAR'
1267 !      include 'COMMON.LOCAL'
1268 !      include 'COMMON.CHAIN'
1269 !      include 'COMMON.DERIV'
1270 !      include 'COMMON.INTERACT'
1271 !      include 'COMMON.IOUNITS'
1272 !      include 'COMMON.NAMES'
1273       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1274       logical :: scheck
1275 !el local variables
1276       integer :: i,iint,j,itypi,itypi1,k,itypj
1277       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1278       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1279
1280 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1281       evdw=0.0D0
1282       do i=iatsc_s,iatsc_e
1283         itypi=iabs(itype(i,1))
1284         if (itypi.eq.ntyp1) cycle
1285         itypi1=iabs(itype(i+1,1))
1286         xi=c(1,nres+i)
1287         yi=c(2,nres+i)
1288         zi=c(3,nres+i)
1289 !
1290 ! Calculate SC interaction energy.
1291 !
1292         do iint=1,nint_gr(i)
1293           do j=istart(i,iint),iend(i,iint)
1294             itypj=iabs(itype(j,1))
1295             if (itypj.eq.ntyp1) cycle
1296             xj=c(1,nres+j)-xi
1297             yj=c(2,nres+j)-yi
1298             zj=c(3,nres+j)-zi
1299             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1300             fac_augm=rrij**expon
1301             e_augm=augm(itypi,itypj)*fac_augm
1302             r_inv_ij=dsqrt(rrij)
1303             rij=1.0D0/r_inv_ij
1304             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1305             fac=r_shift_inv**expon
1306             e1=fac*fac*aa_aq(itypi,itypj)
1307             e2=fac*bb_aq(itypi,itypj)
1308             evdwij=e_augm+e1+e2
1309 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1310 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1311 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1312 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1313 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1314 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1315 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1316             evdw=evdw+evdwij
1317 !
1318 ! Calculate the components of the gradient in DC and X
1319 !
1320             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1321             gg(1)=xj*fac
1322             gg(2)=yj*fac
1323             gg(3)=zj*fac
1324             do k=1,3
1325               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1326               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1327               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1328               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1329             enddo
1330 !grad            do k=i,j-1
1331 !grad              do l=1,3
1332 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1333 !grad              enddo
1334 !grad            enddo
1335           enddo      ! j
1336         enddo        ! iint
1337       enddo          ! i
1338       do i=1,nct
1339         do j=1,3
1340           gvdwc(j,i)=expon*gvdwc(j,i)
1341           gvdwx(j,i)=expon*gvdwx(j,i)
1342         enddo
1343       enddo
1344       return
1345       end subroutine eljk
1346 !-----------------------------------------------------------------------------
1347       subroutine ebp(evdw)
1348 !
1349 ! This subroutine calculates the interaction energy of nonbonded side chains
1350 ! assuming the Berne-Pechukas potential of interaction.
1351 !
1352       use comm_srutu
1353       use calc_data
1354 !      implicit real*8 (a-h,o-z)
1355 !      include 'DIMENSIONS'
1356 !      include 'COMMON.GEO'
1357 !      include 'COMMON.VAR'
1358 !      include 'COMMON.LOCAL'
1359 !      include 'COMMON.CHAIN'
1360 !      include 'COMMON.DERIV'
1361 !      include 'COMMON.NAMES'
1362 !      include 'COMMON.INTERACT'
1363 !      include 'COMMON.IOUNITS'
1364 !      include 'COMMON.CALC'
1365       use comm_srutu
1366 !el      integer :: icall
1367 !el      common /srutu/ icall
1368 !     double precision rrsave(maxdim)
1369       logical :: lprn
1370 !el local variables
1371       integer :: iint,itypi,itypi1,itypj
1372       real(kind=8) :: rrij,xi,yi,zi
1373       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1374
1375 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1376       evdw=0.0D0
1377 !     if (icall.eq.0) then
1378 !       lprn=.true.
1379 !     else
1380         lprn=.false.
1381 !     endif
1382 !el      ind=0
1383       do i=iatsc_s,iatsc_e
1384         itypi=iabs(itype(i,1))
1385         if (itypi.eq.ntyp1) cycle
1386         itypi1=iabs(itype(i+1,1))
1387         xi=c(1,nres+i)
1388         yi=c(2,nres+i)
1389         zi=c(3,nres+i)
1390         dxi=dc_norm(1,nres+i)
1391         dyi=dc_norm(2,nres+i)
1392         dzi=dc_norm(3,nres+i)
1393 !        dsci_inv=dsc_inv(itypi)
1394         dsci_inv=vbld_inv(i+nres)
1395 !
1396 ! Calculate SC interaction energy.
1397 !
1398         do iint=1,nint_gr(i)
1399           do j=istart(i,iint),iend(i,iint)
1400 !el            ind=ind+1
1401             itypj=iabs(itype(j,1))
1402             if (itypj.eq.ntyp1) cycle
1403 !            dscj_inv=dsc_inv(itypj)
1404             dscj_inv=vbld_inv(j+nres)
1405             chi1=chi(itypi,itypj)
1406             chi2=chi(itypj,itypi)
1407             chi12=chi1*chi2
1408             chip1=chip(itypi)
1409             chip2=chip(itypj)
1410             chip12=chip1*chip2
1411             alf1=alp(itypi)
1412             alf2=alp(itypj)
1413             alf12=0.5D0*(alf1+alf2)
1414 ! For diagnostics only!!!
1415 !           chi1=0.0D0
1416 !           chi2=0.0D0
1417 !           chi12=0.0D0
1418 !           chip1=0.0D0
1419 !           chip2=0.0D0
1420 !           chip12=0.0D0
1421 !           alf1=0.0D0
1422 !           alf2=0.0D0
1423 !           alf12=0.0D0
1424             xj=c(1,nres+j)-xi
1425             yj=c(2,nres+j)-yi
1426             zj=c(3,nres+j)-zi
1427             dxj=dc_norm(1,nres+j)
1428             dyj=dc_norm(2,nres+j)
1429             dzj=dc_norm(3,nres+j)
1430             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1431 !d          if (icall.eq.0) then
1432 !d            rrsave(ind)=rrij
1433 !d          else
1434 !d            rrij=rrsave(ind)
1435 !d          endif
1436             rij=dsqrt(rrij)
1437 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1438             call sc_angular
1439 ! Calculate whole angle-dependent part of epsilon and contributions
1440 ! to its derivatives
1441             fac=(rrij*sigsq)**expon2
1442             e1=fac*fac*aa_aq(itypi,itypj)
1443             e2=fac*bb_aq(itypi,itypj)
1444             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1445             eps2der=evdwij*eps3rt
1446             eps3der=evdwij*eps2rt
1447             evdwij=evdwij*eps2rt*eps3rt
1448             evdw=evdw+evdwij
1449             if (lprn) then
1450             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1451             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1452 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1453 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1454 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1455 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1456 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1457 !d     &        evdwij
1458             endif
1459 ! Calculate gradient components.
1460             e1=e1*eps1*eps2rt**2*eps3rt**2
1461             fac=-expon*(e1+evdwij)
1462             sigder=fac/sigsq
1463             fac=rrij*fac
1464 ! Calculate radial part of the gradient
1465             gg(1)=xj*fac
1466             gg(2)=yj*fac
1467             gg(3)=zj*fac
1468 ! Calculate the angular part of the gradient and sum add the contributions
1469 ! to the appropriate components of the Cartesian gradient.
1470             call sc_grad
1471           enddo      ! j
1472         enddo        ! iint
1473       enddo          ! i
1474 !     stop
1475       return
1476       end subroutine ebp
1477 !-----------------------------------------------------------------------------
1478       subroutine egb(evdw)
1479 !
1480 ! This subroutine calculates the interaction energy of nonbonded side chains
1481 ! assuming the Gay-Berne potential of interaction.
1482 !
1483       use calc_data
1484 !      implicit real*8 (a-h,o-z)
1485 !      include 'DIMENSIONS'
1486 !      include 'COMMON.GEO'
1487 !      include 'COMMON.VAR'
1488 !      include 'COMMON.LOCAL'
1489 !      include 'COMMON.CHAIN'
1490 !      include 'COMMON.DERIV'
1491 !      include 'COMMON.NAMES'
1492 !      include 'COMMON.INTERACT'
1493 !      include 'COMMON.IOUNITS'
1494 !      include 'COMMON.CALC'
1495 !      include 'COMMON.CONTROL'
1496 !      include 'COMMON.SBRIDGE'
1497       logical :: lprn
1498 !el local variables
1499       integer :: iint,itypi,itypi1,itypj,subchap
1500       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1501       real(kind=8) :: evdw,sig0ij
1502       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1503                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1504                     sslipi,sslipj,faclip
1505       integer :: ii
1506       real(kind=8) :: fracinbuf
1507
1508 !cccc      energy_dec=.false.
1509 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1510       evdw=0.0D0
1511       lprn=.false.
1512 !     if (icall.eq.0) lprn=.false.
1513 !el      ind=0
1514       do i=iatsc_s,iatsc_e
1515 !C        print *,"I am in EVDW",i
1516         itypi=iabs(itype(i,1))
1517 !        if (i.ne.47) cycle
1518         if (itypi.eq.ntyp1) cycle
1519         itypi1=iabs(itype(i+1,1))
1520         xi=c(1,nres+i)
1521         yi=c(2,nres+i)
1522         zi=c(3,nres+i)
1523           xi=dmod(xi,boxxsize)
1524           if (xi.lt.0) xi=xi+boxxsize
1525           yi=dmod(yi,boxysize)
1526           if (yi.lt.0) yi=yi+boxysize
1527           zi=dmod(zi,boxzsize)
1528           if (zi.lt.0) zi=zi+boxzsize
1529
1530        if ((zi.gt.bordlipbot)  &
1531         .and.(zi.lt.bordliptop)) then
1532 !C the energy transfer exist
1533         if (zi.lt.buflipbot) then
1534 !C what fraction I am in
1535          fracinbuf=1.0d0-  &
1536               ((zi-bordlipbot)/lipbufthick)
1537 !C lipbufthick is thickenes of lipid buffore
1538          sslipi=sscalelip(fracinbuf)
1539          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1540         elseif (zi.gt.bufliptop) then
1541          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1542          sslipi=sscalelip(fracinbuf)
1543          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1544         else
1545          sslipi=1.0d0
1546          ssgradlipi=0.0
1547         endif
1548        else
1549          sslipi=0.0d0
1550          ssgradlipi=0.0
1551        endif
1552 !       print *, sslipi,ssgradlipi
1553         dxi=dc_norm(1,nres+i)
1554         dyi=dc_norm(2,nres+i)
1555         dzi=dc_norm(3,nres+i)
1556 !        dsci_inv=dsc_inv(itypi)
1557         dsci_inv=vbld_inv(i+nres)
1558 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1559 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1560 !
1561 ! Calculate SC interaction energy.
1562 !
1563         do iint=1,nint_gr(i)
1564           do j=istart(i,iint),iend(i,iint)
1565             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1566               call dyn_ssbond_ene(i,j,evdwij)
1567               evdw=evdw+evdwij
1568               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1569                               'evdw',i,j,evdwij,' ss'
1570 !              if (energy_dec) write (iout,*) &
1571 !                              'evdw',i,j,evdwij,' ss'
1572              do k=j+1,iend(i,iint)
1573 !C search over all next residues
1574               if (dyn_ss_mask(k)) then
1575 !C check if they are cysteins
1576 !C              write(iout,*) 'k=',k
1577
1578 !c              write(iout,*) "PRZED TRI", evdwij
1579 !               evdwij_przed_tri=evdwij
1580               call triple_ssbond_ene(i,j,k,evdwij)
1581 !c               if(evdwij_przed_tri.ne.evdwij) then
1582 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1583 !c               endif
1584
1585 !c              write(iout,*) "PO TRI", evdwij
1586 !C call the energy function that removes the artifical triple disulfide
1587 !C bond the soubroutine is located in ssMD.F
1588               evdw=evdw+evdwij
1589               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1590                             'evdw',i,j,evdwij,'tss'
1591               endif!dyn_ss_mask(k)
1592              enddo! k
1593             ELSE
1594 !el            ind=ind+1
1595             itypj=iabs(itype(j,1))
1596             if (itypj.eq.ntyp1) cycle
1597 !             if (j.ne.78) cycle
1598 !            dscj_inv=dsc_inv(itypj)
1599             dscj_inv=vbld_inv(j+nres)
1600 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1601 !              1.0d0/vbld(j+nres) !d
1602 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1603             sig0ij=sigma(itypi,itypj)
1604             chi1=chi(itypi,itypj)
1605             chi2=chi(itypj,itypi)
1606             chi12=chi1*chi2
1607             chip1=chip(itypi)
1608             chip2=chip(itypj)
1609             chip12=chip1*chip2
1610             alf1=alp(itypi)
1611             alf2=alp(itypj)
1612             alf12=0.5D0*(alf1+alf2)
1613 ! For diagnostics only!!!
1614 !           chi1=0.0D0
1615 !           chi2=0.0D0
1616 !           chi12=0.0D0
1617 !           chip1=0.0D0
1618 !           chip2=0.0D0
1619 !           chip12=0.0D0
1620 !           alf1=0.0D0
1621 !           alf2=0.0D0
1622 !           alf12=0.0D0
1623            xj=c(1,nres+j)
1624            yj=c(2,nres+j)
1625            zj=c(3,nres+j)
1626           xj=dmod(xj,boxxsize)
1627           if (xj.lt.0) xj=xj+boxxsize
1628           yj=dmod(yj,boxysize)
1629           if (yj.lt.0) yj=yj+boxysize
1630           zj=dmod(zj,boxzsize)
1631           if (zj.lt.0) zj=zj+boxzsize
1632 !          print *,"tu",xi,yi,zi,xj,yj,zj
1633 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1634 ! this fragment set correct epsilon for lipid phase
1635        if ((zj.gt.bordlipbot)  &
1636        .and.(zj.lt.bordliptop)) then
1637 !C the energy transfer exist
1638         if (zj.lt.buflipbot) then
1639 !C what fraction I am in
1640          fracinbuf=1.0d0-     &
1641              ((zj-bordlipbot)/lipbufthick)
1642 !C lipbufthick is thickenes of lipid buffore
1643          sslipj=sscalelip(fracinbuf)
1644          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1645         elseif (zj.gt.bufliptop) then
1646          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1647          sslipj=sscalelip(fracinbuf)
1648          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1649         else
1650          sslipj=1.0d0
1651          ssgradlipj=0.0
1652         endif
1653        else
1654          sslipj=0.0d0
1655          ssgradlipj=0.0
1656        endif
1657       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1658        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1659       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1660        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1661 !------------------------------------------------
1662       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1663       xj_safe=xj
1664       yj_safe=yj
1665       zj_safe=zj
1666       subchap=0
1667       do xshift=-1,1
1668       do yshift=-1,1
1669       do zshift=-1,1
1670           xj=xj_safe+xshift*boxxsize
1671           yj=yj_safe+yshift*boxysize
1672           zj=zj_safe+zshift*boxzsize
1673           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1674           if(dist_temp.lt.dist_init) then
1675             dist_init=dist_temp
1676             xj_temp=xj
1677             yj_temp=yj
1678             zj_temp=zj
1679             subchap=1
1680           endif
1681        enddo
1682        enddo
1683        enddo
1684        if (subchap.eq.1) then
1685           xj=xj_temp-xi
1686           yj=yj_temp-yi
1687           zj=zj_temp-zi
1688        else
1689           xj=xj_safe-xi
1690           yj=yj_safe-yi
1691           zj=zj_safe-zi
1692        endif
1693             dxj=dc_norm(1,nres+j)
1694             dyj=dc_norm(2,nres+j)
1695             dzj=dc_norm(3,nres+j)
1696 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1697 !            write (iout,*) "j",j," dc_norm",& !d
1698 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1699 !          write(iout,*)"rrij ",rrij
1700 !          write(iout,*)"xj yj zj ", xj, yj, zj
1701 !          write(iout,*)"xi yi zi ", xi, yi, zi
1702 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1703             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1704             rij=dsqrt(rrij)
1705             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1706             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1707 !            print *,sss_ele_cut,sss_ele_grad,&
1708 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1709             if (sss_ele_cut.le.0.0) cycle
1710 ! Calculate angle-dependent terms of energy and contributions to their
1711 ! derivatives.
1712             call sc_angular
1713             sigsq=1.0D0/sigsq
1714             sig=sig0ij*dsqrt(sigsq)
1715             rij_shift=1.0D0/rij-sig+sig0ij
1716 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1717 !            "sig0ij",sig0ij
1718 ! for diagnostics; uncomment
1719 !            rij_shift=1.2*sig0ij
1720 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1721             if (rij_shift.le.0.0D0) then
1722               evdw=1.0D20
1723 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1724 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1725 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1726               return
1727             endif
1728             sigder=-sig*sigsq
1729 !---------------------------------------------------------------
1730             rij_shift=1.0D0/rij_shift
1731             fac=rij_shift**expon
1732             faclip=fac
1733             e1=fac*fac*aa!(itypi,itypj)
1734             e2=fac*bb!(itypi,itypj)
1735             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1736             eps2der=evdwij*eps3rt
1737             eps3der=evdwij*eps2rt
1738 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1739 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1740 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1741             evdwij=evdwij*eps2rt*eps3rt
1742             evdw=evdw+evdwij*sss_ele_cut
1743             if (lprn) then
1744             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1745             epsi=bb**2/aa!(itypi,itypj)
1746             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1747               restyp(itypi,1),i,restyp(itypj,1),j, &
1748               epsi,sigm,chi1,chi2,chip1,chip2, &
1749               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1750               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1751               evdwij
1752             endif
1753
1754             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1755                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1756 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1757 !            if (energy_dec) write (iout,*) &
1758 !                             'evdw',i,j,evdwij
1759 !                       print *,"ZALAMKA", evdw
1760
1761 ! Calculate gradient components.
1762             e1=e1*eps1*eps2rt**2*eps3rt**2
1763             fac=-expon*(e1+evdwij)*rij_shift
1764             sigder=fac*sigder
1765             fac=rij*fac
1766 !            print *,'before fac',fac,rij,evdwij
1767             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1768             /sigma(itypi,itypj)*rij
1769 !            print *,'grad part scale',fac,   &
1770 !             evdwij*sss_ele_grad/sss_ele_cut &
1771 !            /sigma(itypi,itypj)*rij
1772 !            fac=0.0d0
1773 ! Calculate the radial part of the gradient
1774             gg(1)=xj*fac
1775             gg(2)=yj*fac
1776             gg(3)=zj*fac
1777 !C Calculate the radial part of the gradient
1778             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1779        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1780         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1781        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1782             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1783             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1784
1785 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1786 ! Calculate angular part of the gradient.
1787             call sc_grad
1788             ENDIF    ! dyn_ss
1789           enddo      ! j
1790         enddo        ! iint
1791       enddo          ! i
1792 !       print *,"ZALAMKA", evdw
1793 !      write (iout,*) "Number of loop steps in EGB:",ind
1794 !ccc      energy_dec=.false.
1795       return
1796       end subroutine egb
1797 !-----------------------------------------------------------------------------
1798       subroutine egbv(evdw)
1799 !
1800 ! This subroutine calculates the interaction energy of nonbonded side chains
1801 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1802 !
1803       use comm_srutu
1804       use calc_data
1805 !      implicit real*8 (a-h,o-z)
1806 !      include 'DIMENSIONS'
1807 !      include 'COMMON.GEO'
1808 !      include 'COMMON.VAR'
1809 !      include 'COMMON.LOCAL'
1810 !      include 'COMMON.CHAIN'
1811 !      include 'COMMON.DERIV'
1812 !      include 'COMMON.NAMES'
1813 !      include 'COMMON.INTERACT'
1814 !      include 'COMMON.IOUNITS'
1815 !      include 'COMMON.CALC'
1816       use comm_srutu
1817 !el      integer :: icall
1818 !el      common /srutu/ icall
1819       logical :: lprn
1820 !el local variables
1821       integer :: iint,itypi,itypi1,itypj
1822       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1823       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1824
1825 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1826       evdw=0.0D0
1827       lprn=.false.
1828 !     if (icall.eq.0) lprn=.true.
1829 !el      ind=0
1830       do i=iatsc_s,iatsc_e
1831         itypi=iabs(itype(i,1))
1832         if (itypi.eq.ntyp1) cycle
1833         itypi1=iabs(itype(i+1,1))
1834         xi=c(1,nres+i)
1835         yi=c(2,nres+i)
1836         zi=c(3,nres+i)
1837         dxi=dc_norm(1,nres+i)
1838         dyi=dc_norm(2,nres+i)
1839         dzi=dc_norm(3,nres+i)
1840 !        dsci_inv=dsc_inv(itypi)
1841         dsci_inv=vbld_inv(i+nres)
1842 !
1843 ! Calculate SC interaction energy.
1844 !
1845         do iint=1,nint_gr(i)
1846           do j=istart(i,iint),iend(i,iint)
1847 !el            ind=ind+1
1848             itypj=iabs(itype(j,1))
1849             if (itypj.eq.ntyp1) cycle
1850 !            dscj_inv=dsc_inv(itypj)
1851             dscj_inv=vbld_inv(j+nres)
1852             sig0ij=sigma(itypi,itypj)
1853             r0ij=r0(itypi,itypj)
1854             chi1=chi(itypi,itypj)
1855             chi2=chi(itypj,itypi)
1856             chi12=chi1*chi2
1857             chip1=chip(itypi)
1858             chip2=chip(itypj)
1859             chip12=chip1*chip2
1860             alf1=alp(itypi)
1861             alf2=alp(itypj)
1862             alf12=0.5D0*(alf1+alf2)
1863 ! For diagnostics only!!!
1864 !           chi1=0.0D0
1865 !           chi2=0.0D0
1866 !           chi12=0.0D0
1867 !           chip1=0.0D0
1868 !           chip2=0.0D0
1869 !           chip12=0.0D0
1870 !           alf1=0.0D0
1871 !           alf2=0.0D0
1872 !           alf12=0.0D0
1873             xj=c(1,nres+j)-xi
1874             yj=c(2,nres+j)-yi
1875             zj=c(3,nres+j)-zi
1876             dxj=dc_norm(1,nres+j)
1877             dyj=dc_norm(2,nres+j)
1878             dzj=dc_norm(3,nres+j)
1879             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1880             rij=dsqrt(rrij)
1881 ! Calculate angle-dependent terms of energy and contributions to their
1882 ! derivatives.
1883             call sc_angular
1884             sigsq=1.0D0/sigsq
1885             sig=sig0ij*dsqrt(sigsq)
1886             rij_shift=1.0D0/rij-sig+r0ij
1887 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1888             if (rij_shift.le.0.0D0) then
1889               evdw=1.0D20
1890               return
1891             endif
1892             sigder=-sig*sigsq
1893 !---------------------------------------------------------------
1894             rij_shift=1.0D0/rij_shift
1895             fac=rij_shift**expon
1896             e1=fac*fac*aa_aq(itypi,itypj)
1897             e2=fac*bb_aq(itypi,itypj)
1898             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1899             eps2der=evdwij*eps3rt
1900             eps3der=evdwij*eps2rt
1901             fac_augm=rrij**expon
1902             e_augm=augm(itypi,itypj)*fac_augm
1903             evdwij=evdwij*eps2rt*eps3rt
1904             evdw=evdw+evdwij+e_augm
1905             if (lprn) then
1906             sigm=dabs(aa_aq(itypi,itypj)/&
1907             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1908             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1909             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1910               restyp(itypi,1),i,restyp(itypj,1),j,&
1911               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1912               chi1,chi2,chip1,chip2,&
1913               eps1,eps2rt**2,eps3rt**2,&
1914               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1915               evdwij+e_augm
1916             endif
1917 ! Calculate gradient components.
1918             e1=e1*eps1*eps2rt**2*eps3rt**2
1919             fac=-expon*(e1+evdwij)*rij_shift
1920             sigder=fac*sigder
1921             fac=rij*fac-2*expon*rrij*e_augm
1922 ! Calculate the radial part of the gradient
1923             gg(1)=xj*fac
1924             gg(2)=yj*fac
1925             gg(3)=zj*fac
1926 ! Calculate angular part of the gradient.
1927             call sc_grad
1928           enddo      ! j
1929         enddo        ! iint
1930       enddo          ! i
1931       end subroutine egbv
1932 !-----------------------------------------------------------------------------
1933 !el      subroutine sc_angular in module geometry
1934 !-----------------------------------------------------------------------------
1935       subroutine e_softsphere(evdw)
1936 !
1937 ! This subroutine calculates the interaction energy of nonbonded side chains
1938 ! assuming the LJ potential of interaction.
1939 !
1940 !      implicit real*8 (a-h,o-z)
1941 !      include 'DIMENSIONS'
1942       real(kind=8),parameter :: accur=1.0d-10
1943 !      include 'COMMON.GEO'
1944 !      include 'COMMON.VAR'
1945 !      include 'COMMON.LOCAL'
1946 !      include 'COMMON.CHAIN'
1947 !      include 'COMMON.DERIV'
1948 !      include 'COMMON.INTERACT'
1949 !      include 'COMMON.TORSION'
1950 !      include 'COMMON.SBRIDGE'
1951 !      include 'COMMON.NAMES'
1952 !      include 'COMMON.IOUNITS'
1953 !      include 'COMMON.CONTACTS'
1954       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1955 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1956 !el local variables
1957       integer :: i,iint,j,itypi,itypi1,itypj,k
1958       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1959       real(kind=8) :: fac
1960
1961       evdw=0.0D0
1962       do i=iatsc_s,iatsc_e
1963         itypi=iabs(itype(i,1))
1964         if (itypi.eq.ntyp1) cycle
1965         itypi1=iabs(itype(i+1,1))
1966         xi=c(1,nres+i)
1967         yi=c(2,nres+i)
1968         zi=c(3,nres+i)
1969 !
1970 ! Calculate SC interaction energy.
1971 !
1972         do iint=1,nint_gr(i)
1973 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1974 !d   &                  'iend=',iend(i,iint)
1975           do j=istart(i,iint),iend(i,iint)
1976             itypj=iabs(itype(j,1))
1977             if (itypj.eq.ntyp1) cycle
1978             xj=c(1,nres+j)-xi
1979             yj=c(2,nres+j)-yi
1980             zj=c(3,nres+j)-zi
1981             rij=xj*xj+yj*yj+zj*zj
1982 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1983             r0ij=r0(itypi,itypj)
1984             r0ijsq=r0ij*r0ij
1985 !            print *,i,j,r0ij,dsqrt(rij)
1986             if (rij.lt.r0ijsq) then
1987               evdwij=0.25d0*(rij-r0ijsq)**2
1988               fac=rij-r0ijsq
1989             else
1990               evdwij=0.0d0
1991               fac=0.0d0
1992             endif
1993             evdw=evdw+evdwij
1994 !
1995 ! Calculate the components of the gradient in DC and X
1996 !
1997             gg(1)=xj*fac
1998             gg(2)=yj*fac
1999             gg(3)=zj*fac
2000             do k=1,3
2001               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2002               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2003               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2004               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2005             enddo
2006 !grad            do k=i,j-1
2007 !grad              do l=1,3
2008 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2009 !grad              enddo
2010 !grad            enddo
2011           enddo ! j
2012         enddo ! iint
2013       enddo ! i
2014       return
2015       end subroutine e_softsphere
2016 !-----------------------------------------------------------------------------
2017       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2018 !
2019 ! Soft-sphere potential of p-p interaction
2020 !
2021 !      implicit real*8 (a-h,o-z)
2022 !      include 'DIMENSIONS'
2023 !      include 'COMMON.CONTROL'
2024 !      include 'COMMON.IOUNITS'
2025 !      include 'COMMON.GEO'
2026 !      include 'COMMON.VAR'
2027 !      include 'COMMON.LOCAL'
2028 !      include 'COMMON.CHAIN'
2029 !      include 'COMMON.DERIV'
2030 !      include 'COMMON.INTERACT'
2031 !      include 'COMMON.CONTACTS'
2032 !      include 'COMMON.TORSION'
2033 !      include 'COMMON.VECTORS'
2034 !      include 'COMMON.FFIELD'
2035       real(kind=8),dimension(3) :: ggg
2036 !d      write(iout,*) 'In EELEC_soft_sphere'
2037 !el local variables
2038       integer :: i,j,k,num_conti,iteli,itelj
2039       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2040       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2041       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2042
2043       ees=0.0D0
2044       evdw1=0.0D0
2045       eel_loc=0.0d0
2046       eello_turn3=0.0d0
2047       eello_turn4=0.0d0
2048 !el      ind=0
2049       do i=iatel_s,iatel_e
2050         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2051         dxi=dc(1,i)
2052         dyi=dc(2,i)
2053         dzi=dc(3,i)
2054         xmedi=c(1,i)+0.5d0*dxi
2055         ymedi=c(2,i)+0.5d0*dyi
2056         zmedi=c(3,i)+0.5d0*dzi
2057         num_conti=0
2058 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2059         do j=ielstart(i),ielend(i)
2060           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2061 !el          ind=ind+1
2062           iteli=itel(i)
2063           itelj=itel(j)
2064           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2065           r0ij=rpp(iteli,itelj)
2066           r0ijsq=r0ij*r0ij
2067           dxj=dc(1,j)
2068           dyj=dc(2,j)
2069           dzj=dc(3,j)
2070           xj=c(1,j)+0.5D0*dxj-xmedi
2071           yj=c(2,j)+0.5D0*dyj-ymedi
2072           zj=c(3,j)+0.5D0*dzj-zmedi
2073           rij=xj*xj+yj*yj+zj*zj
2074           if (rij.lt.r0ijsq) then
2075             evdw1ij=0.25d0*(rij-r0ijsq)**2
2076             fac=rij-r0ijsq
2077           else
2078             evdw1ij=0.0d0
2079             fac=0.0d0
2080           endif
2081           evdw1=evdw1+evdw1ij
2082 !
2083 ! Calculate contributions to the Cartesian gradient.
2084 !
2085           ggg(1)=fac*xj
2086           ggg(2)=fac*yj
2087           ggg(3)=fac*zj
2088           do k=1,3
2089             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2090             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2091           enddo
2092 !
2093 ! Loop over residues i+1 thru j-1.
2094 !
2095 !grad          do k=i+1,j-1
2096 !grad            do l=1,3
2097 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2098 !grad            enddo
2099 !grad          enddo
2100         enddo ! j
2101       enddo   ! i
2102 !grad      do i=nnt,nct-1
2103 !grad        do k=1,3
2104 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2105 !grad        enddo
2106 !grad        do j=i+1,nct-1
2107 !grad          do k=1,3
2108 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2109 !grad          enddo
2110 !grad        enddo
2111 !grad      enddo
2112       return
2113       end subroutine eelec_soft_sphere
2114 !-----------------------------------------------------------------------------
2115       subroutine vec_and_deriv
2116 !      implicit real*8 (a-h,o-z)
2117 !      include 'DIMENSIONS'
2118 #ifdef MPI
2119       include 'mpif.h'
2120 #endif
2121 !      include 'COMMON.IOUNITS'
2122 !      include 'COMMON.GEO'
2123 !      include 'COMMON.VAR'
2124 !      include 'COMMON.LOCAL'
2125 !      include 'COMMON.CHAIN'
2126 !      include 'COMMON.VECTORS'
2127 !      include 'COMMON.SETUP'
2128 !      include 'COMMON.TIME1'
2129       real(kind=8),dimension(3,3,2) :: uyder,uzder
2130       real(kind=8),dimension(2) :: vbld_inv_temp
2131 ! Compute the local reference systems. For reference system (i), the
2132 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2133 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2134 !el local variables
2135       integer :: i,j,k,l
2136       real(kind=8) :: facy,fac,costh
2137
2138 #ifdef PARVEC
2139       do i=ivec_start,ivec_end
2140 #else
2141       do i=1,nres-1
2142 #endif
2143           if (i.eq.nres-1) then
2144 ! Case of the last full residue
2145 ! Compute the Z-axis
2146             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2147             costh=dcos(pi-theta(nres))
2148             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2149             do k=1,3
2150               uz(k,i)=fac*uz(k,i)
2151             enddo
2152 ! Compute the derivatives of uz
2153             uzder(1,1,1)= 0.0d0
2154             uzder(2,1,1)=-dc_norm(3,i-1)
2155             uzder(3,1,1)= dc_norm(2,i-1)
2156             uzder(1,2,1)= dc_norm(3,i-1)
2157             uzder(2,2,1)= 0.0d0
2158             uzder(3,2,1)=-dc_norm(1,i-1)
2159             uzder(1,3,1)=-dc_norm(2,i-1)
2160             uzder(2,3,1)= dc_norm(1,i-1)
2161             uzder(3,3,1)= 0.0d0
2162             uzder(1,1,2)= 0.0d0
2163             uzder(2,1,2)= dc_norm(3,i)
2164             uzder(3,1,2)=-dc_norm(2,i)
2165             uzder(1,2,2)=-dc_norm(3,i)
2166             uzder(2,2,2)= 0.0d0
2167             uzder(3,2,2)= dc_norm(1,i)
2168             uzder(1,3,2)= dc_norm(2,i)
2169             uzder(2,3,2)=-dc_norm(1,i)
2170             uzder(3,3,2)= 0.0d0
2171 ! Compute the Y-axis
2172             facy=fac
2173             do k=1,3
2174               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2175             enddo
2176 ! Compute the derivatives of uy
2177             do j=1,3
2178               do k=1,3
2179                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2180                               -dc_norm(k,i)*dc_norm(j,i-1)
2181                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2182               enddo
2183               uyder(j,j,1)=uyder(j,j,1)-costh
2184               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2185             enddo
2186             do j=1,2
2187               do k=1,3
2188                 do l=1,3
2189                   uygrad(l,k,j,i)=uyder(l,k,j)
2190                   uzgrad(l,k,j,i)=uzder(l,k,j)
2191                 enddo
2192               enddo
2193             enddo
2194             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2195             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2196             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2197             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2198           else
2199 ! Other residues
2200 ! Compute the Z-axis
2201             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2202             costh=dcos(pi-theta(i+2))
2203             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2204             do k=1,3
2205               uz(k,i)=fac*uz(k,i)
2206             enddo
2207 ! Compute the derivatives of uz
2208             uzder(1,1,1)= 0.0d0
2209             uzder(2,1,1)=-dc_norm(3,i+1)
2210             uzder(3,1,1)= dc_norm(2,i+1)
2211             uzder(1,2,1)= dc_norm(3,i+1)
2212             uzder(2,2,1)= 0.0d0
2213             uzder(3,2,1)=-dc_norm(1,i+1)
2214             uzder(1,3,1)=-dc_norm(2,i+1)
2215             uzder(2,3,1)= dc_norm(1,i+1)
2216             uzder(3,3,1)= 0.0d0
2217             uzder(1,1,2)= 0.0d0
2218             uzder(2,1,2)= dc_norm(3,i)
2219             uzder(3,1,2)=-dc_norm(2,i)
2220             uzder(1,2,2)=-dc_norm(3,i)
2221             uzder(2,2,2)= 0.0d0
2222             uzder(3,2,2)= dc_norm(1,i)
2223             uzder(1,3,2)= dc_norm(2,i)
2224             uzder(2,3,2)=-dc_norm(1,i)
2225             uzder(3,3,2)= 0.0d0
2226 ! Compute the Y-axis
2227             facy=fac
2228             do k=1,3
2229               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2230             enddo
2231 ! Compute the derivatives of uy
2232             do j=1,3
2233               do k=1,3
2234                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2235                               -dc_norm(k,i)*dc_norm(j,i+1)
2236                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2237               enddo
2238               uyder(j,j,1)=uyder(j,j,1)-costh
2239               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2240             enddo
2241             do j=1,2
2242               do k=1,3
2243                 do l=1,3
2244                   uygrad(l,k,j,i)=uyder(l,k,j)
2245                   uzgrad(l,k,j,i)=uzder(l,k,j)
2246                 enddo
2247               enddo
2248             enddo
2249             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2250             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2251             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2252             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2253           endif
2254       enddo
2255       do i=1,nres-1
2256         vbld_inv_temp(1)=vbld_inv(i+1)
2257         if (i.lt.nres-1) then
2258           vbld_inv_temp(2)=vbld_inv(i+2)
2259           else
2260           vbld_inv_temp(2)=vbld_inv(i)
2261           endif
2262         do j=1,2
2263           do k=1,3
2264             do l=1,3
2265               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2266               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2267             enddo
2268           enddo
2269         enddo
2270       enddo
2271 #if defined(PARVEC) && defined(MPI)
2272       if (nfgtasks1.gt.1) then
2273         time00=MPI_Wtime()
2274 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2275 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2276 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2277         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2278          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2279          FG_COMM1,IERR)
2280         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2281          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2282          FG_COMM1,IERR)
2283         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2284          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2285          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2286         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2287          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2288          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2289         time_gather=time_gather+MPI_Wtime()-time00
2290       endif
2291 !      if (fg_rank.eq.0) then
2292 !        write (iout,*) "Arrays UY and UZ"
2293 !        do i=1,nres-1
2294 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2295 !     &     (uz(k,i),k=1,3)
2296 !        enddo
2297 !      endif
2298 #endif
2299       return
2300       end subroutine vec_and_deriv
2301 !-----------------------------------------------------------------------------
2302       subroutine check_vecgrad
2303 !      implicit real*8 (a-h,o-z)
2304 !      include 'DIMENSIONS'
2305 !      include 'COMMON.IOUNITS'
2306 !      include 'COMMON.GEO'
2307 !      include 'COMMON.VAR'
2308 !      include 'COMMON.LOCAL'
2309 !      include 'COMMON.CHAIN'
2310 !      include 'COMMON.VECTORS'
2311       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2312       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2313       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2314       real(kind=8),dimension(3) :: erij
2315       real(kind=8) :: delta=1.0d-7
2316 !el local variables
2317       integer :: i,j,k,l
2318
2319       call vec_and_deriv
2320 !d      do i=1,nres
2321 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2322 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2323 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2324 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2325 !d     &     (dc_norm(if90,i),if90=1,3)
2326 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2327 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2328 !d          write(iout,'(a)')
2329 !d      enddo
2330       do i=1,nres
2331         do j=1,2
2332           do k=1,3
2333             do l=1,3
2334               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2335               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2336             enddo
2337           enddo
2338         enddo
2339       enddo
2340       call vec_and_deriv
2341       do i=1,nres
2342         do j=1,3
2343           uyt(j,i)=uy(j,i)
2344           uzt(j,i)=uz(j,i)
2345         enddo
2346       enddo
2347       do i=1,nres
2348 !d        write (iout,*) 'i=',i
2349         do k=1,3
2350           erij(k)=dc_norm(k,i)
2351         enddo
2352         do j=1,3
2353           do k=1,3
2354             dc_norm(k,i)=erij(k)
2355           enddo
2356           dc_norm(j,i)=dc_norm(j,i)+delta
2357 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2358 !          do k=1,3
2359 !            dc_norm(k,i)=dc_norm(k,i)/fac
2360 !          enddo
2361 !          write (iout,*) (dc_norm(k,i),k=1,3)
2362 !          write (iout,*) (erij(k),k=1,3)
2363           call vec_and_deriv
2364           do k=1,3
2365             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2366             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2367             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2368             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2369           enddo
2370 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2371 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2372 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2373         enddo
2374         do k=1,3
2375           dc_norm(k,i)=erij(k)
2376         enddo
2377 !d        do k=1,3
2378 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2379 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2380 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2381 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2382 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2383 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2384 !d          write (iout,'(a)')
2385 !d        enddo
2386       enddo
2387       return
2388       end subroutine check_vecgrad
2389 !-----------------------------------------------------------------------------
2390       subroutine set_matrices
2391 !      implicit real*8 (a-h,o-z)
2392 !      include 'DIMENSIONS'
2393 #ifdef MPI
2394       include "mpif.h"
2395 !      include "COMMON.SETUP"
2396       integer :: IERR
2397       integer :: status(MPI_STATUS_SIZE)
2398 #endif
2399 !      include 'COMMON.IOUNITS'
2400 !      include 'COMMON.GEO'
2401 !      include 'COMMON.VAR'
2402 !      include 'COMMON.LOCAL'
2403 !      include 'COMMON.CHAIN'
2404 !      include 'COMMON.DERIV'
2405 !      include 'COMMON.INTERACT'
2406 !      include 'COMMON.CONTACTS'
2407 !      include 'COMMON.TORSION'
2408 !      include 'COMMON.VECTORS'
2409 !      include 'COMMON.FFIELD'
2410       real(kind=8) :: auxvec(2),auxmat(2,2)
2411       integer :: i,iti1,iti,k,l
2412       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2413 !       print *,"in set matrices"
2414 !
2415 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2416 ! to calculate the el-loc multibody terms of various order.
2417 !
2418 !AL el      mu=0.0d0
2419 #ifdef PARMAT
2420       do i=ivec_start+2,ivec_end+2
2421 #else
2422       do i=3,nres+1
2423 #endif
2424 !      print *,i,"i"
2425         if (i .lt. nres+1) then
2426           sin1=dsin(phi(i))
2427           cos1=dcos(phi(i))
2428           sintab(i-2)=sin1
2429           costab(i-2)=cos1
2430           obrot(1,i-2)=cos1
2431           obrot(2,i-2)=sin1
2432           sin2=dsin(2*phi(i))
2433           cos2=dcos(2*phi(i))
2434           sintab2(i-2)=sin2
2435           costab2(i-2)=cos2
2436           obrot2(1,i-2)=cos2
2437           obrot2(2,i-2)=sin2
2438           Ug(1,1,i-2)=-cos1
2439           Ug(1,2,i-2)=-sin1
2440           Ug(2,1,i-2)=-sin1
2441           Ug(2,2,i-2)= cos1
2442           Ug2(1,1,i-2)=-cos2
2443           Ug2(1,2,i-2)=-sin2
2444           Ug2(2,1,i-2)=-sin2
2445           Ug2(2,2,i-2)= cos2
2446         else
2447           costab(i-2)=1.0d0
2448           sintab(i-2)=0.0d0
2449           obrot(1,i-2)=1.0d0
2450           obrot(2,i-2)=0.0d0
2451           obrot2(1,i-2)=0.0d0
2452           obrot2(2,i-2)=0.0d0
2453           Ug(1,1,i-2)=1.0d0
2454           Ug(1,2,i-2)=0.0d0
2455           Ug(2,1,i-2)=0.0d0
2456           Ug(2,2,i-2)=1.0d0
2457           Ug2(1,1,i-2)=0.0d0
2458           Ug2(1,2,i-2)=0.0d0
2459           Ug2(2,1,i-2)=0.0d0
2460           Ug2(2,2,i-2)=0.0d0
2461         endif
2462         if (i .gt. 3 .and. i .lt. nres+1) then
2463           obrot_der(1,i-2)=-sin1
2464           obrot_der(2,i-2)= cos1
2465           Ugder(1,1,i-2)= sin1
2466           Ugder(1,2,i-2)=-cos1
2467           Ugder(2,1,i-2)=-cos1
2468           Ugder(2,2,i-2)=-sin1
2469           dwacos2=cos2+cos2
2470           dwasin2=sin2+sin2
2471           obrot2_der(1,i-2)=-dwasin2
2472           obrot2_der(2,i-2)= dwacos2
2473           Ug2der(1,1,i-2)= dwasin2
2474           Ug2der(1,2,i-2)=-dwacos2
2475           Ug2der(2,1,i-2)=-dwacos2
2476           Ug2der(2,2,i-2)=-dwasin2
2477         else
2478           obrot_der(1,i-2)=0.0d0
2479           obrot_der(2,i-2)=0.0d0
2480           Ugder(1,1,i-2)=0.0d0
2481           Ugder(1,2,i-2)=0.0d0
2482           Ugder(2,1,i-2)=0.0d0
2483           Ugder(2,2,i-2)=0.0d0
2484           obrot2_der(1,i-2)=0.0d0
2485           obrot2_der(2,i-2)=0.0d0
2486           Ug2der(1,1,i-2)=0.0d0
2487           Ug2der(1,2,i-2)=0.0d0
2488           Ug2der(2,1,i-2)=0.0d0
2489           Ug2der(2,2,i-2)=0.0d0
2490         endif
2491 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2492         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2493           iti = itortyp(itype(i-2,1))
2494         else
2495           iti=ntortyp+1
2496         endif
2497 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2498         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2499           iti1 = itortyp(itype(i-1,1))
2500         else
2501           iti1=ntortyp+1
2502         endif
2503 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2504 !d        write (iout,*) '*******i',i,' iti1',iti
2505 !d        write (iout,*) 'b1',b1(:,iti)
2506 !d        write (iout,*) 'b2',b2(:,iti)
2507 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2508 !        if (i .gt. iatel_s+2) then
2509         if (i .gt. nnt+2) then
2510           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2511           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2512           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2513           then
2514           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2515           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2516           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2517           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2518           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2519           endif
2520         else
2521           do k=1,2
2522             Ub2(k,i-2)=0.0d0
2523             Ctobr(k,i-2)=0.0d0
2524             Dtobr2(k,i-2)=0.0d0
2525             do l=1,2
2526               EUg(l,k,i-2)=0.0d0
2527               CUg(l,k,i-2)=0.0d0
2528               DUg(l,k,i-2)=0.0d0
2529               DtUg2(l,k,i-2)=0.0d0
2530             enddo
2531           enddo
2532         endif
2533         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2534         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2535         do k=1,2
2536           muder(k,i-2)=Ub2der(k,i-2)
2537         enddo
2538 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2539         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2540           if (itype(i-1,1).le.ntyp) then
2541             iti1 = itortyp(itype(i-1,1))
2542           else
2543             iti1=ntortyp+1
2544           endif
2545         else
2546           iti1=ntortyp+1
2547         endif
2548         do k=1,2
2549           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2550         enddo
2551 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2552 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2553 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2554 !d        write (iout,*) 'mu1',mu1(:,i-2)
2555 !d        write (iout,*) 'mu2',mu2(:,i-2)
2556         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2557         then
2558         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2559         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2560         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2561         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2562         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2563 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2564         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2565         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2566         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2567         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2568         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2569         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2570         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2571         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2572         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2573         endif
2574       enddo
2575 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2576 ! The order of matrices is from left to right.
2577       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2578       then
2579 !      do i=max0(ivec_start,2),ivec_end
2580       do i=2,nres-1
2581         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2582         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2583         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2584         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2585         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2586         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2587         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2588         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2589       enddo
2590       endif
2591 #if defined(MPI) && defined(PARMAT)
2592 #ifdef DEBUG
2593 !      if (fg_rank.eq.0) then
2594         write (iout,*) "Arrays UG and UGDER before GATHER"
2595         do i=1,nres-1
2596           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2597            ((ug(l,k,i),l=1,2),k=1,2),&
2598            ((ugder(l,k,i),l=1,2),k=1,2)
2599         enddo
2600         write (iout,*) "Arrays UG2 and UG2DER"
2601         do i=1,nres-1
2602           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2603            ((ug2(l,k,i),l=1,2),k=1,2),&
2604            ((ug2der(l,k,i),l=1,2),k=1,2)
2605         enddo
2606         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2607         do i=1,nres-1
2608           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2609            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2610            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2611         enddo
2612         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2613         do i=1,nres-1
2614           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2615            costab(i),sintab(i),costab2(i),sintab2(i)
2616         enddo
2617         write (iout,*) "Array MUDER"
2618         do i=1,nres-1
2619           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2620         enddo
2621 !      endif
2622 #endif
2623       if (nfgtasks.gt.1) then
2624         time00=MPI_Wtime()
2625 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2626 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2627 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2628 #ifdef MATGATHER
2629         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2630          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2631          FG_COMM1,IERR)
2632         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2633          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2634          FG_COMM1,IERR)
2635         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2636          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2637          FG_COMM1,IERR)
2638         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2639          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2640          FG_COMM1,IERR)
2641         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2642          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2643          FG_COMM1,IERR)
2644         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2645          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2646          FG_COMM1,IERR)
2647         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2648          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2649          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2650         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2651          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2652          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2653         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2654          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2655          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2656         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2657          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2658          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2659         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2660         then
2661         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2662          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2663          FG_COMM1,IERR)
2664         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2665          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2666          FG_COMM1,IERR)
2667         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2668          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2669          FG_COMM1,IERR)
2670        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2671          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2672          FG_COMM1,IERR)
2673         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2674          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2675          FG_COMM1,IERR)
2676         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2677          ivec_count(fg_rank1),&
2678          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2679          FG_COMM1,IERR)
2680         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2681          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2682          FG_COMM1,IERR)
2683         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2684          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2685          FG_COMM1,IERR)
2686         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2687          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2688          FG_COMM1,IERR)
2689         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2690          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2691          FG_COMM1,IERR)
2692         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2693          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2694          FG_COMM1,IERR)
2695         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2696          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2697          FG_COMM1,IERR)
2698         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2699          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2700          FG_COMM1,IERR)
2701         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2702          ivec_count(fg_rank1),&
2703          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2704          FG_COMM1,IERR)
2705         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2706          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2707          FG_COMM1,IERR)
2708        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2709          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2710          FG_COMM1,IERR)
2711         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2712          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2713          FG_COMM1,IERR)
2714        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2715          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2716          FG_COMM1,IERR)
2717         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2718          ivec_count(fg_rank1),&
2719          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2720          FG_COMM1,IERR)
2721         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2722          ivec_count(fg_rank1),&
2723          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2724          FG_COMM1,IERR)
2725         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2726          ivec_count(fg_rank1),&
2727          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2728          MPI_MAT2,FG_COMM1,IERR)
2729         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2730          ivec_count(fg_rank1),&
2731          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2732          MPI_MAT2,FG_COMM1,IERR)
2733         endif
2734 #else
2735 ! Passes matrix info through the ring
2736       isend=fg_rank1
2737       irecv=fg_rank1-1
2738       if (irecv.lt.0) irecv=nfgtasks1-1
2739       iprev=irecv
2740       inext=fg_rank1+1
2741       if (inext.ge.nfgtasks1) inext=0
2742       do i=1,nfgtasks1-1
2743 !        write (iout,*) "isend",isend," irecv",irecv
2744 !        call flush(iout)
2745         lensend=lentyp(isend)
2746         lenrecv=lentyp(irecv)
2747 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2748 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2749 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2750 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2751 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2752 !        write (iout,*) "Gather ROTAT1"
2753 !        call flush(iout)
2754 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2755 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2756 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2757 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2758 !        write (iout,*) "Gather ROTAT2"
2759 !        call flush(iout)
2760         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2761          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2762          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2763          iprev,4400+irecv,FG_COMM,status,IERR)
2764 !        write (iout,*) "Gather ROTAT_OLD"
2765 !        call flush(iout)
2766         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2767          MPI_PRECOMP11(lensend),inext,5500+isend,&
2768          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2769          iprev,5500+irecv,FG_COMM,status,IERR)
2770 !        write (iout,*) "Gather PRECOMP11"
2771 !        call flush(iout)
2772         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2773          MPI_PRECOMP12(lensend),inext,6600+isend,&
2774          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2775          iprev,6600+irecv,FG_COMM,status,IERR)
2776 !        write (iout,*) "Gather PRECOMP12"
2777 !        call flush(iout)
2778         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2779         then
2780         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2781          MPI_ROTAT2(lensend),inext,7700+isend,&
2782          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2783          iprev,7700+irecv,FG_COMM,status,IERR)
2784 !        write (iout,*) "Gather PRECOMP21"
2785 !        call flush(iout)
2786         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2787          MPI_PRECOMP22(lensend),inext,8800+isend,&
2788          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2789          iprev,8800+irecv,FG_COMM,status,IERR)
2790 !        write (iout,*) "Gather PRECOMP22"
2791 !        call flush(iout)
2792         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2793          MPI_PRECOMP23(lensend),inext,9900+isend,&
2794          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2795          MPI_PRECOMP23(lenrecv),&
2796          iprev,9900+irecv,FG_COMM,status,IERR)
2797 !        write (iout,*) "Gather PRECOMP23"
2798 !        call flush(iout)
2799         endif
2800         isend=irecv
2801         irecv=irecv-1
2802         if (irecv.lt.0) irecv=nfgtasks1-1
2803       enddo
2804 #endif
2805         time_gather=time_gather+MPI_Wtime()-time00
2806       endif
2807 #ifdef DEBUG
2808 !      if (fg_rank.eq.0) then
2809         write (iout,*) "Arrays UG and UGDER"
2810         do i=1,nres-1
2811           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2812            ((ug(l,k,i),l=1,2),k=1,2),&
2813            ((ugder(l,k,i),l=1,2),k=1,2)
2814         enddo
2815         write (iout,*) "Arrays UG2 and UG2DER"
2816         do i=1,nres-1
2817           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2818            ((ug2(l,k,i),l=1,2),k=1,2),&
2819            ((ug2der(l,k,i),l=1,2),k=1,2)
2820         enddo
2821         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2822         do i=1,nres-1
2823           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2824            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2825            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2826         enddo
2827         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2828         do i=1,nres-1
2829           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2830            costab(i),sintab(i),costab2(i),sintab2(i)
2831         enddo
2832         write (iout,*) "Array MUDER"
2833         do i=1,nres-1
2834           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2835         enddo
2836 !      endif
2837 #endif
2838 #endif
2839 !d      do i=1,nres
2840 !d        iti = itortyp(itype(i,1))
2841 !d        write (iout,*) i
2842 !d        do j=1,2
2843 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2844 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2845 !d        enddo
2846 !d      enddo
2847       return
2848       end subroutine set_matrices
2849 !-----------------------------------------------------------------------------
2850       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2851 !
2852 ! This subroutine calculates the average interaction energy and its gradient
2853 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2854 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2855 ! The potential depends both on the distance of peptide-group centers and on
2856 ! the orientation of the CA-CA virtual bonds.
2857 !
2858       use comm_locel
2859 !      implicit real*8 (a-h,o-z)
2860 #ifdef MPI
2861       include 'mpif.h'
2862 #endif
2863 !      include 'DIMENSIONS'
2864 !      include 'COMMON.CONTROL'
2865 !      include 'COMMON.SETUP'
2866 !      include 'COMMON.IOUNITS'
2867 !      include 'COMMON.GEO'
2868 !      include 'COMMON.VAR'
2869 !      include 'COMMON.LOCAL'
2870 !      include 'COMMON.CHAIN'
2871 !      include 'COMMON.DERIV'
2872 !      include 'COMMON.INTERACT'
2873 !      include 'COMMON.CONTACTS'
2874 !      include 'COMMON.TORSION'
2875 !      include 'COMMON.VECTORS'
2876 !      include 'COMMON.FFIELD'
2877 !      include 'COMMON.TIME1'
2878       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2879       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2880       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2881 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2882       real(kind=8),dimension(4) :: muij
2883 !el      integer :: num_conti,j1,j2
2884 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2885 !el        dz_normi,xmedi,ymedi,zmedi
2886
2887 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2888 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2889 !el          num_conti,j1,j2
2890
2891 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2892 #ifdef MOMENT
2893       real(kind=8) :: scal_el=1.0d0
2894 #else
2895       real(kind=8) :: scal_el=0.5d0
2896 #endif
2897 ! 12/13/98
2898 ! 13-go grudnia roku pamietnego...
2899       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2900                                              0.0d0,1.0d0,0.0d0,&
2901                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2902 !el local variables
2903       integer :: i,k,j
2904       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2905       real(kind=8) :: fac,t_eelecij,fracinbuf
2906
2907
2908 !d      write(iout,*) 'In EELEC'
2909 !        print *,"IN EELEC"
2910 !d      do i=1,nloctyp
2911 !d        write(iout,*) 'Type',i
2912 !d        write(iout,*) 'B1',B1(:,i)
2913 !d        write(iout,*) 'B2',B2(:,i)
2914 !d        write(iout,*) 'CC',CC(:,:,i)
2915 !d        write(iout,*) 'DD',DD(:,:,i)
2916 !d        write(iout,*) 'EE',EE(:,:,i)
2917 !d      enddo
2918 !d      call check_vecgrad
2919 !d      stop
2920 !      ees=0.0d0  !AS
2921 !      evdw1=0.0d0
2922 !      eel_loc=0.0d0
2923 !      eello_turn3=0.0d0
2924 !      eello_turn4=0.0d0
2925       t_eelecij=0.0d0
2926       ees=0.0D0
2927       evdw1=0.0D0
2928       eel_loc=0.0d0
2929       eello_turn3=0.0d0
2930       eello_turn4=0.0d0
2931 !
2932
2933       if (icheckgrad.eq.1) then
2934 !el
2935 !        do i=0,2*nres+2
2936 !          dc_norm(1,i)=0.0d0
2937 !          dc_norm(2,i)=0.0d0
2938 !          dc_norm(3,i)=0.0d0
2939 !        enddo
2940         do i=1,nres-1
2941           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2942           do k=1,3
2943             dc_norm(k,i)=dc(k,i)*fac
2944           enddo
2945 !          write (iout,*) 'i',i,' fac',fac
2946         enddo
2947       endif
2948 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2949 !        wturn6
2950       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2951           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2952           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2953 !        call vec_and_deriv
2954 #ifdef TIMING
2955         time01=MPI_Wtime()
2956 #endif
2957 !        print *, "before set matrices"
2958         call set_matrices
2959 !        print *, "after set matrices"
2960
2961 #ifdef TIMING
2962         time_mat=time_mat+MPI_Wtime()-time01
2963 #endif
2964       endif
2965 !       print *, "after set matrices"
2966 !d      do i=1,nres-1
2967 !d        write (iout,*) 'i=',i
2968 !d        do k=1,3
2969 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2970 !d        enddo
2971 !d        do k=1,3
2972 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2973 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2974 !d        enddo
2975 !d      enddo
2976       t_eelecij=0.0d0
2977       ees=0.0D0
2978       evdw1=0.0D0
2979       eel_loc=0.0d0
2980       eello_turn3=0.0d0
2981       eello_turn4=0.0d0
2982 !el      ind=0
2983       do i=1,nres
2984         num_cont_hb(i)=0
2985       enddo
2986 !d      print '(a)','Enter EELEC'
2987 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2988 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2989 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2990       do i=1,nres
2991         gel_loc_loc(i)=0.0d0
2992         gcorr_loc(i)=0.0d0
2993       enddo
2994 !
2995 !
2996 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2997 !
2998 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2999 !
3000
3001
3002 !        print *,"before iturn3 loop"
3003       do i=iturn3_start,iturn3_end
3004         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3005         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3006         dxi=dc(1,i)
3007         dyi=dc(2,i)
3008         dzi=dc(3,i)
3009         dx_normi=dc_norm(1,i)
3010         dy_normi=dc_norm(2,i)
3011         dz_normi=dc_norm(3,i)
3012         xmedi=c(1,i)+0.5d0*dxi
3013         ymedi=c(2,i)+0.5d0*dyi
3014         zmedi=c(3,i)+0.5d0*dzi
3015           xmedi=dmod(xmedi,boxxsize)
3016           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3017           ymedi=dmod(ymedi,boxysize)
3018           if (ymedi.lt.0) ymedi=ymedi+boxysize
3019           zmedi=dmod(zmedi,boxzsize)
3020           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3021         num_conti=0
3022        if ((zmedi.gt.bordlipbot) &
3023         .and.(zmedi.lt.bordliptop)) then
3024 !C the energy transfer exist
3025         if (zmedi.lt.buflipbot) then
3026 !C what fraction I am in
3027          fracinbuf=1.0d0- &
3028                ((zmedi-bordlipbot)/lipbufthick)
3029 !C lipbufthick is thickenes of lipid buffore
3030          sslipi=sscalelip(fracinbuf)
3031          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3032         elseif (zmedi.gt.bufliptop) then
3033          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3034          sslipi=sscalelip(fracinbuf)
3035          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3036         else
3037          sslipi=1.0d0
3038          ssgradlipi=0.0
3039         endif
3040        else
3041          sslipi=0.0d0
3042          ssgradlipi=0.0
3043        endif
3044 !       print *,i,sslipi,ssgradlipi
3045        call eelecij(i,i+2,ees,evdw1,eel_loc)
3046         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3047         num_cont_hb(i)=num_conti
3048       enddo
3049       do i=iturn4_start,iturn4_end
3050         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3051           .or. itype(i+3,1).eq.ntyp1 &
3052           .or. itype(i+4,1).eq.ntyp1) cycle
3053         dxi=dc(1,i)
3054         dyi=dc(2,i)
3055         dzi=dc(3,i)
3056         dx_normi=dc_norm(1,i)
3057         dy_normi=dc_norm(2,i)
3058         dz_normi=dc_norm(3,i)
3059         xmedi=c(1,i)+0.5d0*dxi
3060         ymedi=c(2,i)+0.5d0*dyi
3061         zmedi=c(3,i)+0.5d0*dzi
3062           xmedi=dmod(xmedi,boxxsize)
3063           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3064           ymedi=dmod(ymedi,boxysize)
3065           if (ymedi.lt.0) ymedi=ymedi+boxysize
3066           zmedi=dmod(zmedi,boxzsize)
3067           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3068        if ((zmedi.gt.bordlipbot)  &
3069        .and.(zmedi.lt.bordliptop)) then
3070 !C the energy transfer exist
3071         if (zmedi.lt.buflipbot) then
3072 !C what fraction I am in
3073          fracinbuf=1.0d0- &
3074              ((zmedi-bordlipbot)/lipbufthick)
3075 !C lipbufthick is thickenes of lipid buffore
3076          sslipi=sscalelip(fracinbuf)
3077          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3078         elseif (zmedi.gt.bufliptop) then
3079          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3080          sslipi=sscalelip(fracinbuf)
3081          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3082         else
3083          sslipi=1.0d0
3084          ssgradlipi=0.0
3085         endif
3086        else
3087          sslipi=0.0d0
3088          ssgradlipi=0.0
3089        endif
3090
3091         num_conti=num_cont_hb(i)
3092         call eelecij(i,i+3,ees,evdw1,eel_loc)
3093         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3094          call eturn4(i,eello_turn4)
3095         num_cont_hb(i)=num_conti
3096       enddo   ! i
3097 !
3098 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3099 !
3100 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3101       do i=iatel_s,iatel_e
3102         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3103         dxi=dc(1,i)
3104         dyi=dc(2,i)
3105         dzi=dc(3,i)
3106         dx_normi=dc_norm(1,i)
3107         dy_normi=dc_norm(2,i)
3108         dz_normi=dc_norm(3,i)
3109         xmedi=c(1,i)+0.5d0*dxi
3110         ymedi=c(2,i)+0.5d0*dyi
3111         zmedi=c(3,i)+0.5d0*dzi
3112           xmedi=dmod(xmedi,boxxsize)
3113           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3114           ymedi=dmod(ymedi,boxysize)
3115           if (ymedi.lt.0) ymedi=ymedi+boxysize
3116           zmedi=dmod(zmedi,boxzsize)
3117           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3118        if ((zmedi.gt.bordlipbot)  &
3119         .and.(zmedi.lt.bordliptop)) then
3120 !C the energy transfer exist
3121         if (zmedi.lt.buflipbot) then
3122 !C what fraction I am in
3123          fracinbuf=1.0d0- &
3124              ((zmedi-bordlipbot)/lipbufthick)
3125 !C lipbufthick is thickenes of lipid buffore
3126          sslipi=sscalelip(fracinbuf)
3127          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3128         elseif (zmedi.gt.bufliptop) then
3129          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3130          sslipi=sscalelip(fracinbuf)
3131          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3132         else
3133          sslipi=1.0d0
3134          ssgradlipi=0.0
3135         endif
3136        else
3137          sslipi=0.0d0
3138          ssgradlipi=0.0
3139        endif
3140
3141 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3142         num_conti=num_cont_hb(i)
3143         do j=ielstart(i),ielend(i)
3144 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3145           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3146           call eelecij(i,j,ees,evdw1,eel_loc)
3147         enddo ! j
3148         num_cont_hb(i)=num_conti
3149       enddo   ! i
3150 !      write (iout,*) "Number of loop steps in EELEC:",ind
3151 !d      do i=1,nres
3152 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3153 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3154 !d      enddo
3155 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3156 !cc      eel_loc=eel_loc+eello_turn3
3157 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3158       return
3159       end subroutine eelec
3160 !-----------------------------------------------------------------------------
3161       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3162
3163       use comm_locel
3164 !      implicit real*8 (a-h,o-z)
3165 !      include 'DIMENSIONS'
3166 #ifdef MPI
3167       include "mpif.h"
3168 #endif
3169 !      include 'COMMON.CONTROL'
3170 !      include 'COMMON.IOUNITS'
3171 !      include 'COMMON.GEO'
3172 !      include 'COMMON.VAR'
3173 !      include 'COMMON.LOCAL'
3174 !      include 'COMMON.CHAIN'
3175 !      include 'COMMON.DERIV'
3176 !      include 'COMMON.INTERACT'
3177 !      include 'COMMON.CONTACTS'
3178 !      include 'COMMON.TORSION'
3179 !      include 'COMMON.VECTORS'
3180 !      include 'COMMON.FFIELD'
3181 !      include 'COMMON.TIME1'
3182       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3183       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3184       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3185 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3186       real(kind=8),dimension(4) :: muij
3187       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3188                     dist_temp, dist_init,rlocshield,fracinbuf
3189       integer xshift,yshift,zshift,ilist,iresshield
3190 !el      integer :: num_conti,j1,j2
3191 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3192 !el        dz_normi,xmedi,ymedi,zmedi
3193
3194 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3195 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3196 !el          num_conti,j1,j2
3197
3198 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3199 #ifdef MOMENT
3200       real(kind=8) :: scal_el=1.0d0
3201 #else
3202       real(kind=8) :: scal_el=0.5d0
3203 #endif
3204 ! 12/13/98
3205 ! 13-go grudnia roku pamietnego...
3206       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3207                                              0.0d0,1.0d0,0.0d0,&
3208                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3209 !      integer :: maxconts=nres/4
3210 !el local variables
3211       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3212       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3213       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3214       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3215                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3216                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3217                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3218                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3219                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3220                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3221                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3222 !      maxconts=nres/4
3223 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3224 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3225
3226 !          time00=MPI_Wtime()
3227 !d      write (iout,*) "eelecij",i,j
3228 !          ind=ind+1
3229           iteli=itel(i)
3230           itelj=itel(j)
3231           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3232           aaa=app(iteli,itelj)
3233           bbb=bpp(iteli,itelj)
3234           ael6i=ael6(iteli,itelj)
3235           ael3i=ael3(iteli,itelj)
3236           dxj=dc(1,j)
3237           dyj=dc(2,j)
3238           dzj=dc(3,j)
3239           dx_normj=dc_norm(1,j)
3240           dy_normj=dc_norm(2,j)
3241           dz_normj=dc_norm(3,j)
3242 !          xj=c(1,j)+0.5D0*dxj-xmedi
3243 !          yj=c(2,j)+0.5D0*dyj-ymedi
3244 !          zj=c(3,j)+0.5D0*dzj-zmedi
3245           xj=c(1,j)+0.5D0*dxj
3246           yj=c(2,j)+0.5D0*dyj
3247           zj=c(3,j)+0.5D0*dzj
3248           xj=mod(xj,boxxsize)
3249           if (xj.lt.0) xj=xj+boxxsize
3250           yj=mod(yj,boxysize)
3251           if (yj.lt.0) yj=yj+boxysize
3252           zj=mod(zj,boxzsize)
3253           if (zj.lt.0) zj=zj+boxzsize
3254        if ((zj.gt.bordlipbot)  &
3255        .and.(zj.lt.bordliptop)) then
3256 !C the energy transfer exist
3257         if (zj.lt.buflipbot) then
3258 !C what fraction I am in
3259          fracinbuf=1.0d0-     &
3260              ((zj-bordlipbot)/lipbufthick)
3261 !C lipbufthick is thickenes of lipid buffore
3262          sslipj=sscalelip(fracinbuf)
3263          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3264         elseif (zj.gt.bufliptop) then
3265          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3266          sslipj=sscalelip(fracinbuf)
3267          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3268         else
3269          sslipj=1.0d0
3270          ssgradlipj=0.0
3271         endif
3272        else
3273          sslipj=0.0d0
3274          ssgradlipj=0.0
3275        endif
3276
3277       isubchap=0
3278       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3279       xj_safe=xj
3280       yj_safe=yj
3281       zj_safe=zj
3282       do xshift=-1,1
3283       do yshift=-1,1
3284       do zshift=-1,1
3285           xj=xj_safe+xshift*boxxsize
3286           yj=yj_safe+yshift*boxysize
3287           zj=zj_safe+zshift*boxzsize
3288           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3289           if(dist_temp.lt.dist_init) then
3290             dist_init=dist_temp
3291             xj_temp=xj
3292             yj_temp=yj
3293             zj_temp=zj
3294             isubchap=1
3295           endif
3296        enddo
3297        enddo
3298        enddo
3299        if (isubchap.eq.1) then
3300 !C          print *,i,j
3301           xj=xj_temp-xmedi
3302           yj=yj_temp-ymedi
3303           zj=zj_temp-zmedi
3304        else
3305           xj=xj_safe-xmedi
3306           yj=yj_safe-ymedi
3307           zj=zj_safe-zmedi
3308        endif
3309
3310           rij=xj*xj+yj*yj+zj*zj
3311           rrmij=1.0D0/rij
3312           rij=dsqrt(rij)
3313 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3314             sss_ele_cut=sscale_ele(rij)
3315             sss_ele_grad=sscagrad_ele(rij)
3316 !             sss_ele_cut=1.0d0
3317 !             sss_ele_grad=0.0d0
3318 !            print *,sss_ele_cut,sss_ele_grad,&
3319 !            (rij),r_cut_ele,rlamb_ele
3320 !            if (sss_ele_cut.le.0.0) go to 128
3321
3322           rmij=1.0D0/rij
3323           r3ij=rrmij*rmij
3324           r6ij=r3ij*r3ij
3325           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3326           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3327           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3328           fac=cosa-3.0D0*cosb*cosg
3329           ev1=aaa*r6ij*r6ij
3330 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3331           if (j.eq.i+2) ev1=scal_el*ev1
3332           ev2=bbb*r6ij
3333           fac3=ael6i*r6ij
3334           fac4=ael3i*r3ij
3335           evdwij=ev1+ev2
3336           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3337           el2=fac4*fac
3338 !          eesij=el1+el2
3339           if (shield_mode.gt.0) then
3340 !C          fac_shield(i)=0.4
3341 !C          fac_shield(j)=0.6
3342           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3343           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3344           eesij=(el1+el2)
3345           ees=ees+eesij*sss_ele_cut
3346 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3347 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3348           else
3349           fac_shield(i)=1.0
3350           fac_shield(j)=1.0
3351           eesij=(el1+el2)
3352           ees=ees+eesij   &
3353             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3354 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3355           endif
3356
3357 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3358           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3359 !          ees=ees+eesij*sss_ele_cut
3360           evdw1=evdw1+evdwij*sss_ele_cut  &
3361            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3362 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3363 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3364 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3365 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3366
3367           if (energy_dec) then
3368 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3369 !                  'evdw1',i,j,evdwij,&
3370 !                  iteli,itelj,aaa,evdw1
3371               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3372               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3373           endif
3374 !
3375 ! Calculate contributions to the Cartesian gradient.
3376 !
3377 #ifdef SPLITELE
3378           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3379               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3380           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3381              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3382           fac1=fac
3383           erij(1)=xj*rmij
3384           erij(2)=yj*rmij
3385           erij(3)=zj*rmij
3386 !
3387 ! Radial derivatives. First process both termini of the fragment (i,j)
3388 !
3389           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3390           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3391           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3392            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3393           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3394             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3395
3396           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3397           (shield_mode.gt.0)) then
3398 !C          print *,i,j
3399           do ilist=1,ishield_list(i)
3400            iresshield=shield_list(ilist,i)
3401            do k=1,3
3402            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3403            *2.0*sss_ele_cut
3404            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3405                    rlocshield &
3406             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3407             *sss_ele_cut
3408             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3409            enddo
3410           enddo
3411           do ilist=1,ishield_list(j)
3412            iresshield=shield_list(ilist,j)
3413            do k=1,3
3414            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3415           *2.0*sss_ele_cut
3416            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3417                    rlocshield &
3418            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3419            *sss_ele_cut
3420            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3421            enddo
3422           enddo
3423           do k=1,3
3424             gshieldc(k,i)=gshieldc(k,i)+ &
3425                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3426            *sss_ele_cut
3427
3428             gshieldc(k,j)=gshieldc(k,j)+ &
3429                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3430            *sss_ele_cut
3431
3432             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3433                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3434            *sss_ele_cut
3435
3436             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3437                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3438            *sss_ele_cut
3439
3440            enddo
3441            endif
3442
3443
3444 !          do k=1,3
3445 !            ghalf=0.5D0*ggg(k)
3446 !            gelc(k,i)=gelc(k,i)+ghalf
3447 !            gelc(k,j)=gelc(k,j)+ghalf
3448 !          enddo
3449 ! 9/28/08 AL Gradient compotents will be summed only at the end
3450           do k=1,3
3451             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3452             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3453           enddo
3454             gelc_long(3,j)=gelc_long(3,j)+  &
3455           ssgradlipj*eesij/2.0d0*lipscale**2&
3456            *sss_ele_cut
3457
3458             gelc_long(3,i)=gelc_long(3,i)+  &
3459           ssgradlipi*eesij/2.0d0*lipscale**2&
3460            *sss_ele_cut
3461
3462
3463 !
3464 ! Loop over residues i+1 thru j-1.
3465 !
3466 !grad          do k=i+1,j-1
3467 !grad            do l=1,3
3468 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3469 !grad            enddo
3470 !grad          enddo
3471           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3472            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3473           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3474            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3475           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3476            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3477
3478 !          do k=1,3
3479 !            ghalf=0.5D0*ggg(k)
3480 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3481 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3482 !          enddo
3483 ! 9/28/08 AL Gradient compotents will be summed only at the end
3484           do k=1,3
3485             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3486             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3487           enddo
3488
3489 !C Lipidic part for scaling weight
3490            gvdwpp(3,j)=gvdwpp(3,j)+ &
3491           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3492            gvdwpp(3,i)=gvdwpp(3,i)+ &
3493           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3494 !! Loop over residues i+1 thru j-1.
3495 !
3496 !grad          do k=i+1,j-1
3497 !grad            do l=1,3
3498 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3499 !grad            enddo
3500 !grad          enddo
3501 #else
3502           facvdw=(ev1+evdwij)*sss_ele_cut &
3503            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3504
3505           facel=(el1+eesij)*sss_ele_cut
3506           fac1=fac
3507           fac=-3*rrmij*(facvdw+facvdw+facel)
3508           erij(1)=xj*rmij
3509           erij(2)=yj*rmij
3510           erij(3)=zj*rmij
3511 !
3512 ! Radial derivatives. First process both termini of the fragment (i,j)
3513 !
3514           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3515           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3516           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3517 !          do k=1,3
3518 !            ghalf=0.5D0*ggg(k)
3519 !            gelc(k,i)=gelc(k,i)+ghalf
3520 !            gelc(k,j)=gelc(k,j)+ghalf
3521 !          enddo
3522 ! 9/28/08 AL Gradient compotents will be summed only at the end
3523           do k=1,3
3524             gelc_long(k,j)=gelc(k,j)+ggg(k)
3525             gelc_long(k,i)=gelc(k,i)-ggg(k)
3526           enddo
3527 !
3528 ! Loop over residues i+1 thru j-1.
3529 !
3530 !grad          do k=i+1,j-1
3531 !grad            do l=1,3
3532 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3533 !grad            enddo
3534 !grad          enddo
3535 ! 9/28/08 AL Gradient compotents will be summed only at the end
3536           ggg(1)=facvdw*xj &
3537            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3538           ggg(2)=facvdw*yj &
3539            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3540           ggg(3)=facvdw*zj &
3541            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3542
3543           do k=1,3
3544             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3545             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3546           enddo
3547            gvdwpp(3,j)=gvdwpp(3,j)+ &
3548           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3549            gvdwpp(3,i)=gvdwpp(3,i)+ &
3550           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3551
3552 #endif
3553 !
3554 ! Angular part
3555 !
3556           ecosa=2.0D0*fac3*fac1+fac4
3557           fac4=-3.0D0*fac4
3558           fac3=-6.0D0*fac3
3559           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3560           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3561           do k=1,3
3562             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3563             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3564           enddo
3565 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3566 !d   &          (dcosg(k),k=1,3)
3567           do k=1,3
3568             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3569              *fac_shield(i)**2*fac_shield(j)**2 &
3570              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3571
3572           enddo
3573 !          do k=1,3
3574 !            ghalf=0.5D0*ggg(k)
3575 !            gelc(k,i)=gelc(k,i)+ghalf
3576 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3577 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3578 !            gelc(k,j)=gelc(k,j)+ghalf
3579 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3580 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3581 !          enddo
3582 !grad          do k=i+1,j-1
3583 !grad            do l=1,3
3584 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3585 !grad            enddo
3586 !grad          enddo
3587           do k=1,3
3588             gelc(k,i)=gelc(k,i) &
3589                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3590                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3591                      *sss_ele_cut &
3592                      *fac_shield(i)**2*fac_shield(j)**2 &
3593                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3594
3595             gelc(k,j)=gelc(k,j) &
3596                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3597                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3598                      *sss_ele_cut  &
3599                      *fac_shield(i)**2*fac_shield(j)**2  &
3600                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3601
3602             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3603             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3604           enddo
3605
3606           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3607               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3608               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3609 !
3610 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3611 !   energy of a peptide unit is assumed in the form of a second-order
3612 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3613 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3614 !   are computed for EVERY pair of non-contiguous peptide groups.
3615 !
3616           if (j.lt.nres-1) then
3617             j1=j+1
3618             j2=j-1
3619           else
3620             j1=j-1
3621             j2=j-2
3622           endif
3623           kkk=0
3624           do k=1,2
3625             do l=1,2
3626               kkk=kkk+1
3627               muij(kkk)=mu(k,i)*mu(l,j)
3628             enddo
3629           enddo
3630 !d         write (iout,*) 'EELEC: i',i,' j',j
3631 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3632 !d          write(iout,*) 'muij',muij
3633           ury=scalar(uy(1,i),erij)
3634           urz=scalar(uz(1,i),erij)
3635           vry=scalar(uy(1,j),erij)
3636           vrz=scalar(uz(1,j),erij)
3637           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3638           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3639           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3640           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3641           fac=dsqrt(-ael6i)*r3ij
3642           a22=a22*fac
3643           a23=a23*fac
3644           a32=a32*fac
3645           a33=a33*fac
3646 !d          write (iout,'(4i5,4f10.5)')
3647 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3648 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3649 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3650 !d     &      uy(:,j),uz(:,j)
3651 !d          write (iout,'(4f10.5)')
3652 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3653 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3654 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3655 !d           write (iout,'(9f10.5/)')
3656 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3657 ! Derivatives of the elements of A in virtual-bond vectors
3658           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3659           do k=1,3
3660             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3661             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3662             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3663             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3664             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3665             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3666             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3667             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3668             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3669             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3670             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3671             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3672           enddo
3673 ! Compute radial contributions to the gradient
3674           facr=-3.0d0*rrmij
3675           a22der=a22*facr
3676           a23der=a23*facr
3677           a32der=a32*facr
3678           a33der=a33*facr
3679           agg(1,1)=a22der*xj
3680           agg(2,1)=a22der*yj
3681           agg(3,1)=a22der*zj
3682           agg(1,2)=a23der*xj
3683           agg(2,2)=a23der*yj
3684           agg(3,2)=a23der*zj
3685           agg(1,3)=a32der*xj
3686           agg(2,3)=a32der*yj
3687           agg(3,3)=a32der*zj
3688           agg(1,4)=a33der*xj
3689           agg(2,4)=a33der*yj
3690           agg(3,4)=a33der*zj
3691 ! Add the contributions coming from er
3692           fac3=-3.0d0*fac
3693           do k=1,3
3694             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3695             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3696             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3697             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3698           enddo
3699           do k=1,3
3700 ! Derivatives in DC(i)
3701 !grad            ghalf1=0.5d0*agg(k,1)
3702 !grad            ghalf2=0.5d0*agg(k,2)
3703 !grad            ghalf3=0.5d0*agg(k,3)
3704 !grad            ghalf4=0.5d0*agg(k,4)
3705             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3706             -3.0d0*uryg(k,2)*vry)!+ghalf1
3707             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3708             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3709             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3710             -3.0d0*urzg(k,2)*vry)!+ghalf3
3711             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3712             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3713 ! Derivatives in DC(i+1)
3714             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3715             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3716             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3717             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3718             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3719             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3720             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3721             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3722 ! Derivatives in DC(j)
3723             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3724             -3.0d0*vryg(k,2)*ury)!+ghalf1
3725             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3726             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3727             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3728             -3.0d0*vryg(k,2)*urz)!+ghalf3
3729             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3730             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3731 ! Derivatives in DC(j+1) or DC(nres-1)
3732             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3733             -3.0d0*vryg(k,3)*ury)
3734             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3735             -3.0d0*vrzg(k,3)*ury)
3736             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3737             -3.0d0*vryg(k,3)*urz)
3738             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3739             -3.0d0*vrzg(k,3)*urz)
3740 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3741 !grad              do l=1,4
3742 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3743 !grad              enddo
3744 !grad            endif
3745           enddo
3746           acipa(1,1)=a22
3747           acipa(1,2)=a23
3748           acipa(2,1)=a32
3749           acipa(2,2)=a33
3750           a22=-a22
3751           a23=-a23
3752           do l=1,2
3753             do k=1,3
3754               agg(k,l)=-agg(k,l)
3755               aggi(k,l)=-aggi(k,l)
3756               aggi1(k,l)=-aggi1(k,l)
3757               aggj(k,l)=-aggj(k,l)
3758               aggj1(k,l)=-aggj1(k,l)
3759             enddo
3760           enddo
3761           if (j.lt.nres-1) then
3762             a22=-a22
3763             a32=-a32
3764             do l=1,3,2
3765               do k=1,3
3766                 agg(k,l)=-agg(k,l)
3767                 aggi(k,l)=-aggi(k,l)
3768                 aggi1(k,l)=-aggi1(k,l)
3769                 aggj(k,l)=-aggj(k,l)
3770                 aggj1(k,l)=-aggj1(k,l)
3771               enddo
3772             enddo
3773           else
3774             a22=-a22
3775             a23=-a23
3776             a32=-a32
3777             a33=-a33
3778             do l=1,4
3779               do k=1,3
3780                 agg(k,l)=-agg(k,l)
3781                 aggi(k,l)=-aggi(k,l)
3782                 aggi1(k,l)=-aggi1(k,l)
3783                 aggj(k,l)=-aggj(k,l)
3784                 aggj1(k,l)=-aggj1(k,l)
3785               enddo
3786             enddo
3787           endif
3788           ENDIF ! WCORR
3789           IF (wel_loc.gt.0.0d0) THEN
3790 ! Contribution to the local-electrostatic energy coming from the i-j pair
3791           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3792            +a33*muij(4)
3793           if (shield_mode.eq.0) then
3794            fac_shield(i)=1.0
3795            fac_shield(j)=1.0
3796           endif
3797           eel_loc_ij=eel_loc_ij &
3798          *fac_shield(i)*fac_shield(j) &
3799          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3800 !C Now derivative over eel_loc
3801           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3802          (shield_mode.gt.0)) then
3803 !C          print *,i,j
3804
3805           do ilist=1,ishield_list(i)
3806            iresshield=shield_list(ilist,i)
3807            do k=1,3
3808            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3809                                                 /fac_shield(i)&
3810            *sss_ele_cut
3811            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3812                    rlocshield  &
3813           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3814           *sss_ele_cut
3815
3816             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3817            +rlocshield
3818            enddo
3819           enddo
3820           do ilist=1,ishield_list(j)
3821            iresshield=shield_list(ilist,j)
3822            do k=1,3
3823            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3824                                             /fac_shield(j)   &
3825             *sss_ele_cut
3826            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3827                    rlocshield  &
3828       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3829        *sss_ele_cut
3830
3831            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3832                   +rlocshield
3833
3834            enddo
3835           enddo
3836
3837           do k=1,3
3838             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3839                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3840                     *sss_ele_cut
3841             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3842                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3843                     *sss_ele_cut
3844             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3845                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3846                     *sss_ele_cut
3847             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3848                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3849                     *sss_ele_cut
3850
3851            enddo
3852            endif
3853
3854
3855 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3856 !           eel_loc_ij=0.0
3857           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3858                   'eelloc',i,j,eel_loc_ij
3859 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3860 !          if (energy_dec) write (iout,*) "muij",muij
3861 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3862
3863           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3864 ! Partial derivatives in virtual-bond dihedral angles gamma
3865           if (i.gt.1) &
3866           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3867                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3868                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3869                  *sss_ele_cut  &
3870           *fac_shield(i)*fac_shield(j) &
3871           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3872
3873           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3874                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3875                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3876                  *sss_ele_cut &
3877           *fac_shield(i)*fac_shield(j) &
3878           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3879 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3880 !          do l=1,3
3881 !            ggg(1)=(agg(1,1)*muij(1)+ &
3882 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3883 !            *sss_ele_cut &
3884 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3885 !            ggg(2)=(agg(2,1)*muij(1)+ &
3886 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3887 !            *sss_ele_cut &
3888 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3889 !            ggg(3)=(agg(3,1)*muij(1)+ &
3890 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3891 !            *sss_ele_cut &
3892 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3893            xtemp(1)=xj
3894            xtemp(2)=yj
3895            xtemp(3)=zj
3896
3897            do l=1,3
3898             ggg(l)=(agg(l,1)*muij(1)+ &
3899                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3900             *sss_ele_cut &
3901           *fac_shield(i)*fac_shield(j) &
3902           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3903              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3904
3905
3906             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3907             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3908 !grad            ghalf=0.5d0*ggg(l)
3909 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3910 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3911           enddo
3912             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3913           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3914           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3915
3916             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3917           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3918           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3919
3920 !grad          do k=i+1,j2
3921 !grad            do l=1,3
3922 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3923 !grad            enddo
3924 !grad          enddo
3925 ! Remaining derivatives of eello
3926           do l=1,3
3927             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3928                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3929             *sss_ele_cut &
3930           *fac_shield(i)*fac_shield(j) &
3931           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3932
3933 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3934             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3935                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3936             +aggi1(l,4)*muij(4))&
3937             *sss_ele_cut &
3938           *fac_shield(i)*fac_shield(j) &
3939           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3940
3941 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3942             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3943                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3944             *sss_ele_cut &
3945           *fac_shield(i)*fac_shield(j) &
3946           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3947
3948 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3949             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3950                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3951             +aggj1(l,4)*muij(4))&
3952             *sss_ele_cut &
3953           *fac_shield(i)*fac_shield(j) &
3954           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3955
3956 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3957           enddo
3958           ENDIF
3959 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3960 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3961           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3962              .and. num_conti.le.maxconts) then
3963 !            write (iout,*) i,j," entered corr"
3964 !
3965 ! Calculate the contact function. The ith column of the array JCONT will
3966 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3967 ! greater than I). The arrays FACONT and GACONT will contain the values of
3968 ! the contact function and its derivative.
3969 !           r0ij=1.02D0*rpp(iteli,itelj)
3970 !           r0ij=1.11D0*rpp(iteli,itelj)
3971             r0ij=2.20D0*rpp(iteli,itelj)
3972 !           r0ij=1.55D0*rpp(iteli,itelj)
3973             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3974 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3975             if (fcont.gt.0.0D0) then
3976               num_conti=num_conti+1
3977               if (num_conti.gt.maxconts) then
3978 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3979 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3980                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3981                                ' will skip next contacts for this conf.', num_conti
3982               else
3983                 jcont_hb(num_conti,i)=j
3984 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3985 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3986                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3987                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3988 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3989 !  terms.
3990                 d_cont(num_conti,i)=rij
3991 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3992 !     --- Electrostatic-interaction matrix ---
3993                 a_chuj(1,1,num_conti,i)=a22
3994                 a_chuj(1,2,num_conti,i)=a23
3995                 a_chuj(2,1,num_conti,i)=a32
3996                 a_chuj(2,2,num_conti,i)=a33
3997 !     --- Gradient of rij
3998                 do kkk=1,3
3999                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4000                 enddo
4001                 kkll=0
4002                 do k=1,2
4003                   do l=1,2
4004                     kkll=kkll+1
4005                     do m=1,3
4006                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4007                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4008                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4009                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4010                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4011                     enddo
4012                   enddo
4013                 enddo
4014                 ENDIF
4015                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4016 ! Calculate contact energies
4017                 cosa4=4.0D0*cosa
4018                 wij=cosa-3.0D0*cosb*cosg
4019                 cosbg1=cosb+cosg
4020                 cosbg2=cosb-cosg
4021 !               fac3=dsqrt(-ael6i)/r0ij**3
4022                 fac3=dsqrt(-ael6i)*r3ij
4023 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4024                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4025                 if (ees0tmp.gt.0) then
4026                   ees0pij=dsqrt(ees0tmp)
4027                 else
4028                   ees0pij=0
4029                 endif
4030                 if (shield_mode.eq.0) then
4031                 fac_shield(i)=1.0d0
4032                 fac_shield(j)=1.0d0
4033                 else
4034                 ees0plist(num_conti,i)=j
4035                 endif
4036 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4037                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4038                 if (ees0tmp.gt.0) then
4039                   ees0mij=dsqrt(ees0tmp)
4040                 else
4041                   ees0mij=0
4042                 endif
4043 !               ees0mij=0.0D0
4044                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4045                      *sss_ele_cut &
4046                      *fac_shield(i)*fac_shield(j)
4047
4048                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4049                      *sss_ele_cut &
4050                      *fac_shield(i)*fac_shield(j)
4051
4052 ! Diagnostics. Comment out or remove after debugging!
4053 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4054 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4055 !               ees0m(num_conti,i)=0.0D0
4056 ! End diagnostics.
4057 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4058 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4059 ! Angular derivatives of the contact function
4060                 ees0pij1=fac3/ees0pij
4061                 ees0mij1=fac3/ees0mij
4062                 fac3p=-3.0D0*fac3*rrmij
4063                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4064                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4065 !               ees0mij1=0.0D0
4066                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4067                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4068                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4069                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4070                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4071                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4072                 ecosap=ecosa1+ecosa2
4073                 ecosbp=ecosb1+ecosb2
4074                 ecosgp=ecosg1+ecosg2
4075                 ecosam=ecosa1-ecosa2
4076                 ecosbm=ecosb1-ecosb2
4077                 ecosgm=ecosg1-ecosg2
4078 ! Diagnostics
4079 !               ecosap=ecosa1
4080 !               ecosbp=ecosb1
4081 !               ecosgp=ecosg1
4082 !               ecosam=0.0D0
4083 !               ecosbm=0.0D0
4084 !               ecosgm=0.0D0
4085 ! End diagnostics
4086                 facont_hb(num_conti,i)=fcont
4087                 fprimcont=fprimcont/rij
4088 !d              facont_hb(num_conti,i)=1.0D0
4089 ! Following line is for diagnostics.
4090 !d              fprimcont=0.0D0
4091                 do k=1,3
4092                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4093                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4094                 enddo
4095                 do k=1,3
4096                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4097                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4098                 enddo
4099                 gggp(1)=gggp(1)+ees0pijp*xj &
4100                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4101                 gggp(2)=gggp(2)+ees0pijp*yj &
4102                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4103                 gggp(3)=gggp(3)+ees0pijp*zj &
4104                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4105
4106                 gggm(1)=gggm(1)+ees0mijp*xj &
4107                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4108
4109                 gggm(2)=gggm(2)+ees0mijp*yj &
4110                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4111
4112                 gggm(3)=gggm(3)+ees0mijp*zj &
4113                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4114
4115 ! Derivatives due to the contact function
4116                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4117                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4118                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4119                 do k=1,3
4120 !
4121 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4122 !          following the change of gradient-summation algorithm.
4123 !
4124 !grad                  ghalfp=0.5D0*gggp(k)
4125 !grad                  ghalfm=0.5D0*gggm(k)
4126                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4127                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4128                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4129                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4130
4131                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4132                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4133                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4134                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4135
4136                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4137                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4138
4139                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4140                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4141                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4142                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4143
4144                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4145                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4146                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4147                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4148
4149                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4150                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4151
4152                 enddo
4153 ! Diagnostics. Comment out or remove after debugging!
4154 !diag           do k=1,3
4155 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4156 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4157 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4158 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4159 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4160 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4161 !diag           enddo
4162               ENDIF ! wcorr
4163               endif  ! num_conti.le.maxconts
4164             endif  ! fcont.gt.0
4165           endif    ! j.gt.i+1
4166           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4167             do k=1,4
4168               do l=1,3
4169                 ghalf=0.5d0*agg(l,k)
4170                 aggi(l,k)=aggi(l,k)+ghalf
4171                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4172                 aggj(l,k)=aggj(l,k)+ghalf
4173               enddo
4174             enddo
4175             if (j.eq.nres-1 .and. i.lt.j-2) then
4176               do k=1,4
4177                 do l=1,3
4178                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4179                 enddo
4180               enddo
4181             endif
4182           endif
4183  128  continue
4184 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4185       return
4186       end subroutine eelecij
4187 !-----------------------------------------------------------------------------
4188       subroutine eturn3(i,eello_turn3)
4189 ! Third- and fourth-order contributions from turns
4190
4191       use comm_locel
4192 !      implicit real*8 (a-h,o-z)
4193 !      include 'DIMENSIONS'
4194 !      include 'COMMON.IOUNITS'
4195 !      include 'COMMON.GEO'
4196 !      include 'COMMON.VAR'
4197 !      include 'COMMON.LOCAL'
4198 !      include 'COMMON.CHAIN'
4199 !      include 'COMMON.DERIV'
4200 !      include 'COMMON.INTERACT'
4201 !      include 'COMMON.CONTACTS'
4202 !      include 'COMMON.TORSION'
4203 !      include 'COMMON.VECTORS'
4204 !      include 'COMMON.FFIELD'
4205 !      include 'COMMON.CONTROL'
4206       real(kind=8),dimension(3) :: ggg
4207       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4208         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4209       real(kind=8),dimension(2) :: auxvec,auxvec1
4210 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4211       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4212 !el      integer :: num_conti,j1,j2
4213 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4214 !el        dz_normi,xmedi,ymedi,zmedi
4215
4216 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4217 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4218 !el         num_conti,j1,j2
4219 !el local variables
4220       integer :: i,j,l,k,ilist,iresshield
4221       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4222
4223       j=i+2
4224 !      write (iout,*) "eturn3",i,j,j1,j2
4225           zj=(c(3,j)+c(3,j+1))/2.0d0
4226           zj=mod(zj,boxzsize)
4227           if (zj.lt.0) zj=zj+boxzsize
4228           if ((zj.lt.0)) write (*,*) "CHUJ"
4229        if ((zj.gt.bordlipbot)  &
4230         .and.(zj.lt.bordliptop)) then
4231 !C the energy transfer exist
4232         if (zj.lt.buflipbot) then
4233 !C what fraction I am in
4234          fracinbuf=1.0d0-     &
4235              ((zj-bordlipbot)/lipbufthick)
4236 !C lipbufthick is thickenes of lipid buffore
4237          sslipj=sscalelip(fracinbuf)
4238          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4239         elseif (zj.gt.bufliptop) then
4240          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4241          sslipj=sscalelip(fracinbuf)
4242          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4243         else
4244          sslipj=1.0d0
4245          ssgradlipj=0.0
4246         endif
4247        else
4248          sslipj=0.0d0
4249          ssgradlipj=0.0
4250        endif
4251
4252       a_temp(1,1)=a22
4253       a_temp(1,2)=a23
4254       a_temp(2,1)=a32
4255       a_temp(2,2)=a33
4256 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4257 !
4258 !               Third-order contributions
4259 !
4260 !                 (i+2)o----(i+3)
4261 !                      | |
4262 !                      | |
4263 !                 (i+1)o----i
4264 !
4265 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4266 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4267         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4268         call transpose2(auxmat(1,1),auxmat1(1,1))
4269         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4270         if (shield_mode.eq.0) then
4271         fac_shield(i)=1.0d0
4272         fac_shield(j)=1.0d0
4273         endif
4274
4275         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4276          *fac_shield(i)*fac_shield(j)  &
4277          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4278         eello_t3= &
4279         0.5d0*(pizda(1,1)+pizda(2,2)) &
4280         *fac_shield(i)*fac_shield(j)
4281
4282         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4283                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4284           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4285        (shield_mode.gt.0)) then
4286 !C          print *,i,j
4287
4288           do ilist=1,ishield_list(i)
4289            iresshield=shield_list(ilist,i)
4290            do k=1,3
4291            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4292            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4293                    rlocshield &
4294            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4295             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4296              +rlocshield
4297            enddo
4298           enddo
4299           do ilist=1,ishield_list(j)
4300            iresshield=shield_list(ilist,j)
4301            do k=1,3
4302            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4303            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4304                    rlocshield &
4305            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4306            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4307                   +rlocshield
4308
4309            enddo
4310           enddo
4311
4312           do k=1,3
4313             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4314                    grad_shield(k,i)*eello_t3/fac_shield(i)
4315             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4316                    grad_shield(k,j)*eello_t3/fac_shield(j)
4317             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4318                    grad_shield(k,i)*eello_t3/fac_shield(i)
4319             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4320                    grad_shield(k,j)*eello_t3/fac_shield(j)
4321            enddo
4322            endif
4323
4324 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4325 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4326 !d     &    ' eello_turn3_num',4*eello_turn3_num
4327 ! Derivatives in gamma(i)
4328         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4329         call transpose2(auxmat2(1,1),auxmat3(1,1))
4330         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4331         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4332           *fac_shield(i)*fac_shield(j)        &
4333           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4334 ! Derivatives in gamma(i+1)
4335         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4336         call transpose2(auxmat2(1,1),auxmat3(1,1))
4337         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4338         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4339           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4340           *fac_shield(i)*fac_shield(j)        &
4341           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4342
4343 ! Cartesian derivatives
4344         do l=1,3
4345 !            ghalf1=0.5d0*agg(l,1)
4346 !            ghalf2=0.5d0*agg(l,2)
4347 !            ghalf3=0.5d0*agg(l,3)
4348 !            ghalf4=0.5d0*agg(l,4)
4349           a_temp(1,1)=aggi(l,1)!+ghalf1
4350           a_temp(1,2)=aggi(l,2)!+ghalf2
4351           a_temp(2,1)=aggi(l,3)!+ghalf3
4352           a_temp(2,2)=aggi(l,4)!+ghalf4
4353           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4354           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4355             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4356           *fac_shield(i)*fac_shield(j)      &
4357           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4358
4359           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4360           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4361           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4362           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4363           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4364           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4365             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4366           *fac_shield(i)*fac_shield(j)        &
4367           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4368
4369           a_temp(1,1)=aggj(l,1)!+ghalf1
4370           a_temp(1,2)=aggj(l,2)!+ghalf2
4371           a_temp(2,1)=aggj(l,3)!+ghalf3
4372           a_temp(2,2)=aggj(l,4)!+ghalf4
4373           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4374           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4375             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4376           *fac_shield(i)*fac_shield(j)      &
4377           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4378
4379           a_temp(1,1)=aggj1(l,1)
4380           a_temp(1,2)=aggj1(l,2)
4381           a_temp(2,1)=aggj1(l,3)
4382           a_temp(2,2)=aggj1(l,4)
4383           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4384           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4385             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4386           *fac_shield(i)*fac_shield(j)        &
4387           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4388         enddo
4389          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4390           ssgradlipi*eello_t3/4.0d0*lipscale
4391          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4392           ssgradlipj*eello_t3/4.0d0*lipscale
4393          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4394           ssgradlipi*eello_t3/4.0d0*lipscale
4395          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4396           ssgradlipj*eello_t3/4.0d0*lipscale
4397
4398       return
4399       end subroutine eturn3
4400 !-----------------------------------------------------------------------------
4401       subroutine eturn4(i,eello_turn4)
4402 ! Third- and fourth-order contributions from turns
4403
4404       use comm_locel
4405 !      implicit real*8 (a-h,o-z)
4406 !      include 'DIMENSIONS'
4407 !      include 'COMMON.IOUNITS'
4408 !      include 'COMMON.GEO'
4409 !      include 'COMMON.VAR'
4410 !      include 'COMMON.LOCAL'
4411 !      include 'COMMON.CHAIN'
4412 !      include 'COMMON.DERIV'
4413 !      include 'COMMON.INTERACT'
4414 !      include 'COMMON.CONTACTS'
4415 !      include 'COMMON.TORSION'
4416 !      include 'COMMON.VECTORS'
4417 !      include 'COMMON.FFIELD'
4418 !      include 'COMMON.CONTROL'
4419       real(kind=8),dimension(3) :: ggg
4420       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4421         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4422       real(kind=8),dimension(2) :: auxvec,auxvec1
4423 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4424       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4425 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4426 !el        dz_normi,xmedi,ymedi,zmedi
4427 !el      integer :: num_conti,j1,j2
4428 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4429 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4430 !el          num_conti,j1,j2
4431 !el local variables
4432       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4433       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4434          rlocshield
4435
4436       j=i+3
4437 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4438 !
4439 !               Fourth-order contributions
4440 !
4441 !                 (i+3)o----(i+4)
4442 !                     /  |
4443 !               (i+2)o   |
4444 !                     \  |
4445 !                 (i+1)o----i
4446 !
4447 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4448 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4449 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4450           zj=(c(3,j)+c(3,j+1))/2.0d0
4451           zj=mod(zj,boxzsize)
4452           if (zj.lt.0) zj=zj+boxzsize
4453        if ((zj.gt.bordlipbot)  &
4454         .and.(zj.lt.bordliptop)) then
4455 !C the energy transfer exist
4456         if (zj.lt.buflipbot) then
4457 !C what fraction I am in
4458          fracinbuf=1.0d0-     &
4459              ((zj-bordlipbot)/lipbufthick)
4460 !C lipbufthick is thickenes of lipid buffore
4461          sslipj=sscalelip(fracinbuf)
4462          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4463         elseif (zj.gt.bufliptop) then
4464          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4465          sslipj=sscalelip(fracinbuf)
4466          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4467         else
4468          sslipj=1.0d0
4469          ssgradlipj=0.0
4470         endif
4471        else
4472          sslipj=0.0d0
4473          ssgradlipj=0.0
4474        endif
4475
4476         a_temp(1,1)=a22
4477         a_temp(1,2)=a23
4478         a_temp(2,1)=a32
4479         a_temp(2,2)=a33
4480         iti1=itortyp(itype(i+1,1))
4481         iti2=itortyp(itype(i+2,1))
4482         iti3=itortyp(itype(i+3,1))
4483 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4484         call transpose2(EUg(1,1,i+1),e1t(1,1))
4485         call transpose2(Eug(1,1,i+2),e2t(1,1))
4486         call transpose2(Eug(1,1,i+3),e3t(1,1))
4487         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4488         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4489         s1=scalar2(b1(1,iti2),auxvec(1))
4490         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4491         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4492         s2=scalar2(b1(1,iti1),auxvec(1))
4493         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4494         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4495         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4496         if (shield_mode.eq.0) then
4497         fac_shield(i)=1.0
4498         fac_shield(j)=1.0
4499         endif
4500
4501         eello_turn4=eello_turn4-(s1+s2+s3) &
4502         *fac_shield(i)*fac_shield(j)       &
4503         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4504         eello_t4=-(s1+s2+s3)  &
4505           *fac_shield(i)*fac_shield(j)
4506 !C Now derivative over shield:
4507           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4508          (shield_mode.gt.0)) then
4509 !C          print *,i,j
4510
4511           do ilist=1,ishield_list(i)
4512            iresshield=shield_list(ilist,i)
4513            do k=1,3
4514            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4515            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4516                    rlocshield &
4517             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4518             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4519            +rlocshield
4520            enddo
4521           enddo
4522           do ilist=1,ishield_list(j)
4523            iresshield=shield_list(ilist,j)
4524            do k=1,3
4525            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4526            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4527                    rlocshield  &
4528            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4529            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4530                   +rlocshield
4531
4532            enddo
4533           enddo
4534
4535           do k=1,3
4536             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4537                    grad_shield(k,i)*eello_t4/fac_shield(i)
4538             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4539                    grad_shield(k,j)*eello_t4/fac_shield(j)
4540             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4541                    grad_shield(k,i)*eello_t4/fac_shield(i)
4542             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4543                    grad_shield(k,j)*eello_t4/fac_shield(j)
4544            enddo
4545            endif
4546
4547         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4548            'eturn4',i,j,-(s1+s2+s3)
4549 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4550 !d     &    ' eello_turn4_num',8*eello_turn4_num
4551 ! Derivatives in gamma(i)
4552         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4553         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4554         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4555         s1=scalar2(b1(1,iti2),auxvec(1))
4556         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4557         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4558         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4559        *fac_shield(i)*fac_shield(j)  &
4560        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4561
4562 ! Derivatives in gamma(i+1)
4563         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4564         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4565         s2=scalar2(b1(1,iti1),auxvec(1))
4566         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4567         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4568         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4569         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4570        *fac_shield(i)*fac_shield(j)  &
4571        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4572
4573 ! Derivatives in gamma(i+2)
4574         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4575         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4576         s1=scalar2(b1(1,iti2),auxvec(1))
4577         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4578         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4579         s2=scalar2(b1(1,iti1),auxvec(1))
4580         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4581         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4582         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4583         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4584        *fac_shield(i)*fac_shield(j)  &
4585        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4586
4587 ! Cartesian derivatives
4588 ! Derivatives of this turn contributions in DC(i+2)
4589         if (j.lt.nres-1) then
4590           do l=1,3
4591             a_temp(1,1)=agg(l,1)
4592             a_temp(1,2)=agg(l,2)
4593             a_temp(2,1)=agg(l,3)
4594             a_temp(2,2)=agg(l,4)
4595             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4596             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4597             s1=scalar2(b1(1,iti2),auxvec(1))
4598             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4599             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4600             s2=scalar2(b1(1,iti1),auxvec(1))
4601             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4602             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4603             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4604             ggg(l)=-(s1+s2+s3)
4605             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4606        *fac_shield(i)*fac_shield(j)  &
4607        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4608
4609           enddo
4610         endif
4611 ! Remaining derivatives of this turn contribution
4612         do l=1,3
4613           a_temp(1,1)=aggi(l,1)
4614           a_temp(1,2)=aggi(l,2)
4615           a_temp(2,1)=aggi(l,3)
4616           a_temp(2,2)=aggi(l,4)
4617           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4618           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4619           s1=scalar2(b1(1,iti2),auxvec(1))
4620           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4621           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4622           s2=scalar2(b1(1,iti1),auxvec(1))
4623           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4624           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4625           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4626           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4627          *fac_shield(i)*fac_shield(j)  &
4628          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4629
4630
4631           a_temp(1,1)=aggi1(l,1)
4632           a_temp(1,2)=aggi1(l,2)
4633           a_temp(2,1)=aggi1(l,3)
4634           a_temp(2,2)=aggi1(l,4)
4635           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4636           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4637           s1=scalar2(b1(1,iti2),auxvec(1))
4638           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4639           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4640           s2=scalar2(b1(1,iti1),auxvec(1))
4641           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4642           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4643           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4644           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4645          *fac_shield(i)*fac_shield(j)  &
4646          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4647
4648
4649           a_temp(1,1)=aggj(l,1)
4650           a_temp(1,2)=aggj(l,2)
4651           a_temp(2,1)=aggj(l,3)
4652           a_temp(2,2)=aggj(l,4)
4653           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4654           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4655           s1=scalar2(b1(1,iti2),auxvec(1))
4656           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4657           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4658           s2=scalar2(b1(1,iti1),auxvec(1))
4659           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4660           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4661           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4662           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4663          *fac_shield(i)*fac_shield(j)  &
4664          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4665
4666
4667           a_temp(1,1)=aggj1(l,1)
4668           a_temp(1,2)=aggj1(l,2)
4669           a_temp(2,1)=aggj1(l,3)
4670           a_temp(2,2)=aggj1(l,4)
4671           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4672           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4673           s1=scalar2(b1(1,iti2),auxvec(1))
4674           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4675           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4676           s2=scalar2(b1(1,iti1),auxvec(1))
4677           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4678           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4679           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4680 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4681           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4682          *fac_shield(i)*fac_shield(j)  &
4683          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4684
4685         enddo
4686          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4687           ssgradlipi*eello_t4/4.0d0*lipscale
4688          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4689           ssgradlipj*eello_t4/4.0d0*lipscale
4690          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4691           ssgradlipi*eello_t4/4.0d0*lipscale
4692          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4693           ssgradlipj*eello_t4/4.0d0*lipscale
4694
4695       return
4696       end subroutine eturn4
4697 !-----------------------------------------------------------------------------
4698       subroutine unormderiv(u,ugrad,unorm,ungrad)
4699 ! This subroutine computes the derivatives of a normalized vector u, given
4700 ! the derivatives computed without normalization conditions, ugrad. Returns
4701 ! ungrad.
4702 !      implicit none
4703       real(kind=8),dimension(3) :: u,vec
4704       real(kind=8),dimension(3,3) ::ugrad,ungrad
4705       real(kind=8) :: unorm     !,scalar
4706       integer :: i,j
4707 !      write (2,*) 'ugrad',ugrad
4708 !      write (2,*) 'u',u
4709       do i=1,3
4710         vec(i)=scalar(ugrad(1,i),u(1))
4711       enddo
4712 !      write (2,*) 'vec',vec
4713       do i=1,3
4714         do j=1,3
4715           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4716         enddo
4717       enddo
4718 !      write (2,*) 'ungrad',ungrad
4719       return
4720       end subroutine unormderiv
4721 !-----------------------------------------------------------------------------
4722       subroutine escp_soft_sphere(evdw2,evdw2_14)
4723 !
4724 ! This subroutine calculates the excluded-volume interaction energy between
4725 ! peptide-group centers and side chains and its gradient in virtual-bond and
4726 ! side-chain vectors.
4727 !
4728 !      implicit real*8 (a-h,o-z)
4729 !      include 'DIMENSIONS'
4730 !      include 'COMMON.GEO'
4731 !      include 'COMMON.VAR'
4732 !      include 'COMMON.LOCAL'
4733 !      include 'COMMON.CHAIN'
4734 !      include 'COMMON.DERIV'
4735 !      include 'COMMON.INTERACT'
4736 !      include 'COMMON.FFIELD'
4737 !      include 'COMMON.IOUNITS'
4738 !      include 'COMMON.CONTROL'
4739       real(kind=8),dimension(3) :: ggg
4740 !el local variables
4741       integer :: i,iint,j,k,iteli,itypj
4742       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4743                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4744
4745       evdw2=0.0D0
4746       evdw2_14=0.0d0
4747       r0_scp=4.5d0
4748 !d    print '(a)','Enter ESCP'
4749 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4750       do i=iatscp_s,iatscp_e
4751         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4752         iteli=itel(i)
4753         xi=0.5D0*(c(1,i)+c(1,i+1))
4754         yi=0.5D0*(c(2,i)+c(2,i+1))
4755         zi=0.5D0*(c(3,i)+c(3,i+1))
4756
4757         do iint=1,nscp_gr(i)
4758
4759         do j=iscpstart(i,iint),iscpend(i,iint)
4760           if (itype(j,1).eq.ntyp1) cycle
4761           itypj=iabs(itype(j,1))
4762 ! Uncomment following three lines for SC-p interactions
4763 !         xj=c(1,nres+j)-xi
4764 !         yj=c(2,nres+j)-yi
4765 !         zj=c(3,nres+j)-zi
4766 ! Uncomment following three lines for Ca-p interactions
4767           xj=c(1,j)-xi
4768           yj=c(2,j)-yi
4769           zj=c(3,j)-zi
4770           rij=xj*xj+yj*yj+zj*zj
4771           r0ij=r0_scp
4772           r0ijsq=r0ij*r0ij
4773           if (rij.lt.r0ijsq) then
4774             evdwij=0.25d0*(rij-r0ijsq)**2
4775             fac=rij-r0ijsq
4776           else
4777             evdwij=0.0d0
4778             fac=0.0d0
4779           endif
4780           evdw2=evdw2+evdwij
4781 !
4782 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4783 !
4784           ggg(1)=xj*fac
4785           ggg(2)=yj*fac
4786           ggg(3)=zj*fac
4787 !grad          if (j.lt.i) then
4788 !d          write (iout,*) 'j<i'
4789 ! Uncomment following three lines for SC-p interactions
4790 !           do k=1,3
4791 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4792 !           enddo
4793 !grad          else
4794 !d          write (iout,*) 'j>i'
4795 !grad            do k=1,3
4796 !grad              ggg(k)=-ggg(k)
4797 ! Uncomment following line for SC-p interactions
4798 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4799 !grad            enddo
4800 !grad          endif
4801 !grad          do k=1,3
4802 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4803 !grad          enddo
4804 !grad          kstart=min0(i+1,j)
4805 !grad          kend=max0(i-1,j-1)
4806 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4807 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4808 !grad          do k=kstart,kend
4809 !grad            do l=1,3
4810 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4811 !grad            enddo
4812 !grad          enddo
4813           do k=1,3
4814             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4815             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4816           enddo
4817         enddo
4818
4819         enddo ! iint
4820       enddo ! i
4821       return
4822       end subroutine escp_soft_sphere
4823 !-----------------------------------------------------------------------------
4824       subroutine escp(evdw2,evdw2_14)
4825 !
4826 ! This subroutine calculates the excluded-volume interaction energy between
4827 ! peptide-group centers and side chains and its gradient in virtual-bond and
4828 ! side-chain vectors.
4829 !
4830 !      implicit real*8 (a-h,o-z)
4831 !      include 'DIMENSIONS'
4832 !      include 'COMMON.GEO'
4833 !      include 'COMMON.VAR'
4834 !      include 'COMMON.LOCAL'
4835 !      include 'COMMON.CHAIN'
4836 !      include 'COMMON.DERIV'
4837 !      include 'COMMON.INTERACT'
4838 !      include 'COMMON.FFIELD'
4839 !      include 'COMMON.IOUNITS'
4840 !      include 'COMMON.CONTROL'
4841       real(kind=8),dimension(3) :: ggg
4842 !el local variables
4843       integer :: i,iint,j,k,iteli,itypj,subchap
4844       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4845                    e1,e2,evdwij,rij
4846       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4847                     dist_temp, dist_init
4848       integer xshift,yshift,zshift
4849
4850       evdw2=0.0D0
4851       evdw2_14=0.0d0
4852 !d    print '(a)','Enter ESCP'
4853 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4854       do i=iatscp_s,iatscp_e
4855         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4856         iteli=itel(i)
4857         xi=0.5D0*(c(1,i)+c(1,i+1))
4858         yi=0.5D0*(c(2,i)+c(2,i+1))
4859         zi=0.5D0*(c(3,i)+c(3,i+1))
4860           xi=mod(xi,boxxsize)
4861           if (xi.lt.0) xi=xi+boxxsize
4862           yi=mod(yi,boxysize)
4863           if (yi.lt.0) yi=yi+boxysize
4864           zi=mod(zi,boxzsize)
4865           if (zi.lt.0) zi=zi+boxzsize
4866
4867         do iint=1,nscp_gr(i)
4868
4869         do j=iscpstart(i,iint),iscpend(i,iint)
4870           itypj=iabs(itype(j,1))
4871           if (itypj.eq.ntyp1) cycle
4872 ! Uncomment following three lines for SC-p interactions
4873 !         xj=c(1,nres+j)-xi
4874 !         yj=c(2,nres+j)-yi
4875 !         zj=c(3,nres+j)-zi
4876 ! Uncomment following three lines for Ca-p interactions
4877 !          xj=c(1,j)-xi
4878 !          yj=c(2,j)-yi
4879 !          zj=c(3,j)-zi
4880           xj=c(1,j)
4881           yj=c(2,j)
4882           zj=c(3,j)
4883           xj=mod(xj,boxxsize)
4884           if (xj.lt.0) xj=xj+boxxsize
4885           yj=mod(yj,boxysize)
4886           if (yj.lt.0) yj=yj+boxysize
4887           zj=mod(zj,boxzsize)
4888           if (zj.lt.0) zj=zj+boxzsize
4889       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4890       xj_safe=xj
4891       yj_safe=yj
4892       zj_safe=zj
4893       subchap=0
4894       do xshift=-1,1
4895       do yshift=-1,1
4896       do zshift=-1,1
4897           xj=xj_safe+xshift*boxxsize
4898           yj=yj_safe+yshift*boxysize
4899           zj=zj_safe+zshift*boxzsize
4900           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4901           if(dist_temp.lt.dist_init) then
4902             dist_init=dist_temp
4903             xj_temp=xj
4904             yj_temp=yj
4905             zj_temp=zj
4906             subchap=1
4907           endif
4908        enddo
4909        enddo
4910        enddo
4911        if (subchap.eq.1) then
4912           xj=xj_temp-xi
4913           yj=yj_temp-yi
4914           zj=zj_temp-zi
4915        else
4916           xj=xj_safe-xi
4917           yj=yj_safe-yi
4918           zj=zj_safe-zi
4919        endif
4920
4921           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4922           rij=dsqrt(1.0d0/rrij)
4923             sss_ele_cut=sscale_ele(rij)
4924             sss_ele_grad=sscagrad_ele(rij)
4925 !            print *,sss_ele_cut,sss_ele_grad,&
4926 !            (rij),r_cut_ele,rlamb_ele
4927             if (sss_ele_cut.le.0.0) cycle
4928           fac=rrij**expon2
4929           e1=fac*fac*aad(itypj,iteli)
4930           e2=fac*bad(itypj,iteli)
4931           if (iabs(j-i) .le. 2) then
4932             e1=scal14*e1
4933             e2=scal14*e2
4934             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4935           endif
4936           evdwij=e1+e2
4937           evdw2=evdw2+evdwij*sss_ele_cut
4938 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4939 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4940           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4941              'evdw2',i,j,evdwij
4942 !
4943 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4944 !
4945           fac=-(evdwij+e1)*rrij*sss_ele_cut
4946           fac=fac+evdwij*sss_ele_grad/rij/expon
4947           ggg(1)=xj*fac
4948           ggg(2)=yj*fac
4949           ggg(3)=zj*fac
4950 !grad          if (j.lt.i) then
4951 !d          write (iout,*) 'j<i'
4952 ! Uncomment following three lines for SC-p interactions
4953 !           do k=1,3
4954 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4955 !           enddo
4956 !grad          else
4957 !d          write (iout,*) 'j>i'
4958 !grad            do k=1,3
4959 !grad              ggg(k)=-ggg(k)
4960 ! Uncomment following line for SC-p interactions
4961 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4962 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4963 !grad            enddo
4964 !grad          endif
4965 !grad          do k=1,3
4966 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4967 !grad          enddo
4968 !grad          kstart=min0(i+1,j)
4969 !grad          kend=max0(i-1,j-1)
4970 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4971 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4972 !grad          do k=kstart,kend
4973 !grad            do l=1,3
4974 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4975 !grad            enddo
4976 !grad          enddo
4977           do k=1,3
4978             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4979             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4980           enddo
4981         enddo
4982
4983         enddo ! iint
4984       enddo ! i
4985       do i=1,nct
4986         do j=1,3
4987           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4988           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4989           gradx_scp(j,i)=expon*gradx_scp(j,i)
4990         enddo
4991       enddo
4992 !******************************************************************************
4993 !
4994 !                              N O T E !!!
4995 !
4996 ! To save time the factor EXPON has been extracted from ALL components
4997 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4998 ! use!
4999 !
5000 !******************************************************************************
5001       return
5002       end subroutine escp
5003 !-----------------------------------------------------------------------------
5004       subroutine edis(ehpb)
5005 !
5006 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5007 !
5008 !      implicit real*8 (a-h,o-z)
5009 !      include 'DIMENSIONS'
5010 !      include 'COMMON.SBRIDGE'
5011 !      include 'COMMON.CHAIN'
5012 !      include 'COMMON.DERIV'
5013 !      include 'COMMON.VAR'
5014 !      include 'COMMON.INTERACT'
5015 !      include 'COMMON.IOUNITS'
5016       real(kind=8),dimension(3) :: ggg
5017 !el local variables
5018       integer :: i,j,ii,jj,iii,jjj,k
5019       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5020
5021       ehpb=0.0D0
5022 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5023 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5024       if (link_end.eq.0) return
5025       do i=link_start,link_end
5026 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5027 ! CA-CA distance used in regularization of structure.
5028         ii=ihpb(i)
5029         jj=jhpb(i)
5030 ! iii and jjj point to the residues for which the distance is assigned.
5031         if (ii.gt.nres) then
5032           iii=ii-nres
5033           jjj=jj-nres
5034         else
5035           iii=ii
5036           jjj=jj
5037         endif
5038 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5039 !     &    dhpb(i),dhpb1(i),forcon(i)
5040 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5041 !    distance and angle dependent SS bond potential.
5042 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5043 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5044         if (.not.dyn_ss .and. i.le.nss) then
5045 ! 15/02/13 CC dynamic SSbond - additional check
5046          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5047         iabs(itype(jjj,1)).eq.1) then
5048           call ssbond_ene(iii,jjj,eij)
5049           ehpb=ehpb+2*eij
5050 !d          write (iout,*) "eij",eij
5051          endif
5052         else if (ii.gt.nres .and. jj.gt.nres) then
5053 !c Restraints from contact prediction
5054           dd=dist(ii,jj)
5055           if (constr_dist.eq.11) then
5056             ehpb=ehpb+fordepth(i)**4.0d0 &
5057                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5058             fac=fordepth(i)**4.0d0 &
5059                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5060           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5061             ehpb,fordepth(i),dd
5062            else
5063           if (dhpb1(i).gt.0.0d0) then
5064             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5065             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5066 !c            write (iout,*) "beta nmr",
5067 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5068           else
5069             dd=dist(ii,jj)
5070             rdis=dd-dhpb(i)
5071 !C Get the force constant corresponding to this distance.
5072             waga=forcon(i)
5073 !C Calculate the contribution to energy.
5074             ehpb=ehpb+waga*rdis*rdis
5075 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5076 !C
5077 !C Evaluate gradient.
5078 !C
5079             fac=waga*rdis/dd
5080           endif
5081           endif
5082           do j=1,3
5083             ggg(j)=fac*(c(j,jj)-c(j,ii))
5084           enddo
5085           do j=1,3
5086             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5087             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5088           enddo
5089           do k=1,3
5090             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5091             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5092           enddo
5093         else
5094           dd=dist(ii,jj)
5095           if (constr_dist.eq.11) then
5096             ehpb=ehpb+fordepth(i)**4.0d0 &
5097                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5098             fac=fordepth(i)**4.0d0 &
5099                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5100           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5101          ehpb,fordepth(i),dd
5102            else
5103           if (dhpb1(i).gt.0.0d0) then
5104             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5105             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5106 !c            write (iout,*) "alph nmr",
5107 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5108           else
5109             rdis=dd-dhpb(i)
5110 !C Get the force constant corresponding to this distance.
5111             waga=forcon(i)
5112 !C Calculate the contribution to energy.
5113             ehpb=ehpb+waga*rdis*rdis
5114 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5115 !C
5116 !C Evaluate gradient.
5117 !C
5118             fac=waga*rdis/dd
5119           endif
5120           endif
5121
5122             do j=1,3
5123               ggg(j)=fac*(c(j,jj)-c(j,ii))
5124             enddo
5125 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5126 !C If this is a SC-SC distance, we need to calculate the contributions to the
5127 !C Cartesian gradient in the SC vectors (ghpbx).
5128           if (iii.lt.ii) then
5129           do j=1,3
5130             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5131             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5132           enddo
5133           endif
5134 !cgrad        do j=iii,jjj-1
5135 !cgrad          do k=1,3
5136 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5137 !cgrad          enddo
5138 !cgrad        enddo
5139           do k=1,3
5140             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5141             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5142           enddo
5143         endif
5144       enddo
5145       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5146
5147       return
5148       end subroutine edis
5149 !-----------------------------------------------------------------------------
5150       subroutine ssbond_ene(i,j,eij)
5151 !
5152 ! Calculate the distance and angle dependent SS-bond potential energy
5153 ! using a free-energy function derived based on RHF/6-31G** ab initio
5154 ! calculations of diethyl disulfide.
5155 !
5156 ! A. Liwo and U. Kozlowska, 11/24/03
5157 !
5158 !      implicit real*8 (a-h,o-z)
5159 !      include 'DIMENSIONS'
5160 !      include 'COMMON.SBRIDGE'
5161 !      include 'COMMON.CHAIN'
5162 !      include 'COMMON.DERIV'
5163 !      include 'COMMON.LOCAL'
5164 !      include 'COMMON.INTERACT'
5165 !      include 'COMMON.VAR'
5166 !      include 'COMMON.IOUNITS'
5167       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5168 !el local variables
5169       integer :: i,j,itypi,itypj,k
5170       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5171                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5172                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5173                    cosphi,ggk
5174
5175       itypi=iabs(itype(i,1))
5176       xi=c(1,nres+i)
5177       yi=c(2,nres+i)
5178       zi=c(3,nres+i)
5179       dxi=dc_norm(1,nres+i)
5180       dyi=dc_norm(2,nres+i)
5181       dzi=dc_norm(3,nres+i)
5182 !      dsci_inv=dsc_inv(itypi)
5183       dsci_inv=vbld_inv(nres+i)
5184       itypj=iabs(itype(j,1))
5185 !      dscj_inv=dsc_inv(itypj)
5186       dscj_inv=vbld_inv(nres+j)
5187       xj=c(1,nres+j)-xi
5188       yj=c(2,nres+j)-yi
5189       zj=c(3,nres+j)-zi
5190       dxj=dc_norm(1,nres+j)
5191       dyj=dc_norm(2,nres+j)
5192       dzj=dc_norm(3,nres+j)
5193       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5194       rij=dsqrt(rrij)
5195       erij(1)=xj*rij
5196       erij(2)=yj*rij
5197       erij(3)=zj*rij
5198       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5199       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5200       om12=dxi*dxj+dyi*dyj+dzi*dzj
5201       do k=1,3
5202         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5203         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5204       enddo
5205       rij=1.0d0/rij
5206       deltad=rij-d0cm
5207       deltat1=1.0d0-om1
5208       deltat2=1.0d0+om2
5209       deltat12=om2-om1+2.0d0
5210       cosphi=om12-om1*om2
5211       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5212         +akct*deltad*deltat12 &
5213         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5214 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5215 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5216 !     &  " deltat12",deltat12," eij",eij
5217       ed=2*akcm*deltad+akct*deltat12
5218       pom1=akct*deltad
5219       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5220       eom1=-2*akth*deltat1-pom1-om2*pom2
5221       eom2= 2*akth*deltat2+pom1-om1*pom2
5222       eom12=pom2
5223       do k=1,3
5224         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5225         ghpbx(k,i)=ghpbx(k,i)-ggk &
5226                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5227                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5228         ghpbx(k,j)=ghpbx(k,j)+ggk &
5229                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5230                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5231         ghpbc(k,i)=ghpbc(k,i)-ggk
5232         ghpbc(k,j)=ghpbc(k,j)+ggk
5233       enddo
5234 !
5235 ! Calculate the components of the gradient in DC and X
5236 !
5237 !grad      do k=i,j-1
5238 !grad        do l=1,3
5239 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5240 !grad        enddo
5241 !grad      enddo
5242       return
5243       end subroutine ssbond_ene
5244 !-----------------------------------------------------------------------------
5245       subroutine ebond(estr)
5246 !
5247 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5248 !
5249 !      implicit real*8 (a-h,o-z)
5250 !      include 'DIMENSIONS'
5251 !      include 'COMMON.LOCAL'
5252 !      include 'COMMON.GEO'
5253 !      include 'COMMON.INTERACT'
5254 !      include 'COMMON.DERIV'
5255 !      include 'COMMON.VAR'
5256 !      include 'COMMON.CHAIN'
5257 !      include 'COMMON.IOUNITS'
5258 !      include 'COMMON.NAMES'
5259 !      include 'COMMON.FFIELD'
5260 !      include 'COMMON.CONTROL'
5261 !      include 'COMMON.SETUP'
5262       real(kind=8),dimension(3) :: u,ud
5263 !el local variables
5264       integer :: i,j,iti,nbi,k
5265       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5266                    uprod1,uprod2
5267
5268       estr=0.0d0
5269       estr1=0.0d0
5270 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5271 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5272
5273       do i=ibondp_start,ibondp_end
5274         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5275         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5276 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5277 !C          do j=1,3
5278 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5279 !C            *dc(j,i-1)/vbld(i)
5280 !C          enddo
5281 !C          if (energy_dec) write(iout,*) &
5282 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5283         diff = vbld(i)-vbldpDUM
5284         else
5285         diff = vbld(i)-vbldp0
5286         endif
5287         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5288            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5289         estr=estr+diff*diff
5290         do j=1,3
5291           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5292         enddo
5293 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5294 !        endif
5295       enddo
5296       estr=0.5d0*AKP*estr+estr1
5297 !      print *,"estr_bb",estr,AKP
5298 !
5299 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5300 !
5301       do i=ibond_start,ibond_end
5302         iti=iabs(itype(i,1))
5303         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5304         if (iti.ne.10 .and. iti.ne.ntyp1) then
5305           nbi=nbondterm(iti)
5306           if (nbi.eq.1) then
5307             diff=vbld(i+nres)-vbldsc0(1,iti)
5308             if (energy_dec) write (iout,*) &
5309             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5310             AKSC(1,iti),AKSC(1,iti)*diff*diff
5311             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5312 !            print *,"estr_sc",estr
5313             do j=1,3
5314               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5315             enddo
5316           else
5317             do j=1,nbi
5318               diff=vbld(i+nres)-vbldsc0(j,iti)
5319               ud(j)=aksc(j,iti)*diff
5320               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5321             enddo
5322             uprod=u(1)
5323             do j=2,nbi
5324               uprod=uprod*u(j)
5325             enddo
5326             usum=0.0d0
5327             usumsqder=0.0d0
5328             do j=1,nbi
5329               uprod1=1.0d0
5330               uprod2=1.0d0
5331               do k=1,nbi
5332                 if (k.ne.j) then
5333                   uprod1=uprod1*u(k)
5334                   uprod2=uprod2*u(k)*u(k)
5335                 endif
5336               enddo
5337               usum=usum+uprod1
5338               usumsqder=usumsqder+ud(j)*uprod2
5339             enddo
5340             estr=estr+uprod/usum
5341 !            print *,"estr_sc",estr,i
5342
5343              if (energy_dec) write (iout,*) &
5344             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5345             AKSC(1,iti),uprod/usum
5346             do j=1,3
5347              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5348             enddo
5349           endif
5350         endif
5351       enddo
5352       return
5353       end subroutine ebond
5354 #ifdef CRYST_THETA
5355 !-----------------------------------------------------------------------------
5356       subroutine ebend(etheta)
5357 !
5358 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5359 ! angles gamma and its derivatives in consecutive thetas and gammas.
5360 !
5361       use comm_calcthet
5362 !      implicit real*8 (a-h,o-z)
5363 !      include 'DIMENSIONS'
5364 !      include 'COMMON.LOCAL'
5365 !      include 'COMMON.GEO'
5366 !      include 'COMMON.INTERACT'
5367 !      include 'COMMON.DERIV'
5368 !      include 'COMMON.VAR'
5369 !      include 'COMMON.CHAIN'
5370 !      include 'COMMON.IOUNITS'
5371 !      include 'COMMON.NAMES'
5372 !      include 'COMMON.FFIELD'
5373 !      include 'COMMON.CONTROL'
5374 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5375 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5376 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5377 !el      integer :: it
5378 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5379 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5380 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5381 !el local variables
5382       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5383        ichir21,ichir22
5384       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5385        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5386        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5387       real(kind=8),dimension(2) :: y,z
5388
5389       delta=0.02d0*pi
5390 !      time11=dexp(-2*time)
5391 !      time12=1.0d0
5392       etheta=0.0D0
5393 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5394       do i=ithet_start,ithet_end
5395         if (itype(i-1,1).eq.ntyp1) cycle
5396 ! Zero the energy function and its derivative at 0 or pi.
5397         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5398         it=itype(i-1,1)
5399         ichir1=isign(1,itype(i-2,1))
5400         ichir2=isign(1,itype(i,1))
5401          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5402          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5403          if (itype(i-1,1).eq.10) then
5404           itype1=isign(10,itype(i-2,1))
5405           ichir11=isign(1,itype(i-2,1))
5406           ichir12=isign(1,itype(i-2,1))
5407           itype2=isign(10,itype(i,1))
5408           ichir21=isign(1,itype(i,1))
5409           ichir22=isign(1,itype(i,1))
5410          endif
5411
5412         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5413 #ifdef OSF
5414           phii=phi(i)
5415           if (phii.ne.phii) phii=150.0
5416 #else
5417           phii=phi(i)
5418 #endif
5419           y(1)=dcos(phii)
5420           y(2)=dsin(phii)
5421         else
5422           y(1)=0.0D0
5423           y(2)=0.0D0
5424         endif
5425         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5426 #ifdef OSF
5427           phii1=phi(i+1)
5428           if (phii1.ne.phii1) phii1=150.0
5429           phii1=pinorm(phii1)
5430           z(1)=cos(phii1)
5431 #else
5432           phii1=phi(i+1)
5433           z(1)=dcos(phii1)
5434 #endif
5435           z(2)=dsin(phii1)
5436         else
5437           z(1)=0.0D0
5438           z(2)=0.0D0
5439         endif
5440 ! Calculate the "mean" value of theta from the part of the distribution
5441 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5442 ! In following comments this theta will be referred to as t_c.
5443         thet_pred_mean=0.0d0
5444         do k=1,2
5445             athetk=athet(k,it,ichir1,ichir2)
5446             bthetk=bthet(k,it,ichir1,ichir2)
5447           if (it.eq.10) then
5448              athetk=athet(k,itype1,ichir11,ichir12)
5449              bthetk=bthet(k,itype2,ichir21,ichir22)
5450           endif
5451          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5452         enddo
5453         dthett=thet_pred_mean*ssd
5454         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5455 ! Derivatives of the "mean" values in gamma1 and gamma2.
5456         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5457                +athet(2,it,ichir1,ichir2)*y(1))*ss
5458         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5459                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5460          if (it.eq.10) then
5461         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5462              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5463         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5464                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5465          endif
5466         if (theta(i).gt.pi-delta) then
5467           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5468                E_tc0)
5469           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5470           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5471           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5472               E_theta)
5473           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5474               E_tc)
5475         else if (theta(i).lt.delta) then
5476           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5477           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5478           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5479               E_theta)
5480           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5481           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5482               E_tc)
5483         else
5484           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5485               E_theta,E_tc)
5486         endif
5487         etheta=etheta+ethetai
5488         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5489             'ebend',i,ethetai
5490         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5491         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5492         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5493       enddo
5494 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5495
5496 ! Ufff.... We've done all this!!!
5497       return
5498       end subroutine ebend
5499 !-----------------------------------------------------------------------------
5500       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5501
5502       use comm_calcthet
5503 !      implicit real*8 (a-h,o-z)
5504 !      include 'DIMENSIONS'
5505 !      include 'COMMON.LOCAL'
5506 !      include 'COMMON.IOUNITS'
5507 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5508 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5509 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5510       integer :: i,j,k
5511       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5512 !el      integer :: it
5513 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5514 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5515 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5516 !el local variables
5517       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5518        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5519
5520 ! Calculate the contributions to both Gaussian lobes.
5521 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5522 ! The "polynomial part" of the "standard deviation" of this part of
5523 ! the distribution.
5524         sig=polthet(3,it)
5525         do j=2,0,-1
5526           sig=sig*thet_pred_mean+polthet(j,it)
5527         enddo
5528 ! Derivative of the "interior part" of the "standard deviation of the"
5529 ! gamma-dependent Gaussian lobe in t_c.
5530         sigtc=3*polthet(3,it)
5531         do j=2,1,-1
5532           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5533         enddo
5534         sigtc=sig*sigtc
5535 ! Set the parameters of both Gaussian lobes of the distribution.
5536 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5537         fac=sig*sig+sigc0(it)
5538         sigcsq=fac+fac
5539         sigc=1.0D0/sigcsq
5540 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5541         sigsqtc=-4.0D0*sigcsq*sigtc
5542 !       print *,i,sig,sigtc,sigsqtc
5543 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5544         sigtc=-sigtc/(fac*fac)
5545 ! Following variable is sigma(t_c)**(-2)
5546         sigcsq=sigcsq*sigcsq
5547         sig0i=sig0(it)
5548         sig0inv=1.0D0/sig0i**2
5549         delthec=thetai-thet_pred_mean
5550         delthe0=thetai-theta0i
5551         term1=-0.5D0*sigcsq*delthec*delthec
5552         term2=-0.5D0*sig0inv*delthe0*delthe0
5553 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5554 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5555 ! to the energy (this being the log of the distribution) at the end of energy
5556 ! term evaluation for this virtual-bond angle.
5557         if (term1.gt.term2) then
5558           termm=term1
5559           term2=dexp(term2-termm)
5560           term1=1.0d0
5561         else
5562           termm=term2
5563           term1=dexp(term1-termm)
5564           term2=1.0d0
5565         endif
5566 ! The ratio between the gamma-independent and gamma-dependent lobes of
5567 ! the distribution is a Gaussian function of thet_pred_mean too.
5568         diffak=gthet(2,it)-thet_pred_mean
5569         ratak=diffak/gthet(3,it)**2
5570         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5571 ! Let's differentiate it in thet_pred_mean NOW.
5572         aktc=ak*ratak
5573 ! Now put together the distribution terms to make complete distribution.
5574         termexp=term1+ak*term2
5575         termpre=sigc+ak*sig0i
5576 ! Contribution of the bending energy from this theta is just the -log of
5577 ! the sum of the contributions from the two lobes and the pre-exponential
5578 ! factor. Simple enough, isn't it?
5579         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5580 ! NOW the derivatives!!!
5581 ! 6/6/97 Take into account the deformation.
5582         E_theta=(delthec*sigcsq*term1 &
5583              +ak*delthe0*sig0inv*term2)/termexp
5584         E_tc=((sigtc+aktc*sig0i)/termpre &
5585             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5586              aktc*term2)/termexp)
5587       return
5588       end subroutine theteng
5589 #else
5590 !-----------------------------------------------------------------------------
5591       subroutine ebend(etheta,ethetacnstr)
5592 !
5593 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5594 ! angles gamma and its derivatives in consecutive thetas and gammas.
5595 ! ab initio-derived potentials from
5596 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5597 !
5598 !      implicit real*8 (a-h,o-z)
5599 !      include 'DIMENSIONS'
5600 !      include 'COMMON.LOCAL'
5601 !      include 'COMMON.GEO'
5602 !      include 'COMMON.INTERACT'
5603 !      include 'COMMON.DERIV'
5604 !      include 'COMMON.VAR'
5605 !      include 'COMMON.CHAIN'
5606 !      include 'COMMON.IOUNITS'
5607 !      include 'COMMON.NAMES'
5608 !      include 'COMMON.FFIELD'
5609 !      include 'COMMON.CONTROL'
5610       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5611       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5612       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5613       logical :: lprn=.false., lprn1=.false.
5614 !el local variables
5615       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5616       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5617       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5618 ! local variables for constrains
5619       real(kind=8) :: difi,thetiii
5620        integer itheta
5621
5622       etheta=0.0D0
5623       do i=ithet_start,ithet_end
5624         if (itype(i-1,1).eq.ntyp1) cycle
5625         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5626         if (iabs(itype(i+1,1)).eq.20) iblock=2
5627         if (iabs(itype(i+1,1)).ne.20) iblock=1
5628         dethetai=0.0d0
5629         dephii=0.0d0
5630         dephii1=0.0d0
5631         theti2=0.5d0*theta(i)
5632         ityp2=ithetyp((itype(i-1,1)))
5633         do k=1,nntheterm
5634           coskt(k)=dcos(k*theti2)
5635           sinkt(k)=dsin(k*theti2)
5636         enddo
5637         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5638 #ifdef OSF
5639           phii=phi(i)
5640           if (phii.ne.phii) phii=150.0
5641 #else
5642           phii=phi(i)
5643 #endif
5644           ityp1=ithetyp((itype(i-2,1)))
5645 ! propagation of chirality for glycine type
5646           do k=1,nsingle
5647             cosph1(k)=dcos(k*phii)
5648             sinph1(k)=dsin(k*phii)
5649           enddo
5650         else
5651           phii=0.0d0
5652           ityp1=ithetyp(itype(i-2,1))
5653           do k=1,nsingle
5654             cosph1(k)=0.0d0
5655             sinph1(k)=0.0d0
5656           enddo
5657         endif
5658         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5659 #ifdef OSF
5660           phii1=phi(i+1)
5661           if (phii1.ne.phii1) phii1=150.0
5662           phii1=pinorm(phii1)
5663 #else
5664           phii1=phi(i+1)
5665 #endif
5666           ityp3=ithetyp((itype(i,1)))
5667           do k=1,nsingle
5668             cosph2(k)=dcos(k*phii1)
5669             sinph2(k)=dsin(k*phii1)
5670           enddo
5671         else
5672           phii1=0.0d0
5673           ityp3=ithetyp(itype(i,1))
5674           do k=1,nsingle
5675             cosph2(k)=0.0d0
5676             sinph2(k)=0.0d0
5677           enddo
5678         endif
5679         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5680         do k=1,ndouble
5681           do l=1,k-1
5682             ccl=cosph1(l)*cosph2(k-l)
5683             ssl=sinph1(l)*sinph2(k-l)
5684             scl=sinph1(l)*cosph2(k-l)
5685             csl=cosph1(l)*sinph2(k-l)
5686             cosph1ph2(l,k)=ccl-ssl
5687             cosph1ph2(k,l)=ccl+ssl
5688             sinph1ph2(l,k)=scl+csl
5689             sinph1ph2(k,l)=scl-csl
5690           enddo
5691         enddo
5692         if (lprn) then
5693         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5694           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5695         write (iout,*) "coskt and sinkt"
5696         do k=1,nntheterm
5697           write (iout,*) k,coskt(k),sinkt(k)
5698         enddo
5699         endif
5700         do k=1,ntheterm
5701           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5702           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5703             *coskt(k)
5704           if (lprn) &
5705           write (iout,*) "k",k,&
5706            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5707            " ethetai",ethetai
5708         enddo
5709         if (lprn) then
5710         write (iout,*) "cosph and sinph"
5711         do k=1,nsingle
5712           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5713         enddo
5714         write (iout,*) "cosph1ph2 and sinph2ph2"
5715         do k=2,ndouble
5716           do l=1,k-1
5717             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5718                sinph1ph2(l,k),sinph1ph2(k,l)
5719           enddo
5720         enddo
5721         write(iout,*) "ethetai",ethetai
5722         endif
5723         do m=1,ntheterm2
5724           do k=1,nsingle
5725             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5726                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5727                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5728                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5729             ethetai=ethetai+sinkt(m)*aux
5730             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5731             dephii=dephii+k*sinkt(m)* &
5732                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5733                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5734             dephii1=dephii1+k*sinkt(m)* &
5735                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5736                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5737             if (lprn) &
5738             write (iout,*) "m",m," k",k," bbthet", &
5739                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5740                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5741                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5742                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5743           enddo
5744         enddo
5745         if (lprn) &
5746         write(iout,*) "ethetai",ethetai
5747         do m=1,ntheterm3
5748           do k=2,ndouble
5749             do l=1,k-1
5750               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5751                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5752                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5753                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5754               ethetai=ethetai+sinkt(m)*aux
5755               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5756               dephii=dephii+l*sinkt(m)* &
5757                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5758                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5759                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5760                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5761               dephii1=dephii1+(k-l)*sinkt(m)* &
5762                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5763                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5764                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5765                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5766               if (lprn) then
5767               write (iout,*) "m",m," k",k," l",l," ffthet",&
5768                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5769                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5770                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5771                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5772                   " ethetai",ethetai
5773               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5774                   cosph1ph2(k,l)*sinkt(m),&
5775                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5776               endif
5777             enddo
5778           enddo
5779         enddo
5780 10      continue
5781 !        lprn1=.true.
5782         if (lprn1) &
5783           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5784          i,theta(i)*rad2deg,phii*rad2deg,&
5785          phii1*rad2deg,ethetai
5786 !        lprn1=.false.
5787         etheta=etheta+ethetai
5788         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5789                                     'ebend',i,ethetai
5790         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5791         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5792         gloc(nphi+i-2,icg)=wang*dethetai
5793       enddo
5794 !-----------thete constrains
5795 !      if (tor_mode.ne.2) then
5796       ethetacnstr=0.0d0
5797 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5798       do i=ithetaconstr_start,ithetaconstr_end
5799         itheta=itheta_constr(i)
5800         thetiii=theta(itheta)
5801         difi=pinorm(thetiii-theta_constr0(i))
5802         if (difi.gt.theta_drange(i)) then
5803           difi=difi-theta_drange(i)
5804           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5805           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5806          +for_thet_constr(i)*difi**3
5807         else if (difi.lt.-drange(i)) then
5808           difi=difi+drange(i)
5809           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5810           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5811          +for_thet_constr(i)*difi**3
5812         else
5813           difi=0.0
5814         endif
5815        if (energy_dec) then
5816         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5817          i,itheta,rad2deg*thetiii, &
5818          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5819          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5820          gloc(itheta+nphi-2,icg)
5821         endif
5822       enddo
5823 !      endif
5824
5825       return
5826       end subroutine ebend
5827 #endif
5828 #ifdef CRYST_SC
5829 !-----------------------------------------------------------------------------
5830       subroutine esc(escloc)
5831 ! Calculate the local energy of a side chain and its derivatives in the
5832 ! corresponding virtual-bond valence angles THETA and the spherical angles
5833 ! ALPHA and OMEGA.
5834 !
5835       use comm_sccalc
5836 !      implicit real*8 (a-h,o-z)
5837 !      include 'DIMENSIONS'
5838 !      include 'COMMON.GEO'
5839 !      include 'COMMON.LOCAL'
5840 !      include 'COMMON.VAR'
5841 !      include 'COMMON.INTERACT'
5842 !      include 'COMMON.DERIV'
5843 !      include 'COMMON.CHAIN'
5844 !      include 'COMMON.IOUNITS'
5845 !      include 'COMMON.NAMES'
5846 !      include 'COMMON.FFIELD'
5847 !      include 'COMMON.CONTROL'
5848       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5849          ddersc0,ddummy,xtemp,temp
5850 !el      real(kind=8) :: time11,time12,time112,theti
5851       real(kind=8) :: escloc,delta
5852 !el      integer :: it,nlobit
5853 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5854 !el local variables
5855       integer :: i,k
5856       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5857        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5858       delta=0.02d0*pi
5859       escloc=0.0D0
5860 !     write (iout,'(a)') 'ESC'
5861       do i=loc_start,loc_end
5862         it=itype(i,1)
5863         if (it.eq.ntyp1) cycle
5864         if (it.eq.10) goto 1
5865         nlobit=nlob(iabs(it))
5866 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5867 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5868         theti=theta(i+1)-pipol
5869         x(1)=dtan(theti)
5870         x(2)=alph(i)
5871         x(3)=omeg(i)
5872
5873         if (x(2).gt.pi-delta) then
5874           xtemp(1)=x(1)
5875           xtemp(2)=pi-delta
5876           xtemp(3)=x(3)
5877           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5878           xtemp(2)=pi
5879           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5880           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5881               escloci,dersc(2))
5882           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5883               ddersc0(1),dersc(1))
5884           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5885               ddersc0(3),dersc(3))
5886           xtemp(2)=pi-delta
5887           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5888           xtemp(2)=pi
5889           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5890           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5891                   dersc0(2),esclocbi,dersc02)
5892           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5893                   dersc12,dersc01)
5894           call splinthet(x(2),0.5d0*delta,ss,ssd)
5895           dersc0(1)=dersc01
5896           dersc0(2)=dersc02
5897           dersc0(3)=0.0d0
5898           do k=1,3
5899             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5900           enddo
5901           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5902 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5903 !    &             esclocbi,ss,ssd
5904           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5905 !         escloci=esclocbi
5906 !         write (iout,*) escloci
5907         else if (x(2).lt.delta) then
5908           xtemp(1)=x(1)
5909           xtemp(2)=delta
5910           xtemp(3)=x(3)
5911           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5912           xtemp(2)=0.0d0
5913           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5914           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5915               escloci,dersc(2))
5916           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5917               ddersc0(1),dersc(1))
5918           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5919               ddersc0(3),dersc(3))
5920           xtemp(2)=delta
5921           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5922           xtemp(2)=0.0d0
5923           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5924           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5925                   dersc0(2),esclocbi,dersc02)
5926           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5927                   dersc12,dersc01)
5928           dersc0(1)=dersc01
5929           dersc0(2)=dersc02
5930           dersc0(3)=0.0d0
5931           call splinthet(x(2),0.5d0*delta,ss,ssd)
5932           do k=1,3
5933             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5934           enddo
5935           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5936 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5937 !    &             esclocbi,ss,ssd
5938           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5939 !         write (iout,*) escloci
5940         else
5941           call enesc(x,escloci,dersc,ddummy,.false.)
5942         endif
5943
5944         escloc=escloc+escloci
5945         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5946            'escloc',i,escloci
5947 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5948
5949         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5950          wscloc*dersc(1)
5951         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5952         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5953     1   continue
5954       enddo
5955       return
5956       end subroutine esc
5957 !-----------------------------------------------------------------------------
5958       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5959
5960       use comm_sccalc
5961 !      implicit real*8 (a-h,o-z)
5962 !      include 'DIMENSIONS'
5963 !      include 'COMMON.GEO'
5964 !      include 'COMMON.LOCAL'
5965 !      include 'COMMON.IOUNITS'
5966 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5967       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5968       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5969       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5970       real(kind=8) :: escloci
5971       logical :: mixed
5972 !el local variables
5973       integer :: j,iii,l,k !el,it,nlobit
5974       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5975 !el       time11,time12,time112
5976 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5977         escloc_i=0.0D0
5978         do j=1,3
5979           dersc(j)=0.0D0
5980           if (mixed) ddersc(j)=0.0d0
5981         enddo
5982         x3=x(3)
5983
5984 ! Because of periodicity of the dependence of the SC energy in omega we have
5985 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5986 ! To avoid underflows, first compute & store the exponents.
5987
5988         do iii=-1,1
5989
5990           x(3)=x3+iii*dwapi
5991
5992           do j=1,nlobit
5993             do k=1,3
5994               z(k)=x(k)-censc(k,j,it)
5995             enddo
5996             do k=1,3
5997               Axk=0.0D0
5998               do l=1,3
5999                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6000               enddo
6001               Ax(k,j,iii)=Axk
6002             enddo
6003             expfac=0.0D0
6004             do k=1,3
6005               expfac=expfac+Ax(k,j,iii)*z(k)
6006             enddo
6007             contr(j,iii)=expfac
6008           enddo ! j
6009
6010         enddo ! iii
6011
6012         x(3)=x3
6013 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6014 ! subsequent NaNs and INFs in energy calculation.
6015 ! Find the largest exponent
6016         emin=contr(1,-1)
6017         do iii=-1,1
6018           do j=1,nlobit
6019             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6020           enddo
6021         enddo
6022         emin=0.5D0*emin
6023 !d      print *,'it=',it,' emin=',emin
6024
6025 ! Compute the contribution to SC energy and derivatives
6026         do iii=-1,1
6027
6028           do j=1,nlobit
6029 #ifdef OSF
6030             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6031             if(adexp.ne.adexp) adexp=1.0
6032             expfac=dexp(adexp)
6033 #else
6034             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6035 #endif
6036 !d          print *,'j=',j,' expfac=',expfac
6037             escloc_i=escloc_i+expfac
6038             do k=1,3
6039               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6040             enddo
6041             if (mixed) then
6042               do k=1,3,2
6043                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6044                   +gaussc(k,2,j,it))*expfac
6045               enddo
6046             endif
6047           enddo
6048
6049         enddo ! iii
6050
6051         dersc(1)=dersc(1)/cos(theti)**2
6052         ddersc(1)=ddersc(1)/cos(theti)**2
6053         ddersc(3)=ddersc(3)
6054
6055         escloci=-(dlog(escloc_i)-emin)
6056         do j=1,3
6057           dersc(j)=dersc(j)/escloc_i
6058         enddo
6059         if (mixed) then
6060           do j=1,3,2
6061             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6062           enddo
6063         endif
6064       return
6065       end subroutine enesc
6066 !-----------------------------------------------------------------------------
6067       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6068
6069       use comm_sccalc
6070 !      implicit real*8 (a-h,o-z)
6071 !      include 'DIMENSIONS'
6072 !      include 'COMMON.GEO'
6073 !      include 'COMMON.LOCAL'
6074 !      include 'COMMON.IOUNITS'
6075 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6076       real(kind=8),dimension(3) :: x,z,dersc
6077       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6078       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6079       real(kind=8) :: escloci,dersc12,emin
6080       logical :: mixed
6081 !el local varables
6082       integer :: j,k,l !el,it,nlobit
6083       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6084
6085       escloc_i=0.0D0
6086
6087       do j=1,3
6088         dersc(j)=0.0D0
6089       enddo
6090
6091       do j=1,nlobit
6092         do k=1,2
6093           z(k)=x(k)-censc(k,j,it)
6094         enddo
6095         z(3)=dwapi
6096         do k=1,3
6097           Axk=0.0D0
6098           do l=1,3
6099             Axk=Axk+gaussc(l,k,j,it)*z(l)
6100           enddo
6101           Ax(k,j)=Axk
6102         enddo
6103         expfac=0.0D0
6104         do k=1,3
6105           expfac=expfac+Ax(k,j)*z(k)
6106         enddo
6107         contr(j)=expfac
6108       enddo ! j
6109
6110 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6111 ! subsequent NaNs and INFs in energy calculation.
6112 ! Find the largest exponent
6113       emin=contr(1)
6114       do j=1,nlobit
6115         if (emin.gt.contr(j)) emin=contr(j)
6116       enddo
6117       emin=0.5D0*emin
6118
6119 ! Compute the contribution to SC energy and derivatives
6120
6121       dersc12=0.0d0
6122       do j=1,nlobit
6123         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6124         escloc_i=escloc_i+expfac
6125         do k=1,2
6126           dersc(k)=dersc(k)+Ax(k,j)*expfac
6127         enddo
6128         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6129                   +gaussc(1,2,j,it))*expfac
6130         dersc(3)=0.0d0
6131       enddo
6132
6133       dersc(1)=dersc(1)/cos(theti)**2
6134       dersc12=dersc12/cos(theti)**2
6135       escloci=-(dlog(escloc_i)-emin)
6136       do j=1,2
6137         dersc(j)=dersc(j)/escloc_i
6138       enddo
6139       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6140       return
6141       end subroutine enesc_bound
6142 #else
6143 !-----------------------------------------------------------------------------
6144       subroutine esc(escloc)
6145 ! Calculate the local energy of a side chain and its derivatives in the
6146 ! corresponding virtual-bond valence angles THETA and the spherical angles
6147 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6148 ! added by Urszula Kozlowska. 07/11/2007
6149 !
6150       use comm_sccalc
6151 !      implicit real*8 (a-h,o-z)
6152 !      include 'DIMENSIONS'
6153 !      include 'COMMON.GEO'
6154 !      include 'COMMON.LOCAL'
6155 !      include 'COMMON.VAR'
6156 !      include 'COMMON.SCROT'
6157 !      include 'COMMON.INTERACT'
6158 !      include 'COMMON.DERIV'
6159 !      include 'COMMON.CHAIN'
6160 !      include 'COMMON.IOUNITS'
6161 !      include 'COMMON.NAMES'
6162 !      include 'COMMON.FFIELD'
6163 !      include 'COMMON.CONTROL'
6164 !      include 'COMMON.VECTORS'
6165       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6166       real(kind=8),dimension(65) :: x
6167       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6168          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6169       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6170       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6171          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6172 !el local variables
6173       integer :: i,j,k !el,it,nlobit
6174       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6175 !el      real(kind=8) :: time11,time12,time112,theti
6176 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6177       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6178                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6179                    sumene1x,sumene2x,sumene3x,sumene4x,&
6180                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6181                    cosfac2xx,sinfac2yy
6182 #ifdef DEBUG
6183       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6184                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6185                    de_dt_num
6186 #endif
6187 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6188
6189       delta=0.02d0*pi
6190       escloc=0.0D0
6191       do i=loc_start,loc_end
6192         if (itype(i,1).eq.ntyp1) cycle
6193         costtab(i+1) =dcos(theta(i+1))
6194         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6195         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6196         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6197         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6198         cosfac=dsqrt(cosfac2)
6199         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6200         sinfac=dsqrt(sinfac2)
6201         it=iabs(itype(i,1))
6202         if (it.eq.10) goto 1
6203 !
6204 !  Compute the axes of tghe local cartesian coordinates system; store in
6205 !   x_prime, y_prime and z_prime
6206 !
6207         do j=1,3
6208           x_prime(j) = 0.00
6209           y_prime(j) = 0.00
6210           z_prime(j) = 0.00
6211         enddo
6212 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6213 !     &   dc_norm(3,i+nres)
6214         do j = 1,3
6215           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6216           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6217         enddo
6218         do j = 1,3
6219           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6220         enddo
6221 !       write (2,*) "i",i
6222 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6223 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6224 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6225 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6226 !      & " xy",scalar(x_prime(1),y_prime(1)),
6227 !      & " xz",scalar(x_prime(1),z_prime(1)),
6228 !      & " yy",scalar(y_prime(1),y_prime(1)),
6229 !      & " yz",scalar(y_prime(1),z_prime(1)),
6230 !      & " zz",scalar(z_prime(1),z_prime(1))
6231 !
6232 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6233 ! to local coordinate system. Store in xx, yy, zz.
6234 !
6235         xx=0.0d0
6236         yy=0.0d0
6237         zz=0.0d0
6238         do j = 1,3
6239           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6240           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6241           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6242         enddo
6243
6244         xxtab(i)=xx
6245         yytab(i)=yy
6246         zztab(i)=zz
6247 !
6248 ! Compute the energy of the ith side cbain
6249 !
6250 !        write (2,*) "xx",xx," yy",yy," zz",zz
6251         it=iabs(itype(i,1))
6252         do j = 1,65
6253           x(j) = sc_parmin(j,it)
6254         enddo
6255 #ifdef CHECK_COORD
6256 !c diagnostics - remove later
6257         xx1 = dcos(alph(2))
6258         yy1 = dsin(alph(2))*dcos(omeg(2))
6259         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6260         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6261           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6262           xx1,yy1,zz1
6263 !,"  --- ", xx_w,yy_w,zz_w
6264 ! end diagnostics
6265 #endif
6266         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6267          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6268          + x(10)*yy*zz
6269         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6270          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6271          + x(20)*yy*zz
6272         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6273          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6274          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6275          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6276          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6277          +x(40)*xx*yy*zz
6278         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6279          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6280          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6281          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6282          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6283          +x(60)*xx*yy*zz
6284         dsc_i   = 0.743d0+x(61)
6285         dp2_i   = 1.9d0+x(62)
6286         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6287                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6288         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6289                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6290         s1=(1+x(63))/(0.1d0 + dscp1)
6291         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6292         s2=(1+x(65))/(0.1d0 + dscp2)
6293         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6294         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6295       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6296 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6297 !     &   sumene4,
6298 !     &   dscp1,dscp2,sumene
6299 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6300         escloc = escloc + sumene
6301 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6302 !     & ,zz,xx,yy
6303 !#define DEBUG
6304 #ifdef DEBUG
6305 !
6306 ! This section to check the numerical derivatives of the energy of ith side
6307 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6308 ! #define DEBUG in the code to turn it on.
6309 !
6310         write (2,*) "sumene               =",sumene
6311         aincr=1.0d-7
6312         xxsave=xx
6313         xx=xx+aincr
6314         write (2,*) xx,yy,zz
6315         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6316         de_dxx_num=(sumenep-sumene)/aincr
6317         xx=xxsave
6318         write (2,*) "xx+ sumene from enesc=",sumenep
6319         yysave=yy
6320         yy=yy+aincr
6321         write (2,*) xx,yy,zz
6322         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6323         de_dyy_num=(sumenep-sumene)/aincr
6324         yy=yysave
6325         write (2,*) "yy+ sumene from enesc=",sumenep
6326         zzsave=zz
6327         zz=zz+aincr
6328         write (2,*) xx,yy,zz
6329         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6330         de_dzz_num=(sumenep-sumene)/aincr
6331         zz=zzsave
6332         write (2,*) "zz+ sumene from enesc=",sumenep
6333         costsave=cost2tab(i+1)
6334         sintsave=sint2tab(i+1)
6335         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6336         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6337         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6338         de_dt_num=(sumenep-sumene)/aincr
6339         write (2,*) " t+ sumene from enesc=",sumenep
6340         cost2tab(i+1)=costsave
6341         sint2tab(i+1)=sintsave
6342 ! End of diagnostics section.
6343 #endif
6344 !
6345 ! Compute the gradient of esc
6346 !
6347 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6348         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6349         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6350         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6351         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6352         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6353         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6354         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6355         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6356         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6357            *(pom_s1/dscp1+pom_s16*dscp1**4)
6358         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6359            *(pom_s2/dscp2+pom_s26*dscp2**4)
6360         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6361         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6362         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6363         +x(40)*yy*zz
6364         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6365         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6366         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6367         +x(60)*yy*zz
6368         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6369               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6370               +(pom1+pom2)*pom_dx
6371 #ifdef DEBUG
6372         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6373 #endif
6374 !
6375         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6376         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6377         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6378         +x(40)*xx*zz
6379         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6380         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6381         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6382         +x(59)*zz**2 +x(60)*xx*zz
6383         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6384               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6385               +(pom1-pom2)*pom_dy
6386 #ifdef DEBUG
6387         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6388 #endif
6389 !
6390         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6391         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6392         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6393         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6394         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6395         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6396         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6397         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6398 #ifdef DEBUG
6399         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6400 #endif
6401 !
6402         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6403         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6404         +pom1*pom_dt1+pom2*pom_dt2
6405 #ifdef DEBUG
6406         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6407 #endif
6408 !
6409 !
6410        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6411        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6412        cosfac2xx=cosfac2*xx
6413        sinfac2yy=sinfac2*yy
6414        do k = 1,3
6415          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6416             vbld_inv(i+1)
6417          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6418             vbld_inv(i)
6419          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6420          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6421 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6422 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6423 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6424 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6425          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6426          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6427          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6428          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6429          dZZ_Ci1(k)=0.0d0
6430          dZZ_Ci(k)=0.0d0
6431          do j=1,3
6432            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6433            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6434            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6435            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6436          enddo
6437
6438          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6439          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6440          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6441          (z_prime(k)-zz*dC_norm(k,i+nres))
6442 !
6443          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6444          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6445        enddo
6446
6447        do k=1,3
6448          dXX_Ctab(k,i)=dXX_Ci(k)
6449          dXX_C1tab(k,i)=dXX_Ci1(k)
6450          dYY_Ctab(k,i)=dYY_Ci(k)
6451          dYY_C1tab(k,i)=dYY_Ci1(k)
6452          dZZ_Ctab(k,i)=dZZ_Ci(k)
6453          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6454          dXX_XYZtab(k,i)=dXX_XYZ(k)
6455          dYY_XYZtab(k,i)=dYY_XYZ(k)
6456          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6457        enddo
6458
6459        do k = 1,3
6460 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6461 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6462 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6463 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6464 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6465 !     &    dt_dci(k)
6466 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6467 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6468          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6469           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6470          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6471           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6472          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6473           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6474        enddo
6475 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6476 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6477
6478 ! to check gradient call subroutine check_grad
6479
6480     1 continue
6481       enddo
6482       return
6483       end subroutine esc
6484 !-----------------------------------------------------------------------------
6485       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6486 !      implicit none
6487       real(kind=8),dimension(65) :: x
6488       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6489         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6490
6491       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6492         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6493         + x(10)*yy*zz
6494       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6495         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6496         + x(20)*yy*zz
6497       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6498         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6499         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6500         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6501         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6502         +x(40)*xx*yy*zz
6503       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6504         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6505         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6506         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6507         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6508         +x(60)*xx*yy*zz
6509       dsc_i   = 0.743d0+x(61)
6510       dp2_i   = 1.9d0+x(62)
6511       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6512                 *(xx*cost2+yy*sint2))
6513       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6514                 *(xx*cost2-yy*sint2))
6515       s1=(1+x(63))/(0.1d0 + dscp1)
6516       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6517       s2=(1+x(65))/(0.1d0 + dscp2)
6518       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6519       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6520        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6521       enesc=sumene
6522       return
6523       end function enesc
6524 #endif
6525 !-----------------------------------------------------------------------------
6526       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6527 !
6528 ! This procedure calculates two-body contact function g(rij) and its derivative:
6529 !
6530 !           eps0ij                                     !       x < -1
6531 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6532 !            0                                         !       x > 1
6533 !
6534 ! where x=(rij-r0ij)/delta
6535 !
6536 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6537 !
6538 !      implicit none
6539       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6540       real(kind=8) :: x,x2,x4,delta
6541 !     delta=0.02D0*r0ij
6542 !      delta=0.2D0*r0ij
6543       x=(rij-r0ij)/delta
6544       if (x.lt.-1.0D0) then
6545         fcont=eps0ij
6546         fprimcont=0.0D0
6547       else if (x.le.1.0D0) then
6548         x2=x*x
6549         x4=x2*x2
6550         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6551         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6552       else
6553         fcont=0.0D0
6554         fprimcont=0.0D0
6555       endif
6556       return
6557       end subroutine gcont
6558 !-----------------------------------------------------------------------------
6559       subroutine splinthet(theti,delta,ss,ssder)
6560 !      implicit real*8 (a-h,o-z)
6561 !      include 'DIMENSIONS'
6562 !      include 'COMMON.VAR'
6563 !      include 'COMMON.GEO'
6564       real(kind=8) :: theti,delta,ss,ssder
6565       real(kind=8) :: thetup,thetlow
6566       thetup=pi-delta
6567       thetlow=delta
6568       if (theti.gt.pipol) then
6569         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6570       else
6571         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6572         ssder=-ssder
6573       endif
6574       return
6575       end subroutine splinthet
6576 !-----------------------------------------------------------------------------
6577       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6578 !      implicit none
6579       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6580       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6581       a1=fprim0*delta/(f1-f0)
6582       a2=3.0d0-2.0d0*a1
6583       a3=a1-2.0d0
6584       ksi=(x-x0)/delta
6585       ksi2=ksi*ksi
6586       ksi3=ksi2*ksi
6587       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6588       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6589       return
6590       end subroutine spline1
6591 !-----------------------------------------------------------------------------
6592       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6593 !      implicit none
6594       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6595       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6596       ksi=(x-x0)/delta
6597       ksi2=ksi*ksi
6598       ksi3=ksi2*ksi
6599       a1=fprim0x*delta
6600       a2=3*(f1x-f0x)-2*fprim0x*delta
6601       a3=fprim0x*delta-2*(f1x-f0x)
6602       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6603       return
6604       end subroutine spline2
6605 !-----------------------------------------------------------------------------
6606 #ifdef CRYST_TOR
6607 !-----------------------------------------------------------------------------
6608       subroutine etor(etors,edihcnstr)
6609 !      implicit real*8 (a-h,o-z)
6610 !      include 'DIMENSIONS'
6611 !      include 'COMMON.VAR'
6612 !      include 'COMMON.GEO'
6613 !      include 'COMMON.LOCAL'
6614 !      include 'COMMON.TORSION'
6615 !      include 'COMMON.INTERACT'
6616 !      include 'COMMON.DERIV'
6617 !      include 'COMMON.CHAIN'
6618 !      include 'COMMON.NAMES'
6619 !      include 'COMMON.IOUNITS'
6620 !      include 'COMMON.FFIELD'
6621 !      include 'COMMON.TORCNSTR'
6622 !      include 'COMMON.CONTROL'
6623       real(kind=8) :: etors,edihcnstr
6624       logical :: lprn
6625 !el local variables
6626       integer :: i,j,
6627       real(kind=8) :: phii,fac,etors_ii
6628
6629 ! Set lprn=.true. for debugging
6630       lprn=.false.
6631 !      lprn=.true.
6632       etors=0.0D0
6633       do i=iphi_start,iphi_end
6634       etors_ii=0.0D0
6635         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6636             .or. itype(i,1).eq.ntyp1) cycle
6637         itori=itortyp(itype(i-2,1))
6638         itori1=itortyp(itype(i-1,1))
6639         phii=phi(i)
6640         gloci=0.0D0
6641 ! Proline-Proline pair is a special case...
6642         if (itori.eq.3 .and. itori1.eq.3) then
6643           if (phii.gt.-dwapi3) then
6644             cosphi=dcos(3*phii)
6645             fac=1.0D0/(1.0D0-cosphi)
6646             etorsi=v1(1,3,3)*fac
6647             etorsi=etorsi+etorsi
6648             etors=etors+etorsi-v1(1,3,3)
6649             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6650             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6651           endif
6652           do j=1,3
6653             v1ij=v1(j+1,itori,itori1)
6654             v2ij=v2(j+1,itori,itori1)
6655             cosphi=dcos(j*phii)
6656             sinphi=dsin(j*phii)
6657             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6658             if (energy_dec) etors_ii=etors_ii+ &
6659                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6660             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6661           enddo
6662         else
6663           do j=1,nterm_old
6664             v1ij=v1(j,itori,itori1)
6665             v2ij=v2(j,itori,itori1)
6666             cosphi=dcos(j*phii)
6667             sinphi=dsin(j*phii)
6668             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6669             if (energy_dec) etors_ii=etors_ii+ &
6670                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6671             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6672           enddo
6673         endif
6674         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6675              'etor',i,etors_ii
6676         if (lprn) &
6677         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6678         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6679         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6680         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6681 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6682       enddo
6683 ! 6/20/98 - dihedral angle constraints
6684       edihcnstr=0.0d0
6685       do i=1,ndih_constr
6686         itori=idih_constr(i)
6687         phii=phi(itori)
6688         difi=phii-phi0(i)
6689         if (difi.gt.drange(i)) then
6690           difi=difi-drange(i)
6691           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6692           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6693         else if (difi.lt.-drange(i)) then
6694           difi=difi+drange(i)
6695           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6696           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6697         endif
6698 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6699 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6700       enddo
6701 !      write (iout,*) 'edihcnstr',edihcnstr
6702       return
6703       end subroutine etor
6704 !-----------------------------------------------------------------------------
6705       subroutine etor_d(etors_d)
6706       real(kind=8) :: etors_d
6707       etors_d=0.0d0
6708       return
6709       end subroutine etor_d
6710 #else
6711 !-----------------------------------------------------------------------------
6712       subroutine etor(etors,edihcnstr)
6713 !      implicit real*8 (a-h,o-z)
6714 !      include 'DIMENSIONS'
6715 !      include 'COMMON.VAR'
6716 !      include 'COMMON.GEO'
6717 !      include 'COMMON.LOCAL'
6718 !      include 'COMMON.TORSION'
6719 !      include 'COMMON.INTERACT'
6720 !      include 'COMMON.DERIV'
6721 !      include 'COMMON.CHAIN'
6722 !      include 'COMMON.NAMES'
6723 !      include 'COMMON.IOUNITS'
6724 !      include 'COMMON.FFIELD'
6725 !      include 'COMMON.TORCNSTR'
6726 !      include 'COMMON.CONTROL'
6727       real(kind=8) :: etors,edihcnstr
6728       logical :: lprn
6729 !el local variables
6730       integer :: i,j,iblock,itori,itori1
6731       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6732                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6733 ! Set lprn=.true. for debugging
6734       lprn=.false.
6735 !     lprn=.true.
6736       etors=0.0D0
6737       do i=iphi_start,iphi_end
6738         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6739              .or. itype(i-3,1).eq.ntyp1 &
6740              .or. itype(i,1).eq.ntyp1) cycle
6741         etors_ii=0.0D0
6742          if (iabs(itype(i,1)).eq.20) then
6743          iblock=2
6744          else
6745          iblock=1
6746          endif
6747         itori=itortyp(itype(i-2,1))
6748         itori1=itortyp(itype(i-1,1))
6749         phii=phi(i)
6750         gloci=0.0D0
6751 ! Regular cosine and sine terms
6752         do j=1,nterm(itori,itori1,iblock)
6753           v1ij=v1(j,itori,itori1,iblock)
6754           v2ij=v2(j,itori,itori1,iblock)
6755           cosphi=dcos(j*phii)
6756           sinphi=dsin(j*phii)
6757           etors=etors+v1ij*cosphi+v2ij*sinphi
6758           if (energy_dec) etors_ii=etors_ii+ &
6759                      v1ij*cosphi+v2ij*sinphi
6760           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6761         enddo
6762 ! Lorentz terms
6763 !                         v1
6764 !  E = SUM ----------------------------------- - v1
6765 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6766 !
6767         cosphi=dcos(0.5d0*phii)
6768         sinphi=dsin(0.5d0*phii)
6769         do j=1,nlor(itori,itori1,iblock)
6770           vl1ij=vlor1(j,itori,itori1)
6771           vl2ij=vlor2(j,itori,itori1)
6772           vl3ij=vlor3(j,itori,itori1)
6773           pom=vl2ij*cosphi+vl3ij*sinphi
6774           pom1=1.0d0/(pom*pom+1.0d0)
6775           etors=etors+vl1ij*pom1
6776           if (energy_dec) etors_ii=etors_ii+ &
6777                      vl1ij*pom1
6778           pom=-pom*pom1*pom1
6779           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6780         enddo
6781 ! Subtract the constant term
6782         etors=etors-v0(itori,itori1,iblock)
6783           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6784                'etor',i,etors_ii-v0(itori,itori1,iblock)
6785         if (lprn) &
6786         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6787         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6788         (v1(j,itori,itori1,iblock),j=1,6),&
6789         (v2(j,itori,itori1,iblock),j=1,6)
6790         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6791 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6792       enddo
6793 ! 6/20/98 - dihedral angle constraints
6794       edihcnstr=0.0d0
6795 !      do i=1,ndih_constr
6796       do i=idihconstr_start,idihconstr_end
6797         itori=idih_constr(i)
6798         phii=phi(itori)
6799         difi=pinorm(phii-phi0(i))
6800         if (difi.gt.drange(i)) then
6801           difi=difi-drange(i)
6802           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6803           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6804         else if (difi.lt.-drange(i)) then
6805           difi=difi+drange(i)
6806           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6807           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6808         else
6809           difi=0.0
6810         endif
6811 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6812 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6813 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6814       enddo
6815 !d       write (iout,*) 'edihcnstr',edihcnstr
6816       return
6817       end subroutine etor
6818 !-----------------------------------------------------------------------------
6819       subroutine etor_d(etors_d)
6820 ! 6/23/01 Compute double torsional energy
6821 !      implicit real*8 (a-h,o-z)
6822 !      include 'DIMENSIONS'
6823 !      include 'COMMON.VAR'
6824 !      include 'COMMON.GEO'
6825 !      include 'COMMON.LOCAL'
6826 !      include 'COMMON.TORSION'
6827 !      include 'COMMON.INTERACT'
6828 !      include 'COMMON.DERIV'
6829 !      include 'COMMON.CHAIN'
6830 !      include 'COMMON.NAMES'
6831 !      include 'COMMON.IOUNITS'
6832 !      include 'COMMON.FFIELD'
6833 !      include 'COMMON.TORCNSTR'
6834       real(kind=8) :: etors_d,etors_d_ii
6835       logical :: lprn
6836 !el local variables
6837       integer :: i,j,k,l,itori,itori1,itori2,iblock
6838       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6839                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6840                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6841                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6842 ! Set lprn=.true. for debugging
6843       lprn=.false.
6844 !     lprn=.true.
6845       etors_d=0.0D0
6846 !      write(iout,*) "a tu??"
6847       do i=iphid_start,iphid_end
6848         etors_d_ii=0.0D0
6849         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6850             .or. itype(i-3,1).eq.ntyp1 &
6851             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6852         itori=itortyp(itype(i-2,1))
6853         itori1=itortyp(itype(i-1,1))
6854         itori2=itortyp(itype(i,1))
6855         phii=phi(i)
6856         phii1=phi(i+1)
6857         gloci1=0.0D0
6858         gloci2=0.0D0
6859         iblock=1
6860         if (iabs(itype(i+1,1)).eq.20) iblock=2
6861
6862 ! Regular cosine and sine terms
6863         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6864           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6865           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6866           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6867           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6868           cosphi1=dcos(j*phii)
6869           sinphi1=dsin(j*phii)
6870           cosphi2=dcos(j*phii1)
6871           sinphi2=dsin(j*phii1)
6872           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6873            v2cij*cosphi2+v2sij*sinphi2
6874           if (energy_dec) etors_d_ii=etors_d_ii+ &
6875            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6876           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6877           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6878         enddo
6879         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6880           do l=1,k-1
6881             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6882             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6883             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6884             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6885             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6886             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6887             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6888             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6889             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6890               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6891             if (energy_dec) etors_d_ii=etors_d_ii+ &
6892               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6893               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6894             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6895               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6896             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6897               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6898           enddo
6899         enddo
6900         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6901                             'etor_d',i,etors_d_ii
6902         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6903         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6904       enddo
6905       return
6906       end subroutine etor_d
6907 #endif
6908 !-----------------------------------------------------------------------------
6909       subroutine eback_sc_corr(esccor)
6910 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6911 !        conformational states; temporarily implemented as differences
6912 !        between UNRES torsional potentials (dependent on three types of
6913 !        residues) and the torsional potentials dependent on all 20 types
6914 !        of residues computed from AM1  energy surfaces of terminally-blocked
6915 !        amino-acid residues.
6916 !      implicit real*8 (a-h,o-z)
6917 !      include 'DIMENSIONS'
6918 !      include 'COMMON.VAR'
6919 !      include 'COMMON.GEO'
6920 !      include 'COMMON.LOCAL'
6921 !      include 'COMMON.TORSION'
6922 !      include 'COMMON.SCCOR'
6923 !      include 'COMMON.INTERACT'
6924 !      include 'COMMON.DERIV'
6925 !      include 'COMMON.CHAIN'
6926 !      include 'COMMON.NAMES'
6927 !      include 'COMMON.IOUNITS'
6928 !      include 'COMMON.FFIELD'
6929 !      include 'COMMON.CONTROL'
6930       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6931                    cosphi,sinphi
6932       logical :: lprn
6933       integer :: i,interty,j,isccori,isccori1,intertyp
6934 ! Set lprn=.true. for debugging
6935       lprn=.false.
6936 !      lprn=.true.
6937 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6938       esccor=0.0D0
6939       do i=itau_start,itau_end
6940         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
6941         esccor_ii=0.0D0
6942         isccori=isccortyp(itype(i-2,1))
6943         isccori1=isccortyp(itype(i-1,1))
6944
6945 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6946         phii=phi(i)
6947         do intertyp=1,3 !intertyp
6948          esccor_ii=0.0D0
6949 !c Added 09 May 2012 (Adasko)
6950 !c  Intertyp means interaction type of backbone mainchain correlation:
6951 !   1 = SC...Ca...Ca...Ca
6952 !   2 = Ca...Ca...Ca...SC
6953 !   3 = SC...Ca...Ca...SCi
6954         gloci=0.0D0
6955         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
6956             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
6957             (itype(i-1,1).eq.ntyp1))) &
6958           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
6959            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
6960            .or.(itype(i,1).eq.ntyp1))) &
6961           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
6962             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
6963             (itype(i-3,1).eq.ntyp1)))) cycle
6964         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
6965         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
6966        cycle
6967        do j=1,nterm_sccor(isccori,isccori1)
6968           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6969           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6970           cosphi=dcos(j*tauangle(intertyp,i))
6971           sinphi=dsin(j*tauangle(intertyp,i))
6972           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6973           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6974           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6975         enddo
6976         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6977                                 'esccor',i,intertyp,esccor_ii
6978 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6979         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6980         if (lprn) &
6981         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6982         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
6983         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6984         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6985         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6986        enddo !intertyp
6987       enddo
6988
6989       return
6990       end subroutine eback_sc_corr
6991 !-----------------------------------------------------------------------------
6992       subroutine multibody(ecorr)
6993 ! This subroutine calculates multi-body contributions to energy following
6994 ! the idea of Skolnick et al. If side chains I and J make a contact and
6995 ! at the same time side chains I+1 and J+1 make a contact, an extra
6996 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6997 !      implicit real*8 (a-h,o-z)
6998 !      include 'DIMENSIONS'
6999 !      include 'COMMON.IOUNITS'
7000 !      include 'COMMON.DERIV'
7001 !      include 'COMMON.INTERACT'
7002 !      include 'COMMON.CONTACTS'
7003       real(kind=8),dimension(3) :: gx,gx1
7004       logical :: lprn
7005       real(kind=8) :: ecorr
7006       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7007 ! Set lprn=.true. for debugging
7008       lprn=.false.
7009
7010       if (lprn) then
7011         write (iout,'(a)') 'Contact function values:'
7012         do i=nnt,nct-2
7013           write (iout,'(i2,20(1x,i2,f10.5))') &
7014               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7015         enddo
7016       endif
7017       ecorr=0.0D0
7018
7019 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7020 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7021       do i=nnt,nct
7022         do j=1,3
7023           gradcorr(j,i)=0.0D0
7024           gradxorr(j,i)=0.0D0
7025         enddo
7026       enddo
7027       do i=nnt,nct-2
7028
7029         DO ISHIFT = 3,4
7030
7031         i1=i+ishift
7032         num_conti=num_cont(i)
7033         num_conti1=num_cont(i1)
7034         do jj=1,num_conti
7035           j=jcont(jj,i)
7036           do kk=1,num_conti1
7037             j1=jcont(kk,i1)
7038             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7039 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7040 !d   &                   ' ishift=',ishift
7041 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7042 ! The system gains extra energy.
7043               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7044             endif   ! j1==j+-ishift
7045           enddo     ! kk
7046         enddo       ! jj
7047
7048         ENDDO ! ISHIFT
7049
7050       enddo         ! i
7051       return
7052       end subroutine multibody
7053 !-----------------------------------------------------------------------------
7054       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7055 !      implicit real*8 (a-h,o-z)
7056 !      include 'DIMENSIONS'
7057 !      include 'COMMON.IOUNITS'
7058 !      include 'COMMON.DERIV'
7059 !      include 'COMMON.INTERACT'
7060 !      include 'COMMON.CONTACTS'
7061       real(kind=8),dimension(3) :: gx,gx1
7062       logical :: lprn
7063       integer :: i,j,k,l,jj,kk,m,ll
7064       real(kind=8) :: eij,ekl
7065       lprn=.false.
7066       eij=facont(jj,i)
7067       ekl=facont(kk,k)
7068 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7069 ! Calculate the multi-body contribution to energy.
7070 ! Calculate multi-body contributions to the gradient.
7071 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7072 !d   & k,l,(gacont(m,kk,k),m=1,3)
7073       do m=1,3
7074         gx(m) =ekl*gacont(m,jj,i)
7075         gx1(m)=eij*gacont(m,kk,k)
7076         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7077         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7078         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7079         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7080       enddo
7081       do m=i,j-1
7082         do ll=1,3
7083           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7084         enddo
7085       enddo
7086       do m=k,l-1
7087         do ll=1,3
7088           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7089         enddo
7090       enddo
7091       esccorr=-eij*ekl
7092       return
7093       end function esccorr
7094 !-----------------------------------------------------------------------------
7095       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7096 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7097 !      implicit real*8 (a-h,o-z)
7098 !      include 'DIMENSIONS'
7099 !      include 'COMMON.IOUNITS'
7100 #ifdef MPI
7101       include "mpif.h"
7102 !      integer :: maxconts !max_cont=maxconts  =nres/4
7103       integer,parameter :: max_dim=26
7104       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7105       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7106 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7107 !el      common /przechowalnia/ zapas
7108       integer :: status(MPI_STATUS_SIZE)
7109       integer,dimension((nres/4)*2) :: req !maxconts*2
7110       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7111 #endif
7112 !      include 'COMMON.SETUP'
7113 !      include 'COMMON.FFIELD'
7114 !      include 'COMMON.DERIV'
7115 !      include 'COMMON.INTERACT'
7116 !      include 'COMMON.CONTACTS'
7117 !      include 'COMMON.CONTROL'
7118 !      include 'COMMON.LOCAL'
7119       real(kind=8),dimension(3) :: gx,gx1
7120       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7121       logical :: lprn,ldone
7122 !el local variables
7123       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7124               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7125
7126 ! Set lprn=.true. for debugging
7127       lprn=.false.
7128 #ifdef MPI
7129 !      maxconts=nres/4
7130       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7131       n_corr=0
7132       n_corr1=0
7133       if (nfgtasks.le.1) goto 30
7134       if (lprn) then
7135         write (iout,'(a)') 'Contact function values before RECEIVE:'
7136         do i=nnt,nct-2
7137           write (iout,'(2i3,50(1x,i2,f5.2))') &
7138           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7139           j=1,num_cont_hb(i))
7140         enddo
7141       endif
7142       call flush(iout)
7143       do i=1,ntask_cont_from
7144         ncont_recv(i)=0
7145       enddo
7146       do i=1,ntask_cont_to
7147         ncont_sent(i)=0
7148       enddo
7149 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7150 !     & ntask_cont_to
7151 ! Make the list of contacts to send to send to other procesors
7152 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7153 !      call flush(iout)
7154       do i=iturn3_start,iturn3_end
7155 !        write (iout,*) "make contact list turn3",i," num_cont",
7156 !     &    num_cont_hb(i)
7157         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7158       enddo
7159       do i=iturn4_start,iturn4_end
7160 !        write (iout,*) "make contact list turn4",i," num_cont",
7161 !     &   num_cont_hb(i)
7162         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7163       enddo
7164       do ii=1,nat_sent
7165         i=iat_sent(ii)
7166 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7167 !     &    num_cont_hb(i)
7168         do j=1,num_cont_hb(i)
7169         do k=1,4
7170           jjc=jcont_hb(j,i)
7171           iproc=iint_sent_local(k,jjc,ii)
7172 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7173           if (iproc.gt.0) then
7174             ncont_sent(iproc)=ncont_sent(iproc)+1
7175             nn=ncont_sent(iproc)
7176             zapas(1,nn,iproc)=i
7177             zapas(2,nn,iproc)=jjc
7178             zapas(3,nn,iproc)=facont_hb(j,i)
7179             zapas(4,nn,iproc)=ees0p(j,i)
7180             zapas(5,nn,iproc)=ees0m(j,i)
7181             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7182             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7183             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7184             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7185             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7186             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7187             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7188             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7189             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7190             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7191             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7192             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7193             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7194             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7195             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7196             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7197             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7198             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7199             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7200             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7201             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7202           endif
7203         enddo
7204         enddo
7205       enddo
7206       if (lprn) then
7207       write (iout,*) &
7208         "Numbers of contacts to be sent to other processors",&
7209         (ncont_sent(i),i=1,ntask_cont_to)
7210       write (iout,*) "Contacts sent"
7211       do ii=1,ntask_cont_to
7212         nn=ncont_sent(ii)
7213         iproc=itask_cont_to(ii)
7214         write (iout,*) nn," contacts to processor",iproc,&
7215          " of CONT_TO_COMM group"
7216         do i=1,nn
7217           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7218         enddo
7219       enddo
7220       call flush(iout)
7221       endif
7222       CorrelType=477
7223       CorrelID=fg_rank+1
7224       CorrelType1=478
7225       CorrelID1=nfgtasks+fg_rank+1
7226       ireq=0
7227 ! Receive the numbers of needed contacts from other processors
7228       do ii=1,ntask_cont_from
7229         iproc=itask_cont_from(ii)
7230         ireq=ireq+1
7231         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7232           FG_COMM,req(ireq),IERR)
7233       enddo
7234 !      write (iout,*) "IRECV ended"
7235 !      call flush(iout)
7236 ! Send the number of contacts needed by other processors
7237       do ii=1,ntask_cont_to
7238         iproc=itask_cont_to(ii)
7239         ireq=ireq+1
7240         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7241           FG_COMM,req(ireq),IERR)
7242       enddo
7243 !      write (iout,*) "ISEND ended"
7244 !      write (iout,*) "number of requests (nn)",ireq
7245       call flush(iout)
7246       if (ireq.gt.0) &
7247         call MPI_Waitall(ireq,req,status_array,ierr)
7248 !      write (iout,*)
7249 !     &  "Numbers of contacts to be received from other processors",
7250 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7251 !      call flush(iout)
7252 ! Receive contacts
7253       ireq=0
7254       do ii=1,ntask_cont_from
7255         iproc=itask_cont_from(ii)
7256         nn=ncont_recv(ii)
7257 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7258 !     &   " of CONT_TO_COMM group"
7259         call flush(iout)
7260         if (nn.gt.0) then
7261           ireq=ireq+1
7262           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7263           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7264 !          write (iout,*) "ireq,req",ireq,req(ireq)
7265         endif
7266       enddo
7267 ! Send the contacts to processors that need them
7268       do ii=1,ntask_cont_to
7269         iproc=itask_cont_to(ii)
7270         nn=ncont_sent(ii)
7271 !        write (iout,*) nn," contacts to processor",iproc,
7272 !     &   " of CONT_TO_COMM group"
7273         if (nn.gt.0) then
7274           ireq=ireq+1
7275           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7276             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7277 !          write (iout,*) "ireq,req",ireq,req(ireq)
7278 !          do i=1,nn
7279 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7280 !          enddo
7281         endif
7282       enddo
7283 !      write (iout,*) "number of requests (contacts)",ireq
7284 !      write (iout,*) "req",(req(i),i=1,4)
7285 !      call flush(iout)
7286       if (ireq.gt.0) &
7287        call MPI_Waitall(ireq,req,status_array,ierr)
7288       do iii=1,ntask_cont_from
7289         iproc=itask_cont_from(iii)
7290         nn=ncont_recv(iii)
7291         if (lprn) then
7292         write (iout,*) "Received",nn," contacts from processor",iproc,&
7293          " of CONT_FROM_COMM group"
7294         call flush(iout)
7295         do i=1,nn
7296           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7297         enddo
7298         call flush(iout)
7299         endif
7300         do i=1,nn
7301           ii=zapas_recv(1,i,iii)
7302 ! Flag the received contacts to prevent double-counting
7303           jj=-zapas_recv(2,i,iii)
7304 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7305 !          call flush(iout)
7306           nnn=num_cont_hb(ii)+1
7307           num_cont_hb(ii)=nnn
7308           jcont_hb(nnn,ii)=jj
7309           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7310           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7311           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7312           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7313           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7314           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7315           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7316           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7317           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7318           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7319           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7320           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7321           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7322           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7323           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7324           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7325           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7326           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7327           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7328           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7329           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7330           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7331           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7332           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7333         enddo
7334       enddo
7335       call flush(iout)
7336       if (lprn) then
7337         write (iout,'(a)') 'Contact function values after receive:'
7338         do i=nnt,nct-2
7339           write (iout,'(2i3,50(1x,i3,f5.2))') &
7340           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7341           j=1,num_cont_hb(i))
7342         enddo
7343         call flush(iout)
7344       endif
7345    30 continue
7346 #endif
7347       if (lprn) then
7348         write (iout,'(a)') 'Contact function values:'
7349         do i=nnt,nct-2
7350           write (iout,'(2i3,50(1x,i3,f5.2))') &
7351           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7352           j=1,num_cont_hb(i))
7353         enddo
7354       endif
7355       ecorr=0.0D0
7356
7357 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7358 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7359 ! Remove the loop below after debugging !!!
7360       do i=nnt,nct
7361         do j=1,3
7362           gradcorr(j,i)=0.0D0
7363           gradxorr(j,i)=0.0D0
7364         enddo
7365       enddo
7366 ! Calculate the local-electrostatic correlation terms
7367       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7368         i1=i+1
7369         num_conti=num_cont_hb(i)
7370         num_conti1=num_cont_hb(i+1)
7371         do jj=1,num_conti
7372           j=jcont_hb(jj,i)
7373           jp=iabs(j)
7374           do kk=1,num_conti1
7375             j1=jcont_hb(kk,i1)
7376             jp1=iabs(j1)
7377 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7378 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7379             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7380                 .or. j.lt.0 .and. j1.gt.0) .and. &
7381                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7382 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7383 ! The system gains extra energy.
7384               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7385               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7386                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7387               n_corr=n_corr+1
7388             else if (j1.eq.j) then
7389 ! Contacts I-J and I-(J+1) occur simultaneously.
7390 ! The system loses extra energy.
7391 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7392             endif
7393           enddo ! kk
7394           do kk=1,num_conti
7395             j1=jcont_hb(kk,i)
7396 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7397 !    &         ' jj=',jj,' kk=',kk
7398             if (j1.eq.j+1) then
7399 ! Contacts I-J and (I+1)-J occur simultaneously.
7400 ! The system loses extra energy.
7401 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7402             endif ! j1==j+1
7403           enddo ! kk
7404         enddo ! jj
7405       enddo ! i
7406       return
7407       end subroutine multibody_hb
7408 !-----------------------------------------------------------------------------
7409       subroutine add_hb_contact(ii,jj,itask)
7410 !      implicit real*8 (a-h,o-z)
7411 !      include "DIMENSIONS"
7412 !      include "COMMON.IOUNITS"
7413 !      include "COMMON.CONTACTS"
7414 !      integer,parameter :: maxconts=nres/4
7415       integer,parameter :: max_dim=26
7416       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7417 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7418 !      common /przechowalnia/ zapas
7419       integer :: i,j,ii,jj,iproc,nn,jjc
7420       integer,dimension(4) :: itask
7421 !      write (iout,*) "itask",itask
7422       do i=1,2
7423         iproc=itask(i)
7424         if (iproc.gt.0) then
7425           do j=1,num_cont_hb(ii)
7426             jjc=jcont_hb(j,ii)
7427 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7428             if (jjc.eq.jj) then
7429               ncont_sent(iproc)=ncont_sent(iproc)+1
7430               nn=ncont_sent(iproc)
7431               zapas(1,nn,iproc)=ii
7432               zapas(2,nn,iproc)=jjc
7433               zapas(3,nn,iproc)=facont_hb(j,ii)
7434               zapas(4,nn,iproc)=ees0p(j,ii)
7435               zapas(5,nn,iproc)=ees0m(j,ii)
7436               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7437               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7438               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7439               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7440               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7441               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7442               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7443               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7444               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7445               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7446               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7447               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7448               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7449               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7450               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7451               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7452               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7453               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7454               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7455               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7456               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7457               exit
7458             endif
7459           enddo
7460         endif
7461       enddo
7462       return
7463       end subroutine add_hb_contact
7464 !-----------------------------------------------------------------------------
7465       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7466 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7467 !      implicit real*8 (a-h,o-z)
7468 !      include 'DIMENSIONS'
7469 !      include 'COMMON.IOUNITS'
7470       integer,parameter :: max_dim=70
7471 #ifdef MPI
7472       include "mpif.h"
7473 !      integer :: maxconts !max_cont=maxconts=nres/4
7474       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7475       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7476 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7477 !      common /przechowalnia/ zapas
7478       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7479         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7480         ierr,iii,nnn
7481 #endif
7482 !      include 'COMMON.SETUP'
7483 !      include 'COMMON.FFIELD'
7484 !      include 'COMMON.DERIV'
7485 !      include 'COMMON.LOCAL'
7486 !      include 'COMMON.INTERACT'
7487 !      include 'COMMON.CONTACTS'
7488 !      include 'COMMON.CHAIN'
7489 !      include 'COMMON.CONTROL'
7490       real(kind=8),dimension(3) :: gx,gx1
7491       integer,dimension(nres) :: num_cont_hb_old
7492       logical :: lprn,ldone
7493 !EL      double precision eello4,eello5,eelo6,eello_turn6
7494 !EL      external eello4,eello5,eello6,eello_turn6
7495 !el local variables
7496       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7497               j1,jp1,i1,num_conti1
7498       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7499       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7500
7501 ! Set lprn=.true. for debugging
7502       lprn=.false.
7503       eturn6=0.0d0
7504 #ifdef MPI
7505 !      maxconts=nres/4
7506       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7507       do i=1,nres
7508         num_cont_hb_old(i)=num_cont_hb(i)
7509       enddo
7510       n_corr=0
7511       n_corr1=0
7512       if (nfgtasks.le.1) goto 30
7513       if (lprn) then
7514         write (iout,'(a)') 'Contact function values before RECEIVE:'
7515         do i=nnt,nct-2
7516           write (iout,'(2i3,50(1x,i2,f5.2))') &
7517           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7518           j=1,num_cont_hb(i))
7519         enddo
7520       endif
7521       call flush(iout)
7522       do i=1,ntask_cont_from
7523         ncont_recv(i)=0
7524       enddo
7525       do i=1,ntask_cont_to
7526         ncont_sent(i)=0
7527       enddo
7528 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7529 !     & ntask_cont_to
7530 ! Make the list of contacts to send to send to other procesors
7531       do i=iturn3_start,iturn3_end
7532 !        write (iout,*) "make contact list turn3",i," num_cont",
7533 !     &    num_cont_hb(i)
7534         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7535       enddo
7536       do i=iturn4_start,iturn4_end
7537 !        write (iout,*) "make contact list turn4",i," num_cont",
7538 !     &   num_cont_hb(i)
7539         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7540       enddo
7541       do ii=1,nat_sent
7542         i=iat_sent(ii)
7543 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7544 !     &    num_cont_hb(i)
7545         do j=1,num_cont_hb(i)
7546         do k=1,4
7547           jjc=jcont_hb(j,i)
7548           iproc=iint_sent_local(k,jjc,ii)
7549 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7550           if (iproc.ne.0) then
7551             ncont_sent(iproc)=ncont_sent(iproc)+1
7552             nn=ncont_sent(iproc)
7553             zapas(1,nn,iproc)=i
7554             zapas(2,nn,iproc)=jjc
7555             zapas(3,nn,iproc)=d_cont(j,i)
7556             ind=3
7557             do kk=1,3
7558               ind=ind+1
7559               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7560             enddo
7561             do kk=1,2
7562               do ll=1,2
7563                 ind=ind+1
7564                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7565               enddo
7566             enddo
7567             do jj=1,5
7568               do kk=1,3
7569                 do ll=1,2
7570                   do mm=1,2
7571                     ind=ind+1
7572                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7573                   enddo
7574                 enddo
7575               enddo
7576             enddo
7577           endif
7578         enddo
7579         enddo
7580       enddo
7581       if (lprn) then
7582       write (iout,*) &
7583         "Numbers of contacts to be sent to other processors",&
7584         (ncont_sent(i),i=1,ntask_cont_to)
7585       write (iout,*) "Contacts sent"
7586       do ii=1,ntask_cont_to
7587         nn=ncont_sent(ii)
7588         iproc=itask_cont_to(ii)
7589         write (iout,*) nn," contacts to processor",iproc,&
7590          " of CONT_TO_COMM group"
7591         do i=1,nn
7592           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7593         enddo
7594       enddo
7595       call flush(iout)
7596       endif
7597       CorrelType=477
7598       CorrelID=fg_rank+1
7599       CorrelType1=478
7600       CorrelID1=nfgtasks+fg_rank+1
7601       ireq=0
7602 ! Receive the numbers of needed contacts from other processors
7603       do ii=1,ntask_cont_from
7604         iproc=itask_cont_from(ii)
7605         ireq=ireq+1
7606         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7607           FG_COMM,req(ireq),IERR)
7608       enddo
7609 !      write (iout,*) "IRECV ended"
7610 !      call flush(iout)
7611 ! Send the number of contacts needed by other processors
7612       do ii=1,ntask_cont_to
7613         iproc=itask_cont_to(ii)
7614         ireq=ireq+1
7615         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7616           FG_COMM,req(ireq),IERR)
7617       enddo
7618 !      write (iout,*) "ISEND ended"
7619 !      write (iout,*) "number of requests (nn)",ireq
7620       call flush(iout)
7621       if (ireq.gt.0) &
7622         call MPI_Waitall(ireq,req,status_array,ierr)
7623 !      write (iout,*)
7624 !     &  "Numbers of contacts to be received from other processors",
7625 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7626 !      call flush(iout)
7627 ! Receive contacts
7628       ireq=0
7629       do ii=1,ntask_cont_from
7630         iproc=itask_cont_from(ii)
7631         nn=ncont_recv(ii)
7632 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7633 !     &   " of CONT_TO_COMM group"
7634         call flush(iout)
7635         if (nn.gt.0) then
7636           ireq=ireq+1
7637           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7638           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7639 !          write (iout,*) "ireq,req",ireq,req(ireq)
7640         endif
7641       enddo
7642 ! Send the contacts to processors that need them
7643       do ii=1,ntask_cont_to
7644         iproc=itask_cont_to(ii)
7645         nn=ncont_sent(ii)
7646 !        write (iout,*) nn," contacts to processor",iproc,
7647 !     &   " of CONT_TO_COMM group"
7648         if (nn.gt.0) then
7649           ireq=ireq+1
7650           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7651             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7652 !          write (iout,*) "ireq,req",ireq,req(ireq)
7653 !          do i=1,nn
7654 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7655 !          enddo
7656         endif
7657       enddo
7658 !      write (iout,*) "number of requests (contacts)",ireq
7659 !      write (iout,*) "req",(req(i),i=1,4)
7660 !      call flush(iout)
7661       if (ireq.gt.0) &
7662        call MPI_Waitall(ireq,req,status_array,ierr)
7663       do iii=1,ntask_cont_from
7664         iproc=itask_cont_from(iii)
7665         nn=ncont_recv(iii)
7666         if (lprn) then
7667         write (iout,*) "Received",nn," contacts from processor",iproc,&
7668          " of CONT_FROM_COMM group"
7669         call flush(iout)
7670         do i=1,nn
7671           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7672         enddo
7673         call flush(iout)
7674         endif
7675         do i=1,nn
7676           ii=zapas_recv(1,i,iii)
7677 ! Flag the received contacts to prevent double-counting
7678           jj=-zapas_recv(2,i,iii)
7679 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7680 !          call flush(iout)
7681           nnn=num_cont_hb(ii)+1
7682           num_cont_hb(ii)=nnn
7683           jcont_hb(nnn,ii)=jj
7684           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7685           ind=3
7686           do kk=1,3
7687             ind=ind+1
7688             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7689           enddo
7690           do kk=1,2
7691             do ll=1,2
7692               ind=ind+1
7693               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7694             enddo
7695           enddo
7696           do jj=1,5
7697             do kk=1,3
7698               do ll=1,2
7699                 do mm=1,2
7700                   ind=ind+1
7701                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7702                 enddo
7703               enddo
7704             enddo
7705           enddo
7706         enddo
7707       enddo
7708       call flush(iout)
7709       if (lprn) then
7710         write (iout,'(a)') 'Contact function values after receive:'
7711         do i=nnt,nct-2
7712           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7713           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7714           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7715         enddo
7716         call flush(iout)
7717       endif
7718    30 continue
7719 #endif
7720       if (lprn) then
7721         write (iout,'(a)') 'Contact function values:'
7722         do i=nnt,nct-2
7723           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7724           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7725           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7726         enddo
7727       endif
7728       ecorr=0.0D0
7729       ecorr5=0.0d0
7730       ecorr6=0.0d0
7731
7732 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7733 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7734 ! Remove the loop below after debugging !!!
7735       do i=nnt,nct
7736         do j=1,3
7737           gradcorr(j,i)=0.0D0
7738           gradxorr(j,i)=0.0D0
7739         enddo
7740       enddo
7741 ! Calculate the dipole-dipole interaction energies
7742       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7743       do i=iatel_s,iatel_e+1
7744         num_conti=num_cont_hb(i)
7745         do jj=1,num_conti
7746           j=jcont_hb(jj,i)
7747 #ifdef MOMENT
7748           call dipole(i,j,jj)
7749 #endif
7750         enddo
7751       enddo
7752       endif
7753 ! Calculate the local-electrostatic correlation terms
7754 !                write (iout,*) "gradcorr5 in eello5 before loop"
7755 !                do iii=1,nres
7756 !                  write (iout,'(i5,3f10.5)')
7757 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7758 !                enddo
7759       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7760 !        write (iout,*) "corr loop i",i
7761         i1=i+1
7762         num_conti=num_cont_hb(i)
7763         num_conti1=num_cont_hb(i+1)
7764         do jj=1,num_conti
7765           j=jcont_hb(jj,i)
7766           jp=iabs(j)
7767           do kk=1,num_conti1
7768             j1=jcont_hb(kk,i1)
7769             jp1=iabs(j1)
7770 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7771 !     &         ' jj=',jj,' kk=',kk
7772 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7773             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7774                 .or. j.lt.0 .and. j1.gt.0) .and. &
7775                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7776 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7777 ! The system gains extra energy.
7778               n_corr=n_corr+1
7779               sqd1=dsqrt(d_cont(jj,i))
7780               sqd2=dsqrt(d_cont(kk,i1))
7781               sred_geom = sqd1*sqd2
7782               IF (sred_geom.lt.cutoff_corr) THEN
7783                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7784                   ekont,fprimcont)
7785 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7786 !d     &         ' jj=',jj,' kk=',kk
7787                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7788                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7789                 do l=1,3
7790                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7791                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7792                 enddo
7793                 n_corr1=n_corr1+1
7794 !d               write (iout,*) 'sred_geom=',sred_geom,
7795 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7796 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7797 !d               write (iout,*) "g_contij",g_contij
7798 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7799 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7800                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7801                 if (wcorr4.gt.0.0d0) &
7802                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7803                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7804                        write (iout,'(a6,4i5,0pf7.3)') &
7805                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7806 !                write (iout,*) "gradcorr5 before eello5"
7807 !                do iii=1,nres
7808 !                  write (iout,'(i5,3f10.5)')
7809 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7810 !                enddo
7811                 if (wcorr5.gt.0.0d0) &
7812                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7813 !                write (iout,*) "gradcorr5 after eello5"
7814 !                do iii=1,nres
7815 !                  write (iout,'(i5,3f10.5)')
7816 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7817 !                enddo
7818                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7819                        write (iout,'(a6,4i5,0pf7.3)') &
7820                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7821 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7822 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7823                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7824                      .or. wturn6.eq.0.0d0))then
7825 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7826                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7827                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7828                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7829 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7830 !d     &            'ecorr6=',ecorr6
7831 !d                write (iout,'(4e15.5)') sred_geom,
7832 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7833 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7834 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7835                 else if (wturn6.gt.0.0d0 &
7836                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7837 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7838                   eturn6=eturn6+eello_turn6(i,jj,kk)
7839                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7840                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7841 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7842                 endif
7843               ENDIF
7844 1111          continue
7845             endif
7846           enddo ! kk
7847         enddo ! jj
7848       enddo ! i
7849       do i=1,nres
7850         num_cont_hb(i)=num_cont_hb_old(i)
7851       enddo
7852 !                write (iout,*) "gradcorr5 in eello5"
7853 !                do iii=1,nres
7854 !                  write (iout,'(i5,3f10.5)')
7855 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7856 !                enddo
7857       return
7858       end subroutine multibody_eello
7859 !-----------------------------------------------------------------------------
7860       subroutine add_hb_contact_eello(ii,jj,itask)
7861 !      implicit real*8 (a-h,o-z)
7862 !      include "DIMENSIONS"
7863 !      include "COMMON.IOUNITS"
7864 !      include "COMMON.CONTACTS"
7865 !      integer,parameter :: maxconts=nres/4
7866       integer,parameter :: max_dim=70
7867       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7868 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7869 !      common /przechowalnia/ zapas
7870
7871       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7872       integer,dimension(4) ::itask
7873 !      write (iout,*) "itask",itask
7874       do i=1,2
7875         iproc=itask(i)
7876         if (iproc.gt.0) then
7877           do j=1,num_cont_hb(ii)
7878             jjc=jcont_hb(j,ii)
7879 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7880             if (jjc.eq.jj) then
7881               ncont_sent(iproc)=ncont_sent(iproc)+1
7882               nn=ncont_sent(iproc)
7883               zapas(1,nn,iproc)=ii
7884               zapas(2,nn,iproc)=jjc
7885               zapas(3,nn,iproc)=d_cont(j,ii)
7886               ind=3
7887               do kk=1,3
7888                 ind=ind+1
7889                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7890               enddo
7891               do kk=1,2
7892                 do ll=1,2
7893                   ind=ind+1
7894                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7895                 enddo
7896               enddo
7897               do jj=1,5
7898                 do kk=1,3
7899                   do ll=1,2
7900                     do mm=1,2
7901                       ind=ind+1
7902                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7903                     enddo
7904                   enddo
7905                 enddo
7906               enddo
7907               exit
7908             endif
7909           enddo
7910         endif
7911       enddo
7912       return
7913       end subroutine add_hb_contact_eello
7914 !-----------------------------------------------------------------------------
7915       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7916 !      implicit real*8 (a-h,o-z)
7917 !      include 'DIMENSIONS'
7918 !      include 'COMMON.IOUNITS'
7919 !      include 'COMMON.DERIV'
7920 !      include 'COMMON.INTERACT'
7921 !      include 'COMMON.CONTACTS'
7922       real(kind=8),dimension(3) :: gx,gx1
7923       logical :: lprn
7924 !el local variables
7925       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7926       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7927                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7928                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7929                    rlocshield
7930
7931       lprn=.false.
7932       eij=facont_hb(jj,i)
7933       ekl=facont_hb(kk,k)
7934       ees0pij=ees0p(jj,i)
7935       ees0pkl=ees0p(kk,k)
7936       ees0mij=ees0m(jj,i)
7937       ees0mkl=ees0m(kk,k)
7938       ekont=eij*ekl
7939       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7940 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7941 ! Following 4 lines for diagnostics.
7942 !d    ees0pkl=0.0D0
7943 !d    ees0pij=1.0D0
7944 !d    ees0mkl=0.0D0
7945 !d    ees0mij=1.0D0
7946 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7947 !     & 'Contacts ',i,j,
7948 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7949 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7950 !     & 'gradcorr_long'
7951 ! Calculate the multi-body contribution to energy.
7952 !      ecorr=ecorr+ekont*ees
7953 ! Calculate multi-body contributions to the gradient.
7954       coeffpees0pij=coeffp*ees0pij
7955       coeffmees0mij=coeffm*ees0mij
7956       coeffpees0pkl=coeffp*ees0pkl
7957       coeffmees0mkl=coeffm*ees0mkl
7958       do ll=1,3
7959 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7960         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7961         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7962         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7963         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7964         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7965         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7966 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7967         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7968         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7969         coeffmees0mij*gacontm_hb1(ll,kk,k))
7970         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7971         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7972         coeffmees0mij*gacontm_hb2(ll,kk,k))
7973         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7974            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7975            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7976         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7977         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7978         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7979            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7980            coeffmees0mij*gacontm_hb3(ll,kk,k))
7981         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7982         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7983 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7984       enddo
7985 !      write (iout,*)
7986 !grad      do m=i+1,j-1
7987 !grad        do ll=1,3
7988 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7989 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7990 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7991 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7992 !grad        enddo
7993 !grad      enddo
7994 !grad      do m=k+1,l-1
7995 !grad        do ll=1,3
7996 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7997 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7998 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7999 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8000 !grad        enddo
8001 !grad      enddo
8002 !      write (iout,*) "ehbcorr",ekont*ees
8003       ehbcorr=ekont*ees
8004       if (shield_mode.gt.0) then
8005        j=ees0plist(jj,i)
8006        l=ees0plist(kk,k)
8007 !C        print *,i,j,fac_shield(i),fac_shield(j),
8008 !C     &fac_shield(k),fac_shield(l)
8009         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8010            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8011           do ilist=1,ishield_list(i)
8012            iresshield=shield_list(ilist,i)
8013            do m=1,3
8014            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8015            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8016                    rlocshield  &
8017             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8018             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8019             +rlocshield
8020            enddo
8021           enddo
8022           do ilist=1,ishield_list(j)
8023            iresshield=shield_list(ilist,j)
8024            do m=1,3
8025            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8026            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8027                    rlocshield &
8028             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8029            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8030             +rlocshield
8031            enddo
8032           enddo
8033
8034           do ilist=1,ishield_list(k)
8035            iresshield=shield_list(ilist,k)
8036            do m=1,3
8037            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8038            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8039                    rlocshield &
8040             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8041            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8042             +rlocshield
8043            enddo
8044           enddo
8045           do ilist=1,ishield_list(l)
8046            iresshield=shield_list(ilist,l)
8047            do m=1,3
8048            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8049            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8050                    rlocshield &
8051             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8052            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8053             +rlocshield
8054            enddo
8055           enddo
8056           do m=1,3
8057             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8058                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8059             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8060                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8061             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8062                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8063             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8064                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8065
8066             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8067                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8068             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8069                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8070             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8071                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8072             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8073                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8074
8075            enddo
8076       endif
8077       endif
8078       return
8079       end function ehbcorr
8080 #ifdef MOMENT
8081 !-----------------------------------------------------------------------------
8082       subroutine dipole(i,j,jj)
8083 !      implicit real*8 (a-h,o-z)
8084 !      include 'DIMENSIONS'
8085 !      include 'COMMON.IOUNITS'
8086 !      include 'COMMON.CHAIN'
8087 !      include 'COMMON.FFIELD'
8088 !      include 'COMMON.DERIV'
8089 !      include 'COMMON.INTERACT'
8090 !      include 'COMMON.CONTACTS'
8091 !      include 'COMMON.TORSION'
8092 !      include 'COMMON.VAR'
8093 !      include 'COMMON.GEO'
8094       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8095       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8096       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8097
8098       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8099       allocate(dipderx(3,5,4,maxconts,nres))
8100 !
8101
8102       iti1 = itortyp(itype(i+1,1))
8103       if (j.lt.nres-1) then
8104         itj1 = itortyp(itype(j+1,1))
8105       else
8106         itj1=ntortyp+1
8107       endif
8108       do iii=1,2
8109         dipi(iii,1)=Ub2(iii,i)
8110         dipderi(iii)=Ub2der(iii,i)
8111         dipi(iii,2)=b1(iii,iti1)
8112         dipj(iii,1)=Ub2(iii,j)
8113         dipderj(iii)=Ub2der(iii,j)
8114         dipj(iii,2)=b1(iii,itj1)
8115       enddo
8116       kkk=0
8117       do iii=1,2
8118         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8119         do jjj=1,2
8120           kkk=kkk+1
8121           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8122         enddo
8123       enddo
8124       do kkk=1,5
8125         do lll=1,3
8126           mmm=0
8127           do iii=1,2
8128             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8129               auxvec(1))
8130             do jjj=1,2
8131               mmm=mmm+1
8132               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8133             enddo
8134           enddo
8135         enddo
8136       enddo
8137       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8138       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8139       do iii=1,2
8140         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8141       enddo
8142       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8143       do iii=1,2
8144         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8145       enddo
8146       return
8147       end subroutine dipole
8148 #endif
8149 !-----------------------------------------------------------------------------
8150       subroutine calc_eello(i,j,k,l,jj,kk)
8151 !
8152 ! This subroutine computes matrices and vectors needed to calculate
8153 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8154 !
8155       use comm_kut
8156 !      implicit real*8 (a-h,o-z)
8157 !      include 'DIMENSIONS'
8158 !      include 'COMMON.IOUNITS'
8159 !      include 'COMMON.CHAIN'
8160 !      include 'COMMON.DERIV'
8161 !      include 'COMMON.INTERACT'
8162 !      include 'COMMON.CONTACTS'
8163 !      include 'COMMON.TORSION'
8164 !      include 'COMMON.VAR'
8165 !      include 'COMMON.GEO'
8166 !      include 'COMMON.FFIELD'
8167       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8168       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8169       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8170               itj1
8171 !el      logical :: lprn
8172 !el      common /kutas/ lprn
8173 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8174 !d     & ' jj=',jj,' kk=',kk
8175 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8176 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8177 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8178       do iii=1,2
8179         do jjj=1,2
8180           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8181           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8182         enddo
8183       enddo
8184       call transpose2(aa1(1,1),aa1t(1,1))
8185       call transpose2(aa2(1,1),aa2t(1,1))
8186       do kkk=1,5
8187         do lll=1,3
8188           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8189             aa1tder(1,1,lll,kkk))
8190           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8191             aa2tder(1,1,lll,kkk))
8192         enddo
8193       enddo
8194       if (l.eq.j+1) then
8195 ! parallel orientation of the two CA-CA-CA frames.
8196         if (i.gt.1) then
8197           iti=itortyp(itype(i,1))
8198         else
8199           iti=ntortyp+1
8200         endif
8201         itk1=itortyp(itype(k+1,1))
8202         itj=itortyp(itype(j,1))
8203         if (l.lt.nres-1) then
8204           itl1=itortyp(itype(l+1,1))
8205         else
8206           itl1=ntortyp+1
8207         endif
8208 ! A1 kernel(j+1) A2T
8209 !d        do iii=1,2
8210 !d          write (iout,'(3f10.5,5x,3f10.5)')
8211 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8212 !d        enddo
8213         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8214          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8215          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8216 ! Following matrices are needed only for 6-th order cumulants
8217         IF (wcorr6.gt.0.0d0) THEN
8218         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8219          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8220          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8221         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8222          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8223          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8224          ADtEAderx(1,1,1,1,1,1))
8225         lprn=.false.
8226         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8227          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8228          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8229          ADtEA1derx(1,1,1,1,1,1))
8230         ENDIF
8231 ! End 6-th order cumulants
8232 !d        lprn=.false.
8233 !d        if (lprn) then
8234 !d        write (2,*) 'In calc_eello6'
8235 !d        do iii=1,2
8236 !d          write (2,*) 'iii=',iii
8237 !d          do kkk=1,5
8238 !d            write (2,*) 'kkk=',kkk
8239 !d            do jjj=1,2
8240 !d              write (2,'(3(2f10.5),5x)')
8241 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8242 !d            enddo
8243 !d          enddo
8244 !d        enddo
8245 !d        endif
8246         call transpose2(EUgder(1,1,k),auxmat(1,1))
8247         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8248         call transpose2(EUg(1,1,k),auxmat(1,1))
8249         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8250         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8251         do iii=1,2
8252           do kkk=1,5
8253             do lll=1,3
8254               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8255                 EAEAderx(1,1,lll,kkk,iii,1))
8256             enddo
8257           enddo
8258         enddo
8259 ! A1T kernel(i+1) A2
8260         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8261          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8262          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8263 ! Following matrices are needed only for 6-th order cumulants
8264         IF (wcorr6.gt.0.0d0) THEN
8265         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8266          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8267          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8268         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8269          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8270          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8271          ADtEAderx(1,1,1,1,1,2))
8272         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8273          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8274          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8275          ADtEA1derx(1,1,1,1,1,2))
8276         ENDIF
8277 ! End 6-th order cumulants
8278         call transpose2(EUgder(1,1,l),auxmat(1,1))
8279         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8280         call transpose2(EUg(1,1,l),auxmat(1,1))
8281         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8282         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8283         do iii=1,2
8284           do kkk=1,5
8285             do lll=1,3
8286               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8287                 EAEAderx(1,1,lll,kkk,iii,2))
8288             enddo
8289           enddo
8290         enddo
8291 ! AEAb1 and AEAb2
8292 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8293 ! They are needed only when the fifth- or the sixth-order cumulants are
8294 ! indluded.
8295         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8296         call transpose2(AEA(1,1,1),auxmat(1,1))
8297         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8298         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8299         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8300         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8301         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8302         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8303         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8304         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8305         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8306         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8307         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8308         call transpose2(AEA(1,1,2),auxmat(1,1))
8309         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8310         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8311         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8312         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8313         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8314         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8315         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8316         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8317         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8318         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8319         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8320 ! Calculate the Cartesian derivatives of the vectors.
8321         do iii=1,2
8322           do kkk=1,5
8323             do lll=1,3
8324               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8325               call matvec2(auxmat(1,1),b1(1,iti),&
8326                 AEAb1derx(1,lll,kkk,iii,1,1))
8327               call matvec2(auxmat(1,1),Ub2(1,i),&
8328                 AEAb2derx(1,lll,kkk,iii,1,1))
8329               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8330                 AEAb1derx(1,lll,kkk,iii,2,1))
8331               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8332                 AEAb2derx(1,lll,kkk,iii,2,1))
8333               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8334               call matvec2(auxmat(1,1),b1(1,itj),&
8335                 AEAb1derx(1,lll,kkk,iii,1,2))
8336               call matvec2(auxmat(1,1),Ub2(1,j),&
8337                 AEAb2derx(1,lll,kkk,iii,1,2))
8338               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8339                 AEAb1derx(1,lll,kkk,iii,2,2))
8340               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8341                 AEAb2derx(1,lll,kkk,iii,2,2))
8342             enddo
8343           enddo
8344         enddo
8345         ENDIF
8346 ! End vectors
8347       else
8348 ! Antiparallel orientation of the two CA-CA-CA frames.
8349         if (i.gt.1) then
8350           iti=itortyp(itype(i,1))
8351         else
8352           iti=ntortyp+1
8353         endif
8354         itk1=itortyp(itype(k+1,1))
8355         itl=itortyp(itype(l,1))
8356         itj=itortyp(itype(j,1))
8357         if (j.lt.nres-1) then
8358           itj1=itortyp(itype(j+1,1))
8359         else
8360           itj1=ntortyp+1
8361         endif
8362 ! A2 kernel(j-1)T A1T
8363         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8364          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8365          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8366 ! Following matrices are needed only for 6-th order cumulants
8367         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8368            j.eq.i+4 .and. l.eq.i+3)) THEN
8369         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8370          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8371          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8372         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8373          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8374          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8375          ADtEAderx(1,1,1,1,1,1))
8376         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8377          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8378          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8379          ADtEA1derx(1,1,1,1,1,1))
8380         ENDIF
8381 ! End 6-th order cumulants
8382         call transpose2(EUgder(1,1,k),auxmat(1,1))
8383         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8384         call transpose2(EUg(1,1,k),auxmat(1,1))
8385         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8386         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8387         do iii=1,2
8388           do kkk=1,5
8389             do lll=1,3
8390               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8391                 EAEAderx(1,1,lll,kkk,iii,1))
8392             enddo
8393           enddo
8394         enddo
8395 ! A2T kernel(i+1)T A1
8396         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8397          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8398          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8399 ! Following matrices are needed only for 6-th order cumulants
8400         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8401            j.eq.i+4 .and. l.eq.i+3)) THEN
8402         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8403          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8404          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8405         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8406          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8407          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8408          ADtEAderx(1,1,1,1,1,2))
8409         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8410          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8411          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8412          ADtEA1derx(1,1,1,1,1,2))
8413         ENDIF
8414 ! End 6-th order cumulants
8415         call transpose2(EUgder(1,1,j),auxmat(1,1))
8416         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8417         call transpose2(EUg(1,1,j),auxmat(1,1))
8418         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8419         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8420         do iii=1,2
8421           do kkk=1,5
8422             do lll=1,3
8423               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8424                 EAEAderx(1,1,lll,kkk,iii,2))
8425             enddo
8426           enddo
8427         enddo
8428 ! AEAb1 and AEAb2
8429 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8430 ! They are needed only when the fifth- or the sixth-order cumulants are
8431 ! indluded.
8432         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8433           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8434         call transpose2(AEA(1,1,1),auxmat(1,1))
8435         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8436         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8437         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8438         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8439         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8440         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8441         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8442         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8443         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8444         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8445         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8446         call transpose2(AEA(1,1,2),auxmat(1,1))
8447         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8448         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8449         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8450         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8451         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8452         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8453         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8454         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8455         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8456         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8457         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8458 ! Calculate the Cartesian derivatives of the vectors.
8459         do iii=1,2
8460           do kkk=1,5
8461             do lll=1,3
8462               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8463               call matvec2(auxmat(1,1),b1(1,iti),&
8464                 AEAb1derx(1,lll,kkk,iii,1,1))
8465               call matvec2(auxmat(1,1),Ub2(1,i),&
8466                 AEAb2derx(1,lll,kkk,iii,1,1))
8467               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8468                 AEAb1derx(1,lll,kkk,iii,2,1))
8469               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8470                 AEAb2derx(1,lll,kkk,iii,2,1))
8471               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8472               call matvec2(auxmat(1,1),b1(1,itl),&
8473                 AEAb1derx(1,lll,kkk,iii,1,2))
8474               call matvec2(auxmat(1,1),Ub2(1,l),&
8475                 AEAb2derx(1,lll,kkk,iii,1,2))
8476               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8477                 AEAb1derx(1,lll,kkk,iii,2,2))
8478               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8479                 AEAb2derx(1,lll,kkk,iii,2,2))
8480             enddo
8481           enddo
8482         enddo
8483         ENDIF
8484 ! End vectors
8485       endif
8486       return
8487       end subroutine calc_eello
8488 !-----------------------------------------------------------------------------
8489       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8490       use comm_kut
8491       implicit none
8492       integer :: nderg
8493       logical :: transp
8494       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8495       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8496       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8497       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8498       integer :: iii,kkk,lll
8499       integer :: jjj,mmm
8500 !el      logical :: lprn
8501 !el      common /kutas/ lprn
8502       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8503       do iii=1,nderg
8504         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8505           AKAderg(1,1,iii))
8506       enddo
8507 !d      if (lprn) write (2,*) 'In kernel'
8508       do kkk=1,5
8509 !d        if (lprn) write (2,*) 'kkk=',kkk
8510         do lll=1,3
8511           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8512             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8513 !d          if (lprn) then
8514 !d            write (2,*) 'lll=',lll
8515 !d            write (2,*) 'iii=1'
8516 !d            do jjj=1,2
8517 !d              write (2,'(3(2f10.5),5x)')
8518 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8519 !d            enddo
8520 !d          endif
8521           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8522             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8523 !d          if (lprn) then
8524 !d            write (2,*) 'lll=',lll
8525 !d            write (2,*) 'iii=2'
8526 !d            do jjj=1,2
8527 !d              write (2,'(3(2f10.5),5x)')
8528 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8529 !d            enddo
8530 !d          endif
8531         enddo
8532       enddo
8533       return
8534       end subroutine kernel
8535 !-----------------------------------------------------------------------------
8536       real(kind=8) function eello4(i,j,k,l,jj,kk)
8537 !      implicit real*8 (a-h,o-z)
8538 !      include 'DIMENSIONS'
8539 !      include 'COMMON.IOUNITS'
8540 !      include 'COMMON.CHAIN'
8541 !      include 'COMMON.DERIV'
8542 !      include 'COMMON.INTERACT'
8543 !      include 'COMMON.CONTACTS'
8544 !      include 'COMMON.TORSION'
8545 !      include 'COMMON.VAR'
8546 !      include 'COMMON.GEO'
8547       real(kind=8),dimension(2,2) :: pizda
8548       real(kind=8),dimension(3) :: ggg1,ggg2
8549       real(kind=8) ::  eel4,glongij,glongkl
8550       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8551 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8552 !d        eello4=0.0d0
8553 !d        return
8554 !d      endif
8555 !d      print *,'eello4:',i,j,k,l,jj,kk
8556 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8557 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8558 !old      eij=facont_hb(jj,i)
8559 !old      ekl=facont_hb(kk,k)
8560 !old      ekont=eij*ekl
8561       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8562 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8563       gcorr_loc(k-1)=gcorr_loc(k-1) &
8564          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8565       if (l.eq.j+1) then
8566         gcorr_loc(l-1)=gcorr_loc(l-1) &
8567            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8568       else
8569         gcorr_loc(j-1)=gcorr_loc(j-1) &
8570            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8571       endif
8572       do iii=1,2
8573         do kkk=1,5
8574           do lll=1,3
8575             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8576                               -EAEAderx(2,2,lll,kkk,iii,1)
8577 !d            derx(lll,kkk,iii)=0.0d0
8578           enddo
8579         enddo
8580       enddo
8581 !d      gcorr_loc(l-1)=0.0d0
8582 !d      gcorr_loc(j-1)=0.0d0
8583 !d      gcorr_loc(k-1)=0.0d0
8584 !d      eel4=1.0d0
8585 !d      write (iout,*)'Contacts have occurred for peptide groups',
8586 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8587 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8588       if (j.lt.nres-1) then
8589         j1=j+1
8590         j2=j-1
8591       else
8592         j1=j-1
8593         j2=j-2
8594       endif
8595       if (l.lt.nres-1) then
8596         l1=l+1
8597         l2=l-1
8598       else
8599         l1=l-1
8600         l2=l-2
8601       endif
8602       do ll=1,3
8603 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8604 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8605         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8606         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8607 !grad        ghalf=0.5d0*ggg1(ll)
8608         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8609         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8610         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8611         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8612         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8613         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8614 !grad        ghalf=0.5d0*ggg2(ll)
8615         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8616         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8617         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8618         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8619         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8620         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8621       enddo
8622 !grad      do m=i+1,j-1
8623 !grad        do ll=1,3
8624 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8625 !grad        enddo
8626 !grad      enddo
8627 !grad      do m=k+1,l-1
8628 !grad        do ll=1,3
8629 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8630 !grad        enddo
8631 !grad      enddo
8632 !grad      do m=i+2,j2
8633 !grad        do ll=1,3
8634 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8635 !grad        enddo
8636 !grad      enddo
8637 !grad      do m=k+2,l2
8638 !grad        do ll=1,3
8639 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8640 !grad        enddo
8641 !grad      enddo
8642 !d      do iii=1,nres-3
8643 !d        write (2,*) iii,gcorr_loc(iii)
8644 !d      enddo
8645       eello4=ekont*eel4
8646 !d      write (2,*) 'ekont',ekont
8647 !d      write (iout,*) 'eello4',ekont*eel4
8648       return
8649       end function eello4
8650 !-----------------------------------------------------------------------------
8651       real(kind=8) function eello5(i,j,k,l,jj,kk)
8652 !      implicit real*8 (a-h,o-z)
8653 !      include 'DIMENSIONS'
8654 !      include 'COMMON.IOUNITS'
8655 !      include 'COMMON.CHAIN'
8656 !      include 'COMMON.DERIV'
8657 !      include 'COMMON.INTERACT'
8658 !      include 'COMMON.CONTACTS'
8659 !      include 'COMMON.TORSION'
8660 !      include 'COMMON.VAR'
8661 !      include 'COMMON.GEO'
8662       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8663       real(kind=8),dimension(2) :: vv
8664       real(kind=8),dimension(3) :: ggg1,ggg2
8665       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8666       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8667       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8668 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8669 !                                                                              C
8670 !                            Parallel chains                                   C
8671 !                                                                              C
8672 !          o             o                   o             o                   C
8673 !         /l\           / \             \   / \           / \   /              C
8674 !        /   \         /   \             \ /   \         /   \ /               C
8675 !       j| o |l1       | o |              o| o |         | o |o                C
8676 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8677 !      \i/   \         /   \ /             /   \         /   \                 C
8678 !       o    k1             o                                                  C
8679 !         (I)          (II)                (III)          (IV)                 C
8680 !                                                                              C
8681 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8682 !                                                                              C
8683 !                            Antiparallel chains                               C
8684 !                                                                              C
8685 !          o             o                   o             o                   C
8686 !         /j\           / \             \   / \           / \   /              C
8687 !        /   \         /   \             \ /   \         /   \ /               C
8688 !      j1| o |l        | o |              o| o |         | o |o                C
8689 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8690 !      \i/   \         /   \ /             /   \         /   \                 C
8691 !       o     k1            o                                                  C
8692 !         (I)          (II)                (III)          (IV)                 C
8693 !                                                                              C
8694 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8695 !                                                                              C
8696 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8697 !                                                                              C
8698 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8699 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8700 !d        eello5=0.0d0
8701 !d        return
8702 !d      endif
8703 !d      write (iout,*)
8704 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8705 !d     &   ' and',k,l
8706       itk=itortyp(itype(k,1))
8707       itl=itortyp(itype(l,1))
8708       itj=itortyp(itype(j,1))
8709       eello5_1=0.0d0
8710       eello5_2=0.0d0
8711       eello5_3=0.0d0
8712       eello5_4=0.0d0
8713 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8714 !d     &   eel5_3_num,eel5_4_num)
8715       do iii=1,2
8716         do kkk=1,5
8717           do lll=1,3
8718             derx(lll,kkk,iii)=0.0d0
8719           enddo
8720         enddo
8721       enddo
8722 !d      eij=facont_hb(jj,i)
8723 !d      ekl=facont_hb(kk,k)
8724 !d      ekont=eij*ekl
8725 !d      write (iout,*)'Contacts have occurred for peptide groups',
8726 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8727 !d      goto 1111
8728 ! Contribution from the graph I.
8729 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8730 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8731       call transpose2(EUg(1,1,k),auxmat(1,1))
8732       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8733       vv(1)=pizda(1,1)-pizda(2,2)
8734       vv(2)=pizda(1,2)+pizda(2,1)
8735       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8736        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8737 ! Explicit gradient in virtual-dihedral angles.
8738       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8739        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8740        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8741       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8742       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8743       vv(1)=pizda(1,1)-pizda(2,2)
8744       vv(2)=pizda(1,2)+pizda(2,1)
8745       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8746        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8747        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8748       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8749       vv(1)=pizda(1,1)-pizda(2,2)
8750       vv(2)=pizda(1,2)+pizda(2,1)
8751       if (l.eq.j+1) then
8752         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8753          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8754          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8755       else
8756         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8757          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8758          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8759       endif
8760 ! Cartesian gradient
8761       do iii=1,2
8762         do kkk=1,5
8763           do lll=1,3
8764             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8765               pizda(1,1))
8766             vv(1)=pizda(1,1)-pizda(2,2)
8767             vv(2)=pizda(1,2)+pizda(2,1)
8768             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8769              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8770              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8771           enddo
8772         enddo
8773       enddo
8774 !      goto 1112
8775 !1111  continue
8776 ! Contribution from graph II
8777       call transpose2(EE(1,1,itk),auxmat(1,1))
8778       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8779       vv(1)=pizda(1,1)+pizda(2,2)
8780       vv(2)=pizda(2,1)-pizda(1,2)
8781       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8782        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8783 ! Explicit gradient in virtual-dihedral angles.
8784       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8785        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8786       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8787       vv(1)=pizda(1,1)+pizda(2,2)
8788       vv(2)=pizda(2,1)-pizda(1,2)
8789       if (l.eq.j+1) then
8790         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8791          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8792          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8793       else
8794         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8795          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8796          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8797       endif
8798 ! Cartesian gradient
8799       do iii=1,2
8800         do kkk=1,5
8801           do lll=1,3
8802             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8803               pizda(1,1))
8804             vv(1)=pizda(1,1)+pizda(2,2)
8805             vv(2)=pizda(2,1)-pizda(1,2)
8806             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8807              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8808              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8809           enddo
8810         enddo
8811       enddo
8812 !d      goto 1112
8813 !d1111  continue
8814       if (l.eq.j+1) then
8815 !d        goto 1110
8816 ! Parallel orientation
8817 ! Contribution from graph III
8818         call transpose2(EUg(1,1,l),auxmat(1,1))
8819         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8820         vv(1)=pizda(1,1)-pizda(2,2)
8821         vv(2)=pizda(1,2)+pizda(2,1)
8822         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8823          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8824 ! Explicit gradient in virtual-dihedral angles.
8825         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8826          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8827          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8828         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8829         vv(1)=pizda(1,1)-pizda(2,2)
8830         vv(2)=pizda(1,2)+pizda(2,1)
8831         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8832          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8833          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8834         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8835         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8836         vv(1)=pizda(1,1)-pizda(2,2)
8837         vv(2)=pizda(1,2)+pizda(2,1)
8838         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8839          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8840          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8841 ! Cartesian gradient
8842         do iii=1,2
8843           do kkk=1,5
8844             do lll=1,3
8845               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8846                 pizda(1,1))
8847               vv(1)=pizda(1,1)-pizda(2,2)
8848               vv(2)=pizda(1,2)+pizda(2,1)
8849               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8850                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8851                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8852             enddo
8853           enddo
8854         enddo
8855 !d        goto 1112
8856 ! Contribution from graph IV
8857 !d1110    continue
8858         call transpose2(EE(1,1,itl),auxmat(1,1))
8859         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8860         vv(1)=pizda(1,1)+pizda(2,2)
8861         vv(2)=pizda(2,1)-pizda(1,2)
8862         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8863          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8864 ! Explicit gradient in virtual-dihedral angles.
8865         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8866          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8867         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8868         vv(1)=pizda(1,1)+pizda(2,2)
8869         vv(2)=pizda(2,1)-pizda(1,2)
8870         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8871          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8872          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8873 ! Cartesian gradient
8874         do iii=1,2
8875           do kkk=1,5
8876             do lll=1,3
8877               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8878                 pizda(1,1))
8879               vv(1)=pizda(1,1)+pizda(2,2)
8880               vv(2)=pizda(2,1)-pizda(1,2)
8881               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8882                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8883                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8884             enddo
8885           enddo
8886         enddo
8887       else
8888 ! Antiparallel orientation
8889 ! Contribution from graph III
8890 !        goto 1110
8891         call transpose2(EUg(1,1,j),auxmat(1,1))
8892         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8893         vv(1)=pizda(1,1)-pizda(2,2)
8894         vv(2)=pizda(1,2)+pizda(2,1)
8895         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8896          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8897 ! Explicit gradient in virtual-dihedral angles.
8898         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8899          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8900          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8901         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8902         vv(1)=pizda(1,1)-pizda(2,2)
8903         vv(2)=pizda(1,2)+pizda(2,1)
8904         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8905          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8906          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8907         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8908         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8909         vv(1)=pizda(1,1)-pizda(2,2)
8910         vv(2)=pizda(1,2)+pizda(2,1)
8911         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8912          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8913          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8914 ! Cartesian gradient
8915         do iii=1,2
8916           do kkk=1,5
8917             do lll=1,3
8918               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8919                 pizda(1,1))
8920               vv(1)=pizda(1,1)-pizda(2,2)
8921               vv(2)=pizda(1,2)+pizda(2,1)
8922               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8923                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8924                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8925             enddo
8926           enddo
8927         enddo
8928 !d        goto 1112
8929 ! Contribution from graph IV
8930 1110    continue
8931         call transpose2(EE(1,1,itj),auxmat(1,1))
8932         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8933         vv(1)=pizda(1,1)+pizda(2,2)
8934         vv(2)=pizda(2,1)-pizda(1,2)
8935         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8936          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8937 ! Explicit gradient in virtual-dihedral angles.
8938         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8939          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8940         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8941         vv(1)=pizda(1,1)+pizda(2,2)
8942         vv(2)=pizda(2,1)-pizda(1,2)
8943         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8944          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8945          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8946 ! Cartesian gradient
8947         do iii=1,2
8948           do kkk=1,5
8949             do lll=1,3
8950               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8951                 pizda(1,1))
8952               vv(1)=pizda(1,1)+pizda(2,2)
8953               vv(2)=pizda(2,1)-pizda(1,2)
8954               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8955                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8956                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8957             enddo
8958           enddo
8959         enddo
8960       endif
8961 1112  continue
8962       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8963 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8964 !d        write (2,*) 'ijkl',i,j,k,l
8965 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8966 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8967 !d      endif
8968 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8969 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8970 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8971 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8972       if (j.lt.nres-1) then
8973         j1=j+1
8974         j2=j-1
8975       else
8976         j1=j-1
8977         j2=j-2
8978       endif
8979       if (l.lt.nres-1) then
8980         l1=l+1
8981         l2=l-1
8982       else
8983         l1=l-1
8984         l2=l-2
8985       endif
8986 !d      eij=1.0d0
8987 !d      ekl=1.0d0
8988 !d      ekont=1.0d0
8989 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8990 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8991 !        summed up outside the subrouine as for the other subroutines
8992 !        handling long-range interactions. The old code is commented out
8993 !        with "cgrad" to keep track of changes.
8994       do ll=1,3
8995 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8996 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8997         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8998         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8999 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9000 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9001 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9002 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9003 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9004 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9005 !     &   gradcorr5ij,
9006 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9007 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9008 !grad        ghalf=0.5d0*ggg1(ll)
9009 !d        ghalf=0.0d0
9010         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9011         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9012         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9013         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9014         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9015         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9016 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9017 !grad        ghalf=0.5d0*ggg2(ll)
9018         ghalf=0.0d0
9019         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9020         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9021         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9022         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9023         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9024         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9025       enddo
9026 !d      goto 1112
9027 !grad      do m=i+1,j-1
9028 !grad        do ll=1,3
9029 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9030 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9031 !grad        enddo
9032 !grad      enddo
9033 !grad      do m=k+1,l-1
9034 !grad        do ll=1,3
9035 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9036 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9037 !grad        enddo
9038 !grad      enddo
9039 !1112  continue
9040 !grad      do m=i+2,j2
9041 !grad        do ll=1,3
9042 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9043 !grad        enddo
9044 !grad      enddo
9045 !grad      do m=k+2,l2
9046 !grad        do ll=1,3
9047 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9048 !grad        enddo
9049 !grad      enddo
9050 !d      do iii=1,nres-3
9051 !d        write (2,*) iii,g_corr5_loc(iii)
9052 !d      enddo
9053       eello5=ekont*eel5
9054 !d      write (2,*) 'ekont',ekont
9055 !d      write (iout,*) 'eello5',ekont*eel5
9056       return
9057       end function eello5
9058 !-----------------------------------------------------------------------------
9059       real(kind=8) function eello6(i,j,k,l,jj,kk)
9060 !      implicit real*8 (a-h,o-z)
9061 !      include 'DIMENSIONS'
9062 !      include 'COMMON.IOUNITS'
9063 !      include 'COMMON.CHAIN'
9064 !      include 'COMMON.DERIV'
9065 !      include 'COMMON.INTERACT'
9066 !      include 'COMMON.CONTACTS'
9067 !      include 'COMMON.TORSION'
9068 !      include 'COMMON.VAR'
9069 !      include 'COMMON.GEO'
9070 !      include 'COMMON.FFIELD'
9071       real(kind=8),dimension(3) :: ggg1,ggg2
9072       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9073                    eello6_6,eel6
9074       real(kind=8) :: gradcorr6ij,gradcorr6kl
9075       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9076 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9077 !d        eello6=0.0d0
9078 !d        return
9079 !d      endif
9080 !d      write (iout,*)
9081 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9082 !d     &   ' and',k,l
9083       eello6_1=0.0d0
9084       eello6_2=0.0d0
9085       eello6_3=0.0d0
9086       eello6_4=0.0d0
9087       eello6_5=0.0d0
9088       eello6_6=0.0d0
9089 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9090 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9091       do iii=1,2
9092         do kkk=1,5
9093           do lll=1,3
9094             derx(lll,kkk,iii)=0.0d0
9095           enddo
9096         enddo
9097       enddo
9098 !d      eij=facont_hb(jj,i)
9099 !d      ekl=facont_hb(kk,k)
9100 !d      ekont=eij*ekl
9101 !d      eij=1.0d0
9102 !d      ekl=1.0d0
9103 !d      ekont=1.0d0
9104       if (l.eq.j+1) then
9105         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9106         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9107         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9108         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9109         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9110         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9111       else
9112         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9113         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9114         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9115         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9116         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9117           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9118         else
9119           eello6_5=0.0d0
9120         endif
9121         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9122       endif
9123 ! If turn contributions are considered, they will be handled separately.
9124       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9125 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9126 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9127 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9128 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9129 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9130 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9131 !d      goto 1112
9132       if (j.lt.nres-1) then
9133         j1=j+1
9134         j2=j-1
9135       else
9136         j1=j-1
9137         j2=j-2
9138       endif
9139       if (l.lt.nres-1) then
9140         l1=l+1
9141         l2=l-1
9142       else
9143         l1=l-1
9144         l2=l-2
9145       endif
9146       do ll=1,3
9147 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9148 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9149 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9150 !grad        ghalf=0.5d0*ggg1(ll)
9151 !d        ghalf=0.0d0
9152         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9153         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9154         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9155         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9156         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9157         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9158         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9159         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9160 !grad        ghalf=0.5d0*ggg2(ll)
9161 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9162 !d        ghalf=0.0d0
9163         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9164         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9165         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9166         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9167         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9168         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9169       enddo
9170 !d      goto 1112
9171 !grad      do m=i+1,j-1
9172 !grad        do ll=1,3
9173 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9174 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9175 !grad        enddo
9176 !grad      enddo
9177 !grad      do m=k+1,l-1
9178 !grad        do ll=1,3
9179 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9180 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9181 !grad        enddo
9182 !grad      enddo
9183 !grad1112  continue
9184 !grad      do m=i+2,j2
9185 !grad        do ll=1,3
9186 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9187 !grad        enddo
9188 !grad      enddo
9189 !grad      do m=k+2,l2
9190 !grad        do ll=1,3
9191 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9192 !grad        enddo
9193 !grad      enddo
9194 !d      do iii=1,nres-3
9195 !d        write (2,*) iii,g_corr6_loc(iii)
9196 !d      enddo
9197       eello6=ekont*eel6
9198 !d      write (2,*) 'ekont',ekont
9199 !d      write (iout,*) 'eello6',ekont*eel6
9200       return
9201       end function eello6
9202 !-----------------------------------------------------------------------------
9203       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9204       use comm_kut
9205 !      implicit real*8 (a-h,o-z)
9206 !      include 'DIMENSIONS'
9207 !      include 'COMMON.IOUNITS'
9208 !      include 'COMMON.CHAIN'
9209 !      include 'COMMON.DERIV'
9210 !      include 'COMMON.INTERACT'
9211 !      include 'COMMON.CONTACTS'
9212 !      include 'COMMON.TORSION'
9213 !      include 'COMMON.VAR'
9214 !      include 'COMMON.GEO'
9215       real(kind=8),dimension(2) :: vv,vv1
9216       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9217       logical :: swap
9218 !el      logical :: lprn
9219 !el      common /kutas/ lprn
9220       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9221       real(kind=8) :: s1,s2,s3,s4,s5
9222 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9223 !                                                                              C
9224 !      Parallel       Antiparallel                                             C
9225 !                                                                              C
9226 !          o             o                                                     C
9227 !         /l\           /j\                                                    C
9228 !        /   \         /   \                                                   C
9229 !       /| o |         | o |\                                                  C
9230 !     \ j|/k\|  /   \  |/k\|l /                                                C
9231 !      \ /   \ /     \ /   \ /                                                 C
9232 !       o     o       o     o                                                  C
9233 !       i             i                                                        C
9234 !                                                                              C
9235 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9236       itk=itortyp(itype(k,1))
9237       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9238       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9239       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9240       call transpose2(EUgC(1,1,k),auxmat(1,1))
9241       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9242       vv1(1)=pizda1(1,1)-pizda1(2,2)
9243       vv1(2)=pizda1(1,2)+pizda1(2,1)
9244       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9245       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9246       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9247       s5=scalar2(vv(1),Dtobr2(1,i))
9248 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9249       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9250       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9251        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9252        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9253        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9254        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9255        +scalar2(vv(1),Dtobr2der(1,i)))
9256       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9257       vv1(1)=pizda1(1,1)-pizda1(2,2)
9258       vv1(2)=pizda1(1,2)+pizda1(2,1)
9259       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9260       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9261       if (l.eq.j+1) then
9262         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9263        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9264        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9265        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9266        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9267       else
9268         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9269        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9270        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9271        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9272        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9273       endif
9274       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9275       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9276       vv1(1)=pizda1(1,1)-pizda1(2,2)
9277       vv1(2)=pizda1(1,2)+pizda1(2,1)
9278       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9279        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9280        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9281        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9282       do iii=1,2
9283         if (swap) then
9284           ind=3-iii
9285         else
9286           ind=iii
9287         endif
9288         do kkk=1,5
9289           do lll=1,3
9290             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9291             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9292             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9293             call transpose2(EUgC(1,1,k),auxmat(1,1))
9294             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9295               pizda1(1,1))
9296             vv1(1)=pizda1(1,1)-pizda1(2,2)
9297             vv1(2)=pizda1(1,2)+pizda1(2,1)
9298             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9299             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9300              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9301             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9302              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9303             s5=scalar2(vv(1),Dtobr2(1,i))
9304             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9305           enddo
9306         enddo
9307       enddo
9308       return
9309       end function eello6_graph1
9310 !-----------------------------------------------------------------------------
9311       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9312       use comm_kut
9313 !      implicit real*8 (a-h,o-z)
9314 !      include 'DIMENSIONS'
9315 !      include 'COMMON.IOUNITS'
9316 !      include 'COMMON.CHAIN'
9317 !      include 'COMMON.DERIV'
9318 !      include 'COMMON.INTERACT'
9319 !      include 'COMMON.CONTACTS'
9320 !      include 'COMMON.TORSION'
9321 !      include 'COMMON.VAR'
9322 !      include 'COMMON.GEO'
9323       logical :: swap
9324       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9325       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9326 !el      logical :: lprn
9327 !el      common /kutas/ lprn
9328       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9329       real(kind=8) :: s2,s3,s4
9330 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9331 !                                                                              C
9332 !      Parallel       Antiparallel                                             C
9333 !                                                                              C
9334 !          o             o                                                     C
9335 !     \   /l\           /j\   /                                                C
9336 !      \ /   \         /   \ /                                                 C
9337 !       o| o |         | o |o                                                  C
9338 !     \ j|/k\|      \  |/k\|l                                                  C
9339 !      \ /   \       \ /   \                                                   C
9340 !       o             o                                                        C
9341 !       i             i                                                        C
9342 !                                                                              C
9343 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9344 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9345 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9346 !           but not in a cluster cumulant
9347 #ifdef MOMENT
9348       s1=dip(1,jj,i)*dip(1,kk,k)
9349 #endif
9350       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9351       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9352       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9353       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9354       call transpose2(EUg(1,1,k),auxmat(1,1))
9355       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9356       vv(1)=pizda(1,1)-pizda(2,2)
9357       vv(2)=pizda(1,2)+pizda(2,1)
9358       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9359 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9360 #ifdef MOMENT
9361       eello6_graph2=-(s1+s2+s3+s4)
9362 #else
9363       eello6_graph2=-(s2+s3+s4)
9364 #endif
9365 !      eello6_graph2=-s3
9366 ! Derivatives in gamma(i-1)
9367       if (i.gt.1) then
9368 #ifdef MOMENT
9369         s1=dipderg(1,jj,i)*dip(1,kk,k)
9370 #endif
9371         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9372         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9373         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9374         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9375 #ifdef MOMENT
9376         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9377 #else
9378         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9379 #endif
9380 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9381       endif
9382 ! Derivatives in gamma(k-1)
9383 #ifdef MOMENT
9384       s1=dip(1,jj,i)*dipderg(1,kk,k)
9385 #endif
9386       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9387       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9388       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9389       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9390       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9391       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9392       vv(1)=pizda(1,1)-pizda(2,2)
9393       vv(2)=pizda(1,2)+pizda(2,1)
9394       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9395 #ifdef MOMENT
9396       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9397 #else
9398       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9399 #endif
9400 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9401 ! Derivatives in gamma(j-1) or gamma(l-1)
9402       if (j.gt.1) then
9403 #ifdef MOMENT
9404         s1=dipderg(3,jj,i)*dip(1,kk,k)
9405 #endif
9406         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9407         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9408         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9409         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9410         vv(1)=pizda(1,1)-pizda(2,2)
9411         vv(2)=pizda(1,2)+pizda(2,1)
9412         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9413 #ifdef MOMENT
9414         if (swap) then
9415           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9416         else
9417           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9418         endif
9419 #endif
9420         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9421 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9422       endif
9423 ! Derivatives in gamma(l-1) or gamma(j-1)
9424       if (l.gt.1) then
9425 #ifdef MOMENT
9426         s1=dip(1,jj,i)*dipderg(3,kk,k)
9427 #endif
9428         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9429         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9430         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9431         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9432         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9433         vv(1)=pizda(1,1)-pizda(2,2)
9434         vv(2)=pizda(1,2)+pizda(2,1)
9435         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9436 #ifdef MOMENT
9437         if (swap) then
9438           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9439         else
9440           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9441         endif
9442 #endif
9443         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9444 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9445       endif
9446 ! Cartesian derivatives.
9447       if (lprn) then
9448         write (2,*) 'In eello6_graph2'
9449         do iii=1,2
9450           write (2,*) 'iii=',iii
9451           do kkk=1,5
9452             write (2,*) 'kkk=',kkk
9453             do jjj=1,2
9454               write (2,'(3(2f10.5),5x)') &
9455               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9456             enddo
9457           enddo
9458         enddo
9459       endif
9460       do iii=1,2
9461         do kkk=1,5
9462           do lll=1,3
9463 #ifdef MOMENT
9464             if (iii.eq.1) then
9465               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9466             else
9467               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9468             endif
9469 #endif
9470             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9471               auxvec(1))
9472             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9473             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9474               auxvec(1))
9475             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9476             call transpose2(EUg(1,1,k),auxmat(1,1))
9477             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9478               pizda(1,1))
9479             vv(1)=pizda(1,1)-pizda(2,2)
9480             vv(2)=pizda(1,2)+pizda(2,1)
9481             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9482 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9483 #ifdef MOMENT
9484             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9485 #else
9486             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9487 #endif
9488             if (swap) then
9489               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9490             else
9491               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9492             endif
9493           enddo
9494         enddo
9495       enddo
9496       return
9497       end function eello6_graph2
9498 !-----------------------------------------------------------------------------
9499       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9500 !      implicit real*8 (a-h,o-z)
9501 !      include 'DIMENSIONS'
9502 !      include 'COMMON.IOUNITS'
9503 !      include 'COMMON.CHAIN'
9504 !      include 'COMMON.DERIV'
9505 !      include 'COMMON.INTERACT'
9506 !      include 'COMMON.CONTACTS'
9507 !      include 'COMMON.TORSION'
9508 !      include 'COMMON.VAR'
9509 !      include 'COMMON.GEO'
9510       real(kind=8),dimension(2) :: vv,auxvec
9511       real(kind=8),dimension(2,2) :: pizda,auxmat
9512       logical :: swap
9513       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9514       real(kind=8) :: s1,s2,s3,s4
9515 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9516 !                                                                              C
9517 !      Parallel       Antiparallel                                             C
9518 !                                                                              C
9519 !          o             o                                                     C
9520 !         /l\   /   \   /j\                                                    C
9521 !        /   \ /     \ /   \                                                   C
9522 !       /| o |o       o| o |\                                                  C
9523 !       j|/k\|  /      |/k\|l /                                                C
9524 !        /   \ /       /   \ /                                                 C
9525 !       /     o       /     o                                                  C
9526 !       i             i                                                        C
9527 !                                                                              C
9528 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9529 !
9530 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9531 !           energy moment and not to the cluster cumulant.
9532       iti=itortyp(itype(i,1))
9533       if (j.lt.nres-1) then
9534         itj1=itortyp(itype(j+1,1))
9535       else
9536         itj1=ntortyp+1
9537       endif
9538       itk=itortyp(itype(k,1))
9539       itk1=itortyp(itype(k+1,1))
9540       if (l.lt.nres-1) then
9541         itl1=itortyp(itype(l+1,1))
9542       else
9543         itl1=ntortyp+1
9544       endif
9545 #ifdef MOMENT
9546       s1=dip(4,jj,i)*dip(4,kk,k)
9547 #endif
9548       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9549       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9550       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9551       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9552       call transpose2(EE(1,1,itk),auxmat(1,1))
9553       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9554       vv(1)=pizda(1,1)+pizda(2,2)
9555       vv(2)=pizda(2,1)-pizda(1,2)
9556       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9557 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9558 !d     & "sum",-(s2+s3+s4)
9559 #ifdef MOMENT
9560       eello6_graph3=-(s1+s2+s3+s4)
9561 #else
9562       eello6_graph3=-(s2+s3+s4)
9563 #endif
9564 !      eello6_graph3=-s4
9565 ! Derivatives in gamma(k-1)
9566       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9567       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9568       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9569       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9570 ! Derivatives in gamma(l-1)
9571       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9572       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9573       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9574       vv(1)=pizda(1,1)+pizda(2,2)
9575       vv(2)=pizda(2,1)-pizda(1,2)
9576       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9577       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9578 ! Cartesian derivatives.
9579       do iii=1,2
9580         do kkk=1,5
9581           do lll=1,3
9582 #ifdef MOMENT
9583             if (iii.eq.1) then
9584               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9585             else
9586               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9587             endif
9588 #endif
9589             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9590               auxvec(1))
9591             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9592             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9593               auxvec(1))
9594             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9595             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9596               pizda(1,1))
9597             vv(1)=pizda(1,1)+pizda(2,2)
9598             vv(2)=pizda(2,1)-pizda(1,2)
9599             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9600 #ifdef MOMENT
9601             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9602 #else
9603             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9604 #endif
9605             if (swap) then
9606               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9607             else
9608               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9609             endif
9610 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9611           enddo
9612         enddo
9613       enddo
9614       return
9615       end function eello6_graph3
9616 !-----------------------------------------------------------------------------
9617       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9618 !      implicit real*8 (a-h,o-z)
9619 !      include 'DIMENSIONS'
9620 !      include 'COMMON.IOUNITS'
9621 !      include 'COMMON.CHAIN'
9622 !      include 'COMMON.DERIV'
9623 !      include 'COMMON.INTERACT'
9624 !      include 'COMMON.CONTACTS'
9625 !      include 'COMMON.TORSION'
9626 !      include 'COMMON.VAR'
9627 !      include 'COMMON.GEO'
9628 !      include 'COMMON.FFIELD'
9629       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9630       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9631       logical :: swap
9632       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9633               iii,kkk,lll
9634       real(kind=8) :: s1,s2,s3,s4
9635 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9636 !                                                                              C
9637 !      Parallel       Antiparallel                                             C
9638 !                                                                              C
9639 !          o             o                                                     C
9640 !         /l\   /   \   /j\                                                    C
9641 !        /   \ /     \ /   \                                                   C
9642 !       /| o |o       o| o |\                                                  C
9643 !     \ j|/k\|      \  |/k\|l                                                  C
9644 !      \ /   \       \ /   \                                                   C
9645 !       o     \       o     \                                                  C
9646 !       i             i                                                        C
9647 !                                                                              C
9648 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9649 !
9650 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9651 !           energy moment and not to the cluster cumulant.
9652 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9653       iti=itortyp(itype(i,1))
9654       itj=itortyp(itype(j,1))
9655       if (j.lt.nres-1) then
9656         itj1=itortyp(itype(j+1,1))
9657       else
9658         itj1=ntortyp+1
9659       endif
9660       itk=itortyp(itype(k,1))
9661       if (k.lt.nres-1) then
9662         itk1=itortyp(itype(k+1,1))
9663       else
9664         itk1=ntortyp+1
9665       endif
9666       itl=itortyp(itype(l,1))
9667       if (l.lt.nres-1) then
9668         itl1=itortyp(itype(l+1,1))
9669       else
9670         itl1=ntortyp+1
9671       endif
9672 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9673 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9674 !d     & ' itl',itl,' itl1',itl1
9675 #ifdef MOMENT
9676       if (imat.eq.1) then
9677         s1=dip(3,jj,i)*dip(3,kk,k)
9678       else
9679         s1=dip(2,jj,j)*dip(2,kk,l)
9680       endif
9681 #endif
9682       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9683       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9684       if (j.eq.l+1) then
9685         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9686         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9687       else
9688         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9689         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9690       endif
9691       call transpose2(EUg(1,1,k),auxmat(1,1))
9692       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9693       vv(1)=pizda(1,1)-pizda(2,2)
9694       vv(2)=pizda(2,1)+pizda(1,2)
9695       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9696 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9697 #ifdef MOMENT
9698       eello6_graph4=-(s1+s2+s3+s4)
9699 #else
9700       eello6_graph4=-(s2+s3+s4)
9701 #endif
9702 ! Derivatives in gamma(i-1)
9703       if (i.gt.1) then
9704 #ifdef MOMENT
9705         if (imat.eq.1) then
9706           s1=dipderg(2,jj,i)*dip(3,kk,k)
9707         else
9708           s1=dipderg(4,jj,j)*dip(2,kk,l)
9709         endif
9710 #endif
9711         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9712         if (j.eq.l+1) then
9713           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9714           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9715         else
9716           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9717           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9718         endif
9719         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9720         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9721 !d          write (2,*) 'turn6 derivatives'
9722 #ifdef MOMENT
9723           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9724 #else
9725           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9726 #endif
9727         else
9728 #ifdef MOMENT
9729           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9730 #else
9731           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9732 #endif
9733         endif
9734       endif
9735 ! Derivatives in gamma(k-1)
9736 #ifdef MOMENT
9737       if (imat.eq.1) then
9738         s1=dip(3,jj,i)*dipderg(2,kk,k)
9739       else
9740         s1=dip(2,jj,j)*dipderg(4,kk,l)
9741       endif
9742 #endif
9743       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9744       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9745       if (j.eq.l+1) then
9746         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9747         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9748       else
9749         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9750         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9751       endif
9752       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9753       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9754       vv(1)=pizda(1,1)-pizda(2,2)
9755       vv(2)=pizda(2,1)+pizda(1,2)
9756       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9757       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9758 #ifdef MOMENT
9759         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9760 #else
9761         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9762 #endif
9763       else
9764 #ifdef MOMENT
9765         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9766 #else
9767         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9768 #endif
9769       endif
9770 ! Derivatives in gamma(j-1) or gamma(l-1)
9771       if (l.eq.j+1 .and. l.gt.1) then
9772         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9773         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9774         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9775         vv(1)=pizda(1,1)-pizda(2,2)
9776         vv(2)=pizda(2,1)+pizda(1,2)
9777         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9778         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9779       else if (j.gt.1) then
9780         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9781         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9782         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9783         vv(1)=pizda(1,1)-pizda(2,2)
9784         vv(2)=pizda(2,1)+pizda(1,2)
9785         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9786         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9787           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9788         else
9789           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9790         endif
9791       endif
9792 ! Cartesian derivatives.
9793       do iii=1,2
9794         do kkk=1,5
9795           do lll=1,3
9796 #ifdef MOMENT
9797             if (iii.eq.1) then
9798               if (imat.eq.1) then
9799                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9800               else
9801                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9802               endif
9803             else
9804               if (imat.eq.1) then
9805                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9806               else
9807                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9808               endif
9809             endif
9810 #endif
9811             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9812               auxvec(1))
9813             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9814             if (j.eq.l+1) then
9815               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9816                 b1(1,itj1),auxvec(1))
9817               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9818             else
9819               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9820                 b1(1,itl1),auxvec(1))
9821               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9822             endif
9823             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9824               pizda(1,1))
9825             vv(1)=pizda(1,1)-pizda(2,2)
9826             vv(2)=pizda(2,1)+pizda(1,2)
9827             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9828             if (swap) then
9829               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9830 #ifdef MOMENT
9831                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9832                    -(s1+s2+s4)
9833 #else
9834                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9835                    -(s2+s4)
9836 #endif
9837                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9838               else
9839 #ifdef MOMENT
9840                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9841 #else
9842                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9843 #endif
9844                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9845               endif
9846             else
9847 #ifdef MOMENT
9848               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9849 #else
9850               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9851 #endif
9852               if (l.eq.j+1) then
9853                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9854               else
9855                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9856               endif
9857             endif
9858           enddo
9859         enddo
9860       enddo
9861       return
9862       end function eello6_graph4
9863 !-----------------------------------------------------------------------------
9864       real(kind=8) function eello_turn6(i,jj,kk)
9865 !      implicit real*8 (a-h,o-z)
9866 !      include 'DIMENSIONS'
9867 !      include 'COMMON.IOUNITS'
9868 !      include 'COMMON.CHAIN'
9869 !      include 'COMMON.DERIV'
9870 !      include 'COMMON.INTERACT'
9871 !      include 'COMMON.CONTACTS'
9872 !      include 'COMMON.TORSION'
9873 !      include 'COMMON.VAR'
9874 !      include 'COMMON.GEO'
9875       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9876       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9877       real(kind=8),dimension(3) :: ggg1,ggg2
9878       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9879       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9880 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9881 !           the respective energy moment and not to the cluster cumulant.
9882 !el local variables
9883       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9884       integer :: j1,j2,l1,l2,ll
9885       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9886       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9887       s1=0.0d0
9888       s8=0.0d0
9889       s13=0.0d0
9890 !
9891       eello_turn6=0.0d0
9892       j=i+4
9893       k=i+1
9894       l=i+3
9895       iti=itortyp(itype(i,1))
9896       itk=itortyp(itype(k,1))
9897       itk1=itortyp(itype(k+1,1))
9898       itl=itortyp(itype(l,1))
9899       itj=itortyp(itype(j,1))
9900 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9901 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9902 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9903 !d        eello6=0.0d0
9904 !d        return
9905 !d      endif
9906 !d      write (iout,*)
9907 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9908 !d     &   ' and',k,l
9909 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9910       do iii=1,2
9911         do kkk=1,5
9912           do lll=1,3
9913             derx_turn(lll,kkk,iii)=0.0d0
9914           enddo
9915         enddo
9916       enddo
9917 !d      eij=1.0d0
9918 !d      ekl=1.0d0
9919 !d      ekont=1.0d0
9920       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9921 !d      eello6_5=0.0d0
9922 !d      write (2,*) 'eello6_5',eello6_5
9923 #ifdef MOMENT
9924       call transpose2(AEA(1,1,1),auxmat(1,1))
9925       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9926       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9927       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9928 #endif
9929       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9930       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9931       s2 = scalar2(b1(1,itk),vtemp1(1))
9932 #ifdef MOMENT
9933       call transpose2(AEA(1,1,2),atemp(1,1))
9934       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9935       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9936       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9937 #endif
9938       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9939       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9940       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9941 #ifdef MOMENT
9942       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9943       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9944       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9945       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9946       ss13 = scalar2(b1(1,itk),vtemp4(1))
9947       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9948 #endif
9949 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9950 !      s1=0.0d0
9951 !      s2=0.0d0
9952 !      s8=0.0d0
9953 !      s12=0.0d0
9954 !      s13=0.0d0
9955       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9956 ! Derivatives in gamma(i+2)
9957       s1d =0.0d0
9958       s8d =0.0d0
9959 #ifdef MOMENT
9960       call transpose2(AEA(1,1,1),auxmatd(1,1))
9961       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9962       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9963       call transpose2(AEAderg(1,1,2),atempd(1,1))
9964       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9965       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9966 #endif
9967       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9968       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9969       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9970 !      s1d=0.0d0
9971 !      s2d=0.0d0
9972 !      s8d=0.0d0
9973 !      s12d=0.0d0
9974 !      s13d=0.0d0
9975       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9976 ! Derivatives in gamma(i+3)
9977 #ifdef MOMENT
9978       call transpose2(AEA(1,1,1),auxmatd(1,1))
9979       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9980       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9981       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9982 #endif
9983       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9984       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9985       s2d = scalar2(b1(1,itk),vtemp1d(1))
9986 #ifdef MOMENT
9987       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9988       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9989 #endif
9990       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9991 #ifdef MOMENT
9992       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9993       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9994       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9995 #endif
9996 !      s1d=0.0d0
9997 !      s2d=0.0d0
9998 !      s8d=0.0d0
9999 !      s12d=0.0d0
10000 !      s13d=0.0d0
10001 #ifdef MOMENT
10002       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10003                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10004 #else
10005       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10006                     -0.5d0*ekont*(s2d+s12d)
10007 #endif
10008 ! Derivatives in gamma(i+4)
10009       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10010       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10011       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10012 #ifdef MOMENT
10013       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10014       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10015       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10016 #endif
10017 !      s1d=0.0d0
10018 !      s2d=0.0d0
10019 !      s8d=0.0d0
10020 !      s12d=0.0d0
10021 !      s13d=0.0d0
10022 #ifdef MOMENT
10023       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10024 #else
10025       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10026 #endif
10027 ! Derivatives in gamma(i+5)
10028 #ifdef MOMENT
10029       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10030       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10031       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10032 #endif
10033       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10034       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10035       s2d = scalar2(b1(1,itk),vtemp1d(1))
10036 #ifdef MOMENT
10037       call transpose2(AEA(1,1,2),atempd(1,1))
10038       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10039       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10040 #endif
10041       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10042       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10043 #ifdef MOMENT
10044       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10045       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10046       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10047 #endif
10048 !      s1d=0.0d0
10049 !      s2d=0.0d0
10050 !      s8d=0.0d0
10051 !      s12d=0.0d0
10052 !      s13d=0.0d0
10053 #ifdef MOMENT
10054       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10055                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10056 #else
10057       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10058                     -0.5d0*ekont*(s2d+s12d)
10059 #endif
10060 ! Cartesian derivatives
10061       do iii=1,2
10062         do kkk=1,5
10063           do lll=1,3
10064 #ifdef MOMENT
10065             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10066             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10067             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10068 #endif
10069             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10070             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10071                 vtemp1d(1))
10072             s2d = scalar2(b1(1,itk),vtemp1d(1))
10073 #ifdef MOMENT
10074             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10075             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10076             s8d = -(atempd(1,1)+atempd(2,2))* &
10077                  scalar2(cc(1,1,itl),vtemp2(1))
10078 #endif
10079             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10080                  auxmatd(1,1))
10081             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10082             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10083 !      s1d=0.0d0
10084 !      s2d=0.0d0
10085 !      s8d=0.0d0
10086 !      s12d=0.0d0
10087 !      s13d=0.0d0
10088 #ifdef MOMENT
10089             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10090               - 0.5d0*(s1d+s2d)
10091 #else
10092             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10093               - 0.5d0*s2d
10094 #endif
10095 #ifdef MOMENT
10096             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10097               - 0.5d0*(s8d+s12d)
10098 #else
10099             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10100               - 0.5d0*s12d
10101 #endif
10102           enddo
10103         enddo
10104       enddo
10105 #ifdef MOMENT
10106       do kkk=1,5
10107         do lll=1,3
10108           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10109             achuj_tempd(1,1))
10110           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10111           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10112           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10113           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10114           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10115             vtemp4d(1))
10116           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10117           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10118           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10119         enddo
10120       enddo
10121 #endif
10122 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10123 !d     &  16*eel_turn6_num
10124 !d      goto 1112
10125       if (j.lt.nres-1) then
10126         j1=j+1
10127         j2=j-1
10128       else
10129         j1=j-1
10130         j2=j-2
10131       endif
10132       if (l.lt.nres-1) then
10133         l1=l+1
10134         l2=l-1
10135       else
10136         l1=l-1
10137         l2=l-2
10138       endif
10139       do ll=1,3
10140 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10141 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10142 !grad        ghalf=0.5d0*ggg1(ll)
10143 !d        ghalf=0.0d0
10144         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10145         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10146         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10147           +ekont*derx_turn(ll,2,1)
10148         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10149         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10150           +ekont*derx_turn(ll,4,1)
10151         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10152         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10153         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10154 !grad        ghalf=0.5d0*ggg2(ll)
10155 !d        ghalf=0.0d0
10156         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10157           +ekont*derx_turn(ll,2,2)
10158         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10159         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10160           +ekont*derx_turn(ll,4,2)
10161         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10162         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10163         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10164       enddo
10165 !d      goto 1112
10166 !grad      do m=i+1,j-1
10167 !grad        do ll=1,3
10168 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10169 !grad        enddo
10170 !grad      enddo
10171 !grad      do m=k+1,l-1
10172 !grad        do ll=1,3
10173 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10174 !grad        enddo
10175 !grad      enddo
10176 !grad1112  continue
10177 !grad      do m=i+2,j2
10178 !grad        do ll=1,3
10179 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10180 !grad        enddo
10181 !grad      enddo
10182 !grad      do m=k+2,l2
10183 !grad        do ll=1,3
10184 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10185 !grad        enddo
10186 !grad      enddo
10187 !d      do iii=1,nres-3
10188 !d        write (2,*) iii,g_corr6_loc(iii)
10189 !d      enddo
10190       eello_turn6=ekont*eel_turn6
10191 !d      write (2,*) 'ekont',ekont
10192 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10193       return
10194       end function eello_turn6
10195 !-----------------------------------------------------------------------------
10196       subroutine MATVEC2(A1,V1,V2)
10197 !DIR$ INLINEALWAYS MATVEC2
10198 #ifndef OSF
10199 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10200 #endif
10201 !      implicit real*8 (a-h,o-z)
10202 !      include 'DIMENSIONS'
10203       real(kind=8),dimension(2) :: V1,V2
10204       real(kind=8),dimension(2,2) :: A1
10205       real(kind=8) :: vaux1,vaux2
10206 !      DO 1 I=1,2
10207 !        VI=0.0
10208 !        DO 3 K=1,2
10209 !    3     VI=VI+A1(I,K)*V1(K)
10210 !        Vaux(I)=VI
10211 !    1 CONTINUE
10212
10213       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10214       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10215
10216       v2(1)=vaux1
10217       v2(2)=vaux2
10218       end subroutine MATVEC2
10219 !-----------------------------------------------------------------------------
10220       subroutine MATMAT2(A1,A2,A3)
10221 #ifndef OSF
10222 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10223 #endif
10224 !      implicit real*8 (a-h,o-z)
10225 !      include 'DIMENSIONS'
10226       real(kind=8),dimension(2,2) :: A1,A2,A3
10227       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10228 !      DIMENSION AI3(2,2)
10229 !        DO  J=1,2
10230 !          A3IJ=0.0
10231 !          DO K=1,2
10232 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10233 !          enddo
10234 !          A3(I,J)=A3IJ
10235 !       enddo
10236 !      enddo
10237
10238       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10239       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10240       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10241       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10242
10243       A3(1,1)=AI3_11
10244       A3(2,1)=AI3_21
10245       A3(1,2)=AI3_12
10246       A3(2,2)=AI3_22
10247       end subroutine MATMAT2
10248 !-----------------------------------------------------------------------------
10249       real(kind=8) function scalar2(u,v)
10250 !DIR$ INLINEALWAYS scalar2
10251       implicit none
10252       real(kind=8),dimension(2) :: u,v
10253       real(kind=8) :: sc
10254       integer :: i
10255       scalar2=u(1)*v(1)+u(2)*v(2)
10256       return
10257       end function scalar2
10258 !-----------------------------------------------------------------------------
10259       subroutine transpose2(a,at)
10260 !DIR$ INLINEALWAYS transpose2
10261 #ifndef OSF
10262 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10263 #endif
10264       implicit none
10265       real(kind=8),dimension(2,2) :: a,at
10266       at(1,1)=a(1,1)
10267       at(1,2)=a(2,1)
10268       at(2,1)=a(1,2)
10269       at(2,2)=a(2,2)
10270       return
10271       end subroutine transpose2
10272 !-----------------------------------------------------------------------------
10273       subroutine transpose(n,a,at)
10274       implicit none
10275       integer :: n,i,j
10276       real(kind=8),dimension(n,n) :: a,at
10277       do i=1,n
10278         do j=1,n
10279           at(j,i)=a(i,j)
10280         enddo
10281       enddo
10282       return
10283       end subroutine transpose
10284 !-----------------------------------------------------------------------------
10285       subroutine prodmat3(a1,a2,kk,transp,prod)
10286 !DIR$ INLINEALWAYS prodmat3
10287 #ifndef OSF
10288 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10289 #endif
10290       implicit none
10291       integer :: i,j
10292       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10293       logical :: transp
10294 !rc      double precision auxmat(2,2),prod_(2,2)
10295
10296       if (transp) then
10297 !rc        call transpose2(kk(1,1),auxmat(1,1))
10298 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10299 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10300
10301            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10302        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10303            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10304        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10305            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10306        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10307            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10308        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10309
10310       else
10311 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10312 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10313
10314            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10315         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10316            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10317         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10318            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10319         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10320            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10321         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10322
10323       endif
10324 !      call transpose2(a2(1,1),a2t(1,1))
10325
10326 !rc      print *,transp
10327 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10328 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10329
10330       return
10331       end subroutine prodmat3
10332 !-----------------------------------------------------------------------------
10333 ! energy_p_new_barrier.F
10334 !-----------------------------------------------------------------------------
10335       subroutine sum_gradient
10336 !      implicit real*8 (a-h,o-z)
10337       use io_base, only: pdbout
10338 !      include 'DIMENSIONS'
10339 #ifndef ISNAN
10340       external proc_proc
10341 #ifdef WINPGI
10342 !MS$ATTRIBUTES C ::  proc_proc
10343 #endif
10344 #endif
10345 #ifdef MPI
10346       include 'mpif.h'
10347 #endif
10348       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10349                    gloc_scbuf !(3,maxres)
10350
10351       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10352 !#endif
10353 !el local variables
10354       integer :: i,j,k,ierror,ierr
10355       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10356                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10357                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10358                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10359                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10360                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10361                    gsccorr_max,gsccorrx_max,time00
10362
10363 !      include 'COMMON.SETUP'
10364 !      include 'COMMON.IOUNITS'
10365 !      include 'COMMON.FFIELD'
10366 !      include 'COMMON.DERIV'
10367 !      include 'COMMON.INTERACT'
10368 !      include 'COMMON.SBRIDGE'
10369 !      include 'COMMON.CHAIN'
10370 !      include 'COMMON.VAR'
10371 !      include 'COMMON.CONTROL'
10372 !      include 'COMMON.TIME1'
10373 !      include 'COMMON.MAXGRAD'
10374 !      include 'COMMON.SCCOR'
10375 #ifdef TIMING
10376       time01=MPI_Wtime()
10377 #endif
10378 #ifdef DEBUG
10379       write (iout,*) "sum_gradient gvdwc, gvdwx"
10380       do i=1,nres
10381         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10382          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10383       enddo
10384       call flush(iout)
10385 #endif
10386 #ifdef MPI
10387         gradbufc=0.0d0
10388         gradbufx=0.0d0
10389         gradbufc_sum=0.0d0
10390         gloc_scbuf=0.0d0
10391         glocbuf=0.0d0
10392 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10393         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10394           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10395 #endif
10396 !
10397 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10398 !            in virtual-bond-vector coordinates
10399 !
10400 #ifdef DEBUG
10401 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10402 !      do i=1,nres-1
10403 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10404 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10405 !      enddo
10406 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10407 !      do i=1,nres-1
10408 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10409 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10410 !      enddo
10411       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10412       do i=1,nres
10413         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10414          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10415          (gvdwc_scpp(j,i),j=1,3)
10416       enddo
10417       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10418       do i=1,nres
10419         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10420          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10421          (gelc_loc_long(j,i),j=1,3)
10422       enddo
10423       call flush(iout)
10424 #endif
10425 #ifdef SPLITELE
10426       do i=0,nct
10427         do j=1,3
10428           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10429                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10430                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10431                       wel_loc*gel_loc_long(j,i)+ &
10432                       wcorr*gradcorr_long(j,i)+ &
10433                       wcorr5*gradcorr5_long(j,i)+ &
10434                       wcorr6*gradcorr6_long(j,i)+ &
10435                       wturn6*gcorr6_turn_long(j,i)+ &
10436                       wstrain*ghpbc(j,i) &
10437                      +wliptran*gliptranc(j,i) &
10438                      +gradafm(j,i) &
10439                      +welec*gshieldc(j,i) &
10440                      +wcorr*gshieldc_ec(j,i) &
10441                      +wturn3*gshieldc_t3(j,i)&
10442                      +wturn4*gshieldc_t4(j,i)&
10443                      +wel_loc*gshieldc_ll(j,i)&
10444                      +wtube*gg_tube(j,i) &
10445                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10446                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10447                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10448                      wcorr_nucl*gradcorr_nucl(j,i)&
10449                      +wcorr3_nucl*gradcorr3_nucl(j,i)
10450
10451         enddo
10452       enddo
10453 #else
10454       do i=0,nct
10455         do j=1,3
10456           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10457                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10458                       welec*gelc_long(j,i)+ &
10459                       wbond*gradb(j,i)+ &
10460                       wel_loc*gel_loc_long(j,i)+ &
10461                       wcorr*gradcorr_long(j,i)+ &
10462                       wcorr5*gradcorr5_long(j,i)+ &
10463                       wcorr6*gradcorr6_long(j,i)+ &
10464                       wturn6*gcorr6_turn_long(j,i)+ &
10465                       wstrain*ghpbc(j,i) &
10466                      +wliptran*gliptranc(j,i) &
10467                      +gradafm(j,i) &
10468                      +welec*gshieldc(j,i)&
10469                      +wcorr*gshieldc_ec(j,i) &
10470                      +wturn4*gshieldc_t4(j,i) &
10471                      +wel_loc*gshieldc_ll(j,i)&
10472                      +wtube*gg_tube(j,i) &
10473                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10474                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10475                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10476                      wcorr_nucl*gradcorr_nucl(j,i)
10477                      +wcorr3_nucl*gradcorr3_nucl(j,i)
10478         enddo
10479       enddo
10480 #endif
10481 #ifdef MPI
10482       if (nfgtasks.gt.1) then
10483       time00=MPI_Wtime()
10484 #ifdef DEBUG
10485       write (iout,*) "gradbufc before allreduce"
10486       do i=1,nres
10487         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10488       enddo
10489       call flush(iout)
10490 #endif
10491       do i=0,nres
10492         do j=1,3
10493           gradbufc_sum(j,i)=gradbufc(j,i)
10494         enddo
10495       enddo
10496 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10497 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10498 !      time_reduce=time_reduce+MPI_Wtime()-time00
10499 #ifdef DEBUG
10500 !      write (iout,*) "gradbufc_sum after allreduce"
10501 !      do i=1,nres
10502 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10503 !      enddo
10504 !      call flush(iout)
10505 #endif
10506 #ifdef TIMING
10507 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10508 #endif
10509       do i=0,nres
10510         do k=1,3
10511           gradbufc(k,i)=0.0d0
10512         enddo
10513       enddo
10514 #ifdef DEBUG
10515       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10516       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10517                         " jgrad_end  ",jgrad_end(i),&
10518                         i=igrad_start,igrad_end)
10519 #endif
10520 !
10521 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10522 ! do not parallelize this part.
10523 !
10524 !      do i=igrad_start,igrad_end
10525 !        do j=jgrad_start(i),jgrad_end(i)
10526 !          do k=1,3
10527 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10528 !          enddo
10529 !        enddo
10530 !      enddo
10531       do j=1,3
10532         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10533       enddo
10534       do i=nres-2,-1,-1
10535         do j=1,3
10536           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10537         enddo
10538       enddo
10539 #ifdef DEBUG
10540       write (iout,*) "gradbufc after summing"
10541       do i=1,nres
10542         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10543       enddo
10544       call flush(iout)
10545 #endif
10546       else
10547 #endif
10548 !el#define DEBUG
10549 #ifdef DEBUG
10550       write (iout,*) "gradbufc"
10551       do i=1,nres
10552         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10553       enddo
10554       call flush(iout)
10555 #endif
10556 !el#undef DEBUG
10557       do i=-1,nres
10558         do j=1,3
10559           gradbufc_sum(j,i)=gradbufc(j,i)
10560           gradbufc(j,i)=0.0d0
10561         enddo
10562       enddo
10563       do j=1,3
10564         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10565       enddo
10566       do i=nres-2,-1,-1
10567         do j=1,3
10568           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10569         enddo
10570       enddo
10571 !      do i=nnt,nres-1
10572 !        do k=1,3
10573 !          gradbufc(k,i)=0.0d0
10574 !        enddo
10575 !        do j=i+1,nres
10576 !          do k=1,3
10577 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10578 !          enddo
10579 !        enddo
10580 !      enddo
10581 !el#define DEBUG
10582 #ifdef DEBUG
10583       write (iout,*) "gradbufc after summing"
10584       do i=1,nres
10585         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10586       enddo
10587       call flush(iout)
10588 #endif
10589 !el#undef DEBUG
10590 #ifdef MPI
10591       endif
10592 #endif
10593       do k=1,3
10594         gradbufc(k,nres)=0.0d0
10595       enddo
10596 !el----------------
10597 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10598 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10599 !el-----------------
10600       do i=-1,nct
10601         do j=1,3
10602 #ifdef SPLITELE
10603           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10604                       wel_loc*gel_loc(j,i)+ &
10605                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10606                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10607                       wel_loc*gel_loc_long(j,i)+ &
10608                       wcorr*gradcorr_long(j,i)+ &
10609                       wcorr5*gradcorr5_long(j,i)+ &
10610                       wcorr6*gradcorr6_long(j,i)+ &
10611                       wturn6*gcorr6_turn_long(j,i))+ &
10612                       wbond*gradb(j,i)+ &
10613                       wcorr*gradcorr(j,i)+ &
10614                       wturn3*gcorr3_turn(j,i)+ &
10615                       wturn4*gcorr4_turn(j,i)+ &
10616                       wcorr5*gradcorr5(j,i)+ &
10617                       wcorr6*gradcorr6(j,i)+ &
10618                       wturn6*gcorr6_turn(j,i)+ &
10619                       wsccor*gsccorc(j,i) &
10620                      +wscloc*gscloc(j,i)  &
10621                      +wliptran*gliptranc(j,i) &
10622                      +gradafm(j,i) &
10623                      +welec*gshieldc(j,i) &
10624                      +welec*gshieldc_loc(j,i) &
10625                      +wcorr*gshieldc_ec(j,i) &
10626                      +wcorr*gshieldc_loc_ec(j,i) &
10627                      +wturn3*gshieldc_t3(j,i) &
10628                      +wturn3*gshieldc_loc_t3(j,i) &
10629                      +wturn4*gshieldc_t4(j,i) &
10630                      +wturn4*gshieldc_loc_t4(j,i) &
10631                      +wel_loc*gshieldc_ll(j,i) &
10632                      +wel_loc*gshieldc_loc_ll(j,i) &
10633                      +wtube*gg_tube(j,i) &
10634                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10635                      +wvdwpsb*gvdwpsb1(j,i))&
10636                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10637
10638 !                 if ((i.le.2).and.(i.ge.1)) print *,gradc(j,i,icg),&
10639 !                      gradbufc(j,i),welec*gelc(j,i), &
10640 !                      wel_loc*gel_loc(j,i), &
10641 !                      wscp*gvdwc_scpp(j,i), &
10642 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10643 !                      wel_loc*gel_loc_long(j,i), &
10644 !                      wcorr*gradcorr_long(j,i), &
10645 !                      wcorr5*gradcorr5_long(j,i), &
10646 !                      wcorr6*gradcorr6_long(j,i), &
10647 !                      wturn6*gcorr6_turn_long(j,i), &
10648 !                      wbond*gradb(j,i), &
10649 !                      wcorr*gradcorr(j,i), &
10650 !                      wturn3*gcorr3_turn(j,i), &
10651 !                      wturn4*gcorr4_turn(j,i), &
10652 !                      wcorr5*gradcorr5(j,i), &
10653 !                      wcorr6*gradcorr6(j,i), &
10654 !                      wturn6*gcorr6_turn(j,i), &
10655 !                      wsccor*gsccorc(j,i) &
10656 !                     ,wscloc*gscloc(j,i)  &
10657 !                     ,wliptran*gliptranc(j,i) &
10658 !                     ,gradafm(j,i) &
10659 !                     ,welec*gshieldc(j,i) &
10660 !                     ,welec*gshieldc_loc(j,i) &
10661 !                     ,wcorr*gshieldc_ec(j,i) &
10662 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10663 !                     ,wturn3*gshieldc_t3(j,i) &
10664 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10665 !                     ,wturn4*gshieldc_t4(j,i) &
10666 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10667 !                     ,wel_loc*gshieldc_ll(j,i) &
10668 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10669 !                     ,wtube*gg_tube(j,i) &
10670 !                     ,wbond_nucl*gradb_nucl(j,i) &
10671 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10672 !                     wvdwpsb*gvdwpsb1(j,i)&
10673 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10674
10675
10676
10677 #else
10678           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10679                       wel_loc*gel_loc(j,i)+ &
10680                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10681                       welec*gelc_long(j,i)+ &
10682                       wel_loc*gel_loc_long(j,i)+ &
10683 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10684                       wcorr5*gradcorr5_long(j,i)+ &
10685                       wcorr6*gradcorr6_long(j,i)+ &
10686                       wturn6*gcorr6_turn_long(j,i))+ &
10687                       wbond*gradb(j,i)+ &
10688                       wcorr*gradcorr(j,i)+ &
10689                       wturn3*gcorr3_turn(j,i)+ &
10690                       wturn4*gcorr4_turn(j,i)+ &
10691                       wcorr5*gradcorr5(j,i)+ &
10692                       wcorr6*gradcorr6(j,i)+ &
10693                       wturn6*gcorr6_turn(j,i)+ &
10694                       wsccor*gsccorc(j,i) &
10695                      +wscloc*gscloc(j,i) &
10696                      +gradafm(j,i) &
10697                      +wliptran*gliptranc(j,i) &
10698                      +welec*gshieldc(j,i) &
10699                      +welec*gshieldc_loc(j,) &
10700                      +wcorr*gshieldc_ec(j,i) &
10701                      +wcorr*gshieldc_loc_ec(j,i) &
10702                      +wturn3*gshieldc_t3(j,i) &
10703                      +wturn3*gshieldc_loc_t3(j,i) &
10704                      +wturn4*gshieldc_t4(j,i) &
10705                      +wturn4*gshieldc_loc_t4(j,i) &
10706                      +wel_loc*gshieldc_ll(j,i) &
10707                      +wel_loc*gshieldc_loc_ll(j,i) &
10708                      +wtube*gg_tube(j,i) &
10709                      +wbond_nucl*gradb_nucl(j,i) &
10710                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10711                      +wvdwpsb*gvdwpsb1(j,i))&
10712                      +wsbloc*gsbloc(j,i)
10713
10714
10715
10716
10717 #endif
10718           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10719                         wbond*gradbx(j,i)+ &
10720                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10721                         wsccor*gsccorx(j,i) &
10722                        +wscloc*gsclocx(j,i) &
10723                        +wliptran*gliptranx(j,i) &
10724                        +welec*gshieldx(j,i)     &
10725                        +wcorr*gshieldx_ec(j,i)  &
10726                        +wturn3*gshieldx_t3(j,i) &
10727                        +wturn4*gshieldx_t4(j,i) &
10728                        +wel_loc*gshieldx_ll(j,i)&
10729                        +wtube*gg_tube_sc(j,i)   &
10730                        +wbond_nucl*gradbx_nucl(j,i) &
10731                        +wvdwsb*gvdwsbx(j,i) &
10732                        +welsb*gelsbx(j,i) &
10733                        +wcorr_nucl*gradxorr_nucl(j,i)&
10734                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10735                        +wsbloc*gsblocx(j,i)
10736         enddo
10737       enddo
10738 #ifdef DEBUG
10739       write (iout,*) "gloc before adding corr"
10740       do i=1,4*nres
10741         write (iout,*) i,gloc(i,icg)
10742       enddo
10743 #endif
10744       do i=1,nres-3
10745         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10746          +wcorr5*g_corr5_loc(i) &
10747          +wcorr6*g_corr6_loc(i) &
10748          +wturn4*gel_loc_turn4(i) &
10749          +wturn3*gel_loc_turn3(i) &
10750          +wturn6*gel_loc_turn6(i) &
10751          +wel_loc*gel_loc_loc(i)
10752       enddo
10753 #ifdef DEBUG
10754       write (iout,*) "gloc after adding corr"
10755       do i=1,4*nres
10756         write (iout,*) i,gloc(i,icg)
10757       enddo
10758 #endif
10759 #ifdef MPI
10760       if (nfgtasks.gt.1) then
10761         do j=1,3
10762           do i=0,nres
10763             gradbufc(j,i)=gradc(j,i,icg)
10764             gradbufx(j,i)=gradx(j,i,icg)
10765           enddo
10766         enddo
10767         do i=1,4*nres
10768           glocbuf(i)=gloc(i,icg)
10769         enddo
10770 !#define DEBUG
10771 #ifdef DEBUG
10772       write (iout,*) "gloc_sc before reduce"
10773       do i=1,nres
10774        do j=1,1
10775         write (iout,*) i,j,gloc_sc(j,i,icg)
10776        enddo
10777       enddo
10778 #endif
10779 !#undef DEBUG
10780         do i=1,nres
10781          do j=1,3
10782           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10783          enddo
10784         enddo
10785         time00=MPI_Wtime()
10786         call MPI_Barrier(FG_COMM,IERR)
10787         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10788         time00=MPI_Wtime()
10789         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10790           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10791         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10792           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10793         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10794           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10795         time_reduce=time_reduce+MPI_Wtime()-time00
10796         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10797           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10798         time_reduce=time_reduce+MPI_Wtime()-time00
10799 !#define DEBUG
10800 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10801 #ifdef DEBUG
10802       write (iout,*) "gloc_sc after reduce"
10803       do i=1,nres
10804        do j=1,1
10805         write (iout,*) i,j,gloc_sc(j,i,icg)
10806        enddo
10807       enddo
10808 #endif
10809 !#undef DEBUG
10810 #ifdef DEBUG
10811       write (iout,*) "gloc after reduce"
10812       do i=1,4*nres
10813         write (iout,*) i,gloc(i,icg)
10814       enddo
10815 #endif
10816       endif
10817 #endif
10818       if (gnorm_check) then
10819 !
10820 ! Compute the maximum elements of the gradient
10821 !
10822       gvdwc_max=0.0d0
10823       gvdwc_scp_max=0.0d0
10824       gelc_max=0.0d0
10825       gvdwpp_max=0.0d0
10826       gradb_max=0.0d0
10827       ghpbc_max=0.0d0
10828       gradcorr_max=0.0d0
10829       gel_loc_max=0.0d0
10830       gcorr3_turn_max=0.0d0
10831       gcorr4_turn_max=0.0d0
10832       gradcorr5_max=0.0d0
10833       gradcorr6_max=0.0d0
10834       gcorr6_turn_max=0.0d0
10835       gsccorc_max=0.0d0
10836       gscloc_max=0.0d0
10837       gvdwx_max=0.0d0
10838       gradx_scp_max=0.0d0
10839       ghpbx_max=0.0d0
10840       gradxorr_max=0.0d0
10841       gsccorx_max=0.0d0
10842       gsclocx_max=0.0d0
10843       do i=1,nct
10844         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10845         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10846         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10847         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10848          gvdwc_scp_max=gvdwc_scp_norm
10849         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10850         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10851         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10852         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10853         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10854         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10855         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10856         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10857         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10858         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10859         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10860         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10861         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10862           gcorr3_turn(1,i)))
10863         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10864           gcorr3_turn_max=gcorr3_turn_norm
10865         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10866           gcorr4_turn(1,i)))
10867         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10868           gcorr4_turn_max=gcorr4_turn_norm
10869         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10870         if (gradcorr5_norm.gt.gradcorr5_max) &
10871           gradcorr5_max=gradcorr5_norm
10872         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10873         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10874         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10875           gcorr6_turn(1,i)))
10876         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10877           gcorr6_turn_max=gcorr6_turn_norm
10878         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10879         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10880         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10881         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10882         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10883         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10884         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10885         if (gradx_scp_norm.gt.gradx_scp_max) &
10886           gradx_scp_max=gradx_scp_norm
10887         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10888         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10889         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10890         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10891         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10892         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10893         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10894         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10895       enddo
10896       if (gradout) then
10897 #ifdef AIX
10898         open(istat,file=statname,position="append")
10899 #else
10900         open(istat,file=statname,access="append")
10901 #endif
10902         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10903            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10904            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10905            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10906            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10907            gsccorx_max,gsclocx_max
10908         close(istat)
10909         if (gvdwc_max.gt.1.0d4) then
10910           write (iout,*) "gvdwc gvdwx gradb gradbx"
10911           do i=nnt,nct
10912             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10913               gradb(j,i),gradbx(j,i),j=1,3)
10914           enddo
10915           call pdbout(0.0d0,'cipiszcze',iout)
10916           call flush(iout)
10917         endif
10918       endif
10919       endif
10920 !el#define DEBUG
10921 #ifdef DEBUG
10922       write (iout,*) "gradc gradx gloc"
10923       do i=1,nres
10924         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10925          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10926       enddo
10927 #endif
10928 !el#undef DEBUG
10929 #ifdef TIMING
10930       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10931 #endif
10932       return
10933       end subroutine sum_gradient
10934 !-----------------------------------------------------------------------------
10935       subroutine sc_grad
10936 !      implicit real*8 (a-h,o-z)
10937       use calc_data
10938 !      include 'DIMENSIONS'
10939 !      include 'COMMON.CHAIN'
10940 !      include 'COMMON.DERIV'
10941 !      include 'COMMON.CALC'
10942 !      include 'COMMON.IOUNITS'
10943       real(kind=8), dimension(3) :: dcosom1,dcosom2
10944 !      print *,"wchodze"
10945       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10946       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10947       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10948            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10949 ! diagnostics only
10950 !      eom1=0.0d0
10951 !      eom2=0.0d0
10952 !      eom12=evdwij*eps1_om12
10953 ! end diagnostics
10954 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10955 !       " sigder",sigder
10956 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10957 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10958 !C      print *,sss_ele_cut,'in sc_grad'
10959       do k=1,3
10960         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10961         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10962       enddo
10963       do k=1,3
10964         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10965 !C      print *,'gg',k,gg(k)
10966        enddo
10967 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10968 !      write (iout,*) "gg",(gg(k),k=1,3)
10969       do k=1,3
10970         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10971                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10972                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10973                   *sss_ele_cut
10974
10975         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10976                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10977                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10978                   *sss_ele_cut
10979
10980 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10981 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10982 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10983 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10984       enddo
10985 !
10986 ! Calculate the components of the gradient in DC and X
10987 !
10988 !grad      do k=i,j-1
10989 !grad        do l=1,3
10990 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10991 !grad        enddo
10992 !grad      enddo
10993       do l=1,3
10994         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10995         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10996       enddo
10997       return
10998       end subroutine sc_grad
10999 #ifdef CRYST_THETA
11000 !-----------------------------------------------------------------------------
11001       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11002
11003       use comm_calcthet
11004 !      implicit real*8 (a-h,o-z)
11005 !      include 'DIMENSIONS'
11006 !      include 'COMMON.LOCAL'
11007 !      include 'COMMON.IOUNITS'
11008 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11009 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11010 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11011       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11012       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11013 !el      integer :: it
11014 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11015 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11016 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11017 !el local variables
11018
11019       delthec=thetai-thet_pred_mean
11020       delthe0=thetai-theta0i
11021 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11022       t3 = thetai-thet_pred_mean
11023       t6 = t3**2
11024       t9 = term1
11025       t12 = t3*sigcsq
11026       t14 = t12+t6*sigsqtc
11027       t16 = 1.0d0
11028       t21 = thetai-theta0i
11029       t23 = t21**2
11030       t26 = term2
11031       t27 = t21*t26
11032       t32 = termexp
11033       t40 = t32**2
11034       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11035        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11036        *(-t12*t9-ak*sig0inv*t27)
11037       return
11038       end subroutine mixder
11039 #endif
11040 !-----------------------------------------------------------------------------
11041 ! cartder.F
11042 !-----------------------------------------------------------------------------
11043       subroutine cartder
11044 !-----------------------------------------------------------------------------
11045 ! This subroutine calculates the derivatives of the consecutive virtual
11046 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11047 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11048 ! in the angles alpha and omega, describing the location of a side chain
11049 ! in its local coordinate system.
11050 !
11051 ! The derivatives are stored in the following arrays:
11052 !
11053 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11054 ! The structure is as follows:
11055 !
11056 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11057 ! 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)
11058 !         . . . . . . . . . . . .  . . . . . .
11059 ! 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)
11060 !                          .
11061 !                          .
11062 !                          .
11063 ! 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)
11064 !
11065 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11066 ! The structure is same as above.
11067 !
11068 ! DCDS - the derivatives of the side chain vectors in the local spherical
11069 ! andgles alph and omega:
11070 !
11071 ! 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)
11072 ! 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)
11073 !                          .
11074 !                          .
11075 !                          .
11076 ! 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)
11077 !
11078 ! Version of March '95, based on an early version of November '91.
11079 !
11080 !**********************************************************************
11081 !      implicit real*8 (a-h,o-z)
11082 !      include 'DIMENSIONS'
11083 !      include 'COMMON.VAR'
11084 !      include 'COMMON.CHAIN'
11085 !      include 'COMMON.DERIV'
11086 !      include 'COMMON.GEO'
11087 !      include 'COMMON.LOCAL'
11088 !      include 'COMMON.INTERACT'
11089       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11090       real(kind=8),dimension(3,3) :: dp,temp
11091 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11092       real(kind=8),dimension(3) :: xx,xx1
11093 !el local variables
11094       integer :: i,k,l,j,m,ind,ind1,jjj
11095       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11096                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11097                  sint2,xp,yp,xxp,yyp,zzp,dj
11098
11099 !      common /przechowalnia/ fromto
11100       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11101 ! get the position of the jth ijth fragment of the chain coordinate system
11102 ! in the fromto array.
11103 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11104 !
11105 !      maxdim=(nres-1)*(nres-2)/2
11106 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11107 ! calculate the derivatives of transformation matrix elements in theta
11108 !
11109
11110 !el      call flush(iout) !el
11111       do i=1,nres-2
11112         rdt(1,1,i)=-rt(1,2,i)
11113         rdt(1,2,i)= rt(1,1,i)
11114         rdt(1,3,i)= 0.0d0
11115         rdt(2,1,i)=-rt(2,2,i)
11116         rdt(2,2,i)= rt(2,1,i)
11117         rdt(2,3,i)= 0.0d0
11118         rdt(3,1,i)=-rt(3,2,i)
11119         rdt(3,2,i)= rt(3,1,i)
11120         rdt(3,3,i)= 0.0d0
11121       enddo
11122 !
11123 ! derivatives in phi
11124 !
11125       do i=2,nres-2
11126         drt(1,1,i)= 0.0d0
11127         drt(1,2,i)= 0.0d0
11128         drt(1,3,i)= 0.0d0
11129         drt(2,1,i)= rt(3,1,i)
11130         drt(2,2,i)= rt(3,2,i)
11131         drt(2,3,i)= rt(3,3,i)
11132         drt(3,1,i)=-rt(2,1,i)
11133         drt(3,2,i)=-rt(2,2,i)
11134         drt(3,3,i)=-rt(2,3,i)
11135       enddo
11136 !
11137 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11138 !
11139       do i=2,nres-2
11140         ind=indmat(i,i+1)
11141         do k=1,3
11142           do l=1,3
11143             temp(k,l)=rt(k,l,i)
11144           enddo
11145         enddo
11146         do k=1,3
11147           do l=1,3
11148             fromto(k,l,ind)=temp(k,l)
11149           enddo
11150         enddo
11151         do j=i+1,nres-2
11152           ind=indmat(i,j+1)
11153           do k=1,3
11154             do l=1,3
11155               dpkl=0.0d0
11156               do m=1,3
11157                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11158               enddo
11159               dp(k,l)=dpkl
11160               fromto(k,l,ind)=dpkl
11161             enddo
11162           enddo
11163           do k=1,3
11164             do l=1,3
11165               temp(k,l)=dp(k,l)
11166             enddo
11167           enddo
11168         enddo
11169       enddo
11170 !
11171 ! Calculate derivatives.
11172 !
11173       ind1=0
11174       do i=1,nres-2
11175         ind1=ind1+1
11176 !
11177 ! Derivatives of DC(i+1) in theta(i+2)
11178 !
11179         do j=1,3
11180           do k=1,2
11181             dpjk=0.0D0
11182             do l=1,3
11183               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11184             enddo
11185             dp(j,k)=dpjk
11186             prordt(j,k,i)=dp(j,k)
11187           enddo
11188           dp(j,3)=0.0D0
11189           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11190         enddo
11191 !
11192 ! Derivatives of SC(i+1) in theta(i+2)
11193 !
11194         xx1(1)=-0.5D0*xloc(2,i+1)
11195         xx1(2)= 0.5D0*xloc(1,i+1)
11196         do j=1,3
11197           xj=0.0D0
11198           do k=1,2
11199             xj=xj+r(j,k,i)*xx1(k)
11200           enddo
11201           xx(j)=xj
11202         enddo
11203         do j=1,3
11204           rj=0.0D0
11205           do k=1,3
11206             rj=rj+prod(j,k,i)*xx(k)
11207           enddo
11208           dxdv(j,ind1)=rj
11209         enddo
11210 !
11211 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11212 ! than the other off-diagonal derivatives.
11213 !
11214         do j=1,3
11215           dxoiij=0.0D0
11216           do k=1,3
11217             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11218           enddo
11219           dxdv(j,ind1+1)=dxoiij
11220         enddo
11221 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11222 !
11223 ! Derivatives of DC(i+1) in phi(i+2)
11224 !
11225         do j=1,3
11226           do k=1,3
11227             dpjk=0.0
11228             do l=2,3
11229               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11230             enddo
11231             dp(j,k)=dpjk
11232             prodrt(j,k,i)=dp(j,k)
11233           enddo
11234           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11235         enddo
11236 !
11237 ! Derivatives of SC(i+1) in phi(i+2)
11238 !
11239         xx(1)= 0.0D0
11240         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11241         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11242         do j=1,3
11243           rj=0.0D0
11244           do k=2,3
11245             rj=rj+prod(j,k,i)*xx(k)
11246           enddo
11247           dxdv(j+3,ind1)=-rj
11248         enddo
11249 !
11250 ! Derivatives of SC(i+1) in phi(i+3).
11251 !
11252         do j=1,3
11253           dxoiij=0.0D0
11254           do k=1,3
11255             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11256           enddo
11257           dxdv(j+3,ind1+1)=dxoiij
11258         enddo
11259 !
11260 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11261 ! theta(nres) and phi(i+3) thru phi(nres).
11262 !
11263         do j=i+1,nres-2
11264           ind1=ind1+1
11265           ind=indmat(i+1,j+1)
11266 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11267           do k=1,3
11268             do l=1,3
11269               tempkl=0.0D0
11270               do m=1,2
11271                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11272               enddo
11273               temp(k,l)=tempkl
11274             enddo
11275           enddo
11276 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11277 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11278 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11279 ! Derivatives of virtual-bond vectors in theta
11280           do k=1,3
11281             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11282           enddo
11283 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11284 ! Derivatives of SC vectors in theta
11285           do k=1,3
11286             dxoijk=0.0D0
11287             do l=1,3
11288               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11289             enddo
11290             dxdv(k,ind1+1)=dxoijk
11291           enddo
11292 !
11293 !--- Calculate the derivatives in phi
11294 !
11295           do k=1,3
11296             do l=1,3
11297               tempkl=0.0D0
11298               do m=1,3
11299                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11300               enddo
11301               temp(k,l)=tempkl
11302             enddo
11303           enddo
11304           do k=1,3
11305             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11306           enddo
11307           do k=1,3
11308             dxoijk=0.0D0
11309             do l=1,3
11310               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11311             enddo
11312             dxdv(k+3,ind1+1)=dxoijk
11313           enddo
11314         enddo
11315       enddo
11316 !
11317 ! Derivatives in alpha and omega:
11318 !
11319       do i=2,nres-1
11320 !       dsci=dsc(itype(i,1))
11321         dsci=vbld(i+nres)
11322 #ifdef OSF
11323         alphi=alph(i)
11324         omegi=omeg(i)
11325         if(alphi.ne.alphi) alphi=100.0
11326         if(omegi.ne.omegi) omegi=-100.0
11327 #else
11328         alphi=alph(i)
11329         omegi=omeg(i)
11330 #endif
11331 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11332         cosalphi=dcos(alphi)
11333         sinalphi=dsin(alphi)
11334         cosomegi=dcos(omegi)
11335         sinomegi=dsin(omegi)
11336         temp(1,1)=-dsci*sinalphi
11337         temp(2,1)= dsci*cosalphi*cosomegi
11338         temp(3,1)=-dsci*cosalphi*sinomegi
11339         temp(1,2)=0.0D0
11340         temp(2,2)=-dsci*sinalphi*sinomegi
11341         temp(3,2)=-dsci*sinalphi*cosomegi
11342         theta2=pi-0.5D0*theta(i+1)
11343         cost2=dcos(theta2)
11344         sint2=dsin(theta2)
11345         jjj=0
11346 !d      print *,((temp(l,k),l=1,3),k=1,2)
11347         do j=1,2
11348           xp=temp(1,j)
11349           yp=temp(2,j)
11350           xxp= xp*cost2+yp*sint2
11351           yyp=-xp*sint2+yp*cost2
11352           zzp=temp(3,j)
11353           xx(1)=xxp
11354           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11355           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11356           do k=1,3
11357             dj=0.0D0
11358             do l=1,3
11359               dj=dj+prod(k,l,i-1)*xx(l)
11360             enddo
11361             dxds(jjj+k,i)=dj
11362           enddo
11363           jjj=jjj+3
11364         enddo
11365       enddo
11366       return
11367       end subroutine cartder
11368 !-----------------------------------------------------------------------------
11369 ! checkder_p.F
11370 !-----------------------------------------------------------------------------
11371       subroutine check_cartgrad
11372 ! Check the gradient of Cartesian coordinates in internal coordinates.
11373 !      implicit real*8 (a-h,o-z)
11374 !      include 'DIMENSIONS'
11375 !      include 'COMMON.IOUNITS'
11376 !      include 'COMMON.VAR'
11377 !      include 'COMMON.CHAIN'
11378 !      include 'COMMON.GEO'
11379 !      include 'COMMON.LOCAL'
11380 !      include 'COMMON.DERIV'
11381       real(kind=8),dimension(6,nres) :: temp
11382       real(kind=8),dimension(3) :: xx,gg
11383       integer :: i,k,j,ii
11384       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11385 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11386 !
11387 ! Check the gradient of the virtual-bond and SC vectors in the internal
11388 ! coordinates.
11389 !
11390       aincr=1.0d-6
11391       aincr2=5.0d-7
11392       call cartder
11393       write (iout,'(a)') '**************** dx/dalpha'
11394       write (iout,'(a)')
11395       do i=2,nres-1
11396         alphi=alph(i)
11397         alph(i)=alph(i)+aincr
11398         do k=1,3
11399           temp(k,i)=dc(k,nres+i)
11400         enddo
11401         call chainbuild
11402         do k=1,3
11403           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11404           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11405         enddo
11406         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11407         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11408         write (iout,'(a)')
11409         alph(i)=alphi
11410         call chainbuild
11411       enddo
11412       write (iout,'(a)')
11413       write (iout,'(a)') '**************** dx/domega'
11414       write (iout,'(a)')
11415       do i=2,nres-1
11416         omegi=omeg(i)
11417         omeg(i)=omeg(i)+aincr
11418         do k=1,3
11419           temp(k,i)=dc(k,nres+i)
11420         enddo
11421         call chainbuild
11422         do k=1,3
11423           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11424           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11425                 (aincr*dabs(dxds(k+3,i))+aincr))
11426         enddo
11427         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11428             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11429         write (iout,'(a)')
11430         omeg(i)=omegi
11431         call chainbuild
11432       enddo
11433       write (iout,'(a)')
11434       write (iout,'(a)') '**************** dx/dtheta'
11435       write (iout,'(a)')
11436       do i=3,nres
11437         theti=theta(i)
11438         theta(i)=theta(i)+aincr
11439         do j=i-1,nres-1
11440           do k=1,3
11441             temp(k,j)=dc(k,nres+j)
11442           enddo
11443         enddo
11444         call chainbuild
11445         do j=i-1,nres-1
11446           ii = indmat(i-2,j)
11447 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11448           do k=1,3
11449             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11450             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11451                   (aincr*dabs(dxdv(k,ii))+aincr))
11452           enddo
11453           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11454               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11455           write(iout,'(a)')
11456         enddo
11457         write (iout,'(a)')
11458         theta(i)=theti
11459         call chainbuild
11460       enddo
11461       write (iout,'(a)') '***************** dx/dphi'
11462       write (iout,'(a)')
11463       do i=4,nres
11464         phi(i)=phi(i)+aincr
11465         do j=i-1,nres-1
11466           do k=1,3
11467             temp(k,j)=dc(k,nres+j)
11468           enddo
11469         enddo
11470         call chainbuild
11471         do j=i-1,nres-1
11472           ii = indmat(i-2,j)
11473 !         print *,'ii=',ii
11474           do k=1,3
11475             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11476             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11477                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11478           enddo
11479           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11480               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11481           write(iout,'(a)')
11482         enddo
11483         phi(i)=phi(i)-aincr
11484         call chainbuild
11485       enddo
11486       write (iout,'(a)') '****************** ddc/dtheta'
11487       do i=1,nres-2
11488         thet=theta(i+2)
11489         theta(i+2)=thet+aincr
11490         do j=i,nres
11491           do k=1,3
11492             temp(k,j)=dc(k,j)
11493           enddo
11494         enddo
11495         call chainbuild
11496         do j=i+1,nres-1
11497           ii = indmat(i,j)
11498 !         print *,'ii=',ii
11499           do k=1,3
11500             gg(k)=(dc(k,j)-temp(k,j))/aincr
11501             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11502                  (aincr*dabs(dcdv(k,ii))+aincr))
11503           enddo
11504           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11505                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11506           write (iout,'(a)')
11507         enddo
11508         do j=1,nres
11509           do k=1,3
11510             dc(k,j)=temp(k,j)
11511           enddo
11512         enddo
11513         theta(i+2)=thet
11514       enddo
11515       write (iout,'(a)') '******************* ddc/dphi'
11516       do i=1,nres-3
11517         phii=phi(i+3)
11518         phi(i+3)=phii+aincr
11519         do j=1,nres
11520           do k=1,3
11521             temp(k,j)=dc(k,j)
11522           enddo
11523         enddo
11524         call chainbuild
11525         do j=i+2,nres-1
11526           ii = indmat(i+1,j)
11527 !         print *,'ii=',ii
11528           do k=1,3
11529             gg(k)=(dc(k,j)-temp(k,j))/aincr
11530             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11531                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11532           enddo
11533           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11534                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11535           write (iout,'(a)')
11536         enddo
11537         do j=1,nres
11538           do k=1,3
11539             dc(k,j)=temp(k,j)
11540           enddo
11541         enddo
11542         phi(i+3)=phii
11543       enddo
11544       return
11545       end subroutine check_cartgrad
11546 !-----------------------------------------------------------------------------
11547       subroutine check_ecart
11548 ! Check the gradient of the energy in Cartesian coordinates.
11549 !     implicit real*8 (a-h,o-z)
11550 !     include 'DIMENSIONS'
11551 !     include 'COMMON.CHAIN'
11552 !     include 'COMMON.DERIV'
11553 !     include 'COMMON.IOUNITS'
11554 !     include 'COMMON.VAR'
11555 !     include 'COMMON.CONTACTS'
11556       use comm_srutu
11557 !el      integer :: icall
11558 !el      common /srutu/ icall
11559       real(kind=8),dimension(6) :: ggg
11560       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11561       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11562       real(kind=8),dimension(6,nres) :: grad_s
11563       real(kind=8),dimension(0:n_ene) :: energia,energia1
11564       integer :: uiparm(1)
11565       real(kind=8) :: urparm(1)
11566 !EL      external fdum
11567       integer :: nf,i,j,k
11568       real(kind=8) :: aincr,etot,etot1
11569       icg=1
11570       nf=0
11571       nfl=0
11572       call zerograd
11573       aincr=1.0D-5
11574       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11575       nf=0
11576       icall=0
11577       call geom_to_var(nvar,x)
11578       call etotal(energia)
11579       etot=energia(0)
11580 !el      call enerprint(energia)
11581       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11582       icall =1
11583       do i=1,nres
11584         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11585       enddo
11586       do i=1,nres
11587         do j=1,3
11588           grad_s(j,i)=gradc(j,i,icg)
11589           grad_s(j+3,i)=gradx(j,i,icg)
11590         enddo
11591       enddo
11592       call flush(iout)
11593       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11594       do i=1,nres
11595         do j=1,3
11596           xx(j)=c(j,i+nres)
11597           ddc(j)=dc(j,i)
11598           ddx(j)=dc(j,i+nres)
11599         enddo
11600         do j=1,3
11601           dc(j,i)=dc(j,i)+aincr
11602           do k=i+1,nres
11603             c(j,k)=c(j,k)+aincr
11604             c(j,k+nres)=c(j,k+nres)+aincr
11605           enddo
11606           call etotal(energia1)
11607           etot1=energia1(0)
11608           ggg(j)=(etot1-etot)/aincr
11609           dc(j,i)=ddc(j)
11610           do k=i+1,nres
11611             c(j,k)=c(j,k)-aincr
11612             c(j,k+nres)=c(j,k+nres)-aincr
11613           enddo
11614         enddo
11615         do j=1,3
11616           c(j,i+nres)=c(j,i+nres)+aincr
11617           dc(j,i+nres)=dc(j,i+nres)+aincr
11618           call etotal(energia1)
11619           etot1=energia1(0)
11620           ggg(j+3)=(etot1-etot)/aincr
11621           c(j,i+nres)=xx(j)
11622           dc(j,i+nres)=ddx(j)
11623         enddo
11624         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11625          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11626       enddo
11627       return
11628       end subroutine check_ecart
11629 #ifdef CARGRAD
11630 !-----------------------------------------------------------------------------
11631       subroutine check_ecartint
11632 ! Check the gradient of the energy in Cartesian coordinates.
11633       use io_base, only: intout
11634 !      implicit real*8 (a-h,o-z)
11635 !      include 'DIMENSIONS'
11636 !      include 'COMMON.CONTROL'
11637 !      include 'COMMON.CHAIN'
11638 !      include 'COMMON.DERIV'
11639 !      include 'COMMON.IOUNITS'
11640 !      include 'COMMON.VAR'
11641 !      include 'COMMON.CONTACTS'
11642 !      include 'COMMON.MD'
11643 !      include 'COMMON.LOCAL'
11644 !      include 'COMMON.SPLITELE'
11645       use comm_srutu
11646 !el      integer :: icall
11647 !el      common /srutu/ icall
11648       real(kind=8),dimension(6) :: ggg,ggg1
11649       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11650       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11651       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11652       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11653       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11654       real(kind=8),dimension(0:n_ene) :: energia,energia1
11655       integer :: uiparm(1)
11656       real(kind=8) :: urparm(1)
11657 !EL      external fdum
11658       integer :: i,j,k,nf
11659       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11660                    etot21,etot22
11661       r_cut=2.0d0
11662       rlambd=0.3d0
11663       icg=1
11664       nf=0
11665       nfl=0
11666       call intout
11667 !      call intcartderiv
11668 !      call checkintcartgrad
11669       call zerograd
11670       aincr=1.0D-5
11671       write(iout,*) 'Calling CHECK_ECARTINT.'
11672       nf=0
11673       icall=0
11674       write (iout,*) "Before geom_to_var"
11675       call geom_to_var(nvar,x)
11676       write (iout,*) "after geom_to_var"
11677       write (iout,*) "split_ene ",split_ene
11678       call flush(iout)
11679       if (.not.split_ene) then
11680         write(iout,*) 'Calling CHECK_ECARTINT if'
11681         call etotal(energia)
11682 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11683         etot=energia(0)
11684         write (iout,*) "etot",etot
11685         call flush(iout)
11686 !el        call enerprint(energia)
11687 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11688         call flush(iout)
11689         write (iout,*) "enter cartgrad"
11690         call flush(iout)
11691         call cartgrad
11692 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11693         write (iout,*) "exit cartgrad"
11694         call flush(iout)
11695         icall =1
11696         do i=1,nres
11697           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11698         enddo
11699         do j=1,3
11700           grad_s(j,0)=gcart(j,0)
11701         enddo
11702 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11703         do i=1,nres
11704           do j=1,3
11705             grad_s(j,i)=gcart(j,i)
11706             grad_s(j+3,i)=gxcart(j,i)
11707           enddo
11708         enddo
11709       else
11710 write(iout,*) 'Calling CHECK_ECARTIN else.'
11711 !- split gradient check
11712         call zerograd
11713         call etotal_long(energia)
11714 !el        call enerprint(energia)
11715         call flush(iout)
11716         write (iout,*) "enter cartgrad"
11717         call flush(iout)
11718         call cartgrad
11719         write (iout,*) "exit cartgrad"
11720         call flush(iout)
11721         icall =1
11722         write (iout,*) "longrange grad"
11723         do i=1,nres
11724           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11725           (gxcart(j,i),j=1,3)
11726         enddo
11727         do j=1,3
11728           grad_s(j,0)=gcart(j,0)
11729         enddo
11730         do i=1,nres
11731           do j=1,3
11732             grad_s(j,i)=gcart(j,i)
11733             grad_s(j+3,i)=gxcart(j,i)
11734           enddo
11735         enddo
11736         call zerograd
11737         call etotal_short(energia)
11738         call enerprint(energia)
11739         call flush(iout)
11740         write (iout,*) "enter cartgrad"
11741         call flush(iout)
11742         call cartgrad
11743         write (iout,*) "exit cartgrad"
11744         call flush(iout)
11745         icall =1
11746         write (iout,*) "shortrange grad"
11747         do i=1,nres
11748           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11749           (gxcart(j,i),j=1,3)
11750         enddo
11751         do j=1,3
11752           grad_s1(j,0)=gcart(j,0)
11753         enddo
11754         do i=1,nres
11755           do j=1,3
11756             grad_s1(j,i)=gcart(j,i)
11757             grad_s1(j+3,i)=gxcart(j,i)
11758           enddo
11759         enddo
11760       endif
11761       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11762 !      do i=1,nres
11763       do i=nnt,nct
11764         do j=1,3
11765           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11766           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11767           ddc(j)=c(j,i)
11768           ddx(j)=c(j,i+nres)
11769           dcnorm_safe1(j)=dc_norm(j,i-1)
11770           dcnorm_safe2(j)=dc_norm(j,i)
11771           dxnorm_safe(j)=dc_norm(j,i+nres)
11772         enddo
11773         do j=1,3
11774           c(j,i)=ddc(j)+aincr
11775           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11776           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11777           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11778           dc(j,i)=c(j,i+1)-c(j,i)
11779           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11780           call int_from_cart1(.false.)
11781           if (.not.split_ene) then
11782             call etotal(energia1)
11783             etot1=energia1(0)
11784             write (iout,*) "ij",i,j," etot1",etot1
11785           else
11786 !- split gradient
11787             call etotal_long(energia1)
11788             etot11=energia1(0)
11789             call etotal_short(energia1)
11790             etot12=energia1(0)
11791           endif
11792 !- end split gradient
11793 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11794           c(j,i)=ddc(j)-aincr
11795           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11796           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11797           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11798           dc(j,i)=c(j,i+1)-c(j,i)
11799           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11800           call int_from_cart1(.false.)
11801           if (.not.split_ene) then
11802             call etotal(energia1)
11803             etot2=energia1(0)
11804             write (iout,*) "ij",i,j," etot2",etot2
11805             ggg(j)=(etot1-etot2)/(2*aincr)
11806           else
11807 !- split gradient
11808             call etotal_long(energia1)
11809             etot21=energia1(0)
11810             ggg(j)=(etot11-etot21)/(2*aincr)
11811             call etotal_short(energia1)
11812             etot22=energia1(0)
11813             ggg1(j)=(etot12-etot22)/(2*aincr)
11814 !- end split gradient
11815 !            write (iout,*) "etot21",etot21," etot22",etot22
11816           endif
11817 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11818           c(j,i)=ddc(j)
11819           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11820           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11821           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11822           dc(j,i)=c(j,i+1)-c(j,i)
11823           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11824           dc_norm(j,i-1)=dcnorm_safe1(j)
11825           dc_norm(j,i)=dcnorm_safe2(j)
11826           dc_norm(j,i+nres)=dxnorm_safe(j)
11827         enddo
11828         do j=1,3
11829           c(j,i+nres)=ddx(j)+aincr
11830           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11831           call int_from_cart1(.false.)
11832           if (.not.split_ene) then
11833             call etotal(energia1)
11834             etot1=energia1(0)
11835           else
11836 !- split gradient
11837             call etotal_long(energia1)
11838             etot11=energia1(0)
11839             call etotal_short(energia1)
11840             etot12=energia1(0)
11841           endif
11842 !- end split gradient
11843           c(j,i+nres)=ddx(j)-aincr
11844           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11845           call int_from_cart1(.false.)
11846           if (.not.split_ene) then
11847             call etotal(energia1)
11848             etot2=energia1(0)
11849             ggg(j+3)=(etot1-etot2)/(2*aincr)
11850           else
11851 !- split gradient
11852             call etotal_long(energia1)
11853             etot21=energia1(0)
11854             ggg(j+3)=(etot11-etot21)/(2*aincr)
11855             call etotal_short(energia1)
11856             etot22=energia1(0)
11857             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11858 !- end split gradient
11859           endif
11860 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11861           c(j,i+nres)=ddx(j)
11862           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11863           dc_norm(j,i+nres)=dxnorm_safe(j)
11864           call int_from_cart1(.false.)
11865         enddo
11866         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11867          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11868         if (split_ene) then
11869           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11870          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11871          k=1,6)
11872          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11873          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11874          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11875         endif
11876       enddo
11877       return
11878       end subroutine check_ecartint
11879 #else
11880 !-----------------------------------------------------------------------------
11881       subroutine check_ecartint
11882 ! Check the gradient of the energy in Cartesian coordinates.
11883       use io_base, only: intout
11884 !      implicit real*8 (a-h,o-z)
11885 !      include 'DIMENSIONS'
11886 !      include 'COMMON.CONTROL'
11887 !      include 'COMMON.CHAIN'
11888 !      include 'COMMON.DERIV'
11889 !      include 'COMMON.IOUNITS'
11890 !      include 'COMMON.VAR'
11891 !      include 'COMMON.CONTACTS'
11892 !      include 'COMMON.MD'
11893 !      include 'COMMON.LOCAL'
11894 !      include 'COMMON.SPLITELE'
11895       use comm_srutu
11896 !el      integer :: icall
11897 !el      common /srutu/ icall
11898       real(kind=8),dimension(6) :: ggg,ggg1
11899       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11900       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11901       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11902       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11903       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11904       real(kind=8),dimension(0:n_ene) :: energia,energia1
11905       integer :: uiparm(1)
11906       real(kind=8) :: urparm(1)
11907 !EL      external fdum
11908       integer :: i,j,k,nf
11909       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11910                    etot21,etot22
11911       r_cut=2.0d0
11912       rlambd=0.3d0
11913       icg=1
11914       nf=0
11915       nfl=0
11916       call intout
11917 !      call intcartderiv
11918 !      call checkintcartgrad
11919       call zerograd
11920       aincr=2.0D-5
11921       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11922       nf=0
11923       icall=0
11924       call geom_to_var(nvar,x)
11925       if (.not.split_ene) then
11926         call etotal(energia)
11927         etot=energia(0)
11928 !el        call enerprint(energia)
11929         call flush(iout)
11930         write (iout,*) "enter cartgrad"
11931         call flush(iout)
11932         call cartgrad
11933         write (iout,*) "exit cartgrad"
11934         call flush(iout)
11935         icall =1
11936         do i=1,nres
11937           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11938         enddo
11939         do j=1,3
11940           grad_s(j,0)=gcart(j,0)
11941         enddo
11942         do i=1,nres
11943           do j=1,3
11944             grad_s(j,i)=gcart(j,i)
11945 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
11946             grad_s(j+3,i)=gxcart(j,i)
11947           enddo
11948         enddo
11949       else
11950 !- split gradient check
11951         call zerograd
11952         call etotal_long(energia)
11953 !el        call enerprint(energia)
11954         call flush(iout)
11955         write (iout,*) "enter cartgrad"
11956         call flush(iout)
11957         call cartgrad
11958         write (iout,*) "exit cartgrad"
11959         call flush(iout)
11960         icall =1
11961         write (iout,*) "longrange grad"
11962         do i=1,nres
11963           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11964           (gxcart(j,i),j=1,3)
11965         enddo
11966         do j=1,3
11967           grad_s(j,0)=gcart(j,0)
11968         enddo
11969         do i=1,nres
11970           do j=1,3
11971             grad_s(j,i)=gcart(j,i)
11972             grad_s(j+3,i)=gxcart(j,i)
11973           enddo
11974         enddo
11975         call zerograd
11976         call etotal_short(energia)
11977 !el        call enerprint(energia)
11978         call flush(iout)
11979         write (iout,*) "enter cartgrad"
11980         call flush(iout)
11981         call cartgrad
11982         write (iout,*) "exit cartgrad"
11983         call flush(iout)
11984         icall =1
11985         write (iout,*) "shortrange grad"
11986         do i=1,nres
11987           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11988           (gxcart(j,i),j=1,3)
11989         enddo
11990         do j=1,3
11991           grad_s1(j,0)=gcart(j,0)
11992         enddo
11993         do i=1,nres
11994           do j=1,3
11995             grad_s1(j,i)=gcart(j,i)
11996             grad_s1(j+3,i)=gxcart(j,i)
11997           enddo
11998         enddo
11999       endif
12000       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12001       do i=0,nres
12002         do j=1,3
12003           xx(j)=c(j,i+nres)
12004           ddc(j)=dc(j,i)
12005           ddx(j)=dc(j,i+nres)
12006           do k=1,3
12007             dcnorm_safe(k)=dc_norm(k,i)
12008             dxnorm_safe(k)=dc_norm(k,i+nres)
12009           enddo
12010         enddo
12011         do j=1,3
12012           dc(j,i)=ddc(j)+aincr
12013           call chainbuild_cart
12014 #ifdef MPI
12015 ! Broadcast the order to compute internal coordinates to the slaves.
12016 !          if (nfgtasks.gt.1)
12017 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12018 #endif
12019 !          call int_from_cart1(.false.)
12020           if (.not.split_ene) then
12021             call etotal(energia1)
12022             etot1=energia1(0)
12023 !            call enerprint(energia1)
12024           else
12025 !- split gradient
12026             call etotal_long(energia1)
12027             etot11=energia1(0)
12028             call etotal_short(energia1)
12029             etot12=energia1(0)
12030 !            write (iout,*) "etot11",etot11," etot12",etot12
12031           endif
12032 !- end split gradient
12033 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12034           dc(j,i)=ddc(j)-aincr
12035           call chainbuild_cart
12036 !          call int_from_cart1(.false.)
12037           if (.not.split_ene) then
12038             call etotal(energia1)
12039             etot2=energia1(0)
12040             ggg(j)=(etot1-etot2)/(2*aincr)
12041           else
12042 !- split gradient
12043             call etotal_long(energia1)
12044             etot21=energia1(0)
12045             ggg(j)=(etot11-etot21)/(2*aincr)
12046             call etotal_short(energia1)
12047             etot22=energia1(0)
12048             ggg1(j)=(etot12-etot22)/(2*aincr)
12049 !- end split gradient
12050 !            write (iout,*) "etot21",etot21," etot22",etot22
12051           endif
12052 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12053           dc(j,i)=ddc(j)
12054           call chainbuild_cart
12055         enddo
12056         do j=1,3
12057           dc(j,i+nres)=ddx(j)+aincr
12058           call chainbuild_cart
12059 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12060 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12061 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12062 !          write (iout,*) "dxnormnorm",dsqrt(
12063 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12064 !          write (iout,*) "dxnormnormsafe",dsqrt(
12065 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12066 !          write (iout,*)
12067           if (.not.split_ene) then
12068             call etotal(energia1)
12069             etot1=energia1(0)
12070           else
12071 !- split gradient
12072             call etotal_long(energia1)
12073             etot11=energia1(0)
12074             call etotal_short(energia1)
12075             etot12=energia1(0)
12076           endif
12077 !- end split gradient
12078 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12079           dc(j,i+nres)=ddx(j)-aincr
12080           call chainbuild_cart
12081 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12082 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12083 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12084 !          write (iout,*)
12085 !          write (iout,*) "dxnormnorm",dsqrt(
12086 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12087 !          write (iout,*) "dxnormnormsafe",dsqrt(
12088 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12089           if (.not.split_ene) then
12090             call etotal(energia1)
12091             etot2=energia1(0)
12092             ggg(j+3)=(etot1-etot2)/(2*aincr)
12093           else
12094 !- split gradient
12095             call etotal_long(energia1)
12096             etot21=energia1(0)
12097             ggg(j+3)=(etot11-etot21)/(2*aincr)
12098             call etotal_short(energia1)
12099             etot22=energia1(0)
12100             ggg1(j+3)=(etot12-etot22)/(2*aincr)
12101 !- end split gradient
12102           endif
12103 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12104           dc(j,i+nres)=ddx(j)
12105           call chainbuild_cart
12106         enddo
12107         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12108          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12109         if (split_ene) then
12110           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12111          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12112          k=1,6)
12113          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12114          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12115          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12116         endif
12117       enddo
12118       return
12119       end subroutine check_ecartint
12120 #endif
12121 !-----------------------------------------------------------------------------
12122       subroutine check_eint
12123 ! Check the gradient of energy in internal coordinates.
12124 !      implicit real*8 (a-h,o-z)
12125 !      include 'DIMENSIONS'
12126 !      include 'COMMON.CHAIN'
12127 !      include 'COMMON.DERIV'
12128 !      include 'COMMON.IOUNITS'
12129 !      include 'COMMON.VAR'
12130 !      include 'COMMON.GEO'
12131       use comm_srutu
12132 !el      integer :: icall
12133 !el      common /srutu/ icall
12134       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12135       integer :: uiparm(1)
12136       real(kind=8) :: urparm(1)
12137       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12138       character(len=6) :: key
12139 !EL      external fdum
12140       integer :: i,ii,nf
12141       real(kind=8) :: xi,aincr,etot,etot1,etot2
12142       call zerograd
12143       aincr=1.0D-7
12144       print '(a)','Calling CHECK_INT.'
12145       nf=0
12146       nfl=0
12147       icg=1
12148       call geom_to_var(nvar,x)
12149       call var_to_geom(nvar,x)
12150       call chainbuild
12151       icall=1
12152 !      print *,'ICG=',ICG
12153       call etotal(energia)
12154       etot = energia(0)
12155 !el      call enerprint(energia)
12156 !      print *,'ICG=',ICG
12157 #ifdef MPL
12158       if (MyID.ne.BossID) then
12159         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12160         nf=x(nvar+1)
12161         nfl=x(nvar+2)
12162         icg=x(nvar+3)
12163       endif
12164 #endif
12165       nf=1
12166       nfl=3
12167 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12168       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12169 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12170       icall=1
12171       do i=1,nvar
12172         xi=x(i)
12173         x(i)=xi-0.5D0*aincr
12174         call var_to_geom(nvar,x)
12175         call chainbuild
12176         call etotal(energia1)
12177         etot1=energia1(0)
12178         x(i)=xi+0.5D0*aincr
12179         call var_to_geom(nvar,x)
12180         call chainbuild
12181         call etotal(energia2)
12182         etot2=energia2(0)
12183         gg(i)=(etot2-etot1)/aincr
12184         write (iout,*) i,etot1,etot2
12185         x(i)=xi
12186       enddo
12187       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12188           '     RelDiff*100% '
12189       do i=1,nvar
12190         if (i.le.nphi) then
12191           ii=i
12192           key = ' phi'
12193         else if (i.le.nphi+ntheta) then
12194           ii=i-nphi
12195           key=' theta'
12196         else if (i.le.nphi+ntheta+nside) then
12197            ii=i-(nphi+ntheta)
12198            key=' alpha'
12199         else
12200            ii=i-(nphi+ntheta+nside)
12201            key=' omega'
12202         endif
12203         write (iout,'(i3,a,i3,3(1pd16.6))') &
12204        i,key,ii,gg(i),gana(i),&
12205        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12206       enddo
12207       return
12208       end subroutine check_eint
12209 !-----------------------------------------------------------------------------
12210 ! econstr_local.F
12211 !-----------------------------------------------------------------------------
12212       subroutine Econstr_back
12213 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12214 !      implicit real*8 (a-h,o-z)
12215 !      include 'DIMENSIONS'
12216 !      include 'COMMON.CONTROL'
12217 !      include 'COMMON.VAR'
12218 !      include 'COMMON.MD'
12219       use MD_data
12220 !#ifndef LANG0
12221 !      include 'COMMON.LANGEVIN'
12222 !#else
12223 !      include 'COMMON.LANGEVIN.lang0'
12224 !#endif
12225 !      include 'COMMON.CHAIN'
12226 !      include 'COMMON.DERIV'
12227 !      include 'COMMON.GEO'
12228 !      include 'COMMON.LOCAL'
12229 !      include 'COMMON.INTERACT'
12230 !      include 'COMMON.IOUNITS'
12231 !      include 'COMMON.NAMES'
12232 !      include 'COMMON.TIME1'
12233       integer :: i,j,ii,k
12234       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12235
12236       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12237       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12238       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12239
12240       Uconst_back=0.0d0
12241       do i=1,nres
12242         dutheta(i)=0.0d0
12243         dugamma(i)=0.0d0
12244         do j=1,3
12245           duscdiff(j,i)=0.0d0
12246           duscdiffx(j,i)=0.0d0
12247         enddo
12248       enddo
12249       do i=1,nfrag_back
12250         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12251 !
12252 ! Deviations from theta angles
12253 !
12254         utheta_i=0.0d0
12255         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12256           dtheta_i=theta(j)-thetaref(j)
12257           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12258           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12259         enddo
12260         utheta(i)=utheta_i/(ii-1)
12261 !
12262 ! Deviations from gamma angles
12263 !
12264         ugamma_i=0.0d0
12265         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12266           dgamma_i=pinorm(phi(j)-phiref(j))
12267 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12268           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12269           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12270 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12271         enddo
12272         ugamma(i)=ugamma_i/(ii-2)
12273 !
12274 ! Deviations from local SC geometry
12275 !
12276         uscdiff(i)=0.0d0
12277         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12278           dxx=xxtab(j)-xxref(j)
12279           dyy=yytab(j)-yyref(j)
12280           dzz=zztab(j)-zzref(j)
12281           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12282           do k=1,3
12283             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12284              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12285              (ii-1)
12286             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12287              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12288              (ii-1)
12289             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12290            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12291             /(ii-1)
12292           enddo
12293 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12294 !     &      xxref(j),yyref(j),zzref(j)
12295         enddo
12296         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12297 !        write (iout,*) i," uscdiff",uscdiff(i)
12298 !
12299 ! Put together deviations from local geometry
12300 !
12301         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12302           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12303 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12304 !     &   " uconst_back",uconst_back
12305         utheta(i)=dsqrt(utheta(i))
12306         ugamma(i)=dsqrt(ugamma(i))
12307         uscdiff(i)=dsqrt(uscdiff(i))
12308       enddo
12309       return
12310       end subroutine Econstr_back
12311 !-----------------------------------------------------------------------------
12312 ! energy_p_new-sep_barrier.F
12313 !-----------------------------------------------------------------------------
12314       real(kind=8) function sscale(r)
12315 !      include "COMMON.SPLITELE"
12316       real(kind=8) :: r,gamm
12317       if(r.lt.r_cut-rlamb) then
12318         sscale=1.0d0
12319       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12320         gamm=(r-(r_cut-rlamb))/rlamb
12321         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12322       else
12323         sscale=0d0
12324       endif
12325       return
12326       end function sscale
12327       real(kind=8) function sscale_grad(r)
12328 !      include "COMMON.SPLITELE"
12329       real(kind=8) :: r,gamm
12330       if(r.lt.r_cut-rlamb) then
12331         sscale_grad=0.0d0
12332       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12333         gamm=(r-(r_cut-rlamb))/rlamb
12334         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12335       else
12336         sscale_grad=0d0
12337       endif
12338       return
12339       end function sscale_grad
12340
12341 !!!!!!!!!! PBCSCALE
12342       real(kind=8) function sscale_ele(r)
12343 !      include "COMMON.SPLITELE"
12344       real(kind=8) :: r,gamm
12345       if(r.lt.r_cut_ele-rlamb_ele) then
12346         sscale_ele=1.0d0
12347       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12348         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12349         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12350       else
12351         sscale_ele=0d0
12352       endif
12353       return
12354       end function sscale_ele
12355
12356       real(kind=8)  function sscagrad_ele(r)
12357       real(kind=8) :: r,gamm
12358 !      include "COMMON.SPLITELE"
12359       if(r.lt.r_cut_ele-rlamb_ele) then
12360         sscagrad_ele=0.0d0
12361       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12362         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12363         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12364       else
12365         sscagrad_ele=0.0d0
12366       endif
12367       return
12368       end function sscagrad_ele
12369       real(kind=8) function sscalelip(r)
12370       real(kind=8) r,gamm
12371         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12372       return
12373       end function sscalelip
12374 !C-----------------------------------------------------------------------
12375       real(kind=8) function sscagradlip(r)
12376       real(kind=8) r,gamm
12377         sscagradlip=r*(6.0d0*r-6.0d0)
12378       return
12379       end function sscagradlip
12380
12381 !!!!!!!!!!!!!!!
12382 !-----------------------------------------------------------------------------
12383       subroutine elj_long(evdw)
12384 !
12385 ! This subroutine calculates the interaction energy of nonbonded side chains
12386 ! assuming the LJ potential of interaction.
12387 !
12388 !      implicit real*8 (a-h,o-z)
12389 !      include 'DIMENSIONS'
12390 !      include 'COMMON.GEO'
12391 !      include 'COMMON.VAR'
12392 !      include 'COMMON.LOCAL'
12393 !      include 'COMMON.CHAIN'
12394 !      include 'COMMON.DERIV'
12395 !      include 'COMMON.INTERACT'
12396 !      include 'COMMON.TORSION'
12397 !      include 'COMMON.SBRIDGE'
12398 !      include 'COMMON.NAMES'
12399 !      include 'COMMON.IOUNITS'
12400 !      include 'COMMON.CONTACTS'
12401       real(kind=8),parameter :: accur=1.0d-10
12402       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12403 !el local variables
12404       integer :: i,iint,j,k,itypi,itypi1,itypj
12405       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12406       real(kind=8) :: e1,e2,evdwij,evdw
12407 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12408       evdw=0.0D0
12409       do i=iatsc_s,iatsc_e
12410         itypi=itype(i,1)
12411         if (itypi.eq.ntyp1) cycle
12412         itypi1=itype(i+1,1)
12413         xi=c(1,nres+i)
12414         yi=c(2,nres+i)
12415         zi=c(3,nres+i)
12416 !
12417 ! Calculate SC interaction energy.
12418 !
12419         do iint=1,nint_gr(i)
12420 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12421 !d   &                  'iend=',iend(i,iint)
12422           do j=istart(i,iint),iend(i,iint)
12423             itypj=itype(j,1)
12424             if (itypj.eq.ntyp1) cycle
12425             xj=c(1,nres+j)-xi
12426             yj=c(2,nres+j)-yi
12427             zj=c(3,nres+j)-zi
12428             rij=xj*xj+yj*yj+zj*zj
12429             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12430             if (sss.lt.1.0d0) then
12431               rrij=1.0D0/rij
12432               eps0ij=eps(itypi,itypj)
12433               fac=rrij**expon2
12434               e1=fac*fac*aa_aq(itypi,itypj)
12435               e2=fac*bb_aq(itypi,itypj)
12436               evdwij=e1+e2
12437               evdw=evdw+(1.0d0-sss)*evdwij
12438 !
12439 ! Calculate the components of the gradient in DC and X
12440 !
12441               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12442               gg(1)=xj*fac
12443               gg(2)=yj*fac
12444               gg(3)=zj*fac
12445               do k=1,3
12446                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12447                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12448                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12449                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12450               enddo
12451             endif
12452           enddo      ! j
12453         enddo        ! iint
12454       enddo          ! i
12455       do i=1,nct
12456         do j=1,3
12457           gvdwc(j,i)=expon*gvdwc(j,i)
12458           gvdwx(j,i)=expon*gvdwx(j,i)
12459         enddo
12460       enddo
12461 !******************************************************************************
12462 !
12463 !                              N O T E !!!
12464 !
12465 ! To save time, the factor of EXPON has been extracted from ALL components
12466 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12467 ! use!
12468 !
12469 !******************************************************************************
12470       return
12471       end subroutine elj_long
12472 !-----------------------------------------------------------------------------
12473       subroutine elj_short(evdw)
12474 !
12475 ! This subroutine calculates the interaction energy of nonbonded side chains
12476 ! assuming the LJ potential of interaction.
12477 !
12478 !      implicit real*8 (a-h,o-z)
12479 !      include 'DIMENSIONS'
12480 !      include 'COMMON.GEO'
12481 !      include 'COMMON.VAR'
12482 !      include 'COMMON.LOCAL'
12483 !      include 'COMMON.CHAIN'
12484 !      include 'COMMON.DERIV'
12485 !      include 'COMMON.INTERACT'
12486 !      include 'COMMON.TORSION'
12487 !      include 'COMMON.SBRIDGE'
12488 !      include 'COMMON.NAMES'
12489 !      include 'COMMON.IOUNITS'
12490 !      include 'COMMON.CONTACTS'
12491       real(kind=8),parameter :: accur=1.0d-10
12492       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12493 !el local variables
12494       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12495       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12496       real(kind=8) :: e1,e2,evdwij,evdw
12497 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12498       evdw=0.0D0
12499       do i=iatsc_s,iatsc_e
12500         itypi=itype(i,1)
12501         if (itypi.eq.ntyp1) cycle
12502         itypi1=itype(i+1,1)
12503         xi=c(1,nres+i)
12504         yi=c(2,nres+i)
12505         zi=c(3,nres+i)
12506 ! Change 12/1/95
12507         num_conti=0
12508 !
12509 ! Calculate SC interaction energy.
12510 !
12511         do iint=1,nint_gr(i)
12512 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12513 !d   &                  'iend=',iend(i,iint)
12514           do j=istart(i,iint),iend(i,iint)
12515             itypj=itype(j,1)
12516             if (itypj.eq.ntyp1) cycle
12517             xj=c(1,nres+j)-xi
12518             yj=c(2,nres+j)-yi
12519             zj=c(3,nres+j)-zi
12520 ! Change 12/1/95 to calculate four-body interactions
12521             rij=xj*xj+yj*yj+zj*zj
12522             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12523             if (sss.gt.0.0d0) then
12524               rrij=1.0D0/rij
12525               eps0ij=eps(itypi,itypj)
12526               fac=rrij**expon2
12527               e1=fac*fac*aa_aq(itypi,itypj)
12528               e2=fac*bb_aq(itypi,itypj)
12529               evdwij=e1+e2
12530               evdw=evdw+sss*evdwij
12531 !
12532 ! Calculate the components of the gradient in DC and X
12533 !
12534               fac=-rrij*(e1+evdwij)*sss
12535               gg(1)=xj*fac
12536               gg(2)=yj*fac
12537               gg(3)=zj*fac
12538               do k=1,3
12539                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12540                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12541                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12542                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12543               enddo
12544             endif
12545           enddo      ! j
12546         enddo        ! iint
12547       enddo          ! i
12548       do i=1,nct
12549         do j=1,3
12550           gvdwc(j,i)=expon*gvdwc(j,i)
12551           gvdwx(j,i)=expon*gvdwx(j,i)
12552         enddo
12553       enddo
12554 !******************************************************************************
12555 !
12556 !                              N O T E !!!
12557 !
12558 ! To save time, the factor of EXPON has been extracted from ALL components
12559 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12560 ! use!
12561 !
12562 !******************************************************************************
12563       return
12564       end subroutine elj_short
12565 !-----------------------------------------------------------------------------
12566       subroutine eljk_long(evdw)
12567 !
12568 ! This subroutine calculates the interaction energy of nonbonded side chains
12569 ! assuming the LJK potential of interaction.
12570 !
12571 !      implicit real*8 (a-h,o-z)
12572 !      include 'DIMENSIONS'
12573 !      include 'COMMON.GEO'
12574 !      include 'COMMON.VAR'
12575 !      include 'COMMON.LOCAL'
12576 !      include 'COMMON.CHAIN'
12577 !      include 'COMMON.DERIV'
12578 !      include 'COMMON.INTERACT'
12579 !      include 'COMMON.IOUNITS'
12580 !      include 'COMMON.NAMES'
12581       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12582       logical :: scheck
12583 !el local variables
12584       integer :: i,iint,j,k,itypi,itypi1,itypj
12585       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12586                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12587 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12588       evdw=0.0D0
12589       do i=iatsc_s,iatsc_e
12590         itypi=itype(i,1)
12591         if (itypi.eq.ntyp1) cycle
12592         itypi1=itype(i+1,1)
12593         xi=c(1,nres+i)
12594         yi=c(2,nres+i)
12595         zi=c(3,nres+i)
12596 !
12597 ! Calculate SC interaction energy.
12598 !
12599         do iint=1,nint_gr(i)
12600           do j=istart(i,iint),iend(i,iint)
12601             itypj=itype(j,1)
12602             if (itypj.eq.ntyp1) cycle
12603             xj=c(1,nres+j)-xi
12604             yj=c(2,nres+j)-yi
12605             zj=c(3,nres+j)-zi
12606             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12607             fac_augm=rrij**expon
12608             e_augm=augm(itypi,itypj)*fac_augm
12609             r_inv_ij=dsqrt(rrij)
12610             rij=1.0D0/r_inv_ij
12611             sss=sscale(rij/sigma(itypi,itypj))
12612             if (sss.lt.1.0d0) then
12613               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12614               fac=r_shift_inv**expon
12615               e1=fac*fac*aa_aq(itypi,itypj)
12616               e2=fac*bb_aq(itypi,itypj)
12617               evdwij=e_augm+e1+e2
12618 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12619 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12620 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12621 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12622 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12623 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12624 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12625               evdw=evdw+(1.0d0-sss)*evdwij
12626 !
12627 ! Calculate the components of the gradient in DC and X
12628 !
12629               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12630               fac=fac*(1.0d0-sss)
12631               gg(1)=xj*fac
12632               gg(2)=yj*fac
12633               gg(3)=zj*fac
12634               do k=1,3
12635                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12636                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12637                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12638                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12639               enddo
12640             endif
12641           enddo      ! j
12642         enddo        ! iint
12643       enddo          ! i
12644       do i=1,nct
12645         do j=1,3
12646           gvdwc(j,i)=expon*gvdwc(j,i)
12647           gvdwx(j,i)=expon*gvdwx(j,i)
12648         enddo
12649       enddo
12650       return
12651       end subroutine eljk_long
12652 !-----------------------------------------------------------------------------
12653       subroutine eljk_short(evdw)
12654 !
12655 ! This subroutine calculates the interaction energy of nonbonded side chains
12656 ! assuming the LJK potential of interaction.
12657 !
12658 !      implicit real*8 (a-h,o-z)
12659 !      include 'DIMENSIONS'
12660 !      include 'COMMON.GEO'
12661 !      include 'COMMON.VAR'
12662 !      include 'COMMON.LOCAL'
12663 !      include 'COMMON.CHAIN'
12664 !      include 'COMMON.DERIV'
12665 !      include 'COMMON.INTERACT'
12666 !      include 'COMMON.IOUNITS'
12667 !      include 'COMMON.NAMES'
12668       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12669       logical :: scheck
12670 !el local variables
12671       integer :: i,iint,j,k,itypi,itypi1,itypj
12672       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12673                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12674 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12675       evdw=0.0D0
12676       do i=iatsc_s,iatsc_e
12677         itypi=itype(i,1)
12678         if (itypi.eq.ntyp1) cycle
12679         itypi1=itype(i+1,1)
12680         xi=c(1,nres+i)
12681         yi=c(2,nres+i)
12682         zi=c(3,nres+i)
12683 !
12684 ! Calculate SC interaction energy.
12685 !
12686         do iint=1,nint_gr(i)
12687           do j=istart(i,iint),iend(i,iint)
12688             itypj=itype(j,1)
12689             if (itypj.eq.ntyp1) cycle
12690             xj=c(1,nres+j)-xi
12691             yj=c(2,nres+j)-yi
12692             zj=c(3,nres+j)-zi
12693             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12694             fac_augm=rrij**expon
12695             e_augm=augm(itypi,itypj)*fac_augm
12696             r_inv_ij=dsqrt(rrij)
12697             rij=1.0D0/r_inv_ij
12698             sss=sscale(rij/sigma(itypi,itypj))
12699             if (sss.gt.0.0d0) then
12700               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12701               fac=r_shift_inv**expon
12702               e1=fac*fac*aa_aq(itypi,itypj)
12703               e2=fac*bb_aq(itypi,itypj)
12704               evdwij=e_augm+e1+e2
12705 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12706 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12707 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12708 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12709 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12710 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12711 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12712               evdw=evdw+sss*evdwij
12713 !
12714 ! Calculate the components of the gradient in DC and X
12715 !
12716               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12717               fac=fac*sss
12718               gg(1)=xj*fac
12719               gg(2)=yj*fac
12720               gg(3)=zj*fac
12721               do k=1,3
12722                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12723                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12724                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12725                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12726               enddo
12727             endif
12728           enddo      ! j
12729         enddo        ! iint
12730       enddo          ! i
12731       do i=1,nct
12732         do j=1,3
12733           gvdwc(j,i)=expon*gvdwc(j,i)
12734           gvdwx(j,i)=expon*gvdwx(j,i)
12735         enddo
12736       enddo
12737       return
12738       end subroutine eljk_short
12739 !-----------------------------------------------------------------------------
12740       subroutine ebp_long(evdw)
12741 !
12742 ! This subroutine calculates the interaction energy of nonbonded side chains
12743 ! assuming the Berne-Pechukas potential of interaction.
12744 !
12745       use calc_data
12746 !      implicit real*8 (a-h,o-z)
12747 !      include 'DIMENSIONS'
12748 !      include 'COMMON.GEO'
12749 !      include 'COMMON.VAR'
12750 !      include 'COMMON.LOCAL'
12751 !      include 'COMMON.CHAIN'
12752 !      include 'COMMON.DERIV'
12753 !      include 'COMMON.NAMES'
12754 !      include 'COMMON.INTERACT'
12755 !      include 'COMMON.IOUNITS'
12756 !      include 'COMMON.CALC'
12757       use comm_srutu
12758 !el      integer :: icall
12759 !el      common /srutu/ icall
12760 !     double precision rrsave(maxdim)
12761       logical :: lprn
12762 !el local variables
12763       integer :: iint,itypi,itypi1,itypj
12764       real(kind=8) :: rrij,xi,yi,zi,fac
12765       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12766       evdw=0.0D0
12767 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12768       evdw=0.0D0
12769 !     if (icall.eq.0) then
12770 !       lprn=.true.
12771 !     else
12772         lprn=.false.
12773 !     endif
12774 !el      ind=0
12775       do i=iatsc_s,iatsc_e
12776         itypi=itype(i,1)
12777         if (itypi.eq.ntyp1) cycle
12778         itypi1=itype(i+1,1)
12779         xi=c(1,nres+i)
12780         yi=c(2,nres+i)
12781         zi=c(3,nres+i)
12782         dxi=dc_norm(1,nres+i)
12783         dyi=dc_norm(2,nres+i)
12784         dzi=dc_norm(3,nres+i)
12785 !        dsci_inv=dsc_inv(itypi)
12786         dsci_inv=vbld_inv(i+nres)
12787 !
12788 ! Calculate SC interaction energy.
12789 !
12790         do iint=1,nint_gr(i)
12791           do j=istart(i,iint),iend(i,iint)
12792 !el            ind=ind+1
12793             itypj=itype(j,1)
12794             if (itypj.eq.ntyp1) cycle
12795 !            dscj_inv=dsc_inv(itypj)
12796             dscj_inv=vbld_inv(j+nres)
12797             chi1=chi(itypi,itypj)
12798             chi2=chi(itypj,itypi)
12799             chi12=chi1*chi2
12800             chip1=chip(itypi)
12801             chip2=chip(itypj)
12802             chip12=chip1*chip2
12803             alf1=alp(itypi)
12804             alf2=alp(itypj)
12805             alf12=0.5D0*(alf1+alf2)
12806             xj=c(1,nres+j)-xi
12807             yj=c(2,nres+j)-yi
12808             zj=c(3,nres+j)-zi
12809             dxj=dc_norm(1,nres+j)
12810             dyj=dc_norm(2,nres+j)
12811             dzj=dc_norm(3,nres+j)
12812             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12813             rij=dsqrt(rrij)
12814             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12815
12816             if (sss.lt.1.0d0) then
12817
12818 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12819               call sc_angular
12820 ! Calculate whole angle-dependent part of epsilon and contributions
12821 ! to its derivatives
12822               fac=(rrij*sigsq)**expon2
12823               e1=fac*fac*aa_aq(itypi,itypj)
12824               e2=fac*bb_aq(itypi,itypj)
12825               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12826               eps2der=evdwij*eps3rt
12827               eps3der=evdwij*eps2rt
12828               evdwij=evdwij*eps2rt*eps3rt
12829               evdw=evdw+evdwij*(1.0d0-sss)
12830               if (lprn) then
12831               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12832               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12833 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12834 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12835 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12836 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12837 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12838 !d     &          evdwij
12839               endif
12840 ! Calculate gradient components.
12841               e1=e1*eps1*eps2rt**2*eps3rt**2
12842               fac=-expon*(e1+evdwij)
12843               sigder=fac/sigsq
12844               fac=rrij*fac
12845 ! Calculate radial part of the gradient
12846               gg(1)=xj*fac
12847               gg(2)=yj*fac
12848               gg(3)=zj*fac
12849 ! Calculate the angular part of the gradient and sum add the contributions
12850 ! to the appropriate components of the Cartesian gradient.
12851               call sc_grad_scale(1.0d0-sss)
12852             endif
12853           enddo      ! j
12854         enddo        ! iint
12855       enddo          ! i
12856 !     stop
12857       return
12858       end subroutine ebp_long
12859 !-----------------------------------------------------------------------------
12860       subroutine ebp_short(evdw)
12861 !
12862 ! This subroutine calculates the interaction energy of nonbonded side chains
12863 ! assuming the Berne-Pechukas potential of interaction.
12864 !
12865       use calc_data
12866 !      implicit real*8 (a-h,o-z)
12867 !      include 'DIMENSIONS'
12868 !      include 'COMMON.GEO'
12869 !      include 'COMMON.VAR'
12870 !      include 'COMMON.LOCAL'
12871 !      include 'COMMON.CHAIN'
12872 !      include 'COMMON.DERIV'
12873 !      include 'COMMON.NAMES'
12874 !      include 'COMMON.INTERACT'
12875 !      include 'COMMON.IOUNITS'
12876 !      include 'COMMON.CALC'
12877       use comm_srutu
12878 !el      integer :: icall
12879 !el      common /srutu/ icall
12880 !     double precision rrsave(maxdim)
12881       logical :: lprn
12882 !el local variables
12883       integer :: iint,itypi,itypi1,itypj
12884       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12885       real(kind=8) :: sss,e1,e2,evdw
12886       evdw=0.0D0
12887 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12888       evdw=0.0D0
12889 !     if (icall.eq.0) then
12890 !       lprn=.true.
12891 !     else
12892         lprn=.false.
12893 !     endif
12894 !el      ind=0
12895       do i=iatsc_s,iatsc_e
12896         itypi=itype(i,1)
12897         if (itypi.eq.ntyp1) cycle
12898         itypi1=itype(i+1,1)
12899         xi=c(1,nres+i)
12900         yi=c(2,nres+i)
12901         zi=c(3,nres+i)
12902         dxi=dc_norm(1,nres+i)
12903         dyi=dc_norm(2,nres+i)
12904         dzi=dc_norm(3,nres+i)
12905 !        dsci_inv=dsc_inv(itypi)
12906         dsci_inv=vbld_inv(i+nres)
12907 !
12908 ! Calculate SC interaction energy.
12909 !
12910         do iint=1,nint_gr(i)
12911           do j=istart(i,iint),iend(i,iint)
12912 !el            ind=ind+1
12913             itypj=itype(j,1)
12914             if (itypj.eq.ntyp1) cycle
12915 !            dscj_inv=dsc_inv(itypj)
12916             dscj_inv=vbld_inv(j+nres)
12917             chi1=chi(itypi,itypj)
12918             chi2=chi(itypj,itypi)
12919             chi12=chi1*chi2
12920             chip1=chip(itypi)
12921             chip2=chip(itypj)
12922             chip12=chip1*chip2
12923             alf1=alp(itypi)
12924             alf2=alp(itypj)
12925             alf12=0.5D0*(alf1+alf2)
12926             xj=c(1,nres+j)-xi
12927             yj=c(2,nres+j)-yi
12928             zj=c(3,nres+j)-zi
12929             dxj=dc_norm(1,nres+j)
12930             dyj=dc_norm(2,nres+j)
12931             dzj=dc_norm(3,nres+j)
12932             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12933             rij=dsqrt(rrij)
12934             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12935
12936             if (sss.gt.0.0d0) then
12937
12938 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12939               call sc_angular
12940 ! Calculate whole angle-dependent part of epsilon and contributions
12941 ! to its derivatives
12942               fac=(rrij*sigsq)**expon2
12943               e1=fac*fac*aa_aq(itypi,itypj)
12944               e2=fac*bb_aq(itypi,itypj)
12945               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12946               eps2der=evdwij*eps3rt
12947               eps3der=evdwij*eps2rt
12948               evdwij=evdwij*eps2rt*eps3rt
12949               evdw=evdw+evdwij*sss
12950               if (lprn) then
12951               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12952               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12953 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12954 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12955 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12956 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12957 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12958 !d     &          evdwij
12959               endif
12960 ! Calculate gradient components.
12961               e1=e1*eps1*eps2rt**2*eps3rt**2
12962               fac=-expon*(e1+evdwij)
12963               sigder=fac/sigsq
12964               fac=rrij*fac
12965 ! Calculate radial part of the gradient
12966               gg(1)=xj*fac
12967               gg(2)=yj*fac
12968               gg(3)=zj*fac
12969 ! Calculate the angular part of the gradient and sum add the contributions
12970 ! to the appropriate components of the Cartesian gradient.
12971               call sc_grad_scale(sss)
12972             endif
12973           enddo      ! j
12974         enddo        ! iint
12975       enddo          ! i
12976 !     stop
12977       return
12978       end subroutine ebp_short
12979 !-----------------------------------------------------------------------------
12980       subroutine egb_long(evdw)
12981 !
12982 ! This subroutine calculates the interaction energy of nonbonded side chains
12983 ! assuming the Gay-Berne potential of interaction.
12984 !
12985       use calc_data
12986 !      implicit real*8 (a-h,o-z)
12987 !      include 'DIMENSIONS'
12988 !      include 'COMMON.GEO'
12989 !      include 'COMMON.VAR'
12990 !      include 'COMMON.LOCAL'
12991 !      include 'COMMON.CHAIN'
12992 !      include 'COMMON.DERIV'
12993 !      include 'COMMON.NAMES'
12994 !      include 'COMMON.INTERACT'
12995 !      include 'COMMON.IOUNITS'
12996 !      include 'COMMON.CALC'
12997 !      include 'COMMON.CONTROL'
12998       logical :: lprn
12999 !el local variables
13000       integer :: iint,itypi,itypi1,itypj,subchap
13001       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13002       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13003       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13004                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13005                     ssgradlipi,ssgradlipj
13006
13007
13008       evdw=0.0D0
13009 !cccc      energy_dec=.false.
13010 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13011       evdw=0.0D0
13012       lprn=.false.
13013 !     if (icall.eq.0) lprn=.false.
13014 !el      ind=0
13015       do i=iatsc_s,iatsc_e
13016         itypi=itype(i,1)
13017         if (itypi.eq.ntyp1) cycle
13018         itypi1=itype(i+1,1)
13019         xi=c(1,nres+i)
13020         yi=c(2,nres+i)
13021         zi=c(3,nres+i)
13022           xi=mod(xi,boxxsize)
13023           if (xi.lt.0) xi=xi+boxxsize
13024           yi=mod(yi,boxysize)
13025           if (yi.lt.0) yi=yi+boxysize
13026           zi=mod(zi,boxzsize)
13027           if (zi.lt.0) zi=zi+boxzsize
13028        if ((zi.gt.bordlipbot)    &
13029         .and.(zi.lt.bordliptop)) then
13030 !C the energy transfer exist
13031         if (zi.lt.buflipbot) then
13032 !C what fraction I am in
13033          fracinbuf=1.0d0-    &
13034              ((zi-bordlipbot)/lipbufthick)
13035 !C lipbufthick is thickenes of lipid buffore
13036          sslipi=sscalelip(fracinbuf)
13037          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13038         elseif (zi.gt.bufliptop) then
13039          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13040          sslipi=sscalelip(fracinbuf)
13041          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13042         else
13043          sslipi=1.0d0
13044          ssgradlipi=0.0
13045         endif
13046        else
13047          sslipi=0.0d0
13048          ssgradlipi=0.0
13049        endif
13050
13051         dxi=dc_norm(1,nres+i)
13052         dyi=dc_norm(2,nres+i)
13053         dzi=dc_norm(3,nres+i)
13054 !        dsci_inv=dsc_inv(itypi)
13055         dsci_inv=vbld_inv(i+nres)
13056 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13057 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13058 !
13059 ! Calculate SC interaction energy.
13060 !
13061         do iint=1,nint_gr(i)
13062           do j=istart(i,iint),iend(i,iint)
13063             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13064 !              call dyn_ssbond_ene(i,j,evdwij)
13065 !              evdw=evdw+evdwij
13066 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13067 !                              'evdw',i,j,evdwij,' ss'
13068 !              if (energy_dec) write (iout,*) &
13069 !                              'evdw',i,j,evdwij,' ss'
13070 !             do k=j+1,iend(i,iint)
13071 !C search over all next residues
13072 !              if (dyn_ss_mask(k)) then
13073 !C check if they are cysteins
13074 !C              write(iout,*) 'k=',k
13075
13076 !c              write(iout,*) "PRZED TRI", evdwij
13077 !               evdwij_przed_tri=evdwij
13078 !              call triple_ssbond_ene(i,j,k,evdwij)
13079 !c               if(evdwij_przed_tri.ne.evdwij) then
13080 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13081 !c               endif
13082
13083 !c              write(iout,*) "PO TRI", evdwij
13084 !C call the energy function that removes the artifical triple disulfide
13085 !C bond the soubroutine is located in ssMD.F
13086 !              evdw=evdw+evdwij
13087               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13088                             'evdw',i,j,evdwij,'tss'
13089 !              endif!dyn_ss_mask(k)
13090 !             enddo! k
13091
13092             ELSE
13093 !el            ind=ind+1
13094             itypj=itype(j,1)
13095             if (itypj.eq.ntyp1) cycle
13096 !            dscj_inv=dsc_inv(itypj)
13097             dscj_inv=vbld_inv(j+nres)
13098 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13099 !     &       1.0d0/vbld(j+nres)
13100 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13101             sig0ij=sigma(itypi,itypj)
13102             chi1=chi(itypi,itypj)
13103             chi2=chi(itypj,itypi)
13104             chi12=chi1*chi2
13105             chip1=chip(itypi)
13106             chip2=chip(itypj)
13107             chip12=chip1*chip2
13108             alf1=alp(itypi)
13109             alf2=alp(itypj)
13110             alf12=0.5D0*(alf1+alf2)
13111             xj=c(1,nres+j)
13112             yj=c(2,nres+j)
13113             zj=c(3,nres+j)
13114 ! Searching for nearest neighbour
13115           xj=mod(xj,boxxsize)
13116           if (xj.lt.0) xj=xj+boxxsize
13117           yj=mod(yj,boxysize)
13118           if (yj.lt.0) yj=yj+boxysize
13119           zj=mod(zj,boxzsize)
13120           if (zj.lt.0) zj=zj+boxzsize
13121        if ((zj.gt.bordlipbot)   &
13122       .and.(zj.lt.bordliptop)) then
13123 !C the energy transfer exist
13124         if (zj.lt.buflipbot) then
13125 !C what fraction I am in
13126          fracinbuf=1.0d0-  &
13127              ((zj-bordlipbot)/lipbufthick)
13128 !C lipbufthick is thickenes of lipid buffore
13129          sslipj=sscalelip(fracinbuf)
13130          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13131         elseif (zj.gt.bufliptop) then
13132          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13133          sslipj=sscalelip(fracinbuf)
13134          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13135         else
13136          sslipj=1.0d0
13137          ssgradlipj=0.0
13138         endif
13139        else
13140          sslipj=0.0d0
13141          ssgradlipj=0.0
13142        endif
13143       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13144        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13145       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13146        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13147
13148           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13149           xj_safe=xj
13150           yj_safe=yj
13151           zj_safe=zj
13152           subchap=0
13153           do xshift=-1,1
13154           do yshift=-1,1
13155           do zshift=-1,1
13156           xj=xj_safe+xshift*boxxsize
13157           yj=yj_safe+yshift*boxysize
13158           zj=zj_safe+zshift*boxzsize
13159           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13160           if(dist_temp.lt.dist_init) then
13161             dist_init=dist_temp
13162             xj_temp=xj
13163             yj_temp=yj
13164             zj_temp=zj
13165             subchap=1
13166           endif
13167           enddo
13168           enddo
13169           enddo
13170           if (subchap.eq.1) then
13171           xj=xj_temp-xi
13172           yj=yj_temp-yi
13173           zj=zj_temp-zi
13174           else
13175           xj=xj_safe-xi
13176           yj=yj_safe-yi
13177           zj=zj_safe-zi
13178           endif
13179
13180             dxj=dc_norm(1,nres+j)
13181             dyj=dc_norm(2,nres+j)
13182             dzj=dc_norm(3,nres+j)
13183             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13184             rij=dsqrt(rrij)
13185             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13186             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13187             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13188             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13189             if (sss_ele_cut.le.0.0) cycle
13190             if (sss.lt.1.0d0) then
13191
13192 ! Calculate angle-dependent terms of energy and contributions to their
13193 ! derivatives.
13194               call sc_angular
13195               sigsq=1.0D0/sigsq
13196               sig=sig0ij*dsqrt(sigsq)
13197               rij_shift=1.0D0/rij-sig+sig0ij
13198 ! for diagnostics; uncomment
13199 !              rij_shift=1.2*sig0ij
13200 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13201               if (rij_shift.le.0.0D0) then
13202                 evdw=1.0D20
13203 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13204 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13205 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13206                 return
13207               endif
13208               sigder=-sig*sigsq
13209 !---------------------------------------------------------------
13210               rij_shift=1.0D0/rij_shift
13211               fac=rij_shift**expon
13212               e1=fac*fac*aa
13213               e2=fac*bb
13214               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13215               eps2der=evdwij*eps3rt
13216               eps3der=evdwij*eps2rt
13217 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13218 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13219               evdwij=evdwij*eps2rt*eps3rt
13220               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13221               if (lprn) then
13222               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13223               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13224               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13225                 restyp(itypi,1),i,restyp(itypj,1),j,&
13226                 epsi,sigm,chi1,chi2,chip1,chip2,&
13227                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13228                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13229                 evdwij
13230               endif
13231
13232               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13233                               'evdw',i,j,evdwij
13234 !              if (energy_dec) write (iout,*) &
13235 !                              'evdw',i,j,evdwij,"egb_long"
13236
13237 ! Calculate gradient components.
13238               e1=e1*eps1*eps2rt**2*eps3rt**2
13239               fac=-expon*(e1+evdwij)*rij_shift
13240               sigder=fac*sigder
13241               fac=rij*fac
13242               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13243             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13244             /sigmaii(itypi,itypj))
13245 !              fac=0.0d0
13246 ! Calculate the radial part of the gradient
13247               gg(1)=xj*fac
13248               gg(2)=yj*fac
13249               gg(3)=zj*fac
13250 ! Calculate angular part of the gradient.
13251               call sc_grad_scale(1.0d0-sss)
13252             ENDIF    !mask_dyn_ss
13253             endif
13254           enddo      ! j
13255         enddo        ! iint
13256       enddo          ! i
13257 !      write (iout,*) "Number of loop steps in EGB:",ind
13258 !ccc      energy_dec=.false.
13259       return
13260       end subroutine egb_long
13261 !-----------------------------------------------------------------------------
13262       subroutine egb_short(evdw)
13263 !
13264 ! This subroutine calculates the interaction energy of nonbonded side chains
13265 ! assuming the Gay-Berne potential of interaction.
13266 !
13267       use calc_data
13268 !      implicit real*8 (a-h,o-z)
13269 !      include 'DIMENSIONS'
13270 !      include 'COMMON.GEO'
13271 !      include 'COMMON.VAR'
13272 !      include 'COMMON.LOCAL'
13273 !      include 'COMMON.CHAIN'
13274 !      include 'COMMON.DERIV'
13275 !      include 'COMMON.NAMES'
13276 !      include 'COMMON.INTERACT'
13277 !      include 'COMMON.IOUNITS'
13278 !      include 'COMMON.CALC'
13279 !      include 'COMMON.CONTROL'
13280       logical :: lprn
13281 !el local variables
13282       integer :: iint,itypi,itypi1,itypj,subchap
13283       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13284       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13285       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13286                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13287                     ssgradlipi,ssgradlipj
13288       evdw=0.0D0
13289 !cccc      energy_dec=.false.
13290 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13291       evdw=0.0D0
13292       lprn=.false.
13293 !     if (icall.eq.0) lprn=.false.
13294 !el      ind=0
13295       do i=iatsc_s,iatsc_e
13296         itypi=itype(i,1)
13297         if (itypi.eq.ntyp1) cycle
13298         itypi1=itype(i+1,1)
13299         xi=c(1,nres+i)
13300         yi=c(2,nres+i)
13301         zi=c(3,nres+i)
13302           xi=mod(xi,boxxsize)
13303           if (xi.lt.0) xi=xi+boxxsize
13304           yi=mod(yi,boxysize)
13305           if (yi.lt.0) yi=yi+boxysize
13306           zi=mod(zi,boxzsize)
13307           if (zi.lt.0) zi=zi+boxzsize
13308        if ((zi.gt.bordlipbot)    &
13309         .and.(zi.lt.bordliptop)) then
13310 !C the energy transfer exist
13311         if (zi.lt.buflipbot) then
13312 !C what fraction I am in
13313          fracinbuf=1.0d0-    &
13314              ((zi-bordlipbot)/lipbufthick)
13315 !C lipbufthick is thickenes of lipid buffore
13316          sslipi=sscalelip(fracinbuf)
13317          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13318         elseif (zi.gt.bufliptop) then
13319          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13320          sslipi=sscalelip(fracinbuf)
13321          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13322         else
13323          sslipi=1.0d0
13324          ssgradlipi=0.0
13325         endif
13326        else
13327          sslipi=0.0d0
13328          ssgradlipi=0.0
13329        endif
13330
13331         dxi=dc_norm(1,nres+i)
13332         dyi=dc_norm(2,nres+i)
13333         dzi=dc_norm(3,nres+i)
13334 !        dsci_inv=dsc_inv(itypi)
13335         dsci_inv=vbld_inv(i+nres)
13336
13337         dxi=dc_norm(1,nres+i)
13338         dyi=dc_norm(2,nres+i)
13339         dzi=dc_norm(3,nres+i)
13340 !        dsci_inv=dsc_inv(itypi)
13341         dsci_inv=vbld_inv(i+nres)
13342 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13343 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13344 !
13345 ! Calculate SC interaction energy.
13346 !
13347         do iint=1,nint_gr(i)
13348           do j=istart(i,iint),iend(i,iint)
13349             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13350               call dyn_ssbond_ene(i,j,evdwij)
13351               evdw=evdw+evdwij
13352               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13353                               'evdw',i,j,evdwij,' ss'
13354              do k=j+1,iend(i,iint)
13355 !C search over all next residues
13356               if (dyn_ss_mask(k)) then
13357 !C check if they are cysteins
13358 !C              write(iout,*) 'k=',k
13359
13360 !c              write(iout,*) "PRZED TRI", evdwij
13361 !               evdwij_przed_tri=evdwij
13362               call triple_ssbond_ene(i,j,k,evdwij)
13363 !c               if(evdwij_przed_tri.ne.evdwij) then
13364 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13365 !c               endif
13366
13367 !c              write(iout,*) "PO TRI", evdwij
13368 !C call the energy function that removes the artifical triple disulfide
13369 !C bond the soubroutine is located in ssMD.F
13370               evdw=evdw+evdwij
13371               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13372                             'evdw',i,j,evdwij,'tss'
13373               endif!dyn_ss_mask(k)
13374              enddo! k
13375
13376 !              if (energy_dec) write (iout,*) &
13377 !                              'evdw',i,j,evdwij,' ss'
13378             ELSE
13379 !el            ind=ind+1
13380             itypj=itype(j,1)
13381             if (itypj.eq.ntyp1) cycle
13382 !            dscj_inv=dsc_inv(itypj)
13383             dscj_inv=vbld_inv(j+nres)
13384 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13385 !     &       1.0d0/vbld(j+nres)
13386 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13387             sig0ij=sigma(itypi,itypj)
13388             chi1=chi(itypi,itypj)
13389             chi2=chi(itypj,itypi)
13390             chi12=chi1*chi2
13391             chip1=chip(itypi)
13392             chip2=chip(itypj)
13393             chip12=chip1*chip2
13394             alf1=alp(itypi)
13395             alf2=alp(itypj)
13396             alf12=0.5D0*(alf1+alf2)
13397 !            xj=c(1,nres+j)-xi
13398 !            yj=c(2,nres+j)-yi
13399 !            zj=c(3,nres+j)-zi
13400             xj=c(1,nres+j)
13401             yj=c(2,nres+j)
13402             zj=c(3,nres+j)
13403 ! Searching for nearest neighbour
13404           xj=mod(xj,boxxsize)
13405           if (xj.lt.0) xj=xj+boxxsize
13406           yj=mod(yj,boxysize)
13407           if (yj.lt.0) yj=yj+boxysize
13408           zj=mod(zj,boxzsize)
13409           if (zj.lt.0) zj=zj+boxzsize
13410        if ((zj.gt.bordlipbot)   &
13411       .and.(zj.lt.bordliptop)) then
13412 !C the energy transfer exist
13413         if (zj.lt.buflipbot) then
13414 !C what fraction I am in
13415          fracinbuf=1.0d0-  &
13416              ((zj-bordlipbot)/lipbufthick)
13417 !C lipbufthick is thickenes of lipid buffore
13418          sslipj=sscalelip(fracinbuf)
13419          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13420         elseif (zj.gt.bufliptop) then
13421          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13422          sslipj=sscalelip(fracinbuf)
13423          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13424         else
13425          sslipj=1.0d0
13426          ssgradlipj=0.0
13427         endif
13428        else
13429          sslipj=0.0d0
13430          ssgradlipj=0.0
13431        endif
13432       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13433        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13434       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13435        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13436
13437           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13438           xj_safe=xj
13439           yj_safe=yj
13440           zj_safe=zj
13441           subchap=0
13442
13443           do xshift=-1,1
13444           do yshift=-1,1
13445           do zshift=-1,1
13446           xj=xj_safe+xshift*boxxsize
13447           yj=yj_safe+yshift*boxysize
13448           zj=zj_safe+zshift*boxzsize
13449           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13450           if(dist_temp.lt.dist_init) then
13451             dist_init=dist_temp
13452             xj_temp=xj
13453             yj_temp=yj
13454             zj_temp=zj
13455             subchap=1
13456           endif
13457           enddo
13458           enddo
13459           enddo
13460           if (subchap.eq.1) then
13461           xj=xj_temp-xi
13462           yj=yj_temp-yi
13463           zj=zj_temp-zi
13464           else
13465           xj=xj_safe-xi
13466           yj=yj_safe-yi
13467           zj=zj_safe-zi
13468           endif
13469
13470             dxj=dc_norm(1,nres+j)
13471             dyj=dc_norm(2,nres+j)
13472             dzj=dc_norm(3,nres+j)
13473             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13474             rij=dsqrt(rrij)
13475             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13476             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13477             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13478             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13479             if (sss_ele_cut.le.0.0) cycle
13480
13481             if (sss.gt.0.0d0) then
13482
13483 ! Calculate angle-dependent terms of energy and contributions to their
13484 ! derivatives.
13485               call sc_angular
13486               sigsq=1.0D0/sigsq
13487               sig=sig0ij*dsqrt(sigsq)
13488               rij_shift=1.0D0/rij-sig+sig0ij
13489 ! for diagnostics; uncomment
13490 !              rij_shift=1.2*sig0ij
13491 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13492               if (rij_shift.le.0.0D0) then
13493                 evdw=1.0D20
13494 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13495 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13496 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13497                 return
13498               endif
13499               sigder=-sig*sigsq
13500 !---------------------------------------------------------------
13501               rij_shift=1.0D0/rij_shift
13502               fac=rij_shift**expon
13503               e1=fac*fac*aa
13504               e2=fac*bb
13505               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13506               eps2der=evdwij*eps3rt
13507               eps3der=evdwij*eps2rt
13508 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13509 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13510               evdwij=evdwij*eps2rt*eps3rt
13511               evdw=evdw+evdwij*sss*sss_ele_cut
13512               if (lprn) then
13513               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13514               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13515               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13516                 restyp(itypi,1),i,restyp(itypj,1),j,&
13517                 epsi,sigm,chi1,chi2,chip1,chip2,&
13518                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13519                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13520                 evdwij
13521               endif
13522
13523               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13524                               'evdw',i,j,evdwij
13525 !              if (energy_dec) write (iout,*) &
13526 !                              'evdw',i,j,evdwij,"egb_short"
13527
13528 ! Calculate gradient components.
13529               e1=e1*eps1*eps2rt**2*eps3rt**2
13530               fac=-expon*(e1+evdwij)*rij_shift
13531               sigder=fac*sigder
13532               fac=rij*fac
13533               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13534             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13535             /sigmaii(itypi,itypj))
13536
13537 !              fac=0.0d0
13538 ! Calculate the radial part of the gradient
13539               gg(1)=xj*fac
13540               gg(2)=yj*fac
13541               gg(3)=zj*fac
13542 ! Calculate angular part of the gradient.
13543               call sc_grad_scale(sss)
13544             endif
13545           ENDIF !mask_dyn_ss
13546           enddo      ! j
13547         enddo        ! iint
13548       enddo          ! i
13549 !      write (iout,*) "Number of loop steps in EGB:",ind
13550 !ccc      energy_dec=.false.
13551       return
13552       end subroutine egb_short
13553 !-----------------------------------------------------------------------------
13554       subroutine egbv_long(evdw)
13555 !
13556 ! This subroutine calculates the interaction energy of nonbonded side chains
13557 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13558 !
13559       use calc_data
13560 !      implicit real*8 (a-h,o-z)
13561 !      include 'DIMENSIONS'
13562 !      include 'COMMON.GEO'
13563 !      include 'COMMON.VAR'
13564 !      include 'COMMON.LOCAL'
13565 !      include 'COMMON.CHAIN'
13566 !      include 'COMMON.DERIV'
13567 !      include 'COMMON.NAMES'
13568 !      include 'COMMON.INTERACT'
13569 !      include 'COMMON.IOUNITS'
13570 !      include 'COMMON.CALC'
13571       use comm_srutu
13572 !el      integer :: icall
13573 !el      common /srutu/ icall
13574       logical :: lprn
13575 !el local variables
13576       integer :: iint,itypi,itypi1,itypj
13577       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13578       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13579       evdw=0.0D0
13580 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13581       evdw=0.0D0
13582       lprn=.false.
13583 !     if (icall.eq.0) lprn=.true.
13584 !el      ind=0
13585       do i=iatsc_s,iatsc_e
13586         itypi=itype(i,1)
13587         if (itypi.eq.ntyp1) cycle
13588         itypi1=itype(i+1,1)
13589         xi=c(1,nres+i)
13590         yi=c(2,nres+i)
13591         zi=c(3,nres+i)
13592         dxi=dc_norm(1,nres+i)
13593         dyi=dc_norm(2,nres+i)
13594         dzi=dc_norm(3,nres+i)
13595 !        dsci_inv=dsc_inv(itypi)
13596         dsci_inv=vbld_inv(i+nres)
13597 !
13598 ! Calculate SC interaction energy.
13599 !
13600         do iint=1,nint_gr(i)
13601           do j=istart(i,iint),iend(i,iint)
13602 !el            ind=ind+1
13603             itypj=itype(j,1)
13604             if (itypj.eq.ntyp1) cycle
13605 !            dscj_inv=dsc_inv(itypj)
13606             dscj_inv=vbld_inv(j+nres)
13607             sig0ij=sigma(itypi,itypj)
13608             r0ij=r0(itypi,itypj)
13609             chi1=chi(itypi,itypj)
13610             chi2=chi(itypj,itypi)
13611             chi12=chi1*chi2
13612             chip1=chip(itypi)
13613             chip2=chip(itypj)
13614             chip12=chip1*chip2
13615             alf1=alp(itypi)
13616             alf2=alp(itypj)
13617             alf12=0.5D0*(alf1+alf2)
13618             xj=c(1,nres+j)-xi
13619             yj=c(2,nres+j)-yi
13620             zj=c(3,nres+j)-zi
13621             dxj=dc_norm(1,nres+j)
13622             dyj=dc_norm(2,nres+j)
13623             dzj=dc_norm(3,nres+j)
13624             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13625             rij=dsqrt(rrij)
13626
13627             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13628
13629             if (sss.lt.1.0d0) then
13630
13631 ! Calculate angle-dependent terms of energy and contributions to their
13632 ! derivatives.
13633               call sc_angular
13634               sigsq=1.0D0/sigsq
13635               sig=sig0ij*dsqrt(sigsq)
13636               rij_shift=1.0D0/rij-sig+r0ij
13637 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13638               if (rij_shift.le.0.0D0) then
13639                 evdw=1.0D20
13640                 return
13641               endif
13642               sigder=-sig*sigsq
13643 !---------------------------------------------------------------
13644               rij_shift=1.0D0/rij_shift
13645               fac=rij_shift**expon
13646               e1=fac*fac*aa_aq(itypi,itypj)
13647               e2=fac*bb_aq(itypi,itypj)
13648               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13649               eps2der=evdwij*eps3rt
13650               eps3der=evdwij*eps2rt
13651               fac_augm=rrij**expon
13652               e_augm=augm(itypi,itypj)*fac_augm
13653               evdwij=evdwij*eps2rt*eps3rt
13654               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13655               if (lprn) then
13656               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13657               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13658               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13659                 restyp(itypi,1),i,restyp(itypj,1),j,&
13660                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13661                 chi1,chi2,chip1,chip2,&
13662                 eps1,eps2rt**2,eps3rt**2,&
13663                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13664                 evdwij+e_augm
13665               endif
13666 ! Calculate gradient components.
13667               e1=e1*eps1*eps2rt**2*eps3rt**2
13668               fac=-expon*(e1+evdwij)*rij_shift
13669               sigder=fac*sigder
13670               fac=rij*fac-2*expon*rrij*e_augm
13671 ! Calculate the radial part of the gradient
13672               gg(1)=xj*fac
13673               gg(2)=yj*fac
13674               gg(3)=zj*fac
13675 ! Calculate angular part of the gradient.
13676               call sc_grad_scale(1.0d0-sss)
13677             endif
13678           enddo      ! j
13679         enddo        ! iint
13680       enddo          ! i
13681       end subroutine egbv_long
13682 !-----------------------------------------------------------------------------
13683       subroutine egbv_short(evdw)
13684 !
13685 ! This subroutine calculates the interaction energy of nonbonded side chains
13686 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13687 !
13688       use calc_data
13689 !      implicit real*8 (a-h,o-z)
13690 !      include 'DIMENSIONS'
13691 !      include 'COMMON.GEO'
13692 !      include 'COMMON.VAR'
13693 !      include 'COMMON.LOCAL'
13694 !      include 'COMMON.CHAIN'
13695 !      include 'COMMON.DERIV'
13696 !      include 'COMMON.NAMES'
13697 !      include 'COMMON.INTERACT'
13698 !      include 'COMMON.IOUNITS'
13699 !      include 'COMMON.CALC'
13700       use comm_srutu
13701 !el      integer :: icall
13702 !el      common /srutu/ icall
13703       logical :: lprn
13704 !el local variables
13705       integer :: iint,itypi,itypi1,itypj
13706       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13707       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13708       evdw=0.0D0
13709 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13710       evdw=0.0D0
13711       lprn=.false.
13712 !     if (icall.eq.0) lprn=.true.
13713 !el      ind=0
13714       do i=iatsc_s,iatsc_e
13715         itypi=itype(i,1)
13716         if (itypi.eq.ntyp1) cycle
13717         itypi1=itype(i+1,1)
13718         xi=c(1,nres+i)
13719         yi=c(2,nres+i)
13720         zi=c(3,nres+i)
13721         dxi=dc_norm(1,nres+i)
13722         dyi=dc_norm(2,nres+i)
13723         dzi=dc_norm(3,nres+i)
13724 !        dsci_inv=dsc_inv(itypi)
13725         dsci_inv=vbld_inv(i+nres)
13726 !
13727 ! Calculate SC interaction energy.
13728 !
13729         do iint=1,nint_gr(i)
13730           do j=istart(i,iint),iend(i,iint)
13731 !el            ind=ind+1
13732             itypj=itype(j,1)
13733             if (itypj.eq.ntyp1) cycle
13734 !            dscj_inv=dsc_inv(itypj)
13735             dscj_inv=vbld_inv(j+nres)
13736             sig0ij=sigma(itypi,itypj)
13737             r0ij=r0(itypi,itypj)
13738             chi1=chi(itypi,itypj)
13739             chi2=chi(itypj,itypi)
13740             chi12=chi1*chi2
13741             chip1=chip(itypi)
13742             chip2=chip(itypj)
13743             chip12=chip1*chip2
13744             alf1=alp(itypi)
13745             alf2=alp(itypj)
13746             alf12=0.5D0*(alf1+alf2)
13747             xj=c(1,nres+j)-xi
13748             yj=c(2,nres+j)-yi
13749             zj=c(3,nres+j)-zi
13750             dxj=dc_norm(1,nres+j)
13751             dyj=dc_norm(2,nres+j)
13752             dzj=dc_norm(3,nres+j)
13753             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13754             rij=dsqrt(rrij)
13755
13756             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13757
13758             if (sss.gt.0.0d0) then
13759
13760 ! Calculate angle-dependent terms of energy and contributions to their
13761 ! derivatives.
13762               call sc_angular
13763               sigsq=1.0D0/sigsq
13764               sig=sig0ij*dsqrt(sigsq)
13765               rij_shift=1.0D0/rij-sig+r0ij
13766 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13767               if (rij_shift.le.0.0D0) then
13768                 evdw=1.0D20
13769                 return
13770               endif
13771               sigder=-sig*sigsq
13772 !---------------------------------------------------------------
13773               rij_shift=1.0D0/rij_shift
13774               fac=rij_shift**expon
13775               e1=fac*fac*aa_aq(itypi,itypj)
13776               e2=fac*bb_aq(itypi,itypj)
13777               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13778               eps2der=evdwij*eps3rt
13779               eps3der=evdwij*eps2rt
13780               fac_augm=rrij**expon
13781               e_augm=augm(itypi,itypj)*fac_augm
13782               evdwij=evdwij*eps2rt*eps3rt
13783               evdw=evdw+(evdwij+e_augm)*sss
13784               if (lprn) then
13785               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13786               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13787               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13788                 restyp(itypi,1),i,restyp(itypj,1),j,&
13789                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13790                 chi1,chi2,chip1,chip2,&
13791                 eps1,eps2rt**2,eps3rt**2,&
13792                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13793                 evdwij+e_augm
13794               endif
13795 ! Calculate gradient components.
13796               e1=e1*eps1*eps2rt**2*eps3rt**2
13797               fac=-expon*(e1+evdwij)*rij_shift
13798               sigder=fac*sigder
13799               fac=rij*fac-2*expon*rrij*e_augm
13800 ! Calculate the radial part of the gradient
13801               gg(1)=xj*fac
13802               gg(2)=yj*fac
13803               gg(3)=zj*fac
13804 ! Calculate angular part of the gradient.
13805               call sc_grad_scale(sss)
13806             endif
13807           enddo      ! j
13808         enddo        ! iint
13809       enddo          ! i
13810       end subroutine egbv_short
13811 !-----------------------------------------------------------------------------
13812       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13813 !
13814 ! This subroutine calculates the average interaction energy and its gradient
13815 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13816 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13817 ! The potential depends both on the distance of peptide-group centers and on
13818 ! the orientation of the CA-CA virtual bonds.
13819 !
13820 !      implicit real*8 (a-h,o-z)
13821
13822       use comm_locel
13823 #ifdef MPI
13824       include 'mpif.h'
13825 #endif
13826 !      include 'DIMENSIONS'
13827 !      include 'COMMON.CONTROL'
13828 !      include 'COMMON.SETUP'
13829 !      include 'COMMON.IOUNITS'
13830 !      include 'COMMON.GEO'
13831 !      include 'COMMON.VAR'
13832 !      include 'COMMON.LOCAL'
13833 !      include 'COMMON.CHAIN'
13834 !      include 'COMMON.DERIV'
13835 !      include 'COMMON.INTERACT'
13836 !      include 'COMMON.CONTACTS'
13837 !      include 'COMMON.TORSION'
13838 !      include 'COMMON.VECTORS'
13839 !      include 'COMMON.FFIELD'
13840 !      include 'COMMON.TIME1'
13841       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13842       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13843       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13844 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13845       real(kind=8),dimension(4) :: muij
13846 !el      integer :: num_conti,j1,j2
13847 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13848 !el                   dz_normi,xmedi,ymedi,zmedi
13849 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13850 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13851 !el          num_conti,j1,j2
13852 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13853 #ifdef MOMENT
13854       real(kind=8) :: scal_el=1.0d0
13855 #else
13856       real(kind=8) :: scal_el=0.5d0
13857 #endif
13858 ! 12/13/98
13859 ! 13-go grudnia roku pamietnego...
13860       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13861                                              0.0d0,1.0d0,0.0d0,&
13862                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13863 !el local variables
13864       integer :: i,j,k
13865       real(kind=8) :: fac
13866       real(kind=8) :: dxj,dyj,dzj
13867       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13868
13869 !      allocate(num_cont_hb(nres)) !(maxres)
13870 !d      write(iout,*) 'In EELEC'
13871 !d      do i=1,nloctyp
13872 !d        write(iout,*) 'Type',i
13873 !d        write(iout,*) 'B1',B1(:,i)
13874 !d        write(iout,*) 'B2',B2(:,i)
13875 !d        write(iout,*) 'CC',CC(:,:,i)
13876 !d        write(iout,*) 'DD',DD(:,:,i)
13877 !d        write(iout,*) 'EE',EE(:,:,i)
13878 !d      enddo
13879 !d      call check_vecgrad
13880 !d      stop
13881       if (icheckgrad.eq.1) then
13882         do i=1,nres-1
13883           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13884           do k=1,3
13885             dc_norm(k,i)=dc(k,i)*fac
13886           enddo
13887 !          write (iout,*) 'i',i,' fac',fac
13888         enddo
13889       endif
13890       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13891           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13892           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13893 !        call vec_and_deriv
13894 #ifdef TIMING
13895         time01=MPI_Wtime()
13896 #endif
13897 !        print *, "before set matrices"
13898         call set_matrices
13899 !        print *,"after set martices"
13900 #ifdef TIMING
13901         time_mat=time_mat+MPI_Wtime()-time01
13902 #endif
13903       endif
13904 !d      do i=1,nres-1
13905 !d        write (iout,*) 'i=',i
13906 !d        do k=1,3
13907 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13908 !d        enddo
13909 !d        do k=1,3
13910 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13911 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13912 !d        enddo
13913 !d      enddo
13914       t_eelecij=0.0d0
13915       ees=0.0D0
13916       evdw1=0.0D0
13917       eel_loc=0.0d0
13918       eello_turn3=0.0d0
13919       eello_turn4=0.0d0
13920 !el      ind=0
13921       do i=1,nres
13922         num_cont_hb(i)=0
13923       enddo
13924 !d      print '(a)','Enter EELEC'
13925 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13926 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13927 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13928       do i=1,nres
13929         gel_loc_loc(i)=0.0d0
13930         gcorr_loc(i)=0.0d0
13931       enddo
13932 !
13933 !
13934 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13935 !
13936 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13937 !
13938       do i=iturn3_start,iturn3_end
13939         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
13940         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
13941         dxi=dc(1,i)
13942         dyi=dc(2,i)
13943         dzi=dc(3,i)
13944         dx_normi=dc_norm(1,i)
13945         dy_normi=dc_norm(2,i)
13946         dz_normi=dc_norm(3,i)
13947         xmedi=c(1,i)+0.5d0*dxi
13948         ymedi=c(2,i)+0.5d0*dyi
13949         zmedi=c(3,i)+0.5d0*dzi
13950           xmedi=dmod(xmedi,boxxsize)
13951           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13952           ymedi=dmod(ymedi,boxysize)
13953           if (ymedi.lt.0) ymedi=ymedi+boxysize
13954           zmedi=dmod(zmedi,boxzsize)
13955           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13956         num_conti=0
13957         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13958         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13959         num_cont_hb(i)=num_conti
13960       enddo
13961       do i=iturn4_start,iturn4_end
13962         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
13963           .or. itype(i+3,1).eq.ntyp1 &
13964           .or. itype(i+4,1).eq.ntyp1) cycle
13965         dxi=dc(1,i)
13966         dyi=dc(2,i)
13967         dzi=dc(3,i)
13968         dx_normi=dc_norm(1,i)
13969         dy_normi=dc_norm(2,i)
13970         dz_normi=dc_norm(3,i)
13971         xmedi=c(1,i)+0.5d0*dxi
13972         ymedi=c(2,i)+0.5d0*dyi
13973         zmedi=c(3,i)+0.5d0*dzi
13974           xmedi=dmod(xmedi,boxxsize)
13975           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13976           ymedi=dmod(ymedi,boxysize)
13977           if (ymedi.lt.0) ymedi=ymedi+boxysize
13978           zmedi=dmod(zmedi,boxzsize)
13979           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13980         num_conti=num_cont_hb(i)
13981         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13982         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
13983           call eturn4(i,eello_turn4)
13984         num_cont_hb(i)=num_conti
13985       enddo   ! i
13986 !
13987 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13988 !
13989       do i=iatel_s,iatel_e
13990         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
13991         dxi=dc(1,i)
13992         dyi=dc(2,i)
13993         dzi=dc(3,i)
13994         dx_normi=dc_norm(1,i)
13995         dy_normi=dc_norm(2,i)
13996         dz_normi=dc_norm(3,i)
13997         xmedi=c(1,i)+0.5d0*dxi
13998         ymedi=c(2,i)+0.5d0*dyi
13999         zmedi=c(3,i)+0.5d0*dzi
14000           xmedi=dmod(xmedi,boxxsize)
14001           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14002           ymedi=dmod(ymedi,boxysize)
14003           if (ymedi.lt.0) ymedi=ymedi+boxysize
14004           zmedi=dmod(zmedi,boxzsize)
14005           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14006 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14007         num_conti=num_cont_hb(i)
14008         do j=ielstart(i),ielend(i)
14009           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14010           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14011         enddo ! j
14012         num_cont_hb(i)=num_conti
14013       enddo   ! i
14014 !      write (iout,*) "Number of loop steps in EELEC:",ind
14015 !d      do i=1,nres
14016 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14017 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14018 !d      enddo
14019 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14020 !cc      eel_loc=eel_loc+eello_turn3
14021 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14022       return
14023       end subroutine eelec_scale
14024 !-----------------------------------------------------------------------------
14025       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14026 !      implicit real*8 (a-h,o-z)
14027
14028       use comm_locel
14029 !      include 'DIMENSIONS'
14030 #ifdef MPI
14031       include "mpif.h"
14032 #endif
14033 !      include 'COMMON.CONTROL'
14034 !      include 'COMMON.IOUNITS'
14035 !      include 'COMMON.GEO'
14036 !      include 'COMMON.VAR'
14037 !      include 'COMMON.LOCAL'
14038 !      include 'COMMON.CHAIN'
14039 !      include 'COMMON.DERIV'
14040 !      include 'COMMON.INTERACT'
14041 !      include 'COMMON.CONTACTS'
14042 !      include 'COMMON.TORSION'
14043 !      include 'COMMON.VECTORS'
14044 !      include 'COMMON.FFIELD'
14045 !      include 'COMMON.TIME1'
14046       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14047       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14048       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14049 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14050       real(kind=8),dimension(4) :: muij
14051       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14052                     dist_temp, dist_init,sss_grad
14053       integer xshift,yshift,zshift
14054
14055 !el      integer :: num_conti,j1,j2
14056 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14057 !el                   dz_normi,xmedi,ymedi,zmedi
14058 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14059 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14060 !el          num_conti,j1,j2
14061 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14062 #ifdef MOMENT
14063       real(kind=8) :: scal_el=1.0d0
14064 #else
14065       real(kind=8) :: scal_el=0.5d0
14066 #endif
14067 ! 12/13/98
14068 ! 13-go grudnia roku pamietnego...
14069       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14070                                              0.0d0,1.0d0,0.0d0,&
14071                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14072 !el local variables
14073       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14074       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14075       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14076       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14077       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14078       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14079       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14080                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14081                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14082                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14083                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14084                   ecosam,ecosbm,ecosgm,ghalf,time00
14085 !      integer :: maxconts
14086 !      maxconts = nres/4
14087 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14088 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14089 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14090 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14091 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14092 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14093 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14094 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14095 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14096 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14097 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14098 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14099 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14100
14101 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14102 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14103
14104 #ifdef MPI
14105           time00=MPI_Wtime()
14106 #endif
14107 !d      write (iout,*) "eelecij",i,j
14108 !el          ind=ind+1
14109           iteli=itel(i)
14110           itelj=itel(j)
14111           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14112           aaa=app(iteli,itelj)
14113           bbb=bpp(iteli,itelj)
14114           ael6i=ael6(iteli,itelj)
14115           ael3i=ael3(iteli,itelj)
14116           dxj=dc(1,j)
14117           dyj=dc(2,j)
14118           dzj=dc(3,j)
14119           dx_normj=dc_norm(1,j)
14120           dy_normj=dc_norm(2,j)
14121           dz_normj=dc_norm(3,j)
14122 !          xj=c(1,j)+0.5D0*dxj-xmedi
14123 !          yj=c(2,j)+0.5D0*dyj-ymedi
14124 !          zj=c(3,j)+0.5D0*dzj-zmedi
14125           xj=c(1,j)+0.5D0*dxj
14126           yj=c(2,j)+0.5D0*dyj
14127           zj=c(3,j)+0.5D0*dzj
14128           xj=mod(xj,boxxsize)
14129           if (xj.lt.0) xj=xj+boxxsize
14130           yj=mod(yj,boxysize)
14131           if (yj.lt.0) yj=yj+boxysize
14132           zj=mod(zj,boxzsize)
14133           if (zj.lt.0) zj=zj+boxzsize
14134       isubchap=0
14135       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14136       xj_safe=xj
14137       yj_safe=yj
14138       zj_safe=zj
14139       do xshift=-1,1
14140       do yshift=-1,1
14141       do zshift=-1,1
14142           xj=xj_safe+xshift*boxxsize
14143           yj=yj_safe+yshift*boxysize
14144           zj=zj_safe+zshift*boxzsize
14145           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14146           if(dist_temp.lt.dist_init) then
14147             dist_init=dist_temp
14148             xj_temp=xj
14149             yj_temp=yj
14150             zj_temp=zj
14151             isubchap=1
14152           endif
14153        enddo
14154        enddo
14155        enddo
14156        if (isubchap.eq.1) then
14157 !C          print *,i,j
14158           xj=xj_temp-xmedi
14159           yj=yj_temp-ymedi
14160           zj=zj_temp-zmedi
14161        else
14162           xj=xj_safe-xmedi
14163           yj=yj_safe-ymedi
14164           zj=zj_safe-zmedi
14165        endif
14166
14167           rij=xj*xj+yj*yj+zj*zj
14168           rrmij=1.0D0/rij
14169           rij=dsqrt(rij)
14170           rmij=1.0D0/rij
14171 ! For extracting the short-range part of Evdwpp
14172           sss=sscale(rij/rpp(iteli,itelj))
14173             sss_ele_cut=sscale_ele(rij)
14174             sss_ele_grad=sscagrad_ele(rij)
14175             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14176 !             sss_ele_cut=1.0d0
14177 !             sss_ele_grad=0.0d0
14178             if (sss_ele_cut.le.0.0) go to 128
14179
14180           r3ij=rrmij*rmij
14181           r6ij=r3ij*r3ij
14182           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14183           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14184           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14185           fac=cosa-3.0D0*cosb*cosg
14186           ev1=aaa*r6ij*r6ij
14187 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14188           if (j.eq.i+2) ev1=scal_el*ev1
14189           ev2=bbb*r6ij
14190           fac3=ael6i*r6ij
14191           fac4=ael3i*r3ij
14192           evdwij=ev1+ev2
14193           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14194           el2=fac4*fac
14195           eesij=el1+el2
14196 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14197           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14198           ees=ees+eesij*sss_ele_cut
14199           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14200 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14201 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14202 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14203 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14204
14205           if (energy_dec) then
14206               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14207               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14208           endif
14209
14210 !
14211 ! Calculate contributions to the Cartesian gradient.
14212 !
14213 #ifdef SPLITELE
14214           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14215           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14216           fac1=fac
14217           erij(1)=xj*rmij
14218           erij(2)=yj*rmij
14219           erij(3)=zj*rmij
14220 !
14221 ! Radial derivatives. First process both termini of the fragment (i,j)
14222 !
14223           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14224           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14225           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14226 !          do k=1,3
14227 !            ghalf=0.5D0*ggg(k)
14228 !            gelc(k,i)=gelc(k,i)+ghalf
14229 !            gelc(k,j)=gelc(k,j)+ghalf
14230 !          enddo
14231 ! 9/28/08 AL Gradient compotents will be summed only at the end
14232           do k=1,3
14233             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14234             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14235           enddo
14236 !
14237 ! Loop over residues i+1 thru j-1.
14238 !
14239 !grad          do k=i+1,j-1
14240 !grad            do l=1,3
14241 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14242 !grad            enddo
14243 !grad          enddo
14244           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14245           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14246           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14247           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14248           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14249           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14250 !          do k=1,3
14251 !            ghalf=0.5D0*ggg(k)
14252 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14253 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14254 !          enddo
14255 ! 9/28/08 AL Gradient compotents will be summed only at the end
14256           do k=1,3
14257             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14258             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14259           enddo
14260 !
14261 ! Loop over residues i+1 thru j-1.
14262 !
14263 !grad          do k=i+1,j-1
14264 !grad            do l=1,3
14265 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14266 !grad            enddo
14267 !grad          enddo
14268 #else
14269           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14270           facel=(el1+eesij)*sss_ele_cut
14271           fac1=fac
14272           fac=-3*rrmij*(facvdw+facvdw+facel)
14273           erij(1)=xj*rmij
14274           erij(2)=yj*rmij
14275           erij(3)=zj*rmij
14276 !
14277 ! Radial derivatives. First process both termini of the fragment (i,j)
14278 !
14279           ggg(1)=fac*xj
14280           ggg(2)=fac*yj
14281           ggg(3)=fac*zj
14282 !          do k=1,3
14283 !            ghalf=0.5D0*ggg(k)
14284 !            gelc(k,i)=gelc(k,i)+ghalf
14285 !            gelc(k,j)=gelc(k,j)+ghalf
14286 !          enddo
14287 ! 9/28/08 AL Gradient compotents will be summed only at the end
14288           do k=1,3
14289             gelc_long(k,j)=gelc(k,j)+ggg(k)
14290             gelc_long(k,i)=gelc(k,i)-ggg(k)
14291           enddo
14292 !
14293 ! Loop over residues i+1 thru j-1.
14294 !
14295 !grad          do k=i+1,j-1
14296 !grad            do l=1,3
14297 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14298 !grad            enddo
14299 !grad          enddo
14300 ! 9/28/08 AL Gradient compotents will be summed only at the end
14301           ggg(1)=facvdw*xj
14302           ggg(2)=facvdw*yj
14303           ggg(3)=facvdw*zj
14304           do k=1,3
14305             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14306             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14307           enddo
14308 #endif
14309 !
14310 ! Angular part
14311 !
14312           ecosa=2.0D0*fac3*fac1+fac4
14313           fac4=-3.0D0*fac4
14314           fac3=-6.0D0*fac3
14315           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14316           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14317           do k=1,3
14318             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14319             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14320           enddo
14321 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14322 !d   &          (dcosg(k),k=1,3)
14323           do k=1,3
14324             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14325           enddo
14326 !          do k=1,3
14327 !            ghalf=0.5D0*ggg(k)
14328 !            gelc(k,i)=gelc(k,i)+ghalf
14329 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14330 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14331 !            gelc(k,j)=gelc(k,j)+ghalf
14332 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14333 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14334 !          enddo
14335 !grad          do k=i+1,j-1
14336 !grad            do l=1,3
14337 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14338 !grad            enddo
14339 !grad          enddo
14340           do k=1,3
14341             gelc(k,i)=gelc(k,i) &
14342                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14343                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14344                      *sss_ele_cut
14345             gelc(k,j)=gelc(k,j) &
14346                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14347                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14348                      *sss_ele_cut
14349             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14350             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14351           enddo
14352           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14353               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14354               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14355 !
14356 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14357 !   energy of a peptide unit is assumed in the form of a second-order
14358 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14359 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14360 !   are computed for EVERY pair of non-contiguous peptide groups.
14361 !
14362           if (j.lt.nres-1) then
14363             j1=j+1
14364             j2=j-1
14365           else
14366             j1=j-1
14367             j2=j-2
14368           endif
14369           kkk=0
14370           do k=1,2
14371             do l=1,2
14372               kkk=kkk+1
14373               muij(kkk)=mu(k,i)*mu(l,j)
14374             enddo
14375           enddo
14376 !d         write (iout,*) 'EELEC: i',i,' j',j
14377 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14378 !d          write(iout,*) 'muij',muij
14379           ury=scalar(uy(1,i),erij)
14380           urz=scalar(uz(1,i),erij)
14381           vry=scalar(uy(1,j),erij)
14382           vrz=scalar(uz(1,j),erij)
14383           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14384           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14385           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14386           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14387           fac=dsqrt(-ael6i)*r3ij
14388           a22=a22*fac
14389           a23=a23*fac
14390           a32=a32*fac
14391           a33=a33*fac
14392 !d          write (iout,'(4i5,4f10.5)')
14393 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14394 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14395 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14396 !d     &      uy(:,j),uz(:,j)
14397 !d          write (iout,'(4f10.5)')
14398 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14399 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14400 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14401 !d           write (iout,'(9f10.5/)')
14402 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14403 ! Derivatives of the elements of A in virtual-bond vectors
14404           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14405           do k=1,3
14406             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14407             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14408             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14409             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14410             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14411             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14412             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14413             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14414             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14415             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14416             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14417             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14418           enddo
14419 ! Compute radial contributions to the gradient
14420           facr=-3.0d0*rrmij
14421           a22der=a22*facr
14422           a23der=a23*facr
14423           a32der=a32*facr
14424           a33der=a33*facr
14425           agg(1,1)=a22der*xj
14426           agg(2,1)=a22der*yj
14427           agg(3,1)=a22der*zj
14428           agg(1,2)=a23der*xj
14429           agg(2,2)=a23der*yj
14430           agg(3,2)=a23der*zj
14431           agg(1,3)=a32der*xj
14432           agg(2,3)=a32der*yj
14433           agg(3,3)=a32der*zj
14434           agg(1,4)=a33der*xj
14435           agg(2,4)=a33der*yj
14436           agg(3,4)=a33der*zj
14437 ! Add the contributions coming from er
14438           fac3=-3.0d0*fac
14439           do k=1,3
14440             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14441             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14442             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14443             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14444           enddo
14445           do k=1,3
14446 ! Derivatives in DC(i)
14447 !grad            ghalf1=0.5d0*agg(k,1)
14448 !grad            ghalf2=0.5d0*agg(k,2)
14449 !grad            ghalf3=0.5d0*agg(k,3)
14450 !grad            ghalf4=0.5d0*agg(k,4)
14451             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14452             -3.0d0*uryg(k,2)*vry)!+ghalf1
14453             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14454             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14455             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14456             -3.0d0*urzg(k,2)*vry)!+ghalf3
14457             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14458             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14459 ! Derivatives in DC(i+1)
14460             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14461             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14462             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14463             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14464             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14465             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14466             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14467             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14468 ! Derivatives in DC(j)
14469             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14470             -3.0d0*vryg(k,2)*ury)!+ghalf1
14471             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14472             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14473             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14474             -3.0d0*vryg(k,2)*urz)!+ghalf3
14475             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14476             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14477 ! Derivatives in DC(j+1) or DC(nres-1)
14478             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14479             -3.0d0*vryg(k,3)*ury)
14480             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14481             -3.0d0*vrzg(k,3)*ury)
14482             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14483             -3.0d0*vryg(k,3)*urz)
14484             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14485             -3.0d0*vrzg(k,3)*urz)
14486 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14487 !grad              do l=1,4
14488 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14489 !grad              enddo
14490 !grad            endif
14491           enddo
14492           acipa(1,1)=a22
14493           acipa(1,2)=a23
14494           acipa(2,1)=a32
14495           acipa(2,2)=a33
14496           a22=-a22
14497           a23=-a23
14498           do l=1,2
14499             do k=1,3
14500               agg(k,l)=-agg(k,l)
14501               aggi(k,l)=-aggi(k,l)
14502               aggi1(k,l)=-aggi1(k,l)
14503               aggj(k,l)=-aggj(k,l)
14504               aggj1(k,l)=-aggj1(k,l)
14505             enddo
14506           enddo
14507           if (j.lt.nres-1) then
14508             a22=-a22
14509             a32=-a32
14510             do l=1,3,2
14511               do k=1,3
14512                 agg(k,l)=-agg(k,l)
14513                 aggi(k,l)=-aggi(k,l)
14514                 aggi1(k,l)=-aggi1(k,l)
14515                 aggj(k,l)=-aggj(k,l)
14516                 aggj1(k,l)=-aggj1(k,l)
14517               enddo
14518             enddo
14519           else
14520             a22=-a22
14521             a23=-a23
14522             a32=-a32
14523             a33=-a33
14524             do l=1,4
14525               do k=1,3
14526                 agg(k,l)=-agg(k,l)
14527                 aggi(k,l)=-aggi(k,l)
14528                 aggi1(k,l)=-aggi1(k,l)
14529                 aggj(k,l)=-aggj(k,l)
14530                 aggj1(k,l)=-aggj1(k,l)
14531               enddo
14532             enddo
14533           endif
14534           ENDIF ! WCORR
14535           IF (wel_loc.gt.0.0d0) THEN
14536 ! Contribution to the local-electrostatic energy coming from the i-j pair
14537           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14538            +a33*muij(4)
14539 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14540
14541           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14542                   'eelloc',i,j,eel_loc_ij
14543 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14544
14545           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14546 ! Partial derivatives in virtual-bond dihedral angles gamma
14547           if (i.gt.1) &
14548           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14549                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14550                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14551                  *sss_ele_cut
14552           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14553                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14554                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14555                  *sss_ele_cut
14556            xtemp(1)=xj
14557            xtemp(2)=yj
14558            xtemp(3)=zj
14559
14560 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14561           do l=1,3
14562             ggg(l)=(agg(l,1)*muij(1)+ &
14563                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14564             *sss_ele_cut &
14565              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14566
14567             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14568             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14569 !grad            ghalf=0.5d0*ggg(l)
14570 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14571 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14572           enddo
14573 !grad          do k=i+1,j2
14574 !grad            do l=1,3
14575 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14576 !grad            enddo
14577 !grad          enddo
14578 ! Remaining derivatives of eello
14579           do l=1,3
14580             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14581                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14582             *sss_ele_cut
14583
14584             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14585                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14586             *sss_ele_cut
14587
14588             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14589                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14590             *sss_ele_cut
14591
14592             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14593                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14594             *sss_ele_cut
14595
14596           enddo
14597           ENDIF
14598 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14599 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14600           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14601              .and. num_conti.le.maxconts) then
14602 !            write (iout,*) i,j," entered corr"
14603 !
14604 ! Calculate the contact function. The ith column of the array JCONT will
14605 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14606 ! greater than I). The arrays FACONT and GACONT will contain the values of
14607 ! the contact function and its derivative.
14608 !           r0ij=1.02D0*rpp(iteli,itelj)
14609 !           r0ij=1.11D0*rpp(iteli,itelj)
14610             r0ij=2.20D0*rpp(iteli,itelj)
14611 !           r0ij=1.55D0*rpp(iteli,itelj)
14612             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14613 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14614             if (fcont.gt.0.0D0) then
14615               num_conti=num_conti+1
14616               if (num_conti.gt.maxconts) then
14617 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14618                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14619                                ' will skip next contacts for this conf.',num_conti
14620               else
14621                 jcont_hb(num_conti,i)=j
14622 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14623 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14624                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14625                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14626 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14627 !  terms.
14628                 d_cont(num_conti,i)=rij
14629 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14630 !     --- Electrostatic-interaction matrix ---
14631                 a_chuj(1,1,num_conti,i)=a22
14632                 a_chuj(1,2,num_conti,i)=a23
14633                 a_chuj(2,1,num_conti,i)=a32
14634                 a_chuj(2,2,num_conti,i)=a33
14635 !     --- Gradient of rij
14636                 do kkk=1,3
14637                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14638                 enddo
14639                 kkll=0
14640                 do k=1,2
14641                   do l=1,2
14642                     kkll=kkll+1
14643                     do m=1,3
14644                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14645                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14646                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14647                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14648                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14649                     enddo
14650                   enddo
14651                 enddo
14652                 ENDIF
14653                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14654 ! Calculate contact energies
14655                 cosa4=4.0D0*cosa
14656                 wij=cosa-3.0D0*cosb*cosg
14657                 cosbg1=cosb+cosg
14658                 cosbg2=cosb-cosg
14659 !               fac3=dsqrt(-ael6i)/r0ij**3
14660                 fac3=dsqrt(-ael6i)*r3ij
14661 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14662                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14663                 if (ees0tmp.gt.0) then
14664                   ees0pij=dsqrt(ees0tmp)
14665                 else
14666                   ees0pij=0
14667                 endif
14668 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14669                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14670                 if (ees0tmp.gt.0) then
14671                   ees0mij=dsqrt(ees0tmp)
14672                 else
14673                   ees0mij=0
14674                 endif
14675 !               ees0mij=0.0D0
14676                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14677                      *sss_ele_cut
14678
14679                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14680                      *sss_ele_cut
14681
14682 ! Diagnostics. Comment out or remove after debugging!
14683 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14684 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14685 !               ees0m(num_conti,i)=0.0D0
14686 ! End diagnostics.
14687 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14688 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14689 ! Angular derivatives of the contact function
14690                 ees0pij1=fac3/ees0pij
14691                 ees0mij1=fac3/ees0mij
14692                 fac3p=-3.0D0*fac3*rrmij
14693                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14694                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14695 !               ees0mij1=0.0D0
14696                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14697                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14698                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14699                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14700                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14701                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14702                 ecosap=ecosa1+ecosa2
14703                 ecosbp=ecosb1+ecosb2
14704                 ecosgp=ecosg1+ecosg2
14705                 ecosam=ecosa1-ecosa2
14706                 ecosbm=ecosb1-ecosb2
14707                 ecosgm=ecosg1-ecosg2
14708 ! Diagnostics
14709 !               ecosap=ecosa1
14710 !               ecosbp=ecosb1
14711 !               ecosgp=ecosg1
14712 !               ecosam=0.0D0
14713 !               ecosbm=0.0D0
14714 !               ecosgm=0.0D0
14715 ! End diagnostics
14716                 facont_hb(num_conti,i)=fcont
14717                 fprimcont=fprimcont/rij
14718 !d              facont_hb(num_conti,i)=1.0D0
14719 ! Following line is for diagnostics.
14720 !d              fprimcont=0.0D0
14721                 do k=1,3
14722                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14723                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14724                 enddo
14725                 do k=1,3
14726                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14727                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14728                 enddo
14729 !                gggp(1)=gggp(1)+ees0pijp*xj
14730 !                gggp(2)=gggp(2)+ees0pijp*yj
14731 !                gggp(3)=gggp(3)+ees0pijp*zj
14732 !                gggm(1)=gggm(1)+ees0mijp*xj
14733 !                gggm(2)=gggm(2)+ees0mijp*yj
14734 !                gggm(3)=gggm(3)+ees0mijp*zj
14735                 gggp(1)=gggp(1)+ees0pijp*xj &
14736                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14737                 gggp(2)=gggp(2)+ees0pijp*yj &
14738                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14739                 gggp(3)=gggp(3)+ees0pijp*zj &
14740                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14741
14742                 gggm(1)=gggm(1)+ees0mijp*xj &
14743                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14744
14745                 gggm(2)=gggm(2)+ees0mijp*yj &
14746                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14747
14748                 gggm(3)=gggm(3)+ees0mijp*zj &
14749                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14750
14751 ! Derivatives due to the contact function
14752                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14753                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14754                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14755                 do k=1,3
14756 !
14757 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14758 !          following the change of gradient-summation algorithm.
14759 !
14760 !grad                  ghalfp=0.5D0*gggp(k)
14761 !grad                  ghalfm=0.5D0*gggm(k)
14762 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14763 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14764 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14765 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14766 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14767 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14768 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14769 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14770 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14771 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14772 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14773 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14774 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14775 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14776                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14777                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14778                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14779                      *sss_ele_cut
14780
14781                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14782                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14783                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14784                      *sss_ele_cut
14785
14786                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14787                      *sss_ele_cut
14788
14789                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14790                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14791                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14792                      *sss_ele_cut
14793
14794                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14795                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14796                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14797                      *sss_ele_cut
14798
14799                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14800                      *sss_ele_cut
14801
14802                 enddo
14803               ENDIF ! wcorr
14804               endif  ! num_conti.le.maxconts
14805             endif  ! fcont.gt.0
14806           endif    ! j.gt.i+1
14807           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14808             do k=1,4
14809               do l=1,3
14810                 ghalf=0.5d0*agg(l,k)
14811                 aggi(l,k)=aggi(l,k)+ghalf
14812                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14813                 aggj(l,k)=aggj(l,k)+ghalf
14814               enddo
14815             enddo
14816             if (j.eq.nres-1 .and. i.lt.j-2) then
14817               do k=1,4
14818                 do l=1,3
14819                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14820                 enddo
14821               enddo
14822             endif
14823           endif
14824  128      continue
14825 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14826       return
14827       end subroutine eelecij_scale
14828 !-----------------------------------------------------------------------------
14829       subroutine evdwpp_short(evdw1)
14830 !
14831 ! Compute Evdwpp
14832 !
14833 !      implicit real*8 (a-h,o-z)
14834 !      include 'DIMENSIONS'
14835 !      include 'COMMON.CONTROL'
14836 !      include 'COMMON.IOUNITS'
14837 !      include 'COMMON.GEO'
14838 !      include 'COMMON.VAR'
14839 !      include 'COMMON.LOCAL'
14840 !      include 'COMMON.CHAIN'
14841 !      include 'COMMON.DERIV'
14842 !      include 'COMMON.INTERACT'
14843 !      include 'COMMON.CONTACTS'
14844 !      include 'COMMON.TORSION'
14845 !      include 'COMMON.VECTORS'
14846 !      include 'COMMON.FFIELD'
14847       real(kind=8),dimension(3) :: ggg
14848 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14849 #ifdef MOMENT
14850       real(kind=8) :: scal_el=1.0d0
14851 #else
14852       real(kind=8) :: scal_el=0.5d0
14853 #endif
14854 !el local variables
14855       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14856       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14857       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14858                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14859                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14860       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14861                     dist_temp, dist_init,sss_grad
14862       integer xshift,yshift,zshift
14863
14864
14865       evdw1=0.0D0
14866 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14867 !     & " iatel_e_vdw",iatel_e_vdw
14868       call flush(iout)
14869       do i=iatel_s_vdw,iatel_e_vdw
14870         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14871         dxi=dc(1,i)
14872         dyi=dc(2,i)
14873         dzi=dc(3,i)
14874         dx_normi=dc_norm(1,i)
14875         dy_normi=dc_norm(2,i)
14876         dz_normi=dc_norm(3,i)
14877         xmedi=c(1,i)+0.5d0*dxi
14878         ymedi=c(2,i)+0.5d0*dyi
14879         zmedi=c(3,i)+0.5d0*dzi
14880           xmedi=dmod(xmedi,boxxsize)
14881           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14882           ymedi=dmod(ymedi,boxysize)
14883           if (ymedi.lt.0) ymedi=ymedi+boxysize
14884           zmedi=dmod(zmedi,boxzsize)
14885           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14886         num_conti=0
14887 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14888 !     &   ' ielend',ielend_vdw(i)
14889         call flush(iout)
14890         do j=ielstart_vdw(i),ielend_vdw(i)
14891           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14892 !el          ind=ind+1
14893           iteli=itel(i)
14894           itelj=itel(j)
14895           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14896           aaa=app(iteli,itelj)
14897           bbb=bpp(iteli,itelj)
14898           dxj=dc(1,j)
14899           dyj=dc(2,j)
14900           dzj=dc(3,j)
14901           dx_normj=dc_norm(1,j)
14902           dy_normj=dc_norm(2,j)
14903           dz_normj=dc_norm(3,j)
14904 !          xj=c(1,j)+0.5D0*dxj-xmedi
14905 !          yj=c(2,j)+0.5D0*dyj-ymedi
14906 !          zj=c(3,j)+0.5D0*dzj-zmedi
14907           xj=c(1,j)+0.5D0*dxj
14908           yj=c(2,j)+0.5D0*dyj
14909           zj=c(3,j)+0.5D0*dzj
14910           xj=mod(xj,boxxsize)
14911           if (xj.lt.0) xj=xj+boxxsize
14912           yj=mod(yj,boxysize)
14913           if (yj.lt.0) yj=yj+boxysize
14914           zj=mod(zj,boxzsize)
14915           if (zj.lt.0) zj=zj+boxzsize
14916       isubchap=0
14917       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14918       xj_safe=xj
14919       yj_safe=yj
14920       zj_safe=zj
14921       do xshift=-1,1
14922       do yshift=-1,1
14923       do zshift=-1,1
14924           xj=xj_safe+xshift*boxxsize
14925           yj=yj_safe+yshift*boxysize
14926           zj=zj_safe+zshift*boxzsize
14927           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14928           if(dist_temp.lt.dist_init) then
14929             dist_init=dist_temp
14930             xj_temp=xj
14931             yj_temp=yj
14932             zj_temp=zj
14933             isubchap=1
14934           endif
14935        enddo
14936        enddo
14937        enddo
14938        if (isubchap.eq.1) then
14939 !C          print *,i,j
14940           xj=xj_temp-xmedi
14941           yj=yj_temp-ymedi
14942           zj=zj_temp-zmedi
14943        else
14944           xj=xj_safe-xmedi
14945           yj=yj_safe-ymedi
14946           zj=zj_safe-zmedi
14947        endif
14948
14949           rij=xj*xj+yj*yj+zj*zj
14950           rrmij=1.0D0/rij
14951           rij=dsqrt(rij)
14952           sss=sscale(rij/rpp(iteli,itelj))
14953             sss_ele_cut=sscale_ele(rij)
14954             sss_ele_grad=sscagrad_ele(rij)
14955             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14956             if (sss_ele_cut.le.0.0) cycle
14957           if (sss.gt.0.0d0) then
14958             rmij=1.0D0/rij
14959             r3ij=rrmij*rmij
14960             r6ij=r3ij*r3ij
14961             ev1=aaa*r6ij*r6ij
14962 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14963             if (j.eq.i+2) ev1=scal_el*ev1
14964             ev2=bbb*r6ij
14965             evdwij=ev1+ev2
14966             if (energy_dec) then
14967               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14968             endif
14969             evdw1=evdw1+evdwij*sss*sss_ele_cut
14970 !
14971 ! Calculate contributions to the Cartesian gradient.
14972 !
14973             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14974 !            ggg(1)=facvdw*xj
14975 !            ggg(2)=facvdw*yj
14976 !            ggg(3)=facvdw*zj
14977           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14978           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14979           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14980           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14981           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14982           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14983
14984             do k=1,3
14985               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14986               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14987             enddo
14988           endif
14989         enddo ! j
14990       enddo   ! i
14991       return
14992       end subroutine evdwpp_short
14993 !-----------------------------------------------------------------------------
14994       subroutine escp_long(evdw2,evdw2_14)
14995 !
14996 ! This subroutine calculates the excluded-volume interaction energy between
14997 ! peptide-group centers and side chains and its gradient in virtual-bond and
14998 ! side-chain vectors.
14999 !
15000 !      implicit real*8 (a-h,o-z)
15001 !      include 'DIMENSIONS'
15002 !      include 'COMMON.GEO'
15003 !      include 'COMMON.VAR'
15004 !      include 'COMMON.LOCAL'
15005 !      include 'COMMON.CHAIN'
15006 !      include 'COMMON.DERIV'
15007 !      include 'COMMON.INTERACT'
15008 !      include 'COMMON.FFIELD'
15009 !      include 'COMMON.IOUNITS'
15010 !      include 'COMMON.CONTROL'
15011       real(kind=8),dimension(3) :: ggg
15012 !el local variables
15013       integer :: i,iint,j,k,iteli,itypj,subchap
15014       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15015       real(kind=8) :: evdw2,evdw2_14,evdwij
15016       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15017                     dist_temp, dist_init
15018
15019       evdw2=0.0D0
15020       evdw2_14=0.0d0
15021 !d    print '(a)','Enter ESCP'
15022 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15023       do i=iatscp_s,iatscp_e
15024         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15025         iteli=itel(i)
15026         xi=0.5D0*(c(1,i)+c(1,i+1))
15027         yi=0.5D0*(c(2,i)+c(2,i+1))
15028         zi=0.5D0*(c(3,i)+c(3,i+1))
15029           xi=mod(xi,boxxsize)
15030           if (xi.lt.0) xi=xi+boxxsize
15031           yi=mod(yi,boxysize)
15032           if (yi.lt.0) yi=yi+boxysize
15033           zi=mod(zi,boxzsize)
15034           if (zi.lt.0) zi=zi+boxzsize
15035
15036         do iint=1,nscp_gr(i)
15037
15038         do j=iscpstart(i,iint),iscpend(i,iint)
15039           itypj=itype(j,1)
15040           if (itypj.eq.ntyp1) cycle
15041 ! Uncomment following three lines for SC-p interactions
15042 !         xj=c(1,nres+j)-xi
15043 !         yj=c(2,nres+j)-yi
15044 !         zj=c(3,nres+j)-zi
15045 ! Uncomment following three lines for Ca-p interactions
15046           xj=c(1,j)
15047           yj=c(2,j)
15048           zj=c(3,j)
15049           xj=mod(xj,boxxsize)
15050           if (xj.lt.0) xj=xj+boxxsize
15051           yj=mod(yj,boxysize)
15052           if (yj.lt.0) yj=yj+boxysize
15053           zj=mod(zj,boxzsize)
15054           if (zj.lt.0) zj=zj+boxzsize
15055       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15056       xj_safe=xj
15057       yj_safe=yj
15058       zj_safe=zj
15059       subchap=0
15060       do xshift=-1,1
15061       do yshift=-1,1
15062       do zshift=-1,1
15063           xj=xj_safe+xshift*boxxsize
15064           yj=yj_safe+yshift*boxysize
15065           zj=zj_safe+zshift*boxzsize
15066           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15067           if(dist_temp.lt.dist_init) then
15068             dist_init=dist_temp
15069             xj_temp=xj
15070             yj_temp=yj
15071             zj_temp=zj
15072             subchap=1
15073           endif
15074        enddo
15075        enddo
15076        enddo
15077        if (subchap.eq.1) then
15078           xj=xj_temp-xi
15079           yj=yj_temp-yi
15080           zj=zj_temp-zi
15081        else
15082           xj=xj_safe-xi
15083           yj=yj_safe-yi
15084           zj=zj_safe-zi
15085        endif
15086           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15087
15088           rij=dsqrt(1.0d0/rrij)
15089             sss_ele_cut=sscale_ele(rij)
15090             sss_ele_grad=sscagrad_ele(rij)
15091 !            print *,sss_ele_cut,sss_ele_grad,&
15092 !            (rij),r_cut_ele,rlamb_ele
15093             if (sss_ele_cut.le.0.0) cycle
15094           sss=sscale((rij/rscp(itypj,iteli)))
15095           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15096           if (sss.lt.1.0d0) then
15097
15098             fac=rrij**expon2
15099             e1=fac*fac*aad(itypj,iteli)
15100             e2=fac*bad(itypj,iteli)
15101             if (iabs(j-i) .le. 2) then
15102               e1=scal14*e1
15103               e2=scal14*e2
15104               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15105             endif
15106             evdwij=e1+e2
15107             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15108             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15109                 'evdw2',i,j,sss,evdwij
15110 !
15111 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15112 !
15113             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15114             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15115             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15116             ggg(1)=xj*fac
15117             ggg(2)=yj*fac
15118             ggg(3)=zj*fac
15119 ! Uncomment following three lines for SC-p interactions
15120 !           do k=1,3
15121 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15122 !           enddo
15123 ! Uncomment following line for SC-p interactions
15124 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15125             do k=1,3
15126               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15127               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15128             enddo
15129           endif
15130         enddo
15131
15132         enddo ! iint
15133       enddo ! i
15134       do i=1,nct
15135         do j=1,3
15136           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15137           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15138           gradx_scp(j,i)=expon*gradx_scp(j,i)
15139         enddo
15140       enddo
15141 !******************************************************************************
15142 !
15143 !                              N O T E !!!
15144 !
15145 ! To save time the factor EXPON has been extracted from ALL components
15146 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15147 ! use!
15148 !
15149 !******************************************************************************
15150       return
15151       end subroutine escp_long
15152 !-----------------------------------------------------------------------------
15153       subroutine escp_short(evdw2,evdw2_14)
15154 !
15155 ! This subroutine calculates the excluded-volume interaction energy between
15156 ! peptide-group centers and side chains and its gradient in virtual-bond and
15157 ! side-chain vectors.
15158 !
15159 !      implicit real*8 (a-h,o-z)
15160 !      include 'DIMENSIONS'
15161 !      include 'COMMON.GEO'
15162 !      include 'COMMON.VAR'
15163 !      include 'COMMON.LOCAL'
15164 !      include 'COMMON.CHAIN'
15165 !      include 'COMMON.DERIV'
15166 !      include 'COMMON.INTERACT'
15167 !      include 'COMMON.FFIELD'
15168 !      include 'COMMON.IOUNITS'
15169 !      include 'COMMON.CONTROL'
15170       real(kind=8),dimension(3) :: ggg
15171 !el local variables
15172       integer :: i,iint,j,k,iteli,itypj,subchap
15173       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15174       real(kind=8) :: evdw2,evdw2_14,evdwij
15175       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15176                     dist_temp, dist_init
15177
15178       evdw2=0.0D0
15179       evdw2_14=0.0d0
15180 !d    print '(a)','Enter ESCP'
15181 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15182       do i=iatscp_s,iatscp_e
15183         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15184         iteli=itel(i)
15185         xi=0.5D0*(c(1,i)+c(1,i+1))
15186         yi=0.5D0*(c(2,i)+c(2,i+1))
15187         zi=0.5D0*(c(3,i)+c(3,i+1))
15188           xi=mod(xi,boxxsize)
15189           if (xi.lt.0) xi=xi+boxxsize
15190           yi=mod(yi,boxysize)
15191           if (yi.lt.0) yi=yi+boxysize
15192           zi=mod(zi,boxzsize)
15193           if (zi.lt.0) zi=zi+boxzsize
15194
15195         do iint=1,nscp_gr(i)
15196
15197         do j=iscpstart(i,iint),iscpend(i,iint)
15198           itypj=itype(j,1)
15199           if (itypj.eq.ntyp1) cycle
15200 ! Uncomment following three lines for SC-p interactions
15201 !         xj=c(1,nres+j)-xi
15202 !         yj=c(2,nres+j)-yi
15203 !         zj=c(3,nres+j)-zi
15204 ! Uncomment following three lines for Ca-p interactions
15205 !          xj=c(1,j)-xi
15206 !          yj=c(2,j)-yi
15207 !          zj=c(3,j)-zi
15208           xj=c(1,j)
15209           yj=c(2,j)
15210           zj=c(3,j)
15211           xj=mod(xj,boxxsize)
15212           if (xj.lt.0) xj=xj+boxxsize
15213           yj=mod(yj,boxysize)
15214           if (yj.lt.0) yj=yj+boxysize
15215           zj=mod(zj,boxzsize)
15216           if (zj.lt.0) zj=zj+boxzsize
15217       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15218       xj_safe=xj
15219       yj_safe=yj
15220       zj_safe=zj
15221       subchap=0
15222       do xshift=-1,1
15223       do yshift=-1,1
15224       do zshift=-1,1
15225           xj=xj_safe+xshift*boxxsize
15226           yj=yj_safe+yshift*boxysize
15227           zj=zj_safe+zshift*boxzsize
15228           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15229           if(dist_temp.lt.dist_init) then
15230             dist_init=dist_temp
15231             xj_temp=xj
15232             yj_temp=yj
15233             zj_temp=zj
15234             subchap=1
15235           endif
15236        enddo
15237        enddo
15238        enddo
15239        if (subchap.eq.1) then
15240           xj=xj_temp-xi
15241           yj=yj_temp-yi
15242           zj=zj_temp-zi
15243        else
15244           xj=xj_safe-xi
15245           yj=yj_safe-yi
15246           zj=zj_safe-zi
15247        endif
15248
15249           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15250           rij=dsqrt(1.0d0/rrij)
15251             sss_ele_cut=sscale_ele(rij)
15252             sss_ele_grad=sscagrad_ele(rij)
15253 !            print *,sss_ele_cut,sss_ele_grad,&
15254 !            (rij),r_cut_ele,rlamb_ele
15255             if (sss_ele_cut.le.0.0) cycle
15256           sss=sscale(rij/rscp(itypj,iteli))
15257           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15258           if (sss.gt.0.0d0) then
15259
15260             fac=rrij**expon2
15261             e1=fac*fac*aad(itypj,iteli)
15262             e2=fac*bad(itypj,iteli)
15263             if (iabs(j-i) .le. 2) then
15264               e1=scal14*e1
15265               e2=scal14*e2
15266               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15267             endif
15268             evdwij=e1+e2
15269             evdw2=evdw2+evdwij*sss*sss_ele_cut
15270             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15271                 'evdw2',i,j,sss,evdwij
15272 !
15273 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15274 !
15275             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15276             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15277             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15278
15279             ggg(1)=xj*fac
15280             ggg(2)=yj*fac
15281             ggg(3)=zj*fac
15282 ! Uncomment following three lines for SC-p interactions
15283 !           do k=1,3
15284 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15285 !           enddo
15286 ! Uncomment following line for SC-p interactions
15287 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15288             do k=1,3
15289               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15290               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15291             enddo
15292           endif
15293         enddo
15294
15295         enddo ! iint
15296       enddo ! i
15297       do i=1,nct
15298         do j=1,3
15299           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15300           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15301           gradx_scp(j,i)=expon*gradx_scp(j,i)
15302         enddo
15303       enddo
15304 !******************************************************************************
15305 !
15306 !                              N O T E !!!
15307 !
15308 ! To save time the factor EXPON has been extracted from ALL components
15309 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15310 ! use!
15311 !
15312 !******************************************************************************
15313       return
15314       end subroutine escp_short
15315 !-----------------------------------------------------------------------------
15316 ! energy_p_new-sep_barrier.F
15317 !-----------------------------------------------------------------------------
15318       subroutine sc_grad_scale(scalfac)
15319 !      implicit real*8 (a-h,o-z)
15320       use calc_data
15321 !      include 'DIMENSIONS'
15322 !      include 'COMMON.CHAIN'
15323 !      include 'COMMON.DERIV'
15324 !      include 'COMMON.CALC'
15325 !      include 'COMMON.IOUNITS'
15326       real(kind=8),dimension(3) :: dcosom1,dcosom2
15327       real(kind=8) :: scalfac
15328 !el local variables
15329 !      integer :: i,j,k,l
15330
15331       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15332       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15333       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15334            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15335 ! diagnostics only
15336 !      eom1=0.0d0
15337 !      eom2=0.0d0
15338 !      eom12=evdwij*eps1_om12
15339 ! end diagnostics
15340 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15341 !     &  " sigder",sigder
15342 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15343 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15344       do k=1,3
15345         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15346         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15347       enddo
15348       do k=1,3
15349         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15350          *sss_ele_cut
15351       enddo
15352 !      write (iout,*) "gg",(gg(k),k=1,3)
15353       do k=1,3
15354         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15355                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15356                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15357                  *sss_ele_cut
15358         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15359                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15360                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15361          *sss_ele_cut
15362 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15363 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15364 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15365 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15366       enddo
15367 !
15368 ! Calculate the components of the gradient in DC and X
15369 !
15370       do l=1,3
15371         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15372         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15373       enddo
15374       return
15375       end subroutine sc_grad_scale
15376 !-----------------------------------------------------------------------------
15377 ! energy_split-sep.F
15378 !-----------------------------------------------------------------------------
15379       subroutine etotal_long(energia)
15380 !
15381 ! Compute the long-range slow-varying contributions to the energy
15382 !
15383 !      implicit real*8 (a-h,o-z)
15384 !      include 'DIMENSIONS'
15385       use MD_data, only: totT,usampl,eq_time
15386 #ifndef ISNAN
15387       external proc_proc
15388 #ifdef WINPGI
15389 !MS$ATTRIBUTES C ::  proc_proc
15390 #endif
15391 #endif
15392 #ifdef MPI
15393       include "mpif.h"
15394       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15395 #endif
15396 !      include 'COMMON.SETUP'
15397 !      include 'COMMON.IOUNITS'
15398 !      include 'COMMON.FFIELD'
15399 !      include 'COMMON.DERIV'
15400 !      include 'COMMON.INTERACT'
15401 !      include 'COMMON.SBRIDGE'
15402 !      include 'COMMON.CHAIN'
15403 !      include 'COMMON.VAR'
15404 !      include 'COMMON.LOCAL'
15405 !      include 'COMMON.MD'
15406       real(kind=8),dimension(0:n_ene) :: energia
15407 !el local variables
15408       integer :: i,n_corr,n_corr1,ierror,ierr
15409       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15410                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15411                   ecorr,ecorr5,ecorr6,eturn6,time00
15412 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15413 !elwrite(iout,*)"in etotal long"
15414
15415       if (modecalc.eq.12.or.modecalc.eq.14) then
15416 #ifdef MPI
15417 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15418 #else
15419         call int_from_cart1(.false.)
15420 #endif
15421       endif
15422 !elwrite(iout,*)"in etotal long"
15423
15424 #ifdef MPI
15425 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15426 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15427       call flush(iout)
15428       if (nfgtasks.gt.1) then
15429         time00=MPI_Wtime()
15430 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15431         if (fg_rank.eq.0) then
15432           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15433 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15434 !          call flush(iout)
15435 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15436 ! FG slaves as WEIGHTS array.
15437           weights_(1)=wsc
15438           weights_(2)=wscp
15439           weights_(3)=welec
15440           weights_(4)=wcorr
15441           weights_(5)=wcorr5
15442           weights_(6)=wcorr6
15443           weights_(7)=wel_loc
15444           weights_(8)=wturn3
15445           weights_(9)=wturn4
15446           weights_(10)=wturn6
15447           weights_(11)=wang
15448           weights_(12)=wscloc
15449           weights_(13)=wtor
15450           weights_(14)=wtor_d
15451           weights_(15)=wstrain
15452           weights_(16)=wvdwpp
15453           weights_(17)=wbond
15454           weights_(18)=scal14
15455           weights_(21)=wsccor
15456 ! FG Master broadcasts the WEIGHTS_ array
15457           call MPI_Bcast(weights_(1),n_ene,&
15458               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15459         else
15460 ! FG slaves receive the WEIGHTS array
15461           call MPI_Bcast(weights(1),n_ene,&
15462               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15463           wsc=weights(1)
15464           wscp=weights(2)
15465           welec=weights(3)
15466           wcorr=weights(4)
15467           wcorr5=weights(5)
15468           wcorr6=weights(6)
15469           wel_loc=weights(7)
15470           wturn3=weights(8)
15471           wturn4=weights(9)
15472           wturn6=weights(10)
15473           wang=weights(11)
15474           wscloc=weights(12)
15475           wtor=weights(13)
15476           wtor_d=weights(14)
15477           wstrain=weights(15)
15478           wvdwpp=weights(16)
15479           wbond=weights(17)
15480           scal14=weights(18)
15481           wsccor=weights(21)
15482         endif
15483         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15484           king,FG_COMM,IERR)
15485          time_Bcast=time_Bcast+MPI_Wtime()-time00
15486          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15487 !        call chainbuild_cart
15488 !        call int_from_cart1(.false.)
15489       endif
15490 !      write (iout,*) 'Processor',myrank,
15491 !     &  ' calling etotal_short ipot=',ipot
15492 !      call flush(iout)
15493 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15494 #endif
15495 !d    print *,'nnt=',nnt,' nct=',nct
15496 !
15497 !elwrite(iout,*)"in etotal long"
15498 ! Compute the side-chain and electrostatic interaction energy
15499 !
15500       goto (101,102,103,104,105,106) ipot
15501 ! Lennard-Jones potential.
15502   101 call elj_long(evdw)
15503 !d    print '(a)','Exit ELJ'
15504       goto 107
15505 ! Lennard-Jones-Kihara potential (shifted).
15506   102 call eljk_long(evdw)
15507       goto 107
15508 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15509   103 call ebp_long(evdw)
15510       goto 107
15511 ! Gay-Berne potential (shifted LJ, angular dependence).
15512   104 call egb_long(evdw)
15513       goto 107
15514 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15515   105 call egbv_long(evdw)
15516       goto 107
15517 ! Soft-sphere potential
15518   106 call e_softsphere(evdw)
15519 !
15520 ! Calculate electrostatic (H-bonding) energy of the main chain.
15521 !
15522   107 continue
15523       call vec_and_deriv
15524       if (ipot.lt.6) then
15525 #ifdef SPLITELE
15526          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15527              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15528              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15529              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15530 #else
15531          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15532              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15533              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15534              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15535 #endif
15536            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15537          else
15538             ees=0
15539             evdw1=0
15540             eel_loc=0
15541             eello_turn3=0
15542             eello_turn4=0
15543          endif
15544       else
15545 !        write (iout,*) "Soft-spheer ELEC potential"
15546         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15547          eello_turn4)
15548       endif
15549 !
15550 ! Calculate excluded-volume interaction energy between peptide groups
15551 ! and side chains.
15552 !
15553       if (ipot.lt.6) then
15554        if(wscp.gt.0d0) then
15555         call escp_long(evdw2,evdw2_14)
15556        else
15557         evdw2=0
15558         evdw2_14=0
15559        endif
15560       else
15561         call escp_soft_sphere(evdw2,evdw2_14)
15562       endif
15563 !
15564 ! 12/1/95 Multi-body terms
15565 !
15566       n_corr=0
15567       n_corr1=0
15568       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15569           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15570          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15571 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15572 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15573       else
15574          ecorr=0.0d0
15575          ecorr5=0.0d0
15576          ecorr6=0.0d0
15577          eturn6=0.0d0
15578       endif
15579       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15580          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15581       endif
15582 !
15583 ! If performing constraint dynamics, call the constraint energy
15584 !  after the equilibration time
15585       if(usampl.and.totT.gt.eq_time) then
15586          call EconstrQ
15587          call Econstr_back
15588       else
15589          Uconst=0.0d0
15590          Uconst_back=0.0d0
15591       endif
15592 !
15593 ! Sum the energies
15594 !
15595       do i=1,n_ene
15596         energia(i)=0.0d0
15597       enddo
15598       energia(1)=evdw
15599 #ifdef SCP14
15600       energia(2)=evdw2-evdw2_14
15601       energia(18)=evdw2_14
15602 #else
15603       energia(2)=evdw2
15604       energia(18)=0.0d0
15605 #endif
15606 #ifdef SPLITELE
15607       energia(3)=ees
15608       energia(16)=evdw1
15609 #else
15610       energia(3)=ees+evdw1
15611       energia(16)=0.0d0
15612 #endif
15613       energia(4)=ecorr
15614       energia(5)=ecorr5
15615       energia(6)=ecorr6
15616       energia(7)=eel_loc
15617       energia(8)=eello_turn3
15618       energia(9)=eello_turn4
15619       energia(10)=eturn6
15620       energia(20)=Uconst+Uconst_back
15621       call sum_energy(energia,.true.)
15622 !      write (iout,*) "Exit ETOTAL_LONG"
15623       call flush(iout)
15624       return
15625       end subroutine etotal_long
15626 !-----------------------------------------------------------------------------
15627       subroutine etotal_short(energia)
15628 !
15629 ! Compute the short-range fast-varying contributions to the energy
15630 !
15631 !      implicit real*8 (a-h,o-z)
15632 !      include 'DIMENSIONS'
15633 #ifndef ISNAN
15634       external proc_proc
15635 #ifdef WINPGI
15636 !MS$ATTRIBUTES C ::  proc_proc
15637 #endif
15638 #endif
15639 #ifdef MPI
15640       include "mpif.h"
15641       integer :: ierror,ierr
15642       real(kind=8),dimension(n_ene) :: weights_
15643       real(kind=8) :: time00
15644 #endif
15645 !      include 'COMMON.SETUP'
15646 !      include 'COMMON.IOUNITS'
15647 !      include 'COMMON.FFIELD'
15648 !      include 'COMMON.DERIV'
15649 !      include 'COMMON.INTERACT'
15650 !      include 'COMMON.SBRIDGE'
15651 !      include 'COMMON.CHAIN'
15652 !      include 'COMMON.VAR'
15653 !      include 'COMMON.LOCAL'
15654       real(kind=8),dimension(0:n_ene) :: energia
15655 !el local variables
15656       integer :: i,nres6
15657       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15658       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15659       nres6=6*nres
15660
15661 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15662 !      call flush(iout)
15663       if (modecalc.eq.12.or.modecalc.eq.14) then
15664 #ifdef MPI
15665         if (fg_rank.eq.0) call int_from_cart1(.false.)
15666 #else
15667         call int_from_cart1(.false.)
15668 #endif
15669       endif
15670 #ifdef MPI
15671 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15672 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15673 !      call flush(iout)
15674       if (nfgtasks.gt.1) then
15675         time00=MPI_Wtime()
15676 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15677         if (fg_rank.eq.0) then
15678           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15679 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15680 !          call flush(iout)
15681 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15682 ! FG slaves as WEIGHTS array.
15683           weights_(1)=wsc
15684           weights_(2)=wscp
15685           weights_(3)=welec
15686           weights_(4)=wcorr
15687           weights_(5)=wcorr5
15688           weights_(6)=wcorr6
15689           weights_(7)=wel_loc
15690           weights_(8)=wturn3
15691           weights_(9)=wturn4
15692           weights_(10)=wturn6
15693           weights_(11)=wang
15694           weights_(12)=wscloc
15695           weights_(13)=wtor
15696           weights_(14)=wtor_d
15697           weights_(15)=wstrain
15698           weights_(16)=wvdwpp
15699           weights_(17)=wbond
15700           weights_(18)=scal14
15701           weights_(21)=wsccor
15702 ! FG Master broadcasts the WEIGHTS_ array
15703           call MPI_Bcast(weights_(1),n_ene,&
15704               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15705         else
15706 ! FG slaves receive the WEIGHTS array
15707           call MPI_Bcast(weights(1),n_ene,&
15708               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15709           wsc=weights(1)
15710           wscp=weights(2)
15711           welec=weights(3)
15712           wcorr=weights(4)
15713           wcorr5=weights(5)
15714           wcorr6=weights(6)
15715           wel_loc=weights(7)
15716           wturn3=weights(8)
15717           wturn4=weights(9)
15718           wturn6=weights(10)
15719           wang=weights(11)
15720           wscloc=weights(12)
15721           wtor=weights(13)
15722           wtor_d=weights(14)
15723           wstrain=weights(15)
15724           wvdwpp=weights(16)
15725           wbond=weights(17)
15726           scal14=weights(18)
15727           wsccor=weights(21)
15728         endif
15729 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15730         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15731           king,FG_COMM,IERR)
15732 !        write (iout,*) "Processor",myrank," BROADCAST c"
15733         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15734           king,FG_COMM,IERR)
15735 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15736         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15737           king,FG_COMM,IERR)
15738 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15739         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15740           king,FG_COMM,IERR)
15741 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15742         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15743           king,FG_COMM,IERR)
15744 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15745         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15746           king,FG_COMM,IERR)
15747 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15748         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15749           king,FG_COMM,IERR)
15750 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15751         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15752           king,FG_COMM,IERR)
15753 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15754         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15755           king,FG_COMM,IERR)
15756          time_Bcast=time_Bcast+MPI_Wtime()-time00
15757 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15758       endif
15759 !      write (iout,*) 'Processor',myrank,
15760 !     &  ' calling etotal_short ipot=',ipot
15761 !      call flush(iout)
15762 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15763 #endif
15764 !      call int_from_cart1(.false.)
15765 !
15766 ! Compute the side-chain and electrostatic interaction energy
15767 !
15768       goto (101,102,103,104,105,106) ipot
15769 ! Lennard-Jones potential.
15770   101 call elj_short(evdw)
15771 !d    print '(a)','Exit ELJ'
15772       goto 107
15773 ! Lennard-Jones-Kihara potential (shifted).
15774   102 call eljk_short(evdw)
15775       goto 107
15776 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15777   103 call ebp_short(evdw)
15778       goto 107
15779 ! Gay-Berne potential (shifted LJ, angular dependence).
15780   104 call egb_short(evdw)
15781       goto 107
15782 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15783   105 call egbv_short(evdw)
15784       goto 107
15785 ! Soft-sphere potential - already dealt with in the long-range part
15786   106 evdw=0.0d0
15787 !  106 call e_softsphere_short(evdw)
15788 !
15789 ! Calculate electrostatic (H-bonding) energy of the main chain.
15790 !
15791   107 continue
15792 !
15793 ! Calculate the short-range part of Evdwpp
15794 !
15795       call evdwpp_short(evdw1)
15796 !
15797 ! Calculate the short-range part of ESCp
15798 !
15799       if (ipot.lt.6) then
15800         call escp_short(evdw2,evdw2_14)
15801       endif
15802 !
15803 ! Calculate the bond-stretching energy
15804 !
15805       call ebond(estr)
15806 !
15807 ! Calculate the disulfide-bridge and other energy and the contributions
15808 ! from other distance constraints.
15809       call edis(ehpb)
15810 !
15811 ! Calculate the virtual-bond-angle energy.
15812 !
15813       call ebend(ebe,ethetacnstr)
15814 !
15815 ! Calculate the SC local energy.
15816 !
15817       call vec_and_deriv
15818       call esc(escloc)
15819 !
15820 ! Calculate the virtual-bond torsional energy.
15821 !
15822       call etor(etors,edihcnstr)
15823 !
15824 ! 6/23/01 Calculate double-torsional energy
15825 !
15826       call etor_d(etors_d)
15827 !
15828 ! 21/5/07 Calculate local sicdechain correlation energy
15829 !
15830       if (wsccor.gt.0.0d0) then
15831         call eback_sc_corr(esccor)
15832       else
15833         esccor=0.0d0
15834       endif
15835 !
15836 ! Put energy components into an array
15837 !
15838       do i=1,n_ene
15839         energia(i)=0.0d0
15840       enddo
15841       energia(1)=evdw
15842 #ifdef SCP14
15843       energia(2)=evdw2-evdw2_14
15844       energia(18)=evdw2_14
15845 #else
15846       energia(2)=evdw2
15847       energia(18)=0.0d0
15848 #endif
15849 #ifdef SPLITELE
15850       energia(16)=evdw1
15851 #else
15852       energia(3)=evdw1
15853 #endif
15854       energia(11)=ebe
15855       energia(12)=escloc
15856       energia(13)=etors
15857       energia(14)=etors_d
15858       energia(15)=ehpb
15859       energia(17)=estr
15860       energia(19)=edihcnstr
15861       energia(21)=esccor
15862 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15863       call flush(iout)
15864       call sum_energy(energia,.true.)
15865 !      write (iout,*) "Exit ETOTAL_SHORT"
15866       call flush(iout)
15867       return
15868       end subroutine etotal_short
15869 !-----------------------------------------------------------------------------
15870 ! gnmr1.f
15871 !-----------------------------------------------------------------------------
15872       real(kind=8) function gnmr1(y,ymin,ymax)
15873 !      implicit none
15874       real(kind=8) :: y,ymin,ymax
15875       real(kind=8) :: wykl=4.0d0
15876       if (y.lt.ymin) then
15877         gnmr1=(ymin-y)**wykl/wykl
15878       else if (y.gt.ymax) then
15879         gnmr1=(y-ymax)**wykl/wykl
15880       else
15881         gnmr1=0.0d0
15882       endif
15883       return
15884       end function gnmr1
15885 !-----------------------------------------------------------------------------
15886       real(kind=8) function gnmr1prim(y,ymin,ymax)
15887 !      implicit none
15888       real(kind=8) :: y,ymin,ymax
15889       real(kind=8) :: wykl=4.0d0
15890       if (y.lt.ymin) then
15891         gnmr1prim=-(ymin-y)**(wykl-1)
15892       else if (y.gt.ymax) then
15893         gnmr1prim=(y-ymax)**(wykl-1)
15894       else
15895         gnmr1prim=0.0d0
15896       endif
15897       return
15898       end function gnmr1prim
15899 !----------------------------------------------------------------------------
15900       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15901       real(kind=8) y,ymin,ymax,sigma
15902       real(kind=8) wykl /4.0d0/
15903       if (y.lt.ymin) then
15904         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15905       else if (y.gt.ymax) then
15906         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15907       else
15908         rlornmr1=0.0d0
15909       endif
15910       return
15911       end function rlornmr1
15912 !------------------------------------------------------------------------------
15913       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15914       real(kind=8) y,ymin,ymax,sigma
15915       real(kind=8) wykl /4.0d0/
15916       if (y.lt.ymin) then
15917         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15918         ((ymin-y)**wykl+sigma**wykl)**2
15919       else if (y.gt.ymax) then
15920         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15921         ((y-ymax)**wykl+sigma**wykl)**2
15922       else
15923         rlornmr1prim=0.0d0
15924       endif
15925       return
15926       end function rlornmr1prim
15927
15928       real(kind=8) function harmonic(y,ymax)
15929 !      implicit none
15930       real(kind=8) :: y,ymax
15931       real(kind=8) :: wykl=2.0d0
15932       harmonic=(y-ymax)**wykl
15933       return
15934       end function harmonic
15935 !-----------------------------------------------------------------------------
15936       real(kind=8) function harmonicprim(y,ymax)
15937       real(kind=8) :: y,ymin,ymax
15938       real(kind=8) :: wykl=2.0d0
15939       harmonicprim=(y-ymax)*wykl
15940       return
15941       end function harmonicprim
15942 !-----------------------------------------------------------------------------
15943 ! gradient_p.F
15944 !-----------------------------------------------------------------------------
15945       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15946
15947       use io_base, only:intout,briefout
15948 !      implicit real*8 (a-h,o-z)
15949 !      include 'DIMENSIONS'
15950 !      include 'COMMON.CHAIN'
15951 !      include 'COMMON.DERIV'
15952 !      include 'COMMON.VAR'
15953 !      include 'COMMON.INTERACT'
15954 !      include 'COMMON.FFIELD'
15955 !      include 'COMMON.MD'
15956 !      include 'COMMON.IOUNITS'
15957       real(kind=8),external :: ufparm
15958       integer :: uiparm(1)
15959       real(kind=8) :: urparm(1)
15960       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15961       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15962       integer :: n,nf,ind,ind1,i,k,j
15963 !
15964 ! This subroutine calculates total internal coordinate gradient.
15965 ! Depending on the number of function evaluations, either whole energy
15966 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15967 ! internal coordinates are reevaluated or only the cartesian-in-internal
15968 ! coordinate derivatives are evaluated. The subroutine was designed to work
15969 ! with SUMSL.
15970 !
15971 !
15972       icg=mod(nf,2)+1
15973
15974 !d      print *,'grad',nf,icg
15975       if (nf-nfl+1) 20,30,40
15976    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15977 !    write (iout,*) 'grad 20'
15978       if (nf.eq.0) return
15979       goto 40
15980    30 call var_to_geom(n,x)
15981       call chainbuild
15982 !    write (iout,*) 'grad 30'
15983 !
15984 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15985 !
15986    40 call cartder
15987 !     write (iout,*) 'grad 40'
15988 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15989 !
15990 ! Convert the Cartesian gradient into internal-coordinate gradient.
15991 !
15992       ind=0
15993       ind1=0
15994       do i=1,nres-2
15995         gthetai=0.0D0
15996         gphii=0.0D0
15997         do j=i+1,nres-1
15998           ind=ind+1
15999 !         ind=indmat(i,j)
16000 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16001           do k=1,3
16002             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16003           enddo
16004           do k=1,3
16005             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16006           enddo
16007         enddo
16008         do j=i+1,nres-1
16009           ind1=ind1+1
16010 !         ind1=indmat(i,j)
16011 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16012           do k=1,3
16013             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16014             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16015           enddo
16016         enddo
16017         if (i.gt.1) g(i-1)=gphii
16018         if (n.gt.nphi) g(nphi+i)=gthetai
16019       enddo
16020       if (n.le.nphi+ntheta) goto 10
16021       do i=2,nres-1
16022         if (itype(i,1).ne.10) then
16023           galphai=0.0D0
16024           gomegai=0.0D0
16025           do k=1,3
16026             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16027           enddo
16028           do k=1,3
16029             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16030           enddo
16031           g(ialph(i,1))=galphai
16032           g(ialph(i,1)+nside)=gomegai
16033         endif
16034       enddo
16035 !
16036 ! Add the components corresponding to local energy terms.
16037 !
16038    10 continue
16039       do i=1,nvar
16040 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16041         g(i)=g(i)+gloc(i,icg)
16042       enddo
16043 ! Uncomment following three lines for diagnostics.
16044 !d    call intout
16045 !elwrite(iout,*) "in gradient after calling intout"
16046 !d    call briefout(0,0.0d0)
16047 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16048       return
16049       end subroutine gradient
16050 !-----------------------------------------------------------------------------
16051       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16052
16053       use comm_chu
16054 !      implicit real*8 (a-h,o-z)
16055 !      include 'DIMENSIONS'
16056 !      include 'COMMON.DERIV'
16057 !      include 'COMMON.IOUNITS'
16058 !      include 'COMMON.GEO'
16059       integer :: n,nf
16060 !el      integer :: jjj
16061 !el      common /chuju/ jjj
16062       real(kind=8) :: energia(0:n_ene)
16063       integer :: uiparm(1)
16064       real(kind=8) :: urparm(1)
16065       real(kind=8) :: f
16066       real(kind=8),external :: ufparm
16067       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
16068 !     if (jjj.gt.0) then
16069 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16070 !     endif
16071       nfl=nf
16072       icg=mod(nf,2)+1
16073 !d      print *,'func',nf,nfl,icg
16074       call var_to_geom(n,x)
16075       call zerograd
16076       call chainbuild
16077 !d    write (iout,*) 'ETOTAL called from FUNC'
16078       call etotal(energia)
16079       call sum_gradient
16080       f=energia(0)
16081 !     if (jjj.gt.0) then
16082 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16083 !       write (iout,*) 'f=',etot
16084 !       jjj=0
16085 !     endif
16086       return
16087       end subroutine func
16088 !-----------------------------------------------------------------------------
16089       subroutine cartgrad
16090 !      implicit real*8 (a-h,o-z)
16091 !      include 'DIMENSIONS'
16092       use energy_data
16093       use MD_data, only: totT,usampl,eq_time
16094 #ifdef MPI
16095       include 'mpif.h'
16096 #endif
16097 !      include 'COMMON.CHAIN'
16098 !      include 'COMMON.DERIV'
16099 !      include 'COMMON.VAR'
16100 !      include 'COMMON.INTERACT'
16101 !      include 'COMMON.FFIELD'
16102 !      include 'COMMON.MD'
16103 !      include 'COMMON.IOUNITS'
16104 !      include 'COMMON.TIME1'
16105 !
16106       integer :: i,j
16107
16108 ! This subrouting calculates total Cartesian coordinate gradient.
16109 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16110 !
16111 !el#define DEBUG
16112 #ifdef TIMING
16113       time00=MPI_Wtime()
16114 #endif
16115       icg=1
16116       call sum_gradient
16117 #ifdef TIMING
16118 #endif
16119 !el      write (iout,*) "After sum_gradient"
16120 #ifdef DEBUG
16121 !el      write (iout,*) "After sum_gradient"
16122       do i=1,nres-1
16123         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16124         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16125       enddo
16126 #endif
16127 ! If performing constraint dynamics, add the gradients of the constraint energy
16128       if(usampl.and.totT.gt.eq_time) then
16129          do i=1,nct
16130            do j=1,3
16131              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16132              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16133            enddo
16134          enddo
16135          do i=1,nres-3
16136            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16137          enddo
16138          do i=1,nres-2
16139            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16140          enddo
16141       endif
16142 !elwrite (iout,*) "After sum_gradient"
16143 #ifdef TIMING
16144       time01=MPI_Wtime()
16145 #endif
16146       call intcartderiv
16147 !elwrite (iout,*) "After sum_gradient"
16148 #ifdef TIMING
16149       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16150 #endif
16151 !     call checkintcartgrad
16152 !     write(iout,*) 'calling int_to_cart'
16153 #ifdef DEBUG
16154       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16155 #endif
16156       do i=0,nct
16157         do j=1,3
16158           gcart(j,i)=gradc(j,i,icg)
16159           gxcart(j,i)=gradx(j,i,icg)
16160 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16161         enddo
16162 #ifdef DEBUG
16163         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16164           (gxcart(j,i),j=1,3),gloc(i,icg)
16165 #endif
16166       enddo
16167 #ifdef TIMING
16168       time01=MPI_Wtime()
16169 #endif
16170       call int_to_cart
16171 !       print *,"gcart_two",gcart(2,2),gradc(2,2,icg)
16172
16173 #ifdef TIMING
16174       time_inttocart=time_inttocart+MPI_Wtime()-time01
16175 #endif
16176 #ifdef DEBUG
16177       write (iout,*) "gcart and gxcart after int_to_cart"
16178       do i=0,nres-1
16179         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16180             (gxcart(j,i),j=1,3)
16181       enddo
16182 #endif
16183 #ifdef CARGRAD
16184 #ifdef DEBUG
16185       write (iout,*) "CARGRAD"
16186 #endif
16187       do i=nres,0,-1
16188         do j=1,3
16189           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16190 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16191         enddo
16192 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16193 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16194       enddo
16195 ! Correction: dummy residues
16196         if (nnt.gt.1) then
16197           do j=1,3
16198 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16199             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16200           enddo
16201         endif
16202         if (nct.lt.nres) then
16203           do j=1,3
16204 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16205             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16206           enddo
16207         endif
16208 #endif
16209 #ifdef TIMING
16210       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16211 #endif
16212 !el#undef DEBUG
16213       return
16214       end subroutine cartgrad
16215 !-----------------------------------------------------------------------------
16216       subroutine zerograd
16217 !      implicit real*8 (a-h,o-z)
16218 !      include 'DIMENSIONS'
16219 !      include 'COMMON.DERIV'
16220 !      include 'COMMON.CHAIN'
16221 !      include 'COMMON.VAR'
16222 !      include 'COMMON.MD'
16223 !      include 'COMMON.SCCOR'
16224 !
16225 !el local variables
16226       integer :: i,j,intertyp,k
16227 ! Initialize Cartesian-coordinate gradient
16228 !
16229 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16230 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16231
16232 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16233 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16234 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16235 !      allocate(gradcorr_long(3,nres))
16236 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16237 !      allocate(gcorr6_turn_long(3,nres))
16238 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16239
16240 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16241
16242 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16243 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16244
16245 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16246 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16247
16248 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16249 !      allocate(gscloc(3,nres)) !(3,maxres)
16250 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16251
16252
16253
16254 !      common /deriv_scloc/
16255 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16256 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16257 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
16258 !      common /mpgrad/
16259 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16260
16261
16262
16263 !          gradc(j,i,icg)=0.0d0
16264 !          gradx(j,i,icg)=0.0d0
16265
16266 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16267 !elwrite(iout,*) "icg",icg
16268       do i=-1,nres
16269         do j=1,3
16270           gvdwx(j,i)=0.0D0
16271           gradx_scp(j,i)=0.0D0
16272           gvdwc(j,i)=0.0D0
16273           gvdwc_scp(j,i)=0.0D0
16274           gvdwc_scpp(j,i)=0.0d0
16275           gelc(j,i)=0.0D0
16276           gelc_long(j,i)=0.0D0
16277           gradb(j,i)=0.0d0
16278           gradbx(j,i)=0.0d0
16279           gvdwpp(j,i)=0.0d0
16280           gel_loc(j,i)=0.0d0
16281           gel_loc_long(j,i)=0.0d0
16282           ghpbc(j,i)=0.0D0
16283           ghpbx(j,i)=0.0D0
16284           gcorr3_turn(j,i)=0.0d0
16285           gcorr4_turn(j,i)=0.0d0
16286           gradcorr(j,i)=0.0d0
16287           gradcorr_long(j,i)=0.0d0
16288           gradcorr5_long(j,i)=0.0d0
16289           gradcorr6_long(j,i)=0.0d0
16290           gcorr6_turn_long(j,i)=0.0d0
16291           gradcorr5(j,i)=0.0d0
16292           gradcorr6(j,i)=0.0d0
16293           gcorr6_turn(j,i)=0.0d0
16294           gsccorc(j,i)=0.0d0
16295           gsccorx(j,i)=0.0d0
16296           gradc(j,i,icg)=0.0d0
16297           gradx(j,i,icg)=0.0d0
16298           gscloc(j,i)=0.0d0
16299           gsclocx(j,i)=0.0d0
16300           gliptran(j,i)=0.0d0
16301           gliptranx(j,i)=0.0d0
16302           gliptranc(j,i)=0.0d0
16303           gshieldx(j,i)=0.0d0
16304           gshieldc(j,i)=0.0d0
16305           gshieldc_loc(j,i)=0.0d0
16306           gshieldx_ec(j,i)=0.0d0
16307           gshieldc_ec(j,i)=0.0d0
16308           gshieldc_loc_ec(j,i)=0.0d0
16309           gshieldx_t3(j,i)=0.0d0
16310           gshieldc_t3(j,i)=0.0d0
16311           gshieldc_loc_t3(j,i)=0.0d0
16312           gshieldx_t4(j,i)=0.0d0
16313           gshieldc_t4(j,i)=0.0d0
16314           gshieldc_loc_t4(j,i)=0.0d0
16315           gshieldx_ll(j,i)=0.0d0
16316           gshieldc_ll(j,i)=0.0d0
16317           gshieldc_loc_ll(j,i)=0.0d0
16318           gg_tube(j,i)=0.0d0
16319           gg_tube_sc(j,i)=0.0d0
16320           gradafm(j,i)=0.0d0
16321           gradb_nucl(j,i)=0.0d0
16322           gradbx_nucl(j,i)=0.0d0
16323           gvdwpp_nucl(j,i)=0.0d0
16324           gvdwpp(j,i)=0.0d0
16325           gelpp(j,i)=0.0d0
16326           gvdwpsb(j,i)=0.0d0
16327           gvdwpsb1(j,i)=0.0d0
16328           gvdwsbc(j,i)=0.0d0
16329           gvdwsbx(j,i)=0.0d0
16330           gelsbc(j,i)=0.0d0
16331           gradcorr_nucl(j,i)=0.0d0
16332           gradcorr3_nucl(j,i)=0.0d0
16333           gradxorr_nucl(j,i)=0.0d0
16334           gradxorr3_nucl(j,i)=0.0d0
16335           gelsbx(j,i)=0.0d0
16336           gsbloc(j,i)=0.0d0
16337           gsblocx(j,i)=0.0d0
16338         enddo
16339        enddo
16340       do i=0,nres
16341         do j=1,3
16342           do intertyp=1,3
16343            gloc_sc(intertyp,i,icg)=0.0d0
16344           enddo
16345         enddo
16346       enddo
16347       do i=1,nres
16348        do j=1,maxcontsshi
16349        shield_list(j,i)=0
16350         do k=1,3
16351 !C           print *,i,j,k
16352            grad_shield_side(k,j,i)=0.0d0
16353            grad_shield_loc(k,j,i)=0.0d0
16354          enddo
16355        enddo
16356        ishield_list(i)=0
16357       enddo
16358
16359 !
16360 ! Initialize the gradient of local energy terms.
16361 !
16362 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
16363 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16364 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16365 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
16366 !      allocate(gel_loc_turn3(nres))
16367 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16368 !      allocate(gsccor_loc(nres))       !(maxres)
16369
16370       do i=1,4*nres
16371         gloc(i,icg)=0.0D0
16372       enddo
16373       do i=1,nres
16374         gel_loc_loc(i)=0.0d0
16375         gcorr_loc(i)=0.0d0
16376         g_corr5_loc(i)=0.0d0
16377         g_corr6_loc(i)=0.0d0
16378         gel_loc_turn3(i)=0.0d0
16379         gel_loc_turn4(i)=0.0d0
16380         gel_loc_turn6(i)=0.0d0
16381         gsccor_loc(i)=0.0d0
16382       enddo
16383 ! initialize gcart and gxcart
16384 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16385       do i=0,nres
16386         do j=1,3
16387           gcart(j,i)=0.0d0
16388           gxcart(j,i)=0.0d0
16389         enddo
16390       enddo
16391       return
16392       end subroutine zerograd
16393 !-----------------------------------------------------------------------------
16394       real(kind=8) function fdum()
16395       fdum=0.0D0
16396       return
16397       end function fdum
16398 !-----------------------------------------------------------------------------
16399 ! intcartderiv.F
16400 !-----------------------------------------------------------------------------
16401       subroutine intcartderiv
16402 !      implicit real*8 (a-h,o-z)
16403 !      include 'DIMENSIONS'
16404 #ifdef MPI
16405       include 'mpif.h'
16406 #endif
16407 !      include 'COMMON.SETUP'
16408 !      include 'COMMON.CHAIN'
16409 !      include 'COMMON.VAR'
16410 !      include 'COMMON.GEO'
16411 !      include 'COMMON.INTERACT'
16412 !      include 'COMMON.DERIV'
16413 !      include 'COMMON.IOUNITS'
16414 !      include 'COMMON.LOCAL'
16415 !      include 'COMMON.SCCOR'
16416       real(kind=8) :: pi4,pi34
16417       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16418       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16419                     dcosomega,dsinomega !(3,3,maxres)
16420       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16421
16422       integer :: i,j,k
16423       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16424                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16425                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16426                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16427       integer :: nres2
16428       nres2=2*nres
16429
16430 !el from module energy-------------
16431 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16432 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16433 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16434
16435 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16436 !el      allocate(dsintau(3,3,3,0:nres2))
16437 !el      allocate(dtauangle(3,3,3,0:nres2))
16438 !el      allocate(domicron(3,2,2,0:nres2))
16439 !el      allocate(dcosomicron(3,2,2,0:nres2))
16440
16441
16442
16443 #if defined(MPI) && defined(PARINTDER)
16444       if (nfgtasks.gt.1 .and. me.eq.king) &
16445         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16446 #endif
16447       pi4 = 0.5d0*pipol
16448       pi34 = 3*pi4
16449
16450 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
16451 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16452
16453 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16454       do i=1,nres
16455         do j=1,3
16456           dtheta(j,1,i)=0.0d0
16457           dtheta(j,2,i)=0.0d0
16458           dphi(j,1,i)=0.0d0
16459           dphi(j,2,i)=0.0d0
16460           dphi(j,3,i)=0.0d0
16461         enddo
16462       enddo
16463 ! Derivatives of theta's
16464 #if defined(MPI) && defined(PARINTDER)
16465 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16466       do i=max0(ithet_start-1,3),ithet_end
16467 #else
16468       do i=3,nres
16469 #endif
16470         cost=dcos(theta(i))
16471         sint=sqrt(1-cost*cost)
16472         do j=1,3
16473           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16474           vbld(i-1)
16475           if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16476           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16477           vbld(i)
16478           if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16479         enddo
16480       enddo
16481 #if defined(MPI) && defined(PARINTDER)
16482 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16483       do i=max0(ithet_start-1,3),ithet_end
16484 #else
16485       do i=3,nres
16486 #endif
16487       if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16488         cost1=dcos(omicron(1,i))
16489         sint1=sqrt(1-cost1*cost1)
16490         cost2=dcos(omicron(2,i))
16491         sint2=sqrt(1-cost2*cost2)
16492        do j=1,3
16493 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16494           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16495           cost1*dc_norm(j,i-2))/ &
16496           vbld(i-1)
16497           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16498           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16499           +cost1*(dc_norm(j,i-1+nres)))/ &
16500           vbld(i-1+nres)
16501           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16502 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16503 !C Looks messy but better than if in loop
16504           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16505           +cost2*dc_norm(j,i-1))/ &
16506           vbld(i)
16507           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16508           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16509            +cost2*(-dc_norm(j,i-1+nres)))/ &
16510           vbld(i-1+nres)
16511 !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16512           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16513         enddo
16514        endif
16515       enddo
16516 !elwrite(iout,*) "after vbld write"
16517 ! Derivatives of phi:
16518 ! If phi is 0 or 180 degrees, then the formulas
16519 ! have to be derived by power series expansion of the
16520 ! conventional formulas around 0 and 180.
16521 #ifdef PARINTDER
16522       do i=iphi1_start,iphi1_end
16523 #else
16524       do i=4,nres
16525 #endif
16526 !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16527 ! the conventional case
16528         sint=dsin(theta(i))
16529         sint1=dsin(theta(i-1))
16530         sing=dsin(phi(i))
16531         cost=dcos(theta(i))
16532         cost1=dcos(theta(i-1))
16533         cosg=dcos(phi(i))
16534         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16535         fac0=1.0d0/(sint1*sint)
16536         fac1=cost*fac0
16537         fac2=cost1*fac0
16538         fac3=cosg*cost1/(sint1*sint1)
16539         fac4=cosg*cost/(sint*sint)
16540 !    Obtaining the gamma derivatives from sine derivative
16541        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16542            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16543            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16544          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16545          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16546          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16547          do j=1,3
16548             ctgt=cost/sint
16549             ctgt1=cost1/sint1
16550             cosg_inv=1.0d0/cosg
16551             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16552             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16553               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16554             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16555             dsinphi(j,2,i)= &
16556               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16557               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16558             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16559             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16560               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16561 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16562             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16563             endif
16564 ! Bug fixed 3/24/05 (AL)
16565          enddo
16566 !   Obtaining the gamma derivatives from cosine derivative
16567         else
16568            do j=1,3
16569            if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16570            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16571            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16572            dc_norm(j,i-3))/vbld(i-2)
16573            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16574            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16575            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16576            dcostheta(j,1,i)
16577            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16578            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16579            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16580            dc_norm(j,i-1))/vbld(i)
16581            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16582            endif
16583          enddo
16584         endif
16585       enddo
16586 !alculate derivative of Tauangle
16587 #ifdef PARINTDER
16588       do i=itau_start,itau_end
16589 #else
16590       do i=3,nres
16591 !elwrite(iout,*) " vecpr",i,nres
16592 #endif
16593        if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16594 !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16595 !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16596 !c dtauangle(j,intertyp,dervityp,residue number)
16597 !c INTERTYP=1 SC...Ca...Ca..Ca
16598 ! the conventional case
16599         sint=dsin(theta(i))
16600         sint1=dsin(omicron(2,i-1))
16601         sing=dsin(tauangle(1,i))
16602         cost=dcos(theta(i))
16603         cost1=dcos(omicron(2,i-1))
16604         cosg=dcos(tauangle(1,i))
16605 !elwrite(iout,*) " vecpr5",i,nres
16606         do j=1,3
16607 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16608 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16609         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16610 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16611         enddo
16612         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16613         fac0=1.0d0/(sint1*sint)
16614         fac1=cost*fac0
16615         fac2=cost1*fac0
16616         fac3=cosg*cost1/(sint1*sint1)
16617         fac4=cosg*cost/(sint*sint)
16618 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16619 !    Obtaining the gamma derivatives from sine derivative
16620        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16621            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16622            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16623          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16624          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16625          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16626         do j=1,3
16627             ctgt=cost/sint
16628             ctgt1=cost1/sint1
16629             cosg_inv=1.0d0/cosg
16630             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16631        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16632        *vbld_inv(i-2+nres)
16633             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16634             dsintau(j,1,2,i)= &
16635               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16636               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16637 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16638             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16639 ! Bug fixed 3/24/05 (AL)
16640             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16641               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16642 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16643             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16644          enddo
16645 !   Obtaining the gamma derivatives from cosine derivative
16646         else
16647            do j=1,3
16648            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16649            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16650            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16651            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16652            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16653            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16654            dcostheta(j,1,i)
16655            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16656            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16657            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16658            dc_norm(j,i-1))/vbld(i)
16659            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16660 !         write (iout,*) "else",i
16661          enddo
16662         endif
16663 !        do k=1,3
16664 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16665 !        enddo
16666       enddo
16667 !C Second case Ca...Ca...Ca...SC
16668 #ifdef PARINTDER
16669       do i=itau_start,itau_end
16670 #else
16671       do i=4,nres
16672 #endif
16673        if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16674           (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16675 ! the conventional case
16676         sint=dsin(omicron(1,i))
16677         sint1=dsin(theta(i-1))
16678         sing=dsin(tauangle(2,i))
16679         cost=dcos(omicron(1,i))
16680         cost1=dcos(theta(i-1))
16681         cosg=dcos(tauangle(2,i))
16682 !        do j=1,3
16683 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16684 !        enddo
16685         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16686         fac0=1.0d0/(sint1*sint)
16687         fac1=cost*fac0
16688         fac2=cost1*fac0
16689         fac3=cosg*cost1/(sint1*sint1)
16690         fac4=cosg*cost/(sint*sint)
16691 !    Obtaining the gamma derivatives from sine derivative
16692        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16693            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16694            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16695          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16696          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16697          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16698         do j=1,3
16699             ctgt=cost/sint
16700             ctgt1=cost1/sint1
16701             cosg_inv=1.0d0/cosg
16702             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16703               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16704 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16705 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16706             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16707             dsintau(j,2,2,i)= &
16708               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16709               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16710 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16711 !     & sing*ctgt*domicron(j,1,2,i),
16712 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16713             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16714 ! Bug fixed 3/24/05 (AL)
16715             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16716              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16717 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16718             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16719          enddo
16720 !   Obtaining the gamma derivatives from cosine derivative
16721         else
16722            do j=1,3
16723            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16724            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16725            dc_norm(j,i-3))/vbld(i-2)
16726            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16727            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16728            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16729            dcosomicron(j,1,1,i)
16730            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16731            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16732            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16733            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16734            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16735 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16736          enddo
16737         endif
16738       enddo
16739
16740 !CC third case SC...Ca...Ca...SC
16741 #ifdef PARINTDER
16742
16743       do i=itau_start,itau_end
16744 #else
16745       do i=3,nres
16746 #endif
16747 ! the conventional case
16748       if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16749       (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16750         sint=dsin(omicron(1,i))
16751         sint1=dsin(omicron(2,i-1))
16752         sing=dsin(tauangle(3,i))
16753         cost=dcos(omicron(1,i))
16754         cost1=dcos(omicron(2,i-1))
16755         cosg=dcos(tauangle(3,i))
16756         do j=1,3
16757         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16758 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16759         enddo
16760         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16761         fac0=1.0d0/(sint1*sint)
16762         fac1=cost*fac0
16763         fac2=cost1*fac0
16764         fac3=cosg*cost1/(sint1*sint1)
16765         fac4=cosg*cost/(sint*sint)
16766 !    Obtaining the gamma derivatives from sine derivative
16767        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16768            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16769            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16770          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16771          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16772          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16773         do j=1,3
16774             ctgt=cost/sint
16775             ctgt1=cost1/sint1
16776             cosg_inv=1.0d0/cosg
16777             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16778               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16779               *vbld_inv(i-2+nres)
16780             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16781             dsintau(j,3,2,i)= &
16782               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16783               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16784             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16785 ! Bug fixed 3/24/05 (AL)
16786             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16787               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16788               *vbld_inv(i-1+nres)
16789 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16790             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16791          enddo
16792 !   Obtaining the gamma derivatives from cosine derivative
16793         else
16794            do j=1,3
16795            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16796            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16797            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16798            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16799            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16800            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16801            dcosomicron(j,1,1,i)
16802            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16803            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16804            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16805            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16806            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16807 !          write(iout,*) "else",i
16808          enddo
16809         endif
16810       enddo
16811
16812 #ifdef CRYST_SC
16813 !   Derivatives of side-chain angles alpha and omega
16814 #if defined(MPI) && defined(PARINTDER)
16815         do i=ibond_start,ibond_end
16816 #else
16817         do i=2,nres-1
16818 #endif
16819           if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16820              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16821              fac6=fac5/vbld(i)
16822              fac7=fac5*fac5
16823              fac8=fac5/vbld(i+1)
16824              fac9=fac5/vbld(i+nres)
16825              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16826              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16827              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16828              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16829              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16830              sina=sqrt(1-cosa*cosa)
16831              sino=dsin(omeg(i))
16832 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16833              do j=1,3
16834                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16835                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16836                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16837                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16838                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16839                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16840                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16841                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16842                 vbld(i+nres))
16843                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16844             enddo
16845 ! obtaining the derivatives of omega from sines
16846             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16847                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16848                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16849                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16850                dsin(theta(i+1)))
16851                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16852                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16853                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16854                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16855                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16856                coso_inv=1.0d0/dcos(omeg(i))
16857                do j=1,3
16858                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16859                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16860                  (sino*dc_norm(j,i-1))/vbld(i)
16861                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16862                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16863                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16864                  -sino*dc_norm(j,i)/vbld(i+1)
16865                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16866                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16867                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16868                  vbld(i+nres)
16869                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16870               enddo
16871            else
16872 !   obtaining the derivatives of omega from cosines
16873              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16874              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16875              fac12=fac10*sina
16876              fac13=fac12*fac12
16877              fac14=sina*sina
16878              do j=1,3
16879                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16880                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16881                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16882                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16883                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16884                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16885                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16886                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16887                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16888                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16889                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16890                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16891                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16892                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16893                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16894             enddo
16895           endif
16896          else
16897            do j=1,3
16898              do k=1,3
16899                dalpha(k,j,i)=0.0d0
16900                domega(k,j,i)=0.0d0
16901              enddo
16902            enddo
16903          endif
16904        enddo
16905 #endif
16906 #if defined(MPI) && defined(PARINTDER)
16907       if (nfgtasks.gt.1) then
16908 #ifdef DEBUG
16909 !d      write (iout,*) "Gather dtheta"
16910 !d      call flush(iout)
16911       write (iout,*) "dtheta before gather"
16912       do i=1,nres
16913         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16914       enddo
16915 #endif
16916       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16917         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16918         king,FG_COMM,IERROR)
16919 #ifdef DEBUG
16920 !d      write (iout,*) "Gather dphi"
16921 !d      call flush(iout)
16922       write (iout,*) "dphi before gather"
16923       do i=1,nres
16924         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16925       enddo
16926 #endif
16927       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16928         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16929         king,FG_COMM,IERROR)
16930 !d      write (iout,*) "Gather dalpha"
16931 !d      call flush(iout)
16932 #ifdef CRYST_SC
16933       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16934         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16935         king,FG_COMM,IERROR)
16936 !d      write (iout,*) "Gather domega"
16937 !d      call flush(iout)
16938       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16939         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16940         king,FG_COMM,IERROR)
16941 #endif
16942       endif
16943 #endif
16944 #ifdef DEBUG
16945       write (iout,*) "dtheta after gather"
16946       do i=1,nres
16947         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16948       enddo
16949       write (iout,*) "dphi after gather"
16950       do i=1,nres
16951         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16952       enddo
16953       write (iout,*) "dalpha after gather"
16954       do i=1,nres
16955         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16956       enddo
16957       write (iout,*) "domega after gather"
16958       do i=1,nres
16959         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16960       enddo
16961 #endif
16962       return
16963       end subroutine intcartderiv
16964 !-----------------------------------------------------------------------------
16965       subroutine checkintcartgrad
16966 !      implicit real*8 (a-h,o-z)
16967 !      include 'DIMENSIONS'
16968 #ifdef MPI
16969       include 'mpif.h'
16970 #endif
16971 !      include 'COMMON.CHAIN'
16972 !      include 'COMMON.VAR'
16973 !      include 'COMMON.GEO'
16974 !      include 'COMMON.INTERACT'
16975 !      include 'COMMON.DERIV'
16976 !      include 'COMMON.IOUNITS'
16977 !      include 'COMMON.SETUP'
16978       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16979       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16980       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16981       real(kind=8),dimension(3) :: dc_norm_s
16982       real(kind=8) :: aincr=1.0d-5
16983       integer :: i,j
16984       real(kind=8) :: dcji
16985       do i=1,nres
16986         phi_s(i)=phi(i)
16987         theta_s(i)=theta(i)
16988         alph_s(i)=alph(i)
16989         omeg_s(i)=omeg(i)
16990       enddo
16991 ! Check theta gradient
16992       write (iout,*) &
16993        "Analytical (upper) and numerical (lower) gradient of theta"
16994       write (iout,*)
16995       do i=3,nres
16996         do j=1,3
16997           dcji=dc(j,i-2)
16998           dc(j,i-2)=dcji+aincr
16999           call chainbuild_cart
17000           call int_from_cart1(.false.)
17001           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17002           dc(j,i-2)=dcji
17003           dcji=dc(j,i-1)
17004           dc(j,i-1)=dc(j,i-1)+aincr
17005           call chainbuild_cart
17006           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17007           dc(j,i-1)=dcji
17008         enddo
17009 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17010 !el          (dtheta(j,2,i),j=1,3)
17011 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17012 !el          (dthetanum(j,2,i),j=1,3)
17013 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17014 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17015 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17016 !el        write (iout,*)
17017       enddo
17018 ! Check gamma gradient
17019       write (iout,*) &
17020        "Analytical (upper) and numerical (lower) gradient of gamma"
17021       do i=4,nres
17022         do j=1,3
17023           dcji=dc(j,i-3)
17024           dc(j,i-3)=dcji+aincr
17025           call chainbuild_cart
17026           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17027           dc(j,i-3)=dcji
17028           dcji=dc(j,i-2)
17029           dc(j,i-2)=dcji+aincr
17030           call chainbuild_cart
17031           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17032           dc(j,i-2)=dcji
17033           dcji=dc(j,i-1)
17034           dc(j,i-1)=dc(j,i-1)+aincr
17035           call chainbuild_cart
17036           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17037           dc(j,i-1)=dcji
17038         enddo
17039 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17040 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17041 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17042 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17043 !el        write (iout,'(5x,3(3f10.5,5x))') &
17044 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17045 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17046 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17047 !el        write (iout,*)
17048       enddo
17049 ! Check alpha gradient
17050       write (iout,*) &
17051        "Analytical (upper) and numerical (lower) gradient of alpha"
17052       do i=2,nres-1
17053        if(itype(i,1).ne.10) then
17054             do j=1,3
17055               dcji=dc(j,i-1)
17056               dc(j,i-1)=dcji+aincr
17057               call chainbuild_cart
17058               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17059               /aincr
17060               dc(j,i-1)=dcji
17061               dcji=dc(j,i)
17062               dc(j,i)=dcji+aincr
17063               call chainbuild_cart
17064               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17065               /aincr
17066               dc(j,i)=dcji
17067               dcji=dc(j,i+nres)
17068               dc(j,i+nres)=dc(j,i+nres)+aincr
17069               call chainbuild_cart
17070               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17071               /aincr
17072              dc(j,i+nres)=dcji
17073             enddo
17074           endif
17075 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17076 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17077 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17078 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17079 !el        write (iout,'(5x,3(3f10.5,5x))') &
17080 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17081 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17082 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17083 !el        write (iout,*)
17084       enddo
17085 !     Check omega gradient
17086       write (iout,*) &
17087        "Analytical (upper) and numerical (lower) gradient of omega"
17088       do i=2,nres-1
17089        if(itype(i,1).ne.10) then
17090             do j=1,3
17091               dcji=dc(j,i-1)
17092               dc(j,i-1)=dcji+aincr
17093               call chainbuild_cart
17094               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17095               /aincr
17096               dc(j,i-1)=dcji
17097               dcji=dc(j,i)
17098               dc(j,i)=dcji+aincr
17099               call chainbuild_cart
17100               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17101               /aincr
17102               dc(j,i)=dcji
17103               dcji=dc(j,i+nres)
17104               dc(j,i+nres)=dc(j,i+nres)+aincr
17105               call chainbuild_cart
17106               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17107               /aincr
17108              dc(j,i+nres)=dcji
17109             enddo
17110           endif
17111 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17112 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17113 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17114 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17115 !el        write (iout,'(5x,3(3f10.5,5x))') &
17116 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17117 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17118 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17119 !el        write (iout,*)
17120       enddo
17121       return
17122       end subroutine checkintcartgrad
17123 !-----------------------------------------------------------------------------
17124 ! q_measure.F
17125 !-----------------------------------------------------------------------------
17126       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17127 !      implicit real*8 (a-h,o-z)
17128 !      include 'DIMENSIONS'
17129 !      include 'COMMON.IOUNITS'
17130 !      include 'COMMON.CHAIN'
17131 !      include 'COMMON.INTERACT'
17132 !      include 'COMMON.VAR'
17133       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17134       integer :: kkk,nsep=3
17135       real(kind=8) :: qm        !dist,
17136       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17137       logical :: lprn=.false.
17138       logical :: flag
17139 !      real(kind=8) :: sigm,x
17140
17141 !el      sigm(x)=0.25d0*x     ! local function
17142       qqmax=1.0d10
17143       do kkk=1,nperm
17144       qq = 0.0d0
17145       nl=0
17146        if(flag) then
17147         do il=seg1+nsep,seg2
17148           do jl=seg1,il-nsep
17149             nl=nl+1
17150             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17151                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17152                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17153             dij=dist(il,jl)
17154             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17155             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17156               nl=nl+1
17157               d0ijCM=dsqrt( &
17158                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17159                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17160                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17161               dijCM=dist(il+nres,jl+nres)
17162               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17163             endif
17164             qq = qq+qqij+qqijCM
17165           enddo
17166         enddo
17167         qq = qq/nl
17168       else
17169       do il=seg1,seg2
17170         if((seg3-il).lt.3) then
17171              secseg=il+3
17172         else
17173              secseg=seg3
17174         endif
17175           do jl=secseg,seg4
17176             nl=nl+1
17177             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17178                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17179                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17180             dij=dist(il,jl)
17181             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17182             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17183               nl=nl+1
17184               d0ijCM=dsqrt( &
17185                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17186                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17187                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17188               dijCM=dist(il+nres,jl+nres)
17189               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17190             endif
17191             qq = qq+qqij+qqijCM
17192           enddo
17193         enddo
17194       qq = qq/nl
17195       endif
17196       if (qqmax.le.qq) qqmax=qq
17197       enddo
17198       qwolynes=1.0d0-qqmax
17199       return
17200       end function qwolynes
17201 !-----------------------------------------------------------------------------
17202       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17203 !      implicit real*8 (a-h,o-z)
17204 !      include 'DIMENSIONS'
17205 !      include 'COMMON.IOUNITS'
17206 !      include 'COMMON.CHAIN'
17207 !      include 'COMMON.INTERACT'
17208 !      include 'COMMON.VAR'
17209 !      include 'COMMON.MD'
17210       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17211       integer :: nsep=3, kkk
17212 !el      real(kind=8) :: dist
17213       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17214       logical :: lprn=.false.
17215       logical :: flag
17216       real(kind=8) :: sim,dd0,fac,ddqij
17217 !el      sigm(x)=0.25d0*x            ! local function
17218       do kkk=1,nperm
17219       do i=0,nres
17220         do j=1,3
17221           dqwol(j,i)=0.0d0
17222           dxqwol(j,i)=0.0d0
17223         enddo
17224       enddo
17225       nl=0
17226        if(flag) then
17227         do il=seg1+nsep,seg2
17228           do jl=seg1,il-nsep
17229             nl=nl+1
17230             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17231                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17232                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17233             dij=dist(il,jl)
17234             sim = 1.0d0/sigm(d0ij)
17235             sim = sim*sim
17236             dd0 = dij-d0ij
17237             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17238             do k=1,3
17239               ddqij = (c(k,il)-c(k,jl))*fac
17240               dqwol(k,il)=dqwol(k,il)+ddqij
17241               dqwol(k,jl)=dqwol(k,jl)-ddqij
17242             enddo
17243
17244             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17245               nl=nl+1
17246               d0ijCM=dsqrt( &
17247                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17248                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17249                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17250               dijCM=dist(il+nres,jl+nres)
17251               sim = 1.0d0/sigm(d0ijCM)
17252               sim = sim*sim
17253               dd0=dijCM-d0ijCM
17254               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17255               do k=1,3
17256                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17257                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17258                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17259               enddo
17260             endif
17261           enddo
17262         enddo
17263        else
17264         do il=seg1,seg2
17265         if((seg3-il).lt.3) then
17266              secseg=il+3
17267         else
17268              secseg=seg3
17269         endif
17270           do jl=secseg,seg4
17271             nl=nl+1
17272             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17273                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17274                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17275             dij=dist(il,jl)
17276             sim = 1.0d0/sigm(d0ij)
17277             sim = sim*sim
17278             dd0 = dij-d0ij
17279             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17280             do k=1,3
17281               ddqij = (c(k,il)-c(k,jl))*fac
17282               dqwol(k,il)=dqwol(k,il)+ddqij
17283               dqwol(k,jl)=dqwol(k,jl)-ddqij
17284             enddo
17285             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17286               nl=nl+1
17287               d0ijCM=dsqrt( &
17288                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17289                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17290                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17291               dijCM=dist(il+nres,jl+nres)
17292               sim = 1.0d0/sigm(d0ijCM)
17293               sim=sim*sim
17294               dd0 = dijCM-d0ijCM
17295               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17296               do k=1,3
17297                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17298                dxqwol(k,il)=dxqwol(k,il)+ddqij
17299                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17300               enddo
17301             endif
17302           enddo
17303         enddo
17304       endif
17305       enddo
17306        do i=0,nres
17307          do j=1,3
17308            dqwol(j,i)=dqwol(j,i)/nl
17309            dxqwol(j,i)=dxqwol(j,i)/nl
17310          enddo
17311        enddo
17312       return
17313       end subroutine qwolynes_prim
17314 !-----------------------------------------------------------------------------
17315       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17316 !      implicit real*8 (a-h,o-z)
17317 !      include 'DIMENSIONS'
17318 !      include 'COMMON.IOUNITS'
17319 !      include 'COMMON.CHAIN'
17320 !      include 'COMMON.INTERACT'
17321 !      include 'COMMON.VAR'
17322       integer :: seg1,seg2,seg3,seg4
17323       logical :: flag
17324       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17325       real(kind=8),dimension(3,0:2*nres) :: cdummy
17326       real(kind=8) :: q1,q2
17327       real(kind=8) :: delta=1.0d-10
17328       integer :: i,j
17329
17330       do i=0,nres
17331         do j=1,3
17332           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17333           cdummy(j,i)=c(j,i)
17334           c(j,i)=c(j,i)+delta
17335           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17336           qwolan(j,i)=(q2-q1)/delta
17337           c(j,i)=cdummy(j,i)
17338         enddo
17339       enddo
17340       do i=0,nres
17341         do j=1,3
17342           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17343           cdummy(j,i+nres)=c(j,i+nres)
17344           c(j,i+nres)=c(j,i+nres)+delta
17345           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17346           qwolxan(j,i)=(q2-q1)/delta
17347           c(j,i+nres)=cdummy(j,i+nres)
17348         enddo
17349       enddo
17350 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17351 !      do i=0,nct
17352 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17353 !      enddo
17354 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17355 !      do i=0,nct
17356 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17357 !      enddo
17358       return
17359       end subroutine qwol_num
17360 !-----------------------------------------------------------------------------
17361       subroutine EconstrQ
17362 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17363 !      implicit real*8 (a-h,o-z)
17364 !      include 'DIMENSIONS'
17365 !      include 'COMMON.CONTROL'
17366 !      include 'COMMON.VAR'
17367 !      include 'COMMON.MD'
17368       use MD_data
17369 !#ifndef LANG0
17370 !      include 'COMMON.LANGEVIN'
17371 !#else
17372 !      include 'COMMON.LANGEVIN.lang0'
17373 !#endif
17374 !      include 'COMMON.CHAIN'
17375 !      include 'COMMON.DERIV'
17376 !      include 'COMMON.GEO'
17377 !      include 'COMMON.LOCAL'
17378 !      include 'COMMON.INTERACT'
17379 !      include 'COMMON.IOUNITS'
17380 !      include 'COMMON.NAMES'
17381 !      include 'COMMON.TIME1'
17382       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17383       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17384                    duconst,duxconst
17385       integer :: kstart,kend,lstart,lend,idummy
17386       real(kind=8) :: delta=1.0d-7
17387       integer :: i,j,k,ii
17388       do i=0,nres
17389          do j=1,3
17390             duconst(j,i)=0.0d0
17391             dudconst(j,i)=0.0d0
17392             duxconst(j,i)=0.0d0
17393             dudxconst(j,i)=0.0d0
17394          enddo
17395       enddo
17396       Uconst=0.0d0
17397       do i=1,nfrag
17398          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17399            idummy,idummy)
17400          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17401 ! Calculating the derivatives of Constraint energy with respect to Q
17402          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17403            qinfrag(i,iset))
17404 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17405 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17406 !         hmnum=(hm2-hm1)/delta
17407 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17408 !     &   qinfrag(i,iset))
17409 !         write(iout,*) "harmonicnum frag", hmnum
17410 ! Calculating the derivatives of Q with respect to cartesian coordinates
17411          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17412           idummy,idummy)
17413 !         write(iout,*) "dqwol "
17414 !         do ii=1,nres
17415 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17416 !         enddo
17417 !         write(iout,*) "dxqwol "
17418 !         do ii=1,nres
17419 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17420 !         enddo
17421 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17422 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17423 !     &  ,idummy,idummy)
17424 !  The gradients of Uconst in Cs
17425          do ii=0,nres
17426             do j=1,3
17427                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17428                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17429             enddo
17430          enddo
17431       enddo
17432       do i=1,npair
17433          kstart=ifrag(1,ipair(1,i,iset),iset)
17434          kend=ifrag(2,ipair(1,i,iset),iset)
17435          lstart=ifrag(1,ipair(2,i,iset),iset)
17436          lend=ifrag(2,ipair(2,i,iset),iset)
17437          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17438          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17439 !  Calculating dU/dQ
17440          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17441 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17442 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17443 !         hmnum=(hm2-hm1)/delta
17444 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17445 !     &   qinpair(i,iset))
17446 !         write(iout,*) "harmonicnum pair ", hmnum
17447 ! Calculating dQ/dXi
17448          call qwolynes_prim(kstart,kend,.false.,&
17449           lstart,lend)
17450 !         write(iout,*) "dqwol "
17451 !         do ii=1,nres
17452 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17453 !         enddo
17454 !         write(iout,*) "dxqwol "
17455 !         do ii=1,nres
17456 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17457 !        enddo
17458 ! Calculating numerical gradients
17459 !        call qwol_num(kstart,kend,.false.
17460 !     &  ,lstart,lend)
17461 ! The gradients of Uconst in Cs
17462          do ii=0,nres
17463             do j=1,3
17464                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17465                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17466             enddo
17467          enddo
17468       enddo
17469 !      write(iout,*) "Uconst inside subroutine ", Uconst
17470 ! Transforming the gradients from Cs to dCs for the backbone
17471       do i=0,nres
17472          do j=i+1,nres
17473            do k=1,3
17474              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17475            enddo
17476          enddo
17477       enddo
17478 !  Transforming the gradients from Cs to dCs for the side chains
17479       do i=1,nres
17480          do j=1,3
17481            dudxconst(j,i)=duxconst(j,i)
17482          enddo
17483       enddo
17484 !      write(iout,*) "dU/ddc backbone "
17485 !       do ii=0,nres
17486 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17487 !      enddo
17488 !      write(iout,*) "dU/ddX side chain "
17489 !      do ii=1,nres
17490 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17491 !      enddo
17492 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17493 !      call dEconstrQ_num
17494       return
17495       end subroutine EconstrQ
17496 !-----------------------------------------------------------------------------
17497       subroutine dEconstrQ_num
17498 ! Calculating numerical dUconst/ddc and dUconst/ddx
17499 !      implicit real*8 (a-h,o-z)
17500 !      include 'DIMENSIONS'
17501 !      include 'COMMON.CONTROL'
17502 !      include 'COMMON.VAR'
17503 !      include 'COMMON.MD'
17504       use MD_data
17505 !#ifndef LANG0
17506 !      include 'COMMON.LANGEVIN'
17507 !#else
17508 !      include 'COMMON.LANGEVIN.lang0'
17509 !#endif
17510 !      include 'COMMON.CHAIN'
17511 !      include 'COMMON.DERIV'
17512 !      include 'COMMON.GEO'
17513 !      include 'COMMON.LOCAL'
17514 !      include 'COMMON.INTERACT'
17515 !      include 'COMMON.IOUNITS'
17516 !      include 'COMMON.NAMES'
17517 !      include 'COMMON.TIME1'
17518       real(kind=8) :: uzap1,uzap2
17519       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17520       integer :: kstart,kend,lstart,lend,idummy
17521       real(kind=8) :: delta=1.0d-7
17522 !el local variables
17523       integer :: i,ii,j
17524 !     real(kind=8) ::
17525 !     For the backbone
17526       do i=0,nres-1
17527          do j=1,3
17528             dUcartan(j,i)=0.0d0
17529             cdummy(j,i)=dc(j,i)
17530             dc(j,i)=dc(j,i)+delta
17531             call chainbuild_cart
17532             uzap2=0.0d0
17533             do ii=1,nfrag
17534              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17535                 idummy,idummy)
17536                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17537                 qinfrag(ii,iset))
17538             enddo
17539             do ii=1,npair
17540                kstart=ifrag(1,ipair(1,ii,iset),iset)
17541                kend=ifrag(2,ipair(1,ii,iset),iset)
17542                lstart=ifrag(1,ipair(2,ii,iset),iset)
17543                lend=ifrag(2,ipair(2,ii,iset),iset)
17544                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17545                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17546                  qinpair(ii,iset))
17547             enddo
17548             dc(j,i)=cdummy(j,i)
17549             call chainbuild_cart
17550             uzap1=0.0d0
17551              do ii=1,nfrag
17552              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17553                 idummy,idummy)
17554                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17555                 qinfrag(ii,iset))
17556             enddo
17557             do ii=1,npair
17558                kstart=ifrag(1,ipair(1,ii,iset),iset)
17559                kend=ifrag(2,ipair(1,ii,iset),iset)
17560                lstart=ifrag(1,ipair(2,ii,iset),iset)
17561                lend=ifrag(2,ipair(2,ii,iset),iset)
17562                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17563                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17564                 qinpair(ii,iset))
17565             enddo
17566             ducartan(j,i)=(uzap2-uzap1)/(delta)
17567          enddo
17568       enddo
17569 ! Calculating numerical gradients for dU/ddx
17570       do i=0,nres-1
17571          duxcartan(j,i)=0.0d0
17572          do j=1,3
17573             cdummy(j,i)=dc(j,i+nres)
17574             dc(j,i+nres)=dc(j,i+nres)+delta
17575             call chainbuild_cart
17576             uzap2=0.0d0
17577             do ii=1,nfrag
17578              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17579                 idummy,idummy)
17580                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17581                 qinfrag(ii,iset))
17582             enddo
17583             do ii=1,npair
17584                kstart=ifrag(1,ipair(1,ii,iset),iset)
17585                kend=ifrag(2,ipair(1,ii,iset),iset)
17586                lstart=ifrag(1,ipair(2,ii,iset),iset)
17587                lend=ifrag(2,ipair(2,ii,iset),iset)
17588                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17589                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17590                 qinpair(ii,iset))
17591             enddo
17592             dc(j,i+nres)=cdummy(j,i)
17593             call chainbuild_cart
17594             uzap1=0.0d0
17595              do ii=1,nfrag
17596                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17597                 ifrag(2,ii,iset),.true.,idummy,idummy)
17598                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17599                 qinfrag(ii,iset))
17600             enddo
17601             do ii=1,npair
17602                kstart=ifrag(1,ipair(1,ii,iset),iset)
17603                kend=ifrag(2,ipair(1,ii,iset),iset)
17604                lstart=ifrag(1,ipair(2,ii,iset),iset)
17605                lend=ifrag(2,ipair(2,ii,iset),iset)
17606                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17607                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17608                 qinpair(ii,iset))
17609             enddo
17610             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17611          enddo
17612       enddo
17613       write(iout,*) "Numerical dUconst/ddc backbone "
17614       do ii=0,nres
17615         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17616       enddo
17617 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17618 !      do ii=1,nres
17619 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17620 !      enddo
17621       return
17622       end subroutine dEconstrQ_num
17623 !-----------------------------------------------------------------------------
17624 ! ssMD.F
17625 !-----------------------------------------------------------------------------
17626       subroutine check_energies
17627
17628 !      use random, only: ran_number
17629
17630 !      implicit none
17631 !     Includes
17632 !      include 'DIMENSIONS'
17633 !      include 'COMMON.CHAIN'
17634 !      include 'COMMON.VAR'
17635 !      include 'COMMON.IOUNITS'
17636 !      include 'COMMON.SBRIDGE'
17637 !      include 'COMMON.LOCAL'
17638 !      include 'COMMON.GEO'
17639
17640 !     External functions
17641 !EL      double precision ran_number
17642 !EL      external ran_number
17643
17644 !     Local variables
17645       integer :: i,j,k,l,lmax,p,pmax
17646       real(kind=8) :: rmin,rmax
17647       real(kind=8) :: eij
17648
17649       real(kind=8) :: d
17650       real(kind=8) :: wi,rij,tj,pj
17651 !      return
17652
17653       i=5
17654       j=14
17655
17656       d=dsc(1)
17657       rmin=2.0D0
17658       rmax=12.0D0
17659
17660       lmax=10000
17661       pmax=1
17662
17663       do k=1,3
17664         c(k,i)=0.0D0
17665         c(k,j)=0.0D0
17666         c(k,nres+i)=0.0D0
17667         c(k,nres+j)=0.0D0
17668       enddo
17669
17670       do l=1,lmax
17671
17672 !t        wi=ran_number(0.0D0,pi)
17673 !        wi=ran_number(0.0D0,pi/6.0D0)
17674 !        wi=0.0D0
17675 !t        tj=ran_number(0.0D0,pi)
17676 !t        pj=ran_number(0.0D0,pi)
17677 !        pj=ran_number(0.0D0,pi/6.0D0)
17678 !        pj=0.0D0
17679
17680         do p=1,pmax
17681 !t           rij=ran_number(rmin,rmax)
17682
17683            c(1,j)=d*sin(pj)*cos(tj)
17684            c(2,j)=d*sin(pj)*sin(tj)
17685            c(3,j)=d*cos(pj)
17686
17687            c(3,nres+i)=-rij
17688
17689            c(1,i)=d*sin(wi)
17690            c(3,i)=-rij-d*cos(wi)
17691
17692            do k=1,3
17693               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17694               dc_norm(k,nres+i)=dc(k,nres+i)/d
17695               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17696               dc_norm(k,nres+j)=dc(k,nres+j)/d
17697            enddo
17698
17699            call dyn_ssbond_ene(i,j,eij)
17700         enddo
17701       enddo
17702       call exit(1)
17703       return
17704       end subroutine check_energies
17705 !-----------------------------------------------------------------------------
17706       subroutine dyn_ssbond_ene(resi,resj,eij)
17707 !      implicit none
17708 !      Includes
17709       use calc_data
17710       use comm_sschecks
17711 !      include 'DIMENSIONS'
17712 !      include 'COMMON.SBRIDGE'
17713 !      include 'COMMON.CHAIN'
17714 !      include 'COMMON.DERIV'
17715 !      include 'COMMON.LOCAL'
17716 !      include 'COMMON.INTERACT'
17717 !      include 'COMMON.VAR'
17718 !      include 'COMMON.IOUNITS'
17719 !      include 'COMMON.CALC'
17720 #ifndef CLUST
17721 #ifndef WHAM
17722        use MD_data
17723 !      include 'COMMON.MD'
17724 !      use MD, only: totT,t_bath
17725 #endif
17726 #endif
17727 !     External functions
17728 !EL      double precision h_base
17729 !EL      external h_base
17730
17731 !     Input arguments
17732       integer :: resi,resj
17733
17734 !     Output arguments
17735       real(kind=8) :: eij
17736
17737 !     Local variables
17738       logical :: havebond
17739       integer itypi,itypj
17740       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17741       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17742       real(kind=8),dimension(3) :: dcosom1,dcosom2
17743       real(kind=8) :: ed
17744       real(kind=8) :: pom1,pom2
17745       real(kind=8) :: ljA,ljB,ljXs
17746       real(kind=8),dimension(1:3) :: d_ljB
17747       real(kind=8) :: ssA,ssB,ssC,ssXs
17748       real(kind=8) :: ssxm,ljxm,ssm,ljm
17749       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17750       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17751       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17752 !-------FIRST METHOD
17753       real(kind=8) :: xm
17754       real(kind=8),dimension(1:3) :: d_xm
17755 !-------END FIRST METHOD
17756 !-------SECOND METHOD
17757 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17758 !-------END SECOND METHOD
17759
17760 !-------TESTING CODE
17761 !el      logical :: checkstop,transgrad
17762 !el      common /sschecks/ checkstop,transgrad
17763
17764       integer :: icheck,nicheck,jcheck,njcheck
17765       real(kind=8),dimension(-1:1) :: echeck
17766       real(kind=8) :: deps,ssx0,ljx0
17767 !-------END TESTING CODE
17768
17769       eij=0.0d0
17770       i=resi
17771       j=resj
17772
17773 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17774 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17775
17776       itypi=itype(i,1)
17777       dxi=dc_norm(1,nres+i)
17778       dyi=dc_norm(2,nres+i)
17779       dzi=dc_norm(3,nres+i)
17780       dsci_inv=vbld_inv(i+nres)
17781
17782       itypj=itype(j,1)
17783       xj=c(1,nres+j)-c(1,nres+i)
17784       yj=c(2,nres+j)-c(2,nres+i)
17785       zj=c(3,nres+j)-c(3,nres+i)
17786       dxj=dc_norm(1,nres+j)
17787       dyj=dc_norm(2,nres+j)
17788       dzj=dc_norm(3,nres+j)
17789       dscj_inv=vbld_inv(j+nres)
17790
17791       chi1=chi(itypi,itypj)
17792       chi2=chi(itypj,itypi)
17793       chi12=chi1*chi2
17794       chip1=chip(itypi)
17795       chip2=chip(itypj)
17796       chip12=chip1*chip2
17797       alf1=alp(itypi)
17798       alf2=alp(itypj)
17799       alf12=0.5D0*(alf1+alf2)
17800
17801       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17802       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17803 !     The following are set in sc_angular
17804 !      erij(1)=xj*rij
17805 !      erij(2)=yj*rij
17806 !      erij(3)=zj*rij
17807 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17808 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17809 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17810       call sc_angular
17811       rij=1.0D0/rij  ! Reset this so it makes sense
17812
17813       sig0ij=sigma(itypi,itypj)
17814       sig=sig0ij*dsqrt(1.0D0/sigsq)
17815
17816       ljXs=sig-sig0ij
17817       ljA=eps1*eps2rt**2*eps3rt**2
17818       ljB=ljA*bb_aq(itypi,itypj)
17819       ljA=ljA*aa_aq(itypi,itypj)
17820       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17821
17822       ssXs=d0cm
17823       deltat1=1.0d0-om1
17824       deltat2=1.0d0+om2
17825       deltat12=om2-om1+2.0d0
17826       cosphi=om12-om1*om2
17827       ssA=akcm
17828       ssB=akct*deltat12
17829       ssC=ss_depth &
17830            +akth*(deltat1*deltat1+deltat2*deltat2) &
17831            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17832       ssxm=ssXs-0.5D0*ssB/ssA
17833
17834 !-------TESTING CODE
17835 !$$$c     Some extra output
17836 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17837 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17838 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17839 !$$$      if (ssx0.gt.0.0d0) then
17840 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17841 !$$$      else
17842 !$$$        ssx0=ssxm
17843 !$$$      endif
17844 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17845 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17846 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17847 !$$$      return
17848 !-------END TESTING CODE
17849
17850 !-------TESTING CODE
17851 !     Stop and plot energy and derivative as a function of distance
17852       if (checkstop) then
17853         ssm=ssC-0.25D0*ssB*ssB/ssA
17854         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17855         if (ssm.lt.ljm .and. &
17856              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17857           nicheck=1000
17858           njcheck=1
17859           deps=0.5d-7
17860         else
17861           checkstop=.false.
17862         endif
17863       endif
17864       if (.not.checkstop) then
17865         nicheck=0
17866         njcheck=-1
17867       endif
17868
17869       do icheck=0,nicheck
17870       do jcheck=-1,njcheck
17871       if (checkstop) rij=(ssxm-1.0d0)+ &
17872              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17873 !-------END TESTING CODE
17874
17875       if (rij.gt.ljxm) then
17876         havebond=.false.
17877         ljd=rij-ljXs
17878         fac=(1.0D0/ljd)**expon
17879         e1=fac*fac*aa_aq(itypi,itypj)
17880         e2=fac*bb_aq(itypi,itypj)
17881         eij=eps1*eps2rt*eps3rt*(e1+e2)
17882         eps2der=eij*eps3rt
17883         eps3der=eij*eps2rt
17884         eij=eij*eps2rt*eps3rt
17885
17886         sigder=-sig/sigsq
17887         e1=e1*eps1*eps2rt**2*eps3rt**2
17888         ed=-expon*(e1+eij)/ljd
17889         sigder=ed*sigder
17890         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17891         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17892         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17893              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17894       else if (rij.lt.ssxm) then
17895         havebond=.true.
17896         ssd=rij-ssXs
17897         eij=ssA*ssd*ssd+ssB*ssd+ssC
17898
17899         ed=2*akcm*ssd+akct*deltat12
17900         pom1=akct*ssd
17901         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17902         eom1=-2*akth*deltat1-pom1-om2*pom2
17903         eom2= 2*akth*deltat2+pom1-om1*pom2
17904         eom12=pom2
17905       else
17906         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17907
17908         d_ssxm(1)=0.5D0*akct/ssA
17909         d_ssxm(2)=-d_ssxm(1)
17910         d_ssxm(3)=0.0D0
17911
17912         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17913         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17914         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17915         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17916
17917 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17918         xm=0.5d0*(ssxm+ljxm)
17919         do k=1,3
17920           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17921         enddo
17922         if (rij.lt.xm) then
17923           havebond=.true.
17924           ssm=ssC-0.25D0*ssB*ssB/ssA
17925           d_ssm(1)=0.5D0*akct*ssB/ssA
17926           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17927           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17928           d_ssm(3)=omega
17929           f1=(rij-xm)/(ssxm-xm)
17930           f2=(rij-ssxm)/(xm-ssxm)
17931           h1=h_base(f1,hd1)
17932           h2=h_base(f2,hd2)
17933           eij=ssm*h1+Ht*h2
17934           delta_inv=1.0d0/(xm-ssxm)
17935           deltasq_inv=delta_inv*delta_inv
17936           fac=ssm*hd1-Ht*hd2
17937           fac1=deltasq_inv*fac*(xm-rij)
17938           fac2=deltasq_inv*fac*(rij-ssxm)
17939           ed=delta_inv*(Ht*hd2-ssm*hd1)
17940           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17941           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17942           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17943         else
17944           havebond=.false.
17945           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17946           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17947           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17948           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17949                alf12/eps3rt)
17950           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17951           f1=(rij-ljxm)/(xm-ljxm)
17952           f2=(rij-xm)/(ljxm-xm)
17953           h1=h_base(f1,hd1)
17954           h2=h_base(f2,hd2)
17955           eij=Ht*h1+ljm*h2
17956           delta_inv=1.0d0/(ljxm-xm)
17957           deltasq_inv=delta_inv*delta_inv
17958           fac=Ht*hd1-ljm*hd2
17959           fac1=deltasq_inv*fac*(ljxm-rij)
17960           fac2=deltasq_inv*fac*(rij-xm)
17961           ed=delta_inv*(ljm*hd2-Ht*hd1)
17962           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17963           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17964           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17965         endif
17966 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17967
17968 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17969 !$$$        ssd=rij-ssXs
17970 !$$$        ljd=rij-ljXs
17971 !$$$        fac1=rij-ljxm
17972 !$$$        fac2=rij-ssxm
17973 !$$$
17974 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17975 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17976 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17977 !$$$
17978 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17979 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17980 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17981 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17982 !$$$        d_ssm(3)=omega
17983 !$$$
17984 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17985 !$$$        do k=1,3
17986 !$$$          d_ljm(k)=ljm*d_ljB(k)
17987 !$$$        enddo
17988 !$$$        ljm=ljm*ljB
17989 !$$$
17990 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17991 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17992 !$$$        d_ss(2)=akct*ssd
17993 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17994 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17995 !$$$        d_ss(3)=omega
17996 !$$$
17997 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17998 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17999 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18000 !$$$        do k=1,3
18001 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18002 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18003 !$$$        enddo
18004 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18005 !$$$
18006 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18007 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18008 !$$$        h1=h_base(f1,hd1)
18009 !$$$        h2=h_base(f2,hd2)
18010 !$$$        eij=ss*h1+ljf*h2
18011 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18012 !$$$        deltasq_inv=delta_inv*delta_inv
18013 !$$$        fac=ljf*hd2-ss*hd1
18014 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18015 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18016 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18017 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18018 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18019 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18020 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18021 !$$$
18022 !$$$        havebond=.false.
18023 !$$$        if (ed.gt.0.0d0) havebond=.true.
18024 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18025
18026       endif
18027
18028       if (havebond) then
18029 !#ifndef CLUST
18030 !#ifndef WHAM
18031 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18032 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18033 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18034 !        endif
18035 !#endif
18036 !#endif
18037         dyn_ssbond_ij(i,j)=eij
18038       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18039         dyn_ssbond_ij(i,j)=1.0d300
18040 !#ifndef CLUST
18041 !#ifndef WHAM
18042 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18043 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18044 !#endif
18045 !#endif
18046       endif
18047
18048 !-------TESTING CODE
18049 !el      if (checkstop) then
18050         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18051              "CHECKSTOP",rij,eij,ed
18052         echeck(jcheck)=eij
18053 !el      endif
18054       enddo
18055       if (checkstop) then
18056         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18057       endif
18058       enddo
18059       if (checkstop) then
18060         transgrad=.true.
18061         checkstop=.false.
18062       endif
18063 !-------END TESTING CODE
18064
18065       do k=1,3
18066         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18067         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18068       enddo
18069       do k=1,3
18070         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18071       enddo
18072       do k=1,3
18073         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18074              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18075              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18076         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18077              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18078              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18079       enddo
18080 !grad      do k=i,j-1
18081 !grad        do l=1,3
18082 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18083 !grad        enddo
18084 !grad      enddo
18085
18086       do l=1,3
18087         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18088         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18089       enddo
18090
18091       return
18092       end subroutine dyn_ssbond_ene
18093 !--------------------------------------------------------------------------
18094          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18095 !      implicit none
18096 !      Includes
18097       use calc_data
18098       use comm_sschecks
18099 !      include 'DIMENSIONS'
18100 !      include 'COMMON.SBRIDGE'
18101 !      include 'COMMON.CHAIN'
18102 !      include 'COMMON.DERIV'
18103 !      include 'COMMON.LOCAL'
18104 !      include 'COMMON.INTERACT'
18105 !      include 'COMMON.VAR'
18106 !      include 'COMMON.IOUNITS'
18107 !      include 'COMMON.CALC'
18108 #ifndef CLUST
18109 #ifndef WHAM
18110        use MD_data
18111 !      include 'COMMON.MD'
18112 !      use MD, only: totT,t_bath
18113 #endif
18114 #endif
18115       double precision h_base
18116       external h_base
18117
18118 !c     Input arguments
18119       integer resi,resj,resk,m,itypi,itypj,itypk
18120
18121 !c     Output arguments
18122       double precision eij,eij1,eij2,eij3
18123
18124 !c     Local variables
18125       logical havebond
18126 !c      integer itypi,itypj,k,l
18127       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18128       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18129       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18130       double precision sig0ij,ljd,sig,fac,e1,e2
18131       double precision dcosom1(3),dcosom2(3),ed
18132       double precision pom1,pom2
18133       double precision ljA,ljB,ljXs
18134       double precision d_ljB(1:3)
18135       double precision ssA,ssB,ssC,ssXs
18136       double precision ssxm,ljxm,ssm,ljm
18137       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18138       eij=0.0
18139       if (dtriss.eq.0) return
18140       i=resi
18141       j=resj
18142       k=resk
18143 !C      write(iout,*) resi,resj,resk
18144       itypi=itype(i,1)
18145       dxi=dc_norm(1,nres+i)
18146       dyi=dc_norm(2,nres+i)
18147       dzi=dc_norm(3,nres+i)
18148       dsci_inv=vbld_inv(i+nres)
18149       xi=c(1,nres+i)
18150       yi=c(2,nres+i)
18151       zi=c(3,nres+i)
18152       itypj=itype(j,1)
18153       xj=c(1,nres+j)
18154       yj=c(2,nres+j)
18155       zj=c(3,nres+j)
18156
18157       dxj=dc_norm(1,nres+j)
18158       dyj=dc_norm(2,nres+j)
18159       dzj=dc_norm(3,nres+j)
18160       dscj_inv=vbld_inv(j+nres)
18161       itypk=itype(k,1)
18162       xk=c(1,nres+k)
18163       yk=c(2,nres+k)
18164       zk=c(3,nres+k)
18165
18166       dxk=dc_norm(1,nres+k)
18167       dyk=dc_norm(2,nres+k)
18168       dzk=dc_norm(3,nres+k)
18169       dscj_inv=vbld_inv(k+nres)
18170       xij=xj-xi
18171       xik=xk-xi
18172       xjk=xk-xj
18173       yij=yj-yi
18174       yik=yk-yi
18175       yjk=yk-yj
18176       zij=zj-zi
18177       zik=zk-zi
18178       zjk=zk-zj
18179       rrij=(xij*xij+yij*yij+zij*zij)
18180       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18181       rrik=(xik*xik+yik*yik+zik*zik)
18182       rik=dsqrt(rrik)
18183       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18184       rjk=dsqrt(rrjk)
18185 !C there are three combination of distances for each trisulfide bonds
18186 !C The first case the ith atom is the center
18187 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18188 !C distance y is second distance the a,b,c,d are parameters derived for
18189 !C this problem d parameter was set as a penalty currenlty set to 1.
18190       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18191       eij1=0.0d0
18192       else
18193       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18194       endif
18195 !C second case jth atom is center
18196       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18197       eij2=0.0d0
18198       else
18199       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18200       endif
18201 !C the third case kth atom is the center
18202       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18203       eij3=0.0d0
18204       else
18205       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18206       endif
18207 !C      eij2=0.0
18208 !C      eij3=0.0
18209 !C      eij1=0.0
18210       eij=eij1+eij2+eij3
18211 !C      write(iout,*)i,j,k,eij
18212 !C The energy penalty calculated now time for the gradient part
18213 !C derivative over rij
18214       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18215       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18216             gg(1)=xij*fac/rij
18217             gg(2)=yij*fac/rij
18218             gg(3)=zij*fac/rij
18219       do m=1,3
18220         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18221         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18222       enddo
18223
18224       do l=1,3
18225         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18226         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18227       enddo
18228 !C now derivative over rik
18229       fac=-eij1**2/dtriss* &
18230       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18231       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18232             gg(1)=xik*fac/rik
18233             gg(2)=yik*fac/rik
18234             gg(3)=zik*fac/rik
18235       do m=1,3
18236         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18237         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18238       enddo
18239       do l=1,3
18240         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18241         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18242       enddo
18243 !C now derivative over rjk
18244       fac=-eij2**2/dtriss* &
18245       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18246       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18247             gg(1)=xjk*fac/rjk
18248             gg(2)=yjk*fac/rjk
18249             gg(3)=zjk*fac/rjk
18250       do m=1,3
18251         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18252         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18253       enddo
18254       do l=1,3
18255         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18256         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18257       enddo
18258       return
18259       end subroutine triple_ssbond_ene
18260
18261
18262
18263 !-----------------------------------------------------------------------------
18264       real(kind=8) function h_base(x,deriv)
18265 !     A smooth function going 0->1 in range [0,1]
18266 !     It should NOT be called outside range [0,1], it will not work there.
18267       implicit none
18268
18269 !     Input arguments
18270       real(kind=8) :: x
18271
18272 !     Output arguments
18273       real(kind=8) :: deriv
18274
18275 !     Local variables
18276       real(kind=8) :: xsq
18277
18278
18279 !     Two parabolas put together.  First derivative zero at extrema
18280 !$$$      if (x.lt.0.5D0) then
18281 !$$$        h_base=2.0D0*x*x
18282 !$$$        deriv=4.0D0*x
18283 !$$$      else
18284 !$$$        deriv=1.0D0-x
18285 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18286 !$$$        deriv=4.0D0*deriv
18287 !$$$      endif
18288
18289 !     Third degree polynomial.  First derivative zero at extrema
18290       h_base=x*x*(3.0d0-2.0d0*x)
18291       deriv=6.0d0*x*(1.0d0-x)
18292
18293 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18294 !$$$      xsq=x*x
18295 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18296 !$$$      deriv=x-1.0d0
18297 !$$$      deriv=deriv*deriv
18298 !$$$      deriv=30.0d0*xsq*deriv
18299
18300       return
18301       end function h_base
18302 !-----------------------------------------------------------------------------
18303       subroutine dyn_set_nss
18304 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18305 !      implicit none
18306       use MD_data, only: totT,t_bath
18307 !     Includes
18308 !      include 'DIMENSIONS'
18309 #ifdef MPI
18310       include "mpif.h"
18311 #endif
18312 !      include 'COMMON.SBRIDGE'
18313 !      include 'COMMON.CHAIN'
18314 !      include 'COMMON.IOUNITS'
18315 !      include 'COMMON.SETUP'
18316 !      include 'COMMON.MD'
18317 !     Local variables
18318       real(kind=8) :: emin
18319       integer :: i,j,imin,ierr
18320       integer :: diff,allnss,newnss
18321       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18322                 newihpb,newjhpb
18323       logical :: found
18324       integer,dimension(0:nfgtasks) :: i_newnss
18325       integer,dimension(0:nfgtasks) :: displ
18326       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18327       integer :: g_newnss
18328
18329       allnss=0
18330       do i=1,nres-1
18331         do j=i+1,nres
18332           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18333             allnss=allnss+1
18334             allflag(allnss)=0
18335             allihpb(allnss)=i
18336             alljhpb(allnss)=j
18337           endif
18338         enddo
18339       enddo
18340
18341 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18342
18343  1    emin=1.0d300
18344       do i=1,allnss
18345         if (allflag(i).eq.0 .and. &
18346              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18347           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18348           imin=i
18349         endif
18350       enddo
18351       if (emin.lt.1.0d300) then
18352         allflag(imin)=1
18353         do i=1,allnss
18354           if (allflag(i).eq.0 .and. &
18355                (allihpb(i).eq.allihpb(imin) .or. &
18356                alljhpb(i).eq.allihpb(imin) .or. &
18357                allihpb(i).eq.alljhpb(imin) .or. &
18358                alljhpb(i).eq.alljhpb(imin))) then
18359             allflag(i)=-1
18360           endif
18361         enddo
18362         goto 1
18363       endif
18364
18365 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18366
18367       newnss=0
18368       do i=1,allnss
18369         if (allflag(i).eq.1) then
18370           newnss=newnss+1
18371           newihpb(newnss)=allihpb(i)
18372           newjhpb(newnss)=alljhpb(i)
18373         endif
18374       enddo
18375
18376 #ifdef MPI
18377       if (nfgtasks.gt.1)then
18378
18379         call MPI_Reduce(newnss,g_newnss,1,&
18380           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18381         call MPI_Gather(newnss,1,MPI_INTEGER,&
18382                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18383         displ(0)=0
18384         do i=1,nfgtasks-1,1
18385           displ(i)=i_newnss(i-1)+displ(i-1)
18386         enddo
18387         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18388                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18389                          king,FG_COMM,IERR)
18390         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18391                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18392                          king,FG_COMM,IERR)
18393         if(fg_rank.eq.0) then
18394 !         print *,'g_newnss',g_newnss
18395 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18396 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18397          newnss=g_newnss
18398          do i=1,newnss
18399           newihpb(i)=g_newihpb(i)
18400           newjhpb(i)=g_newjhpb(i)
18401          enddo
18402         endif
18403       endif
18404 #endif
18405
18406       diff=newnss-nss
18407
18408 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18409 !       print *,newnss,nss,maxdim
18410       do i=1,nss
18411         found=.false.
18412 !        print *,newnss
18413         do j=1,newnss
18414 !!          print *,j
18415           if (idssb(i).eq.newihpb(j) .and. &
18416                jdssb(i).eq.newjhpb(j)) found=.true.
18417         enddo
18418 #ifndef CLUST
18419 #ifndef WHAM
18420 !        write(iout,*) "found",found,i,j
18421         if (.not.found.and.fg_rank.eq.0) &
18422             write(iout,'(a15,f12.2,f8.1,2i5)') &
18423              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18424 #endif
18425 #endif
18426       enddo
18427
18428       do i=1,newnss
18429         found=.false.
18430         do j=1,nss
18431 !          print *,i,j
18432           if (newihpb(i).eq.idssb(j) .and. &
18433                newjhpb(i).eq.jdssb(j)) found=.true.
18434         enddo
18435 #ifndef CLUST
18436 #ifndef WHAM
18437 !        write(iout,*) "found",found,i,j
18438         if (.not.found.and.fg_rank.eq.0) &
18439             write(iout,'(a15,f12.2,f8.1,2i5)') &
18440              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18441 #endif
18442 #endif
18443       enddo
18444
18445       nss=newnss
18446       do i=1,nss
18447         idssb(i)=newihpb(i)
18448         jdssb(i)=newjhpb(i)
18449       enddo
18450
18451       return
18452       end subroutine dyn_set_nss
18453 ! Lipid transfer energy function
18454       subroutine Eliptransfer(eliptran)
18455 !C this is done by Adasko
18456 !C      print *,"wchodze"
18457 !C structure of box:
18458 !C      water
18459 !C--bordliptop-- buffore starts
18460 !C--bufliptop--- here true lipid starts
18461 !C      lipid
18462 !C--buflipbot--- lipid ends buffore starts
18463 !C--bordlipbot--buffore ends
18464       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18465       integer :: i
18466       eliptran=0.0
18467 !      print *, "I am in eliptran"
18468       do i=ilip_start,ilip_end
18469 !C       do i=1,1
18470         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18471          cycle
18472
18473         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18474         if (positi.le.0.0) positi=positi+boxzsize
18475 !C        print *,i
18476 !C first for peptide groups
18477 !c for each residue check if it is in lipid or lipid water border area
18478        if ((positi.gt.bordlipbot)  &
18479       .and.(positi.lt.bordliptop)) then
18480 !C the energy transfer exist
18481         if (positi.lt.buflipbot) then
18482 !C what fraction I am in
18483          fracinbuf=1.0d0-      &
18484              ((positi-bordlipbot)/lipbufthick)
18485 !C lipbufthick is thickenes of lipid buffore
18486          sslip=sscalelip(fracinbuf)
18487          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18488          eliptran=eliptran+sslip*pepliptran
18489          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18490          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18491 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18492
18493 !C        print *,"doing sccale for lower part"
18494 !C         print *,i,sslip,fracinbuf,ssgradlip
18495         elseif (positi.gt.bufliptop) then
18496          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18497          sslip=sscalelip(fracinbuf)
18498          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18499          eliptran=eliptran+sslip*pepliptran
18500          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18501          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18502 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18503 !C          print *, "doing sscalefor top part"
18504 !C         print *,i,sslip,fracinbuf,ssgradlip
18505         else
18506          eliptran=eliptran+pepliptran
18507 !C         print *,"I am in true lipid"
18508         endif
18509 !C       else
18510 !C       eliptran=elpitran+0.0 ! I am in water
18511        endif
18512        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18513        enddo
18514 ! here starts the side chain transfer
18515        do i=ilip_start,ilip_end
18516         if (itype(i,1).eq.ntyp1) cycle
18517         positi=(mod(c(3,i+nres),boxzsize))
18518         if (positi.le.0) positi=positi+boxzsize
18519 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18520 !c for each residue check if it is in lipid or lipid water border area
18521 !C       respos=mod(c(3,i+nres),boxzsize)
18522 !C       print *,positi,bordlipbot,buflipbot
18523        if ((positi.gt.bordlipbot) &
18524        .and.(positi.lt.bordliptop)) then
18525 !C the energy transfer exist
18526         if (positi.lt.buflipbot) then
18527          fracinbuf=1.0d0-   &
18528            ((positi-bordlipbot)/lipbufthick)
18529 !C lipbufthick is thickenes of lipid buffore
18530          sslip=sscalelip(fracinbuf)
18531          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18532          eliptran=eliptran+sslip*liptranene(itype(i,1))
18533          gliptranx(3,i)=gliptranx(3,i) &
18534       +ssgradlip*liptranene(itype(i,1))
18535          gliptranc(3,i-1)= gliptranc(3,i-1) &
18536       +ssgradlip*liptranene(itype(i,1))
18537 !C         print *,"doing sccale for lower part"
18538         elseif (positi.gt.bufliptop) then
18539          fracinbuf=1.0d0-  &
18540       ((bordliptop-positi)/lipbufthick)
18541          sslip=sscalelip(fracinbuf)
18542          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18543          eliptran=eliptran+sslip*liptranene(itype(i,1))
18544          gliptranx(3,i)=gliptranx(3,i)  &
18545        +ssgradlip*liptranene(itype(i,1))
18546          gliptranc(3,i-1)= gliptranc(3,i-1) &
18547       +ssgradlip*liptranene(itype(i,1))
18548 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18549         else
18550          eliptran=eliptran+liptranene(itype(i,1))
18551 !C         print *,"I am in true lipid"
18552         endif
18553         endif ! if in lipid or buffor
18554 !C       else
18555 !C       eliptran=elpitran+0.0 ! I am in water
18556         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18557        enddo
18558        return
18559        end  subroutine Eliptransfer
18560 !----------------------------------NANO FUNCTIONS
18561 !C-----------------------------------------------------------------------
18562 !C-----------------------------------------------------------
18563 !C This subroutine is to mimic the histone like structure but as well can be
18564 !C utilizet to nanostructures (infinit) small modification has to be used to
18565 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18566 !C gradient has to be modified at the ends
18567 !C The energy function is Kihara potential
18568 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18569 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18570 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18571 !C simple Kihara potential
18572       subroutine calctube(Etube)
18573       real(kind=8),dimension(3) :: vectube
18574       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18575        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18576        sc_aa_tube,sc_bb_tube
18577       integer :: i,j,iti
18578       Etube=0.0d0
18579       do i=itube_start,itube_end
18580         enetube(i)=0.0d0
18581         enetube(i+nres)=0.0d0
18582       enddo
18583 !C first we calculate the distance from tube center
18584 !C for UNRES
18585        do i=itube_start,itube_end
18586 !C lets ommit dummy atoms for now
18587        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18588 !C now calculate distance from center of tube and direction vectors
18589       xmin=boxxsize
18590       ymin=boxysize
18591 ! Find minimum distance in periodic box
18592         do j=-1,1
18593          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18594          vectube(1)=vectube(1)+boxxsize*j
18595          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18596          vectube(2)=vectube(2)+boxysize*j
18597          xminact=abs(vectube(1)-tubecenter(1))
18598          yminact=abs(vectube(2)-tubecenter(2))
18599            if (xmin.gt.xminact) then
18600             xmin=xminact
18601             xtemp=vectube(1)
18602            endif
18603            if (ymin.gt.yminact) then
18604              ymin=yminact
18605              ytemp=vectube(2)
18606             endif
18607          enddo
18608       vectube(1)=xtemp
18609       vectube(2)=ytemp
18610       vectube(1)=vectube(1)-tubecenter(1)
18611       vectube(2)=vectube(2)-tubecenter(2)
18612
18613 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18614 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18615
18616 !C as the tube is infinity we do not calculate the Z-vector use of Z
18617 !C as chosen axis
18618       vectube(3)=0.0d0
18619 !C now calculte the distance
18620        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18621 !C now normalize vector
18622       vectube(1)=vectube(1)/tub_r
18623       vectube(2)=vectube(2)/tub_r
18624 !C calculte rdiffrence between r and r0
18625       rdiff=tub_r-tubeR0
18626 !C and its 6 power
18627       rdiff6=rdiff**6.0d0
18628 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18629        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18630 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18631 !C       print *,rdiff,rdiff6,pep_aa_tube
18632 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18633 !C now we calculate gradient
18634        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18635             6.0d0*pep_bb_tube)/rdiff6/rdiff
18636 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18637 !C     &rdiff,fac
18638 !C now direction of gg_tube vector
18639         do j=1,3
18640         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18641         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18642         enddo
18643         enddo
18644 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18645 !C        print *,gg_tube(1,0),"TU"
18646
18647
18648        do i=itube_start,itube_end
18649 !C Lets not jump over memory as we use many times iti
18650          iti=itype(i,1)
18651 !C lets ommit dummy atoms for now
18652          if ((iti.eq.ntyp1)  &
18653 !C in UNRES uncomment the line below as GLY has no side-chain...
18654 !C      .or.(iti.eq.10)
18655         ) cycle
18656       xmin=boxxsize
18657       ymin=boxysize
18658         do j=-1,1
18659          vectube(1)=mod((c(1,i+nres)),boxxsize)
18660          vectube(1)=vectube(1)+boxxsize*j
18661          vectube(2)=mod((c(2,i+nres)),boxysize)
18662          vectube(2)=vectube(2)+boxysize*j
18663
18664          xminact=abs(vectube(1)-tubecenter(1))
18665          yminact=abs(vectube(2)-tubecenter(2))
18666            if (xmin.gt.xminact) then
18667             xmin=xminact
18668             xtemp=vectube(1)
18669            endif
18670            if (ymin.gt.yminact) then
18671              ymin=yminact
18672              ytemp=vectube(2)
18673             endif
18674          enddo
18675       vectube(1)=xtemp
18676       vectube(2)=ytemp
18677 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18678 !C     &     tubecenter(2)
18679       vectube(1)=vectube(1)-tubecenter(1)
18680       vectube(2)=vectube(2)-tubecenter(2)
18681
18682 !C as the tube is infinity we do not calculate the Z-vector use of Z
18683 !C as chosen axis
18684       vectube(3)=0.0d0
18685 !C now calculte the distance
18686        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18687 !C now normalize vector
18688       vectube(1)=vectube(1)/tub_r
18689       vectube(2)=vectube(2)/tub_r
18690
18691 !C calculte rdiffrence between r and r0
18692       rdiff=tub_r-tubeR0
18693 !C and its 6 power
18694       rdiff6=rdiff**6.0d0
18695 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18696        sc_aa_tube=sc_aa_tube_par(iti)
18697        sc_bb_tube=sc_bb_tube_par(iti)
18698        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18699        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18700              6.0d0*sc_bb_tube/rdiff6/rdiff
18701 !C now direction of gg_tube vector
18702          do j=1,3
18703           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18704           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18705          enddo
18706         enddo
18707         do i=itube_start,itube_end
18708           Etube=Etube+enetube(i)+enetube(i+nres)
18709         enddo
18710 !C        print *,"ETUBE", etube
18711         return
18712         end subroutine calctube
18713 !C TO DO 1) add to total energy
18714 !C       2) add to gradient summation
18715 !C       3) add reading parameters (AND of course oppening of PARAM file)
18716 !C       4) add reading the center of tube
18717 !C       5) add COMMONs
18718 !C       6) add to zerograd
18719 !C       7) allocate matrices
18720
18721
18722 !C-----------------------------------------------------------------------
18723 !C-----------------------------------------------------------
18724 !C This subroutine is to mimic the histone like structure but as well can be
18725 !C utilizet to nanostructures (infinit) small modification has to be used to
18726 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18727 !C gradient has to be modified at the ends
18728 !C The energy function is Kihara potential
18729 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18730 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18731 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18732 !C simple Kihara potential
18733       subroutine calctube2(Etube)
18734             real(kind=8),dimension(3) :: vectube
18735       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18736        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18737        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18738       integer:: i,j,iti
18739       Etube=0.0d0
18740       do i=itube_start,itube_end
18741         enetube(i)=0.0d0
18742         enetube(i+nres)=0.0d0
18743       enddo
18744 !C first we calculate the distance from tube center
18745 !C first sugare-phosphate group for NARES this would be peptide group
18746 !C for UNRES
18747        do i=itube_start,itube_end
18748 !C lets ommit dummy atoms for now
18749
18750        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18751 !C now calculate distance from center of tube and direction vectors
18752 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18753 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18754 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18755 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18756       xmin=boxxsize
18757       ymin=boxysize
18758         do j=-1,1
18759          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18760          vectube(1)=vectube(1)+boxxsize*j
18761          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18762          vectube(2)=vectube(2)+boxysize*j
18763
18764          xminact=abs(vectube(1)-tubecenter(1))
18765          yminact=abs(vectube(2)-tubecenter(2))
18766            if (xmin.gt.xminact) then
18767             xmin=xminact
18768             xtemp=vectube(1)
18769            endif
18770            if (ymin.gt.yminact) then
18771              ymin=yminact
18772              ytemp=vectube(2)
18773             endif
18774          enddo
18775       vectube(1)=xtemp
18776       vectube(2)=ytemp
18777       vectube(1)=vectube(1)-tubecenter(1)
18778       vectube(2)=vectube(2)-tubecenter(2)
18779
18780 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18781 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18782
18783 !C as the tube is infinity we do not calculate the Z-vector use of Z
18784 !C as chosen axis
18785       vectube(3)=0.0d0
18786 !C now calculte the distance
18787        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18788 !C now normalize vector
18789       vectube(1)=vectube(1)/tub_r
18790       vectube(2)=vectube(2)/tub_r
18791 !C calculte rdiffrence between r and r0
18792       rdiff=tub_r-tubeR0
18793 !C and its 6 power
18794       rdiff6=rdiff**6.0d0
18795 !C THIS FRAGMENT MAKES TUBE FINITE
18796         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18797         if (positi.le.0) positi=positi+boxzsize
18798 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18799 !c for each residue check if it is in lipid or lipid water border area
18800 !C       respos=mod(c(3,i+nres),boxzsize)
18801 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18802        if ((positi.gt.bordtubebot)  &
18803         .and.(positi.lt.bordtubetop)) then
18804 !C the energy transfer exist
18805         if (positi.lt.buftubebot) then
18806          fracinbuf=1.0d0-  &
18807            ((positi-bordtubebot)/tubebufthick)
18808 !C lipbufthick is thickenes of lipid buffore
18809          sstube=sscalelip(fracinbuf)
18810          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18811 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18812          enetube(i)=enetube(i)+sstube*tubetranenepep
18813 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18814 !C     &+ssgradtube*tubetranene(itype(i,1))
18815 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18816 !C     &+ssgradtube*tubetranene(itype(i,1))
18817 !C         print *,"doing sccale for lower part"
18818         elseif (positi.gt.buftubetop) then
18819          fracinbuf=1.0d0-  &
18820         ((bordtubetop-positi)/tubebufthick)
18821          sstube=sscalelip(fracinbuf)
18822          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18823          enetube(i)=enetube(i)+sstube*tubetranenepep
18824 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18825 !C     &+ssgradtube*tubetranene(itype(i,1))
18826 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18827 !C     &+ssgradtube*tubetranene(itype(i,1))
18828 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18829         else
18830          sstube=1.0d0
18831          ssgradtube=0.0d0
18832          enetube(i)=enetube(i)+sstube*tubetranenepep
18833 !C         print *,"I am in true lipid"
18834         endif
18835         else
18836 !C          sstube=0.0d0
18837 !C          ssgradtube=0.0d0
18838         cycle
18839         endif ! if in lipid or buffor
18840
18841 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18842        enetube(i)=enetube(i)+sstube* &
18843         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18844 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18845 !C       print *,rdiff,rdiff6,pep_aa_tube
18846 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18847 !C now we calculate gradient
18848        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18849              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18850 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18851 !C     &rdiff,fac
18852
18853 !C now direction of gg_tube vector
18854        do j=1,3
18855         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18856         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18857         enddo
18858          gg_tube(3,i)=gg_tube(3,i)  &
18859        +ssgradtube*enetube(i)/sstube/2.0d0
18860          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18861        +ssgradtube*enetube(i)/sstube/2.0d0
18862
18863         enddo
18864 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18865 !C        print *,gg_tube(1,0),"TU"
18866         do i=itube_start,itube_end
18867 !C Lets not jump over memory as we use many times iti
18868          iti=itype(i,1)
18869 !C lets ommit dummy atoms for now
18870          if ((iti.eq.ntyp1) &
18871 !!C in UNRES uncomment the line below as GLY has no side-chain...
18872            .or.(iti.eq.10) &
18873           ) cycle
18874           vectube(1)=c(1,i+nres)
18875           vectube(1)=mod(vectube(1),boxxsize)
18876           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18877           vectube(2)=c(2,i+nres)
18878           vectube(2)=mod(vectube(2),boxysize)
18879           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18880
18881       vectube(1)=vectube(1)-tubecenter(1)
18882       vectube(2)=vectube(2)-tubecenter(2)
18883 !C THIS FRAGMENT MAKES TUBE FINITE
18884         positi=(mod(c(3,i+nres),boxzsize))
18885         if (positi.le.0) positi=positi+boxzsize
18886 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18887 !c for each residue check if it is in lipid or lipid water border area
18888 !C       respos=mod(c(3,i+nres),boxzsize)
18889 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18890
18891        if ((positi.gt.bordtubebot)  &
18892         .and.(positi.lt.bordtubetop)) then
18893 !C the energy transfer exist
18894         if (positi.lt.buftubebot) then
18895          fracinbuf=1.0d0- &
18896             ((positi-bordtubebot)/tubebufthick)
18897 !C lipbufthick is thickenes of lipid buffore
18898          sstube=sscalelip(fracinbuf)
18899          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18900 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18901          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18902 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18903 !C     &+ssgradtube*tubetranene(itype(i,1))
18904 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18905 !C     &+ssgradtube*tubetranene(itype(i,1))
18906 !C         print *,"doing sccale for lower part"
18907         elseif (positi.gt.buftubetop) then
18908          fracinbuf=1.0d0- &
18909         ((bordtubetop-positi)/tubebufthick)
18910
18911          sstube=sscalelip(fracinbuf)
18912          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18913          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18914 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18915 !C     &+ssgradtube*tubetranene(itype(i,1))
18916 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18917 !C     &+ssgradtube*tubetranene(itype(i,1))
18918 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18919         else
18920          sstube=1.0d0
18921          ssgradtube=0.0d0
18922          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18923 !C         print *,"I am in true lipid"
18924         endif
18925         else
18926 !C          sstube=0.0d0
18927 !C          ssgradtube=0.0d0
18928         cycle
18929         endif ! if in lipid or buffor
18930 !CEND OF FINITE FRAGMENT
18931 !C as the tube is infinity we do not calculate the Z-vector use of Z
18932 !C as chosen axis
18933       vectube(3)=0.0d0
18934 !C now calculte the distance
18935        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18936 !C now normalize vector
18937       vectube(1)=vectube(1)/tub_r
18938       vectube(2)=vectube(2)/tub_r
18939 !C calculte rdiffrence between r and r0
18940       rdiff=tub_r-tubeR0
18941 !C and its 6 power
18942       rdiff6=rdiff**6.0d0
18943 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18944        sc_aa_tube=sc_aa_tube_par(iti)
18945        sc_bb_tube=sc_bb_tube_par(iti)
18946        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18947                        *sstube+enetube(i+nres)
18948 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18949 !C now we calculate gradient
18950        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18951             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18952 !C now direction of gg_tube vector
18953          do j=1,3
18954           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18955           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18956          enddo
18957          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18958        +ssgradtube*enetube(i+nres)/sstube
18959          gg_tube(3,i-1)= gg_tube(3,i-1) &
18960        +ssgradtube*enetube(i+nres)/sstube
18961
18962         enddo
18963         do i=itube_start,itube_end
18964           Etube=Etube+enetube(i)+enetube(i+nres)
18965         enddo
18966 !C        print *,"ETUBE", etube
18967         return
18968         end subroutine calctube2
18969 !=====================================================================================================================================
18970       subroutine calcnano(Etube)
18971       real(kind=8),dimension(3) :: vectube
18972
18973       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18974        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
18975        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
18976        integer:: i,j,iti,r
18977
18978       Etube=0.0d0
18979 !      print *,itube_start,itube_end,"poczatek"
18980       do i=itube_start,itube_end
18981         enetube(i)=0.0d0
18982         enetube(i+nres)=0.0d0
18983       enddo
18984 !C first we calculate the distance from tube center
18985 !C first sugare-phosphate group for NARES this would be peptide group
18986 !C for UNRES
18987        do i=itube_start,itube_end
18988 !C lets ommit dummy atoms for now
18989        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18990 !C now calculate distance from center of tube and direction vectors
18991       xmin=boxxsize
18992       ymin=boxysize
18993       zmin=boxzsize
18994
18995         do j=-1,1
18996          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18997          vectube(1)=vectube(1)+boxxsize*j
18998          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18999          vectube(2)=vectube(2)+boxysize*j
19000          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19001          vectube(3)=vectube(3)+boxzsize*j
19002
19003
19004          xminact=dabs(vectube(1)-tubecenter(1))
19005          yminact=dabs(vectube(2)-tubecenter(2))
19006          zminact=dabs(vectube(3)-tubecenter(3))
19007
19008            if (xmin.gt.xminact) then
19009             xmin=xminact
19010             xtemp=vectube(1)
19011            endif
19012            if (ymin.gt.yminact) then
19013              ymin=yminact
19014              ytemp=vectube(2)
19015             endif
19016            if (zmin.gt.zminact) then
19017              zmin=zminact
19018              ztemp=vectube(3)
19019             endif
19020          enddo
19021       vectube(1)=xtemp
19022       vectube(2)=ytemp
19023       vectube(3)=ztemp
19024
19025       vectube(1)=vectube(1)-tubecenter(1)
19026       vectube(2)=vectube(2)-tubecenter(2)
19027       vectube(3)=vectube(3)-tubecenter(3)
19028
19029 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19030 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19031 !C as the tube is infinity we do not calculate the Z-vector use of Z
19032 !C as chosen axis
19033 !C      vectube(3)=0.0d0
19034 !C now calculte the distance
19035        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19036 !C now normalize vector
19037       vectube(1)=vectube(1)/tub_r
19038       vectube(2)=vectube(2)/tub_r
19039       vectube(3)=vectube(3)/tub_r
19040 !C calculte rdiffrence between r and r0
19041       rdiff=tub_r-tubeR0
19042 !C and its 6 power
19043       rdiff6=rdiff**6.0d0
19044 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19045        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19046 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19047 !C       print *,rdiff,rdiff6,pep_aa_tube
19048 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19049 !C now we calculate gradient
19050        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19051             6.0d0*pep_bb_tube)/rdiff6/rdiff
19052 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19053 !C     &rdiff,fac
19054          if (acavtubpep.eq.0.0d0) then
19055 !C go to 667
19056          enecavtube(i)=0.0
19057          faccav=0.0
19058          else
19059          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19060          enecavtube(i)=  &
19061         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19062         /denominator
19063          enecavtube(i)=0.0
19064          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19065         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19066         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19067         /denominator**2.0d0
19068 !C         faccav=0.0
19069 !C         fac=fac+faccav
19070 !C 667     continue
19071          endif
19072           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19073         do j=1,3
19074         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19075         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19076         enddo
19077         enddo
19078
19079        do i=itube_start,itube_end
19080         enecavtube(i)=0.0d0
19081 !C Lets not jump over memory as we use many times iti
19082          iti=itype(i,1)
19083 !C lets ommit dummy atoms for now
19084          if ((iti.eq.ntyp1) &
19085 !C in UNRES uncomment the line below as GLY has no side-chain...
19086 !C      .or.(iti.eq.10)
19087          ) cycle
19088       xmin=boxxsize
19089       ymin=boxysize
19090       zmin=boxzsize
19091         do j=-1,1
19092          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19093          vectube(1)=vectube(1)+boxxsize*j
19094          vectube(2)=dmod((c(2,i+nres)),boxysize)
19095          vectube(2)=vectube(2)+boxysize*j
19096          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19097          vectube(3)=vectube(3)+boxzsize*j
19098
19099
19100          xminact=dabs(vectube(1)-tubecenter(1))
19101          yminact=dabs(vectube(2)-tubecenter(2))
19102          zminact=dabs(vectube(3)-tubecenter(3))
19103
19104            if (xmin.gt.xminact) then
19105             xmin=xminact
19106             xtemp=vectube(1)
19107            endif
19108            if (ymin.gt.yminact) then
19109              ymin=yminact
19110              ytemp=vectube(2)
19111             endif
19112            if (zmin.gt.zminact) then
19113              zmin=zminact
19114              ztemp=vectube(3)
19115             endif
19116          enddo
19117       vectube(1)=xtemp
19118       vectube(2)=ytemp
19119       vectube(3)=ztemp
19120
19121 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19122 !C     &     tubecenter(2)
19123       vectube(1)=vectube(1)-tubecenter(1)
19124       vectube(2)=vectube(2)-tubecenter(2)
19125       vectube(3)=vectube(3)-tubecenter(3)
19126 !C now calculte the distance
19127        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19128 !C now normalize vector
19129       vectube(1)=vectube(1)/tub_r
19130       vectube(2)=vectube(2)/tub_r
19131       vectube(3)=vectube(3)/tub_r
19132
19133 !C calculte rdiffrence between r and r0
19134       rdiff=tub_r-tubeR0
19135 !C and its 6 power
19136       rdiff6=rdiff**6.0d0
19137        sc_aa_tube=sc_aa_tube_par(iti)
19138        sc_bb_tube=sc_bb_tube_par(iti)
19139        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19140 !C       enetube(i+nres)=0.0d0
19141 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19142 !C now we calculate gradient
19143        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19144             6.0d0*sc_bb_tube/rdiff6/rdiff
19145 !C       fac=0.0
19146 !C now direction of gg_tube vector
19147 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19148          if (acavtub(iti).eq.0.0d0) then
19149 !C go to 667
19150          enecavtube(i+nres)=0.0d0
19151          faccav=0.0d0
19152          else
19153          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19154          enecavtube(i+nres)=   &
19155         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19156         /denominator
19157 !C         enecavtube(i)=0.0
19158          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19159         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19160         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19161         /denominator**2.0d0
19162 !C         faccav=0.0
19163          fac=fac+faccav
19164 !C 667     continue
19165          endif
19166 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19167 !C     &   enecavtube(i),faccav
19168 !C         print *,"licz=",
19169 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19170 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19171          do j=1,3
19172           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19173           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19174          enddo
19175           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19176         enddo
19177
19178
19179
19180         do i=itube_start,itube_end
19181           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19182          +enecavtube(i+nres)
19183         enddo
19184 !        do i=1,20
19185 !         print *,"begin", i,"a"
19186 !         do r=1,10000
19187 !          rdiff=r/100.0d0
19188 !          rdiff6=rdiff**6.0d0
19189 !          sc_aa_tube=sc_aa_tube_par(i)
19190 !          sc_bb_tube=sc_bb_tube_par(i)
19191 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19192 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19193 !          enecavtube(i)=   &
19194 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19195 !         /denominator
19196
19197 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19198 !         enddo
19199 !         print *,"end",i,"a"
19200 !        enddo
19201 !C        print *,"ETUBE", etube
19202         return
19203         end subroutine calcnano
19204
19205 !===============================================
19206 !--------------------------------------------------------------------------------
19207 !C first for shielding is setting of function of side-chains
19208
19209        subroutine set_shield_fac2
19210        real(kind=8) :: div77_81=0.974996043d0, &
19211         div4_81=0.2222222222d0
19212        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19213          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19214          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19215          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19216 !C the vector between center of side_chain and peptide group
19217        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19218          pept_group,costhet_grad,cosphi_grad_long, &
19219          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19220          sh_frac_dist_grad,pep_side
19221         integer i,j,k
19222 !C      write(2,*) "ivec",ivec_start,ivec_end
19223       do i=1,nres
19224         fac_shield(i)=0.0d0
19225         do j=1,3
19226         grad_shield(j,i)=0.0d0
19227         enddo
19228       enddo
19229       do i=ivec_start,ivec_end
19230 !C      do i=1,nres-1
19231 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19232       ishield_list(i)=0
19233       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19234 !Cif there two consequtive dummy atoms there is no peptide group between them
19235 !C the line below has to be changed for FGPROC>1
19236       VolumeTotal=0.0
19237       do k=1,nres
19238        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19239        dist_pep_side=0.0
19240        dist_side_calf=0.0
19241        do j=1,3
19242 !C first lets set vector conecting the ithe side-chain with kth side-chain
19243       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19244 !C      pep_side(j)=2.0d0
19245 !C and vector conecting the side-chain with its proper calfa
19246       side_calf(j)=c(j,k+nres)-c(j,k)
19247 !C      side_calf(j)=2.0d0
19248       pept_group(j)=c(j,i)-c(j,i+1)
19249 !C lets have their lenght
19250       dist_pep_side=pep_side(j)**2+dist_pep_side
19251       dist_side_calf=dist_side_calf+side_calf(j)**2
19252       dist_pept_group=dist_pept_group+pept_group(j)**2
19253       enddo
19254        dist_pep_side=sqrt(dist_pep_side)
19255        dist_pept_group=sqrt(dist_pept_group)
19256        dist_side_calf=sqrt(dist_side_calf)
19257       do j=1,3
19258         pep_side_norm(j)=pep_side(j)/dist_pep_side
19259         side_calf_norm(j)=dist_side_calf
19260       enddo
19261 !C now sscale fraction
19262        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19263 !C       print *,buff_shield,"buff"
19264 !C now sscale
19265         if (sh_frac_dist.le.0.0) cycle
19266 !C        print *,ishield_list(i),i
19267 !C If we reach here it means that this side chain reaches the shielding sphere
19268 !C Lets add him to the list for gradient
19269         ishield_list(i)=ishield_list(i)+1
19270 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19271 !C this list is essential otherwise problem would be O3
19272         shield_list(ishield_list(i),i)=k
19273 !C Lets have the sscale value
19274         if (sh_frac_dist.gt.1.0) then
19275          scale_fac_dist=1.0d0
19276          do j=1,3
19277          sh_frac_dist_grad(j)=0.0d0
19278          enddo
19279         else
19280          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19281                         *(2.0d0*sh_frac_dist-3.0d0)
19282          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19283                        /dist_pep_side/buff_shield*0.5d0
19284          do j=1,3
19285          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19286 !C         sh_frac_dist_grad(j)=0.0d0
19287 !C         scale_fac_dist=1.0d0
19288 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19289 !C     &                    sh_frac_dist_grad(j)
19290          enddo
19291         endif
19292 !C this is what is now we have the distance scaling now volume...
19293       short=short_r_sidechain(itype(k,1))
19294       long=long_r_sidechain(itype(k,1))
19295       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19296       sinthet=short/dist_pep_side*costhet
19297 !C now costhet_grad
19298 !C       costhet=0.6d0
19299 !C       sinthet=0.8
19300        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19301 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19302 !C     &             -short/dist_pep_side**2/costhet)
19303 !C       costhet_fac=0.0d0
19304        do j=1,3
19305          costhet_grad(j)=costhet_fac*pep_side(j)
19306        enddo
19307 !C remember for the final gradient multiply costhet_grad(j)
19308 !C for side_chain by factor -2 !
19309 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19310 !C pep_side0pept_group is vector multiplication
19311       pep_side0pept_group=0.0d0
19312       do j=1,3
19313       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19314       enddo
19315       cosalfa=(pep_side0pept_group/ &
19316       (dist_pep_side*dist_side_calf))
19317       fac_alfa_sin=1.0d0-cosalfa**2
19318       fac_alfa_sin=dsqrt(fac_alfa_sin)
19319       rkprim=fac_alfa_sin*(long-short)+short
19320 !C      rkprim=short
19321
19322 !C now costhet_grad
19323        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19324 !C       cosphi=0.6
19325        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19326        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19327            dist_pep_side**2)
19328 !C       sinphi=0.8
19329        do j=1,3
19330          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19331       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19332       *(long-short)/fac_alfa_sin*cosalfa/ &
19333       ((dist_pep_side*dist_side_calf))* &
19334       ((side_calf(j))-cosalfa* &
19335       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19336 !C       cosphi_grad_long(j)=0.0d0
19337         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19338       *(long-short)/fac_alfa_sin*cosalfa &
19339       /((dist_pep_side*dist_side_calf))* &
19340       (pep_side(j)- &
19341       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19342 !C       cosphi_grad_loc(j)=0.0d0
19343        enddo
19344 !C      print *,sinphi,sinthet
19345       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19346      &                    /VSolvSphere_div
19347 !C     &                    *wshield
19348 !C now the gradient...
19349       do j=1,3
19350       grad_shield(j,i)=grad_shield(j,i) &
19351 !C gradient po skalowaniu
19352                      +(sh_frac_dist_grad(j)*VofOverlap &
19353 !C  gradient po costhet
19354             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19355         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19356             sinphi/sinthet*costhet*costhet_grad(j) &
19357            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19358         )*wshield
19359 !C grad_shield_side is Cbeta sidechain gradient
19360       grad_shield_side(j,ishield_list(i),i)=&
19361              (sh_frac_dist_grad(j)*-2.0d0&
19362              *VofOverlap&
19363             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19364        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19365             sinphi/sinthet*costhet*costhet_grad(j)&
19366            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19367             )*wshield
19368
19369        grad_shield_loc(j,ishield_list(i),i)=   &
19370             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19371       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19372             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19373              ))&
19374              *wshield
19375       enddo
19376       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19377       enddo
19378       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19379
19380 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19381       enddo
19382       return
19383       end subroutine set_shield_fac2
19384 !----------------------------------------------------------------------------
19385 ! SOUBROUTINE FOR AFM
19386        subroutine AFMvel(Eafmforce)
19387        use MD_data, only:totTafm
19388       real(kind=8),dimension(3) :: diffafm
19389       real(kind=8) :: afmdist,Eafmforce
19390        integer :: i
19391 !C Only for check grad COMMENT if not used for checkgrad
19392 !C      totT=3.0d0
19393 !C--------------------------------------------------------
19394 !C      print *,"wchodze"
19395       afmdist=0.0d0
19396       Eafmforce=0.0d0
19397       do i=1,3
19398       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19399       afmdist=afmdist+diffafm(i)**2
19400       enddo
19401       afmdist=dsqrt(afmdist)
19402 !      totTafm=3.0
19403       Eafmforce=0.5d0*forceAFMconst &
19404       *(distafminit+totTafm*velAFMconst-afmdist)**2
19405 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19406       do i=1,3
19407       gradafm(i,afmend-1)=-forceAFMconst* &
19408        (distafminit+totTafm*velAFMconst-afmdist) &
19409        *diffafm(i)/afmdist
19410       gradafm(i,afmbeg-1)=forceAFMconst* &
19411       (distafminit+totTafm*velAFMconst-afmdist) &
19412       *diffafm(i)/afmdist
19413       enddo
19414 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19415       return
19416       end subroutine AFMvel
19417 !---------------------------------------------------------
19418        subroutine AFMforce(Eafmforce)
19419
19420       real(kind=8),dimension(3) :: diffafm
19421 !      real(kind=8) ::afmdist
19422       real(kind=8) :: afmdist,Eafmforce
19423       integer :: i
19424       afmdist=0.0d0
19425       Eafmforce=0.0d0
19426       do i=1,3
19427       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19428       afmdist=afmdist+diffafm(i)**2
19429       enddo
19430       afmdist=dsqrt(afmdist)
19431 !      print *,afmdist,distafminit
19432       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19433       do i=1,3
19434       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19435       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19436       enddo
19437 !C      print *,'AFM',Eafmforce
19438       return
19439       end subroutine AFMforce
19440
19441 !-----------------------------------------------------------------------------
19442 #ifdef WHAM
19443       subroutine read_ssHist
19444 !      implicit none
19445 !      Includes
19446 !      include 'DIMENSIONS'
19447 !      include "DIMENSIONS.FREE"
19448 !      include 'COMMON.FREE'
19449 !     Local variables
19450       integer :: i,j
19451       character(len=80) :: controlcard
19452
19453       do i=1,dyn_nssHist
19454         call card_concat(controlcard,.true.)
19455         read(controlcard,*) &
19456              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19457       enddo
19458
19459       return
19460       end subroutine read_ssHist
19461 #endif
19462 !-----------------------------------------------------------------------------
19463       integer function indmat(i,j)
19464 !el
19465 ! get the position of the jth ijth fragment of the chain coordinate system
19466 ! in the fromto array.
19467         integer :: i,j
19468
19469         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19470       return
19471       end function indmat
19472 !-----------------------------------------------------------------------------
19473       real(kind=8) function sigm(x)
19474 !el
19475        real(kind=8) :: x
19476         sigm=0.25d0*x
19477       return
19478       end function sigm
19479 !-----------------------------------------------------------------------------
19480 !-----------------------------------------------------------------------------
19481       subroutine alloc_ener_arrays
19482 !EL Allocation of arrays used by module energy
19483       use MD_data, only: mset
19484 !el local variables
19485       integer :: i,j
19486
19487       if(nres.lt.100) then
19488         maxconts=nres
19489       elseif(nres.lt.200) then
19490         maxconts=0.8*nres       ! Max. number of contacts per residue
19491       else
19492         maxconts=0.6*nres ! (maxconts=maxres/4)
19493       endif
19494       maxcont=12*nres   ! Max. number of SC contacts
19495       maxvar=6*nres     ! Max. number of variables
19496 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19497       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19498 !----------------------
19499 ! arrays in subroutine init_int_table
19500 !el#ifdef MPI
19501 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19502 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19503 !el#endif
19504       allocate(nint_gr(nres))
19505       allocate(nscp_gr(nres))
19506       allocate(ielstart(nres))
19507       allocate(ielend(nres))
19508 !(maxres)
19509       allocate(istart(nres,maxint_gr))
19510       allocate(iend(nres,maxint_gr))
19511 !(maxres,maxint_gr)
19512       allocate(iscpstart(nres,maxint_gr))
19513       allocate(iscpend(nres,maxint_gr))
19514 !(maxres,maxint_gr)
19515       allocate(ielstart_vdw(nres))
19516       allocate(ielend_vdw(nres))
19517 !(maxres)
19518       allocate(nint_gr_nucl(nres))
19519       allocate(nscp_gr_nucl(nres))
19520       allocate(ielstart_nucl(nres))
19521       allocate(ielend_nucl(nres))
19522 !(maxres)
19523       allocate(istart_nucl(nres,maxint_gr))
19524       allocate(iend_nucl(nres,maxint_gr))
19525 !(maxres,maxint_gr)
19526       allocate(iscpstart_nucl(nres,maxint_gr))
19527       allocate(iscpend_nucl(nres,maxint_gr))
19528 !(maxres,maxint_gr)
19529       allocate(ielstart_vdw_nucl(nres))
19530       allocate(ielend_vdw_nucl(nres))
19531
19532       allocate(lentyp(0:nfgtasks-1))
19533 !(0:maxprocs-1)
19534 !----------------------
19535 ! commom.contacts
19536 !      common /contacts/
19537       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19538       allocate(icont(2,maxcont))
19539 !(2,maxcont)
19540 !      common /contacts1/
19541       allocate(num_cont(0:nres+4))
19542 !(maxres)
19543       allocate(jcont(maxconts,nres))
19544 !(maxconts,maxres)
19545       allocate(facont(maxconts,nres))
19546 !(maxconts,maxres)
19547       allocate(gacont(3,maxconts,nres))
19548 !(3,maxconts,maxres)
19549 !      common /contacts_hb/
19550       allocate(gacontp_hb1(3,maxconts,nres))
19551       allocate(gacontp_hb2(3,maxconts,nres))
19552       allocate(gacontp_hb3(3,maxconts,nres))
19553       allocate(gacontm_hb1(3,maxconts,nres))
19554       allocate(gacontm_hb2(3,maxconts,nres))
19555       allocate(gacontm_hb3(3,maxconts,nres))
19556       allocate(gacont_hbr(3,maxconts,nres))
19557       allocate(grij_hb_cont(3,maxconts,nres))
19558 !(3,maxconts,maxres)
19559       allocate(facont_hb(maxconts,nres))
19560
19561       allocate(ees0p(maxconts,nres))
19562       allocate(ees0m(maxconts,nres))
19563       allocate(d_cont(maxconts,nres))
19564       allocate(ees0plist(maxconts,nres))
19565
19566 !(maxconts,maxres)
19567       allocate(num_cont_hb(nres))
19568 !(maxres)
19569       allocate(jcont_hb(maxconts,nres))
19570 !(maxconts,maxres)
19571 !      common /rotat/
19572       allocate(Ug(2,2,nres))
19573       allocate(Ugder(2,2,nres))
19574       allocate(Ug2(2,2,nres))
19575       allocate(Ug2der(2,2,nres))
19576 !(2,2,maxres)
19577       allocate(obrot(2,nres))
19578       allocate(obrot2(2,nres))
19579       allocate(obrot_der(2,nres))
19580       allocate(obrot2_der(2,nres))
19581 !(2,maxres)
19582 !      common /precomp1/
19583       allocate(mu(2,nres))
19584       allocate(muder(2,nres))
19585       allocate(Ub2(2,nres))
19586       Ub2(1,:)=0.0d0
19587       Ub2(2,:)=0.0d0
19588       allocate(Ub2der(2,nres))
19589       allocate(Ctobr(2,nres))
19590       allocate(Ctobrder(2,nres))
19591       allocate(Dtobr2(2,nres))
19592       allocate(Dtobr2der(2,nres))
19593 !(2,maxres)
19594       allocate(EUg(2,2,nres))
19595       allocate(EUgder(2,2,nres))
19596       allocate(CUg(2,2,nres))
19597       allocate(CUgder(2,2,nres))
19598       allocate(DUg(2,2,nres))
19599       allocate(Dugder(2,2,nres))
19600       allocate(DtUg2(2,2,nres))
19601       allocate(DtUg2der(2,2,nres))
19602 !(2,2,maxres)
19603 !      common /precomp2/
19604       allocate(Ug2Db1t(2,nres))
19605       allocate(Ug2Db1tder(2,nres))
19606       allocate(CUgb2(2,nres))
19607       allocate(CUgb2der(2,nres))
19608 !(2,maxres)
19609       allocate(EUgC(2,2,nres))
19610       allocate(EUgCder(2,2,nres))
19611       allocate(EUgD(2,2,nres))
19612       allocate(EUgDder(2,2,nres))
19613       allocate(DtUg2EUg(2,2,nres))
19614       allocate(Ug2DtEUg(2,2,nres))
19615 !(2,2,maxres)
19616       allocate(Ug2DtEUgder(2,2,2,nres))
19617       allocate(DtUg2EUgder(2,2,2,nres))
19618 !(2,2,2,maxres)
19619 !      common /rotat_old/
19620       allocate(costab(nres))
19621       allocate(sintab(nres))
19622       allocate(costab2(nres))
19623       allocate(sintab2(nres))
19624 !(maxres)
19625 !      common /dipmat/
19626       allocate(a_chuj(2,2,maxconts,nres))
19627 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19628       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19629 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19630 !      common /contdistrib/
19631       allocate(ncont_sent(nres))
19632       allocate(ncont_recv(nres))
19633
19634       allocate(iat_sent(nres))
19635 !(maxres)
19636       allocate(iint_sent(4,nres,nres))
19637       allocate(iint_sent_local(4,nres,nres))
19638 !(4,maxres,maxres)
19639       allocate(iturn3_sent(4,0:nres+4))
19640       allocate(iturn4_sent(4,0:nres+4))
19641       allocate(iturn3_sent_local(4,nres))
19642       allocate(iturn4_sent_local(4,nres))
19643 !(4,maxres)
19644       allocate(itask_cont_from(0:nfgtasks-1))
19645       allocate(itask_cont_to(0:nfgtasks-1))
19646 !(0:max_fg_procs-1)
19647
19648
19649
19650 !----------------------
19651 ! commom.deriv;
19652 !      common /derivat/
19653       allocate(dcdv(6,maxdim))
19654       allocate(dxdv(6,maxdim))
19655 !(6,maxdim)
19656       allocate(dxds(6,nres))
19657 !(6,maxres)
19658       allocate(gradx(3,-1:nres,0:2))
19659       allocate(gradc(3,-1:nres,0:2))
19660 !(3,maxres,2)
19661       allocate(gvdwx(3,-1:nres))
19662       allocate(gvdwc(3,-1:nres))
19663       allocate(gelc(3,-1:nres))
19664       allocate(gelc_long(3,-1:nres))
19665       allocate(gvdwpp(3,-1:nres))
19666       allocate(gvdwc_scpp(3,-1:nres))
19667       allocate(gradx_scp(3,-1:nres))
19668       allocate(gvdwc_scp(3,-1:nres))
19669       allocate(ghpbx(3,-1:nres))
19670       allocate(ghpbc(3,-1:nres))
19671       allocate(gradcorr(3,-1:nres))
19672       allocate(gradcorr_long(3,-1:nres))
19673       allocate(gradcorr5_long(3,-1:nres))
19674       allocate(gradcorr6_long(3,-1:nres))
19675       allocate(gcorr6_turn_long(3,-1:nres))
19676       allocate(gradxorr(3,-1:nres))
19677       allocate(gradcorr5(3,-1:nres))
19678       allocate(gradcorr6(3,-1:nres))
19679       allocate(gliptran(3,-1:nres))
19680       allocate(gliptranc(3,-1:nres))
19681       allocate(gliptranx(3,-1:nres))
19682       allocate(gshieldx(3,-1:nres))
19683       allocate(gshieldc(3,-1:nres))
19684       allocate(gshieldc_loc(3,-1:nres))
19685       allocate(gshieldx_ec(3,-1:nres))
19686       allocate(gshieldc_ec(3,-1:nres))
19687       allocate(gshieldc_loc_ec(3,-1:nres))
19688       allocate(gshieldx_t3(3,-1:nres))
19689       allocate(gshieldc_t3(3,-1:nres))
19690       allocate(gshieldc_loc_t3(3,-1:nres))
19691       allocate(gshieldx_t4(3,-1:nres))
19692       allocate(gshieldc_t4(3,-1:nres))
19693       allocate(gshieldc_loc_t4(3,-1:nres))
19694       allocate(gshieldx_ll(3,-1:nres))
19695       allocate(gshieldc_ll(3,-1:nres))
19696       allocate(gshieldc_loc_ll(3,-1:nres))
19697       allocate(grad_shield(3,-1:nres))
19698       allocate(gg_tube_sc(3,-1:nres))
19699       allocate(gg_tube(3,-1:nres))
19700       allocate(gradafm(3,-1:nres))
19701       allocate(gradb_nucl(3,-1:nres))
19702       allocate(gradbx_nucl(3,-1:nres))
19703       allocate(gvdwpsb1(3,-1:nres))
19704       allocate(gelpp(3,-1:nres))
19705       allocate(gvdwpsb(3,-1:nres))
19706       allocate(gelsbc(3,-1:nres))
19707       allocate(gelsbx(3,-1:nres))
19708       allocate(gvdwsbx(3,-1:nres))
19709       allocate(gvdwsbc(3,-1:nres))
19710       allocate(gsbloc(3,-1:nres))
19711       allocate(gsblocx(3,-1:nres))
19712       allocate(gradcorr_nucl(3,-1:nres))
19713       allocate(gradxorr_nucl(3,-1:nres))
19714       allocate(gradcorr3_nucl(3,-1:nres))
19715       allocate(gradxorr3_nucl(3,-1:nres))
19716       allocate(gvdwpp_nucl(3,-1:nres))
19717
19718 !(3,maxres)
19719       allocate(grad_shield_side(3,50,nres))
19720       allocate(grad_shield_loc(3,50,nres))
19721 ! grad for shielding surroing
19722       allocate(gloc(0:maxvar,0:2))
19723       allocate(gloc_x(0:maxvar,2))
19724 !(maxvar,2)
19725       allocate(gel_loc(3,-1:nres))
19726       allocate(gel_loc_long(3,-1:nres))
19727       allocate(gcorr3_turn(3,-1:nres))
19728       allocate(gcorr4_turn(3,-1:nres))
19729       allocate(gcorr6_turn(3,-1:nres))
19730       allocate(gradb(3,-1:nres))
19731       allocate(gradbx(3,-1:nres))
19732 !(3,maxres)
19733       allocate(gel_loc_loc(maxvar))
19734       allocate(gel_loc_turn3(maxvar))
19735       allocate(gel_loc_turn4(maxvar))
19736       allocate(gel_loc_turn6(maxvar))
19737       allocate(gcorr_loc(maxvar))
19738       allocate(g_corr5_loc(maxvar))
19739       allocate(g_corr6_loc(maxvar))
19740 !(maxvar)
19741       allocate(gsccorc(3,-1:nres))
19742       allocate(gsccorx(3,-1:nres))
19743 !(3,maxres)
19744       allocate(gsccor_loc(-1:nres))
19745 !(maxres)
19746       allocate(dtheta(3,2,-1:nres))
19747 !(3,2,maxres)
19748       allocate(gscloc(3,-1:nres))
19749       allocate(gsclocx(3,-1:nres))
19750 !(3,maxres)
19751       allocate(dphi(3,3,-1:nres))
19752       allocate(dalpha(3,3,-1:nres))
19753       allocate(domega(3,3,-1:nres))
19754 !(3,3,maxres)
19755 !      common /deriv_scloc/
19756       allocate(dXX_C1tab(3,nres))
19757       allocate(dYY_C1tab(3,nres))
19758       allocate(dZZ_C1tab(3,nres))
19759       allocate(dXX_Ctab(3,nres))
19760       allocate(dYY_Ctab(3,nres))
19761       allocate(dZZ_Ctab(3,nres))
19762       allocate(dXX_XYZtab(3,nres))
19763       allocate(dYY_XYZtab(3,nres))
19764       allocate(dZZ_XYZtab(3,nres))
19765 !(3,maxres)
19766 !      common /mpgrad/
19767       allocate(jgrad_start(nres))
19768       allocate(jgrad_end(nres))
19769 !(maxres)
19770 !----------------------
19771
19772 !      common /indices/
19773       allocate(ibond_displ(0:nfgtasks-1))
19774       allocate(ibond_count(0:nfgtasks-1))
19775       allocate(ithet_displ(0:nfgtasks-1))
19776       allocate(ithet_count(0:nfgtasks-1))
19777       allocate(iphi_displ(0:nfgtasks-1))
19778       allocate(iphi_count(0:nfgtasks-1))
19779       allocate(iphi1_displ(0:nfgtasks-1))
19780       allocate(iphi1_count(0:nfgtasks-1))
19781       allocate(ivec_displ(0:nfgtasks-1))
19782       allocate(ivec_count(0:nfgtasks-1))
19783       allocate(iset_displ(0:nfgtasks-1))
19784       allocate(iset_count(0:nfgtasks-1))
19785       allocate(iint_count(0:nfgtasks-1))
19786       allocate(iint_displ(0:nfgtasks-1))
19787 !(0:max_fg_procs-1)
19788 !----------------------
19789 ! common.MD
19790 !      common /mdgrad/
19791       allocate(gcart(3,-1:nres))
19792       allocate(gxcart(3,-1:nres))
19793 !(3,0:MAXRES)
19794       allocate(gradcag(3,-1:nres))
19795       allocate(gradxag(3,-1:nres))
19796 !(3,MAXRES)
19797 !      common /back_constr/
19798 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19799       allocate(dutheta(nres))
19800       allocate(dugamma(nres))
19801 !(maxres)
19802       allocate(duscdiff(3,nres))
19803       allocate(duscdiffx(3,nres))
19804 !(3,maxres)
19805 !el i io:read_fragments
19806 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19807 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19808 !      common /qmeas/
19809 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19810 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19811       allocate(mset(0:nprocs))  !(maxprocs/20)
19812       mset(:)=0
19813 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19814 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19815       allocate(dUdconst(3,0:nres))
19816       allocate(dUdxconst(3,0:nres))
19817       allocate(dqwol(3,0:nres))
19818       allocate(dxqwol(3,0:nres))
19819 !(3,0:MAXRES)
19820 !----------------------
19821 ! common.sbridge
19822 !      common /sbridge/ in io_common: read_bridge
19823 !el    allocate((:),allocatable :: iss  !(maxss)
19824 !      common /links/  in io_common: read_bridge
19825 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19826 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19827 !      common /dyn_ssbond/
19828 ! and side-chain vectors in theta or phi.
19829       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19830 !(maxres,maxres)
19831 !      do i=1,nres
19832 !        do j=i+1,nres
19833       dyn_ssbond_ij(:,:)=1.0d300
19834 !        enddo
19835 !      enddo
19836
19837 !      if (nss.gt.0) then
19838         allocate(idssb(maxdim),jdssb(maxdim))
19839 !        allocate(newihpb(nss),newjhpb(nss))
19840 !(maxdim)
19841 !      endif
19842       allocate(ishield_list(nres))
19843       allocate(shield_list(50,nres))
19844       allocate(dyn_ss_mask(nres))
19845       allocate(fac_shield(nres))
19846       allocate(enetube(nres*2))
19847       allocate(enecavtube(nres*2))
19848
19849 !(maxres)
19850       dyn_ss_mask(:)=.false.
19851 !----------------------
19852 ! common.sccor
19853 ! Parameters of the SCCOR term
19854 !      common/sccor/
19855 !el in io_conf: parmread
19856 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19857 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19858 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19859 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19860 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19861 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19862 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19863 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19864 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
19865 !----------------
19866       allocate(gloc_sc(3,0:2*nres,0:10))
19867 !(3,0:maxres2,10)maxres2=2*maxres
19868       allocate(dcostau(3,3,3,2*nres))
19869       allocate(dsintau(3,3,3,2*nres))
19870       allocate(dtauangle(3,3,3,2*nres))
19871       allocate(dcosomicron(3,3,3,2*nres))
19872       allocate(domicron(3,3,3,2*nres))
19873 !(3,3,3,maxres2)maxres2=2*maxres
19874 !----------------------
19875 ! common.var
19876 !      common /restr/
19877       allocate(varall(maxvar))
19878 !(maxvar)(maxvar=6*maxres)
19879       allocate(mask_theta(nres))
19880       allocate(mask_phi(nres))
19881       allocate(mask_side(nres))
19882 !(maxres)
19883 !----------------------
19884 ! common.vectors
19885 !      common /vectors/
19886       allocate(uy(3,nres))
19887       allocate(uz(3,nres))
19888 !(3,maxres)
19889       allocate(uygrad(3,3,2,nres))
19890       allocate(uzgrad(3,3,2,nres))
19891 !(3,3,2,maxres)
19892
19893       return
19894       end subroutine alloc_ener_arrays
19895 !-----------------------------------------------------------------
19896       subroutine ebond_nucl(estr_nucl)
19897 !c
19898 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
19899 !c
19900
19901       real(kind=8),dimension(3) :: u,ud
19902       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
19903       real(kind=8) :: estr_nucl,diff
19904       integer :: iti,i,j,k,nbi
19905       estr_nucl=0.0d0
19906 !C      print *,"I enter ebond"
19907       if (energy_dec) &
19908       write (iout,*) "ibondp_start,ibondp_end",&
19909        ibondp_nucl_start,ibondp_nucl_end
19910       do i=ibondp_nucl_start,ibondp_nucl_end
19911         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
19912          itype(i,2).eq.ntyp1_molec(2)) cycle
19913 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
19914 !          do j=1,3
19915 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
19916 !     &      *dc(j,i-1)/vbld(i)
19917 !          enddo
19918 !          if (energy_dec) write(iout,*)
19919 !     &       "estr1",i,vbld(i),distchainmax,
19920 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
19921
19922           diff = vbld(i)-vbldp0_nucl
19923           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
19924           vbldp0_nucl,diff,AKP_nucl*diff*diff
19925           estr_nucl=estr_nucl+diff*diff
19926 !          print *,estr_nucl
19927           do j=1,3
19928             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
19929           enddo
19930 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
19931       enddo
19932       estr_nucl=0.5d0*AKP_nucl*estr_nucl
19933 !      print *,"partial sum", estr_nucl,AKP_nucl
19934
19935       if (energy_dec) &
19936       write (iout,*) "ibondp_start,ibondp_end",&
19937        ibond_nucl_start,ibond_nucl_end
19938
19939       do i=ibond_nucl_start,ibond_nucl_end
19940 !C        print *, "I am stuck",i
19941         iti=itype(i,2)
19942         if (iti.eq.ntyp1_molec(2)) cycle
19943           nbi=nbondterm_nucl(iti)
19944 !C        print *,iti,nbi
19945           if (nbi.eq.1) then
19946             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
19947
19948             if (energy_dec) &
19949            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
19950            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
19951             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
19952 !            print *,estr_nucl
19953             do j=1,3
19954               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
19955             enddo
19956           else
19957             do j=1,nbi
19958               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
19959               ud(j)=aksc_nucl(j,iti)*diff
19960               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
19961             enddo
19962             uprod=u(1)
19963             do j=2,nbi
19964               uprod=uprod*u(j)
19965             enddo
19966             usum=0.0d0
19967             usumsqder=0.0d0
19968             do j=1,nbi
19969               uprod1=1.0d0
19970               uprod2=1.0d0
19971               do k=1,nbi
19972                 if (k.ne.j) then
19973                   uprod1=uprod1*u(k)
19974                   uprod2=uprod2*u(k)*u(k)
19975                 endif
19976               enddo
19977               usum=usum+uprod1
19978               usumsqder=usumsqder+ud(j)*uprod2
19979             enddo
19980             estr_nucl=estr_nucl+uprod/usum
19981             do j=1,3
19982              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
19983             enddo
19984         endif
19985       enddo
19986 !C      print *,"I am about to leave ebond"
19987       return
19988       end subroutine ebond_nucl
19989
19990 !-----------------------------------------------------------------------------
19991       subroutine ebend_nucl(etheta_nucl)
19992       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
19993       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
19994       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
19995       logical :: lprn=.false., lprn1=.false.
19996 !el local variables
19997       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
19998       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
19999       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20000 ! local variables for constrains
20001       real(kind=8) :: difi,thetiii
20002        integer itheta
20003       etheta_nucl=0.0D0
20004 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20005       do i=ithet_nucl_start,ithet_nucl_end
20006         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20007         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20008         (itype(i,2).eq.ntyp1_molec(2))) cycle
20009         dethetai=0.0d0
20010         dephii=0.0d0
20011         dephii1=0.0d0
20012         theti2=0.5d0*theta(i)
20013         ityp2=ithetyp_nucl(itype(i-1,2))
20014         do k=1,nntheterm_nucl
20015           coskt(k)=dcos(k*theti2)
20016           sinkt(k)=dsin(k*theti2)
20017         enddo
20018         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20019 #ifdef OSF
20020           phii=phi(i)
20021           if (phii.ne.phii) phii=150.0
20022 #else
20023           phii=phi(i)
20024 #endif
20025           ityp1=ithetyp_nucl(itype(i-2,2))
20026           do k=1,nsingle_nucl
20027             cosph1(k)=dcos(k*phii)
20028             sinph1(k)=dsin(k*phii)
20029           enddo
20030         else
20031           phii=0.0d0
20032           ityp1=nthetyp_nucl+1
20033           do k=1,nsingle_nucl
20034             cosph1(k)=0.0d0
20035             sinph1(k)=0.0d0
20036           enddo
20037         endif
20038
20039         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20040 #ifdef OSF
20041           phii1=phi(i+1)
20042           if (phii1.ne.phii1) phii1=150.0
20043           phii1=pinorm(phii1)
20044 #else
20045           phii1=phi(i+1)
20046 #endif
20047           ityp3=ithetyp_nucl(itype(i,2))
20048           do k=1,nsingle_nucl
20049             cosph2(k)=dcos(k*phii1)
20050             sinph2(k)=dsin(k*phii1)
20051           enddo
20052         else
20053           phii1=0.0d0
20054           ityp3=nthetyp_nucl+1
20055           do k=1,nsingle_nucl
20056             cosph2(k)=0.0d0
20057             sinph2(k)=0.0d0
20058           enddo
20059         endif
20060         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20061         do k=1,ndouble_nucl
20062           do l=1,k-1
20063             ccl=cosph1(l)*cosph2(k-l)
20064             ssl=sinph1(l)*sinph2(k-l)
20065             scl=sinph1(l)*cosph2(k-l)
20066             csl=cosph1(l)*sinph2(k-l)
20067             cosph1ph2(l,k)=ccl-ssl
20068             cosph1ph2(k,l)=ccl+ssl
20069             sinph1ph2(l,k)=scl+csl
20070             sinph1ph2(k,l)=scl-csl
20071           enddo
20072         enddo
20073         if (lprn) then
20074         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20075          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20076         write (iout,*) "coskt and sinkt",nntheterm_nucl
20077         do k=1,nntheterm_nucl
20078           write (iout,*) k,coskt(k),sinkt(k)
20079         enddo
20080         endif
20081         do k=1,ntheterm_nucl
20082           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20083           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20084            *coskt(k)
20085           if (lprn)&
20086          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20087           " ethetai",ethetai
20088         enddo
20089         if (lprn) then
20090         write (iout,*) "cosph and sinph"
20091         do k=1,nsingle_nucl
20092           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20093         enddo
20094         write (iout,*) "cosph1ph2 and sinph2ph2"
20095         do k=2,ndouble_nucl
20096           do l=1,k-1
20097             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20098               sinph1ph2(l,k),sinph1ph2(k,l)
20099           enddo
20100         enddo
20101         write(iout,*) "ethetai",ethetai
20102         endif
20103         do m=1,ntheterm2_nucl
20104           do k=1,nsingle_nucl
20105             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20106               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20107               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20108               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20109             ethetai=ethetai+sinkt(m)*aux
20110             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20111             dephii=dephii+k*sinkt(m)*(&
20112                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20113                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20114             dephii1=dephii1+k*sinkt(m)*(&
20115                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20116                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20117             if (lprn) &
20118            write (iout,*) "m",m," k",k," bbthet",&
20119               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20120               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20121               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20122               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20123           enddo
20124         enddo
20125         if (lprn) &
20126         write(iout,*) "ethetai",ethetai
20127         do m=1,ntheterm3_nucl
20128           do k=2,ndouble_nucl
20129             do l=1,k-1
20130               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20131                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20132                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20133                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20134               ethetai=ethetai+sinkt(m)*aux
20135               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20136               dephii=dephii+l*sinkt(m)*(&
20137                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20138                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20139                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20140                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20141               dephii1=dephii1+(k-l)*sinkt(m)*( &
20142                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20143                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20144                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20145                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20146               if (lprn) then
20147               write (iout,*) "m",m," k",k," l",l," ffthet", &
20148                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20149                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20150                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20151                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20152               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20153                  cosph1ph2(k,l)*sinkt(m),&
20154                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20155               endif
20156             enddo
20157           enddo
20158         enddo
20159 10      continue
20160         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20161         i,theta(i)*rad2deg,phii*rad2deg, &
20162         phii1*rad2deg,ethetai
20163         etheta_nucl=etheta_nucl+ethetai
20164 !        print *,i,"partial sum",etheta_nucl
20165         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20166         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20167         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20168       enddo
20169       return
20170       end subroutine ebend_nucl
20171 !----------------------------------------------------
20172       subroutine etor_nucl(etors_nucl)
20173 !      implicit real*8 (a-h,o-z)
20174 !      include 'DIMENSIONS'
20175 !      include 'COMMON.VAR'
20176 !      include 'COMMON.GEO'
20177 !      include 'COMMON.LOCAL'
20178 !      include 'COMMON.TORSION'
20179 !      include 'COMMON.INTERACT'
20180 !      include 'COMMON.DERIV'
20181 !      include 'COMMON.CHAIN'
20182 !      include 'COMMON.NAMES'
20183 !      include 'COMMON.IOUNITS'
20184 !      include 'COMMON.FFIELD'
20185 !      include 'COMMON.TORCNSTR'
20186 !      include 'COMMON.CONTROL'
20187       real(kind=8) :: etors_nucl,edihcnstr
20188       logical :: lprn
20189 !el local variables
20190       integer :: i,j,iblock,itori,itori1
20191       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20192                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20193 ! Set lprn=.true. for debugging
20194       lprn=.false.
20195 !     lprn=.true.
20196       etors_nucl=0.0D0
20197 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20198       do i=iphi_nucl_start,iphi_nucl_end
20199         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20200              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20201              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20202         etors_ii=0.0D0
20203         itori=itortyp_nucl(itype(i-2,2))
20204         itori1=itortyp_nucl(itype(i-1,2))
20205         phii=phi(i)
20206 !         print *,i,itori,itori1
20207         gloci=0.0D0
20208 !C Regular cosine and sine terms
20209         do j=1,nterm_nucl(itori,itori1)
20210           v1ij=v1_nucl(j,itori,itori1)
20211           v2ij=v2_nucl(j,itori,itori1)
20212           cosphi=dcos(j*phii)
20213           sinphi=dsin(j*phii)
20214           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20215           if (energy_dec) etors_ii=etors_ii+&
20216                      v1ij*cosphi+v2ij*sinphi
20217           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20218         enddo
20219 !C Lorentz terms
20220 !C                         v1
20221 !C  E = SUM ----------------------------------- - v1
20222 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20223 !C
20224         cosphi=dcos(0.5d0*phii)
20225         sinphi=dsin(0.5d0*phii)
20226         do j=1,nlor_nucl(itori,itori1)
20227           vl1ij=vlor1_nucl(j,itori,itori1)
20228           vl2ij=vlor2_nucl(j,itori,itori1)
20229           vl3ij=vlor3_nucl(j,itori,itori1)
20230           pom=vl2ij*cosphi+vl3ij*sinphi
20231           pom1=1.0d0/(pom*pom+1.0d0)
20232           etors_nucl=etors_nucl+vl1ij*pom1
20233           if (energy_dec) etors_ii=etors_ii+ &
20234                      vl1ij*pom1
20235           pom=-pom*pom1*pom1
20236           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20237         enddo
20238 !C Subtract the constant term
20239         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20240           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20241               'etor',i,etors_ii-v0_nucl(itori,itori1)
20242         if (lprn) &
20243        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20244        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20245        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20246         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20247 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20248       enddo
20249       return
20250       end subroutine etor_nucl
20251 !------------------------------------------------------------
20252       subroutine epp_nucl_sub(evdw1,ees)
20253 !C
20254 !C This subroutine calculates the average interaction energy and its gradient
20255 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20256 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20257 !C The potential depends both on the distance of peptide-group centers and on
20258 !C the orientation of the CA-CA virtual bonds.
20259 !C
20260       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20261       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20262       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20263                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20264                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20265       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20266                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20267       integer xshift,yshift,zshift
20268       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20269       real(kind=8) :: ees,eesij
20270 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20271       real(kind=8) scal_el /0.5d0/
20272       t_eelecij=0.0d0
20273       ees=0.0D0
20274       evdw1=0.0D0
20275       ind=0
20276 !c
20277 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20278 !c
20279 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20280       do i=iatel_s_nucl,iatel_e_nucl
20281         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20282         dxi=dc(1,i)
20283         dyi=dc(2,i)
20284         dzi=dc(3,i)
20285         dx_normi=dc_norm(1,i)
20286         dy_normi=dc_norm(2,i)
20287         dz_normi=dc_norm(3,i)
20288         xmedi=c(1,i)+0.5d0*dxi
20289         ymedi=c(2,i)+0.5d0*dyi
20290         zmedi=c(3,i)+0.5d0*dzi
20291           xmedi=dmod(xmedi,boxxsize)
20292           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20293           ymedi=dmod(ymedi,boxysize)
20294           if (ymedi.lt.0) ymedi=ymedi+boxysize
20295           zmedi=dmod(zmedi,boxzsize)
20296           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20297
20298         do j=ielstart_nucl(i),ielend_nucl(i)
20299           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20300           ind=ind+1
20301           dxj=dc(1,j)
20302           dyj=dc(2,j)
20303           dzj=dc(3,j)
20304 !          xj=c(1,j)+0.5D0*dxj-xmedi
20305 !          yj=c(2,j)+0.5D0*dyj-ymedi
20306 !          zj=c(3,j)+0.5D0*dzj-zmedi
20307           xj=c(1,j)+0.5D0*dxj
20308           yj=c(2,j)+0.5D0*dyj
20309           zj=c(3,j)+0.5D0*dzj
20310           xj=mod(xj,boxxsize)
20311           if (xj.lt.0) xj=xj+boxxsize
20312           yj=mod(yj,boxysize)
20313           if (yj.lt.0) yj=yj+boxysize
20314           zj=mod(zj,boxzsize)
20315           if (zj.lt.0) zj=zj+boxzsize
20316       isubchap=0
20317       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20318       xj_safe=xj
20319       yj_safe=yj
20320       zj_safe=zj
20321       do xshift=-1,1
20322       do yshift=-1,1
20323       do zshift=-1,1
20324           xj=xj_safe+xshift*boxxsize
20325           yj=yj_safe+yshift*boxysize
20326           zj=zj_safe+zshift*boxzsize
20327           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20328           if(dist_temp.lt.dist_init) then
20329             dist_init=dist_temp
20330             xj_temp=xj
20331             yj_temp=yj
20332             zj_temp=zj
20333             isubchap=1
20334           endif
20335        enddo
20336        enddo
20337        enddo
20338        if (isubchap.eq.1) then
20339 !C          print *,i,j
20340           xj=xj_temp-xmedi
20341           yj=yj_temp-ymedi
20342           zj=zj_temp-zmedi
20343        else
20344           xj=xj_safe-xmedi
20345           yj=yj_safe-ymedi
20346           zj=zj_safe-zmedi
20347        endif
20348
20349           rij=xj*xj+yj*yj+zj*zj
20350 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20351           fac=(r0pp**2/rij)**3
20352           ev1=epspp*fac*fac
20353           ev2=epspp*fac
20354           evdw1ij=ev1-2*ev2
20355           fac=(-ev1-evdw1ij)/rij
20356 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20357           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20358           evdw1=evdw1+evdw1ij
20359 !C
20360 !C Calculate contributions to the Cartesian gradient.
20361 !C
20362           ggg(1)=fac*xj
20363           ggg(2)=fac*yj
20364           ggg(3)=fac*zj
20365           do k=1,3
20366             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20367             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20368           enddo
20369 !c phoshate-phosphate electrostatic interactions
20370           rij=dsqrt(rij)
20371           fac=1.0d0/rij
20372           eesij=dexp(-BEES*rij)*fac
20373 !          write (2,*)"fac",fac," eesijpp",eesij
20374           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20375           ees=ees+eesij
20376 !c          fac=-eesij*fac
20377           fac=-(fac+BEES)*eesij*fac
20378           ggg(1)=fac*xj
20379           ggg(2)=fac*yj
20380           ggg(3)=fac*zj
20381 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20382 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20383 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20384           do k=1,3
20385             gelpp(k,i)=gelpp(k,i)-ggg(k)
20386             gelpp(k,j)=gelpp(k,j)+ggg(k)
20387           enddo
20388         enddo ! j
20389       enddo   ! i
20390 !c      ees=332.0d0*ees
20391       ees=AEES*ees
20392       do i=nnt,nct
20393 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20394         do k=1,3
20395           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20396 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20397           gelpp(k,i)=AEES*gelpp(k,i)
20398         enddo
20399 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20400       enddo
20401 !c      write (2,*) "total EES",ees
20402       return
20403       end subroutine epp_nucl_sub
20404 !---------------------------------------------------------------------
20405       subroutine epsb(evdwpsb,eelpsb)
20406 !      use comm_locel
20407 !C
20408 !C This subroutine calculates the excluded-volume interaction energy between
20409 !C peptide-group centers and side chains and its gradient in virtual-bond and
20410 !C side-chain vectors.
20411 !C
20412       real(kind=8),dimension(3):: ggg
20413       integer :: i,iint,j,k,iteli,itypj,subchap
20414       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20415                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20416       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20417                     dist_temp, dist_init
20418       integer xshift,yshift,zshift
20419
20420 !cd    print '(a)','Enter ESCP'
20421 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20422       eelpsb=0.0d0
20423       evdwpsb=0.0d0
20424 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20425       do i=iatscp_s_nucl,iatscp_e_nucl
20426         if (itype(i,2).eq.ntyp1_molec(2) &
20427          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20428         xi=0.5D0*(c(1,i)+c(1,i+1))
20429         yi=0.5D0*(c(2,i)+c(2,i+1))
20430         zi=0.5D0*(c(3,i)+c(3,i+1))
20431           xi=mod(xi,boxxsize)
20432           if (xi.lt.0) xi=xi+boxxsize
20433           yi=mod(yi,boxysize)
20434           if (yi.lt.0) yi=yi+boxysize
20435           zi=mod(zi,boxzsize)
20436           if (zi.lt.0) zi=zi+boxzsize
20437
20438         do iint=1,nscp_gr_nucl(i)
20439
20440         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20441           itypj=itype(j,2)
20442           if (itypj.eq.ntyp1_molec(2)) cycle
20443 !C Uncomment following three lines for SC-p interactions
20444 !c         xj=c(1,nres+j)-xi
20445 !c         yj=c(2,nres+j)-yi
20446 !c         zj=c(3,nres+j)-zi
20447 !C Uncomment following three lines for Ca-p interactions
20448 !          xj=c(1,j)-xi
20449 !          yj=c(2,j)-yi
20450 !          zj=c(3,j)-zi
20451           xj=c(1,j)
20452           yj=c(2,j)
20453           zj=c(3,j)
20454           xj=mod(xj,boxxsize)
20455           if (xj.lt.0) xj=xj+boxxsize
20456           yj=mod(yj,boxysize)
20457           if (yj.lt.0) yj=yj+boxysize
20458           zj=mod(zj,boxzsize)
20459           if (zj.lt.0) zj=zj+boxzsize
20460       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20461       xj_safe=xj
20462       yj_safe=yj
20463       zj_safe=zj
20464       subchap=0
20465       do xshift=-1,1
20466       do yshift=-1,1
20467       do zshift=-1,1
20468           xj=xj_safe+xshift*boxxsize
20469           yj=yj_safe+yshift*boxysize
20470           zj=zj_safe+zshift*boxzsize
20471           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20472           if(dist_temp.lt.dist_init) then
20473             dist_init=dist_temp
20474             xj_temp=xj
20475             yj_temp=yj
20476             zj_temp=zj
20477             subchap=1
20478           endif
20479        enddo
20480        enddo
20481        enddo
20482        if (subchap.eq.1) then
20483           xj=xj_temp-xi
20484           yj=yj_temp-yi
20485           zj=zj_temp-zi
20486        else
20487           xj=xj_safe-xi
20488           yj=yj_safe-yi
20489           zj=zj_safe-zi
20490        endif
20491
20492           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20493           fac=rrij**expon2
20494           e1=fac*fac*aad_nucl(itypj)
20495           e2=fac*bad_nucl(itypj)
20496           if (iabs(j-i) .le. 2) then
20497             e1=scal14*e1
20498             e2=scal14*e2
20499           endif
20500           evdwij=e1+e2
20501           evdwpsb=evdwpsb+evdwij
20502           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20503              'evdw2',i,j,evdwij,"tu4"
20504 !C
20505 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20506 !C
20507           fac=-(evdwij+e1)*rrij
20508           ggg(1)=xj*fac
20509           ggg(2)=yj*fac
20510           ggg(3)=zj*fac
20511           do k=1,3
20512             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20513             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20514           enddo
20515         enddo
20516
20517         enddo ! iint
20518       enddo ! i
20519       do i=1,nct
20520         do j=1,3
20521           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20522           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20523         enddo
20524       enddo
20525       return
20526       end subroutine epsb
20527
20528 !------------------------------------------------------
20529       subroutine esb_gb(evdwsb,eelsb)
20530       use comm_locel
20531       use calc_data_nucl
20532       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20533       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20534       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20535       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20536                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20537       integer :: ii
20538       logical lprn
20539       evdw=0.0D0
20540       eelsb=0.0d0
20541       ecorr=0.0d0
20542       evdwsb=0.0D0
20543       lprn=.false.
20544       ind=0
20545 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20546       do i=iatsc_s_nucl,iatsc_e_nucl
20547         num_conti=0
20548         num_conti2=0
20549         itypi=itype(i,2)
20550 !        PRINT *,"I=",i,itypi
20551         if (itypi.eq.ntyp1_molec(2)) cycle
20552         itypi1=itype(i+1,2)
20553         xi=c(1,nres+i)
20554         yi=c(2,nres+i)
20555         zi=c(3,nres+i)
20556           xi=dmod(xi,boxxsize)
20557           if (xi.lt.0) xi=xi+boxxsize
20558           yi=dmod(yi,boxysize)
20559           if (yi.lt.0) yi=yi+boxysize
20560           zi=dmod(zi,boxzsize)
20561           if (zi.lt.0) zi=zi+boxzsize
20562
20563         dxi=dc_norm(1,nres+i)
20564         dyi=dc_norm(2,nres+i)
20565         dzi=dc_norm(3,nres+i)
20566         dsci_inv=vbld_inv(i+nres)
20567 !C
20568 !C Calculate SC interaction energy.
20569 !C
20570         do iint=1,nint_gr_nucl(i)
20571 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20572           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20573             ind=ind+1
20574 !            print *,"JESTEM"
20575             itypj=itype(j,2)
20576             if (itypj.eq.ntyp1_molec(2)) cycle
20577             dscj_inv=vbld_inv(j+nres)
20578             sig0ij=sigma_nucl(itypi,itypj)
20579             chi1=chi_nucl(itypi,itypj)
20580             chi2=chi_nucl(itypj,itypi)
20581             chi12=chi1*chi2
20582             chip1=chip_nucl(itypi,itypj)
20583             chip2=chip_nucl(itypj,itypi)
20584             chip12=chip1*chip2
20585 !            xj=c(1,nres+j)-xi
20586 !            yj=c(2,nres+j)-yi
20587 !            zj=c(3,nres+j)-zi
20588            xj=c(1,nres+j)
20589            yj=c(2,nres+j)
20590            zj=c(3,nres+j)
20591           xj=dmod(xj,boxxsize)
20592           if (xj.lt.0) xj=xj+boxxsize
20593           yj=dmod(yj,boxysize)
20594           if (yj.lt.0) yj=yj+boxysize
20595           zj=dmod(zj,boxzsize)
20596           if (zj.lt.0) zj=zj+boxzsize
20597       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20598       xj_safe=xj
20599       yj_safe=yj
20600       zj_safe=zj
20601       subchap=0
20602       do xshift=-1,1
20603       do yshift=-1,1
20604       do zshift=-1,1
20605           xj=xj_safe+xshift*boxxsize
20606           yj=yj_safe+yshift*boxysize
20607           zj=zj_safe+zshift*boxzsize
20608           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20609           if(dist_temp.lt.dist_init) then
20610             dist_init=dist_temp
20611             xj_temp=xj
20612             yj_temp=yj
20613             zj_temp=zj
20614             subchap=1
20615           endif
20616        enddo
20617        enddo
20618        enddo
20619        if (subchap.eq.1) then
20620           xj=xj_temp-xi
20621           yj=yj_temp-yi
20622           zj=zj_temp-zi
20623        else
20624           xj=xj_safe-xi
20625           yj=yj_safe-yi
20626           zj=zj_safe-zi
20627        endif
20628
20629             dxj=dc_norm(1,nres+j)
20630             dyj=dc_norm(2,nres+j)
20631             dzj=dc_norm(3,nres+j)
20632             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20633             rij=dsqrt(rrij)
20634 !C Calculate angle-dependent terms of energy and contributions to their
20635 !C derivatives.
20636             erij(1)=xj*rij
20637             erij(2)=yj*rij
20638             erij(3)=zj*rij
20639             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20640             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20641             om12=dxi*dxj+dyi*dyj+dzi*dzj
20642             call sc_angular_nucl
20643             sigsq=1.0D0/sigsq
20644             sig=sig0ij*dsqrt(sigsq)
20645             rij_shift=1.0D0/rij-sig+sig0ij
20646 !            print *,rij_shift,"rij_shift"
20647 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20648 !c     &       " rij_shift",rij_shift
20649             if (rij_shift.le.0.0D0) then
20650               evdw=1.0D20
20651               return
20652             endif
20653             sigder=-sig*sigsq
20654 !c---------------------------------------------------------------
20655             rij_shift=1.0D0/rij_shift
20656             fac=rij_shift**expon
20657             e1=fac*fac*aa_nucl(itypi,itypj)
20658             e2=fac*bb_nucl(itypi,itypj)
20659             evdwij=eps1*eps2rt*(e1+e2)
20660 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20661 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20662             eps2der=evdwij
20663             evdwij=evdwij*eps2rt
20664             evdwsb=evdwsb+evdwij
20665             if (lprn) then
20666             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
20667             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
20668             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20669              restyp(itypi,2),i,restyp(itypj,2),j, &
20670              epsi,sigm,chi1,chi2,chip1,chip2, &
20671              eps1,eps2rt**2,sig,sig0ij, &
20672              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20673             evdwij
20674             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20675             endif
20676
20677             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20678                              'evdw',i,j,evdwij,"tu3"
20679
20680
20681 !C Calculate gradient components.
20682             e1=e1*eps1*eps2rt**2
20683             fac=-expon*(e1+evdwij)*rij_shift
20684             sigder=fac*sigder
20685             fac=rij*fac
20686 !c            fac=0.0d0
20687 !C Calculate the radial part of the gradient
20688             gg(1)=xj*fac
20689             gg(2)=yj*fac
20690             gg(3)=zj*fac
20691 !C Calculate angular part of the gradient.
20692             call sc_grad_nucl
20693             call eelsbij(eelij,num_conti2)
20694             if (energy_dec .and. &
20695            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20696           write (istat,'(e14.5)') evdwij
20697             eelsb=eelsb+eelij
20698           enddo      ! j
20699         enddo        ! iint
20700         num_cont_hb(i)=num_conti2
20701       enddo          ! i
20702 !c      write (iout,*) "Number of loop steps in EGB:",ind
20703 !cccc      energy_dec=.false.
20704       return
20705       end subroutine esb_gb
20706 !-------------------------------------------------------------------------------
20707       subroutine eelsbij(eesij,num_conti2)
20708       use comm_locel
20709       use calc_data_nucl
20710       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20711       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20712       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20713                     dist_temp, dist_init,rlocshield,fracinbuf
20714       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20715
20716 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20717       real(kind=8) scal_el /0.5d0/
20718       integer :: iteli,itelj,kkk,kkll,m,isubchap
20719       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20720       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20721       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20722                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20723                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20724                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20725                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20726                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20727                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20728                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20729       ind=ind+1
20730       itypi=itype(i,2)
20731       itypj=itype(j,2)
20732 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20733       ael6i=ael6_nucl(itypi,itypj)
20734       ael3i=ael3_nucl(itypi,itypj)
20735       ael63i=ael63_nucl(itypi,itypj)
20736       ael32i=ael32_nucl(itypi,itypj)
20737 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20738 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20739       dxj=dc(1,j+nres)
20740       dyj=dc(2,j+nres)
20741       dzj=dc(3,j+nres)
20742       dx_normi=dc_norm(1,i+nres)
20743       dy_normi=dc_norm(2,i+nres)
20744       dz_normi=dc_norm(3,i+nres)
20745       dx_normj=dc_norm(1,j+nres)
20746       dy_normj=dc_norm(2,j+nres)
20747       dz_normj=dc_norm(3,j+nres)
20748 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20749 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20750 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20751       if (ipot_nucl.ne.2) then
20752         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20753         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20754         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20755       else
20756         cosa=om12
20757         cosb=om1
20758         cosg=om2
20759       endif
20760       r3ij=rij*rrij
20761       r6ij=r3ij*r3ij
20762       fac=cosa-3.0D0*cosb*cosg
20763       facfac=fac*fac
20764       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20765       fac3=ael6i*r6ij
20766       fac4=ael3i*r3ij
20767       fac5=ael63i*r6ij
20768       fac6=ael32i*r6ij
20769 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20770 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20771       el1=fac3*(4.0D0+facfac-fac1)
20772       el2=fac4*fac
20773       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20774       el4=fac6*facfac
20775       eesij=el1+el2+el3+el4
20776 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20777       ees0ij=4.0D0+facfac-fac1
20778
20779       if (energy_dec) then
20780           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20781           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20782            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20783            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20784            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20785           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20786       endif
20787
20788 !C
20789 !C Calculate contributions to the Cartesian gradient.
20790 !C
20791       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20792       fac1=fac
20793 !c      erij(1)=xj*rmij
20794 !c      erij(2)=yj*rmij
20795 !c      erij(3)=zj*rmij
20796 !*
20797 !* Radial derivatives. First process both termini of the fragment (i,j)
20798 !*
20799       ggg(1)=facel*xj
20800       ggg(2)=facel*yj
20801       ggg(3)=facel*zj
20802       do k=1,3
20803         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20804         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20805         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20806         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20807       enddo
20808 !*
20809 !* Angular part
20810 !*
20811       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20812       fac4=-3.0D0*fac4
20813       fac3=-6.0D0*fac3
20814       fac5= 6.0d0*fac5
20815       fac6=-6.0d0*fac6
20816       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20817        fac6*fac1*cosg
20818       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20819        fac6*fac1*cosb
20820       do k=1,3
20821         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20822         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20823       enddo
20824       do k=1,3
20825         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20826       enddo
20827       do k=1,3
20828         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20829              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20830              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20831         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20832              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20833              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20834         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20835         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20836       enddo
20837 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20838        IF ( j.gt.i+1 .and.&
20839           num_conti.le.maxconts) THEN
20840 !C
20841 !C Calculate the contact function. The ith column of the array JCONT will
20842 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20843 !C greater than I). The arrays FACONT and GACONT will contain the values of
20844 !C the contact function and its derivative.
20845         r0ij=2.20D0*sigma(itypi,itypj)
20846 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20847         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20848 !c        write (2,*) "fcont",fcont
20849         if (fcont.gt.0.0D0) then
20850           num_conti=num_conti+1
20851           num_conti2=num_conti2+1
20852
20853           if (num_conti.gt.maxconts) then
20854             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20855                           ' will skip next contacts for this conf.'
20856           else
20857             jcont_hb(num_conti,i)=j
20858 !c            write (iout,*) "num_conti",num_conti,
20859 !c     &        " jcont_hb",jcont_hb(num_conti,i)
20860 !C Calculate contact energies
20861             cosa4=4.0D0*cosa
20862             wij=cosa-3.0D0*cosb*cosg
20863             cosbg1=cosb+cosg
20864             cosbg2=cosb-cosg
20865             fac3=dsqrt(-ael6i)*r3ij
20866 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
20867             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
20868             if (ees0tmp.gt.0) then
20869               ees0pij=dsqrt(ees0tmp)
20870             else
20871               ees0pij=0
20872             endif
20873             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
20874             if (ees0tmp.gt.0) then
20875               ees0mij=dsqrt(ees0tmp)
20876             else
20877               ees0mij=0
20878             endif
20879             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
20880             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
20881 !c            write (iout,*) "i",i," j",j,
20882 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
20883             ees0pij1=fac3/ees0pij
20884             ees0mij1=fac3/ees0mij
20885             fac3p=-3.0D0*fac3*rrij
20886             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
20887             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
20888             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
20889             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
20890             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
20891             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
20892             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
20893             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
20894             ecosap=ecosa1+ecosa2
20895             ecosbp=ecosb1+ecosb2
20896             ecosgp=ecosg1+ecosg2
20897             ecosam=ecosa1-ecosa2
20898             ecosbm=ecosb1-ecosb2
20899             ecosgm=ecosg1-ecosg2
20900 !C End diagnostics
20901             facont_hb(num_conti,i)=fcont
20902             fprimcont=fprimcont/rij
20903             do k=1,3
20904               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
20905               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
20906             enddo
20907             gggp(1)=gggp(1)+ees0pijp*xj
20908             gggp(2)=gggp(2)+ees0pijp*yj
20909             gggp(3)=gggp(3)+ees0pijp*zj
20910             gggm(1)=gggm(1)+ees0mijp*xj
20911             gggm(2)=gggm(2)+ees0mijp*yj
20912             gggm(3)=gggm(3)+ees0mijp*zj
20913 !C Derivatives due to the contact function
20914             gacont_hbr(1,num_conti,i)=fprimcont*xj
20915             gacont_hbr(2,num_conti,i)=fprimcont*yj
20916             gacont_hbr(3,num_conti,i)=fprimcont*zj
20917             do k=1,3
20918 !c
20919 !c Gradient of the correlation terms
20920 !c
20921               gacontp_hb1(k,num_conti,i)= &
20922              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
20923             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20924               gacontp_hb2(k,num_conti,i)= &
20925              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
20926             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20927               gacontp_hb3(k,num_conti,i)=gggp(k)
20928               gacontm_hb1(k,num_conti,i)= &
20929              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
20930             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20931               gacontm_hb2(k,num_conti,i)= &
20932              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20933             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20934               gacontm_hb3(k,num_conti,i)=gggm(k)
20935             enddo
20936           endif
20937         endif
20938       ENDIF
20939       return
20940       end subroutine eelsbij
20941 !------------------------------------------------------------------
20942       subroutine sc_grad_nucl
20943       use comm_locel
20944       use calc_data_nucl
20945       real(kind=8),dimension(3) :: dcosom1,dcosom2
20946       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
20947       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
20948       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
20949       do k=1,3
20950         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
20951         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
20952       enddo
20953       do k=1,3
20954         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
20955       enddo
20956       do k=1,3
20957         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
20958                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
20959                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
20960         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
20961                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
20962                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
20963       enddo
20964 !C
20965 !C Calculate the components of the gradient in DC and X
20966 !C
20967       do l=1,3
20968         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
20969         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
20970       enddo
20971       return
20972       end subroutine sc_grad_nucl
20973 !-----------------------------------------------------------------------
20974       subroutine esb(esbloc)
20975 !C Calculate the local energy of a side chain and its derivatives in the
20976 !C corresponding virtual-bond valence angles THETA and the spherical angles
20977 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
20978 !C added by Urszula Kozlowska. 07/11/2007
20979 !C
20980       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
20981       real(kind=8),dimension(9):: x
20982      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
20983       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
20984       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
20985       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
20986        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
20987        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
20988        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
20989        integer::it,nlobit,i,j,k
20990 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
20991       delta=0.02d0*pi
20992       esbloc=0.0D0
20993       do i=loc_start_nucl,loc_end_nucl
20994         if (itype(i,2).eq.ntyp1_molec(2)) cycle
20995         costtab(i+1) =dcos(theta(i+1))
20996         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
20997         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
20998         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
20999         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21000         cosfac=dsqrt(cosfac2)
21001         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21002         sinfac=dsqrt(sinfac2)
21003         it=itype(i,2)
21004         if (it.eq.10) goto 1
21005
21006 !c
21007 !C  Compute the axes of tghe local cartesian coordinates system; store in
21008 !c   x_prime, y_prime and z_prime
21009 !c
21010         do j=1,3
21011           x_prime(j) = 0.00
21012           y_prime(j) = 0.00
21013           z_prime(j) = 0.00
21014         enddo
21015 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21016 !C     &   dc_norm(3,i+nres)
21017         do j = 1,3
21018           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21019           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21020         enddo
21021         do j = 1,3
21022           z_prime(j) = -uz(j,i-1)
21023 !           z_prime(j)=0.0
21024         enddo
21025
21026         xx=0.0d0
21027         yy=0.0d0
21028         zz=0.0d0
21029         do j = 1,3
21030           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21031           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21032           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21033         enddo
21034
21035         xxtab(i)=xx
21036         yytab(i)=yy
21037         zztab(i)=zz
21038          it=itype(i,2)
21039         do j = 1,9
21040           x(j) = sc_parmin_nucl(j,it)
21041         enddo
21042 #ifdef CHECK_COORD
21043 !Cc diagnostics - remove later
21044         xx1 = dcos(alph(2))
21045         yy1 = dsin(alph(2))*dcos(omeg(2))
21046         zz1 = -dsin(alph(2))*dsin(omeg(2))
21047         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21048          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21049          xx1,yy1,zz1
21050 !C,"  --- ", xx_w,yy_w,zz_w
21051 !c end diagnostics
21052 #endif
21053         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21054         esbloc = esbloc + sumene
21055         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21056 !        print *,"enecomp",sumene,sumene2
21057 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21058 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21059 #ifdef DEBUG
21060         write (2,*) "x",(x(k),k=1,9)
21061 !C
21062 !C This section to check the numerical derivatives of the energy of ith side
21063 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21064 !C #define DEBUG in the code to turn it on.
21065 !C
21066         write (2,*) "sumene               =",sumene
21067         aincr=1.0d-7
21068         xxsave=xx
21069         xx=xx+aincr
21070         write (2,*) xx,yy,zz
21071         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21072         de_dxx_num=(sumenep-sumene)/aincr
21073         xx=xxsave
21074         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21075         yysave=yy
21076         yy=yy+aincr
21077         write (2,*) xx,yy,zz
21078         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21079         de_dyy_num=(sumenep-sumene)/aincr
21080         yy=yysave
21081         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21082         zzsave=zz
21083         zz=zz+aincr
21084         write (2,*) xx,yy,zz
21085         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21086         de_dzz_num=(sumenep-sumene)/aincr
21087         zz=zzsave
21088         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21089         costsave=cost2tab(i+1)
21090         sintsave=sint2tab(i+1)
21091         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21092         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21093         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21094         de_dt_num=(sumenep-sumene)/aincr
21095         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21096         cost2tab(i+1)=costsave
21097         sint2tab(i+1)=sintsave
21098 !C End of diagnostics section.
21099 #endif
21100 !C
21101 !C Compute the gradient of esc
21102 !C
21103         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21104         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21105         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21106         de_dtt=0.0d0
21107 #ifdef DEBUG
21108         write (2,*) "x",(x(k),k=1,9)
21109         write (2,*) "xx",xx," yy",yy," zz",zz
21110         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21111           " de_zz   ",de_zz," de_tt   ",de_tt
21112         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21113           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21114 #endif
21115 !C
21116        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21117        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21118        cosfac2xx=cosfac2*xx
21119        sinfac2yy=sinfac2*yy
21120        do k = 1,3
21121          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21122            vbld_inv(i+1)
21123          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21124            vbld_inv(i)
21125          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21126          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21127 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21128 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21129 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21130 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21131          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21132          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21133          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21134          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21135          dZZ_Ci1(k)=0.0d0
21136          dZZ_Ci(k)=0.0d0
21137          do j=1,3
21138            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21139            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21140          enddo
21141
21142          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21143          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21144          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21145 !c
21146          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21147          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21148        enddo
21149
21150        do k=1,3
21151          dXX_Ctab(k,i)=dXX_Ci(k)
21152          dXX_C1tab(k,i)=dXX_Ci1(k)
21153          dYY_Ctab(k,i)=dYY_Ci(k)
21154          dYY_C1tab(k,i)=dYY_Ci1(k)
21155          dZZ_Ctab(k,i)=dZZ_Ci(k)
21156          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21157          dXX_XYZtab(k,i)=dXX_XYZ(k)
21158          dYY_XYZtab(k,i)=dYY_XYZ(k)
21159          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21160        enddo
21161        do k = 1,3
21162 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21163 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21164 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21165 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21166 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21167 !c     &    dt_dci(k)
21168 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21169 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21170          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21171          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21172          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21173          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21174          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21175          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21176 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21177        enddo
21178 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21179 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21180
21181 !C to check gradient call subroutine check_grad
21182
21183     1 continue
21184       enddo
21185       return
21186       end subroutine esb
21187 !=-------------------------------------------------------
21188       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21189 !      implicit none
21190       real(kind=8),dimension(9):: x(9)
21191        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21192       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21193       integer i
21194 !c      write (2,*) "enesc"
21195 !c      write (2,*) "x",(x(i),i=1,9)
21196 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21197       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21198         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21199         + x(9)*yy*zz
21200       enesc_nucl=sumene
21201       return
21202       end function enesc_nucl
21203 !-----------------------------------------------------------------------------
21204       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21205 #ifdef MPI
21206       include 'mpif.h'
21207       integer,parameter :: max_cont=2000
21208       integer,parameter:: max_dim=2*(8*3+6)
21209       integer, parameter :: msglen1=max_cont*max_dim
21210       integer,parameter :: msglen2=2*msglen1
21211       integer source,CorrelType,CorrelID,Error
21212       real(kind=8) :: buffer(max_cont,max_dim)
21213       integer status(MPI_STATUS_SIZE)
21214       integer :: ierror,nbytes
21215 #endif
21216       real(kind=8),dimension(3):: gx(3),gx1(3)
21217       real(kind=8) :: time00
21218       logical lprn,ldone
21219       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21220       real(kind=8) ecorr,ecorr3
21221       integer :: n_corr,n_corr1,mm,msglen
21222 !C Set lprn=.true. for debugging
21223       lprn=.false.
21224       n_corr=0
21225       n_corr1=0
21226 #ifdef MPI
21227       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21228
21229       if (nfgtasks.le.1) goto 30
21230       if (lprn) then
21231         write (iout,'(a)') 'Contact function values:'
21232         do i=nnt,nct-1
21233           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21234          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21235          j=1,num_cont_hb(i))
21236         enddo
21237       endif
21238 !C Caution! Following code assumes that electrostatic interactions concerning
21239 !C a given atom are split among at most two processors!
21240       CorrelType=477
21241       CorrelID=fg_rank+1
21242       ldone=.false.
21243       do i=1,max_cont
21244         do j=1,max_dim
21245           buffer(i,j)=0.0D0
21246         enddo
21247       enddo
21248       mm=mod(fg_rank,2)
21249 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21250       if (mm) 20,20,10
21251    10 continue
21252 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21253       if (fg_rank.gt.0) then
21254 !C Send correlation contributions to the preceding processor
21255         msglen=msglen1
21256         nn=num_cont_hb(iatel_s_nucl)
21257         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21258 !c        write (*,*) 'The BUFFER array:'
21259 !c        do i=1,nn
21260 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21261 !c        enddo
21262         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21263           msglen=msglen2
21264           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21265 !C Clear the contacts of the atom passed to the neighboring processor
21266         nn=num_cont_hb(iatel_s_nucl+1)
21267 !c        do i=1,nn
21268 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21269 !c        enddo
21270             num_cont_hb(iatel_s_nucl)=0
21271         endif
21272 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21273 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21274 !cd   & ' msglen=',msglen
21275 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21276 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21277 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21278         time00=MPI_Wtime()
21279         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21280          CorrelType,FG_COMM,IERROR)
21281         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21282 !cd      write (iout,*) 'Processor ',fg_rank,
21283 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21284 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21285 !c        write (*,*) 'Processor ',fg_rank,
21286 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21287 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21288 !c        msglen=msglen1
21289       endif ! (fg_rank.gt.0)
21290       if (ldone) goto 30
21291       ldone=.true.
21292    20 continue
21293 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21294       if (fg_rank.lt.nfgtasks-1) then
21295 !C Receive correlation contributions from the next processor
21296         msglen=msglen1
21297         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21298 !cd      write (iout,*) 'Processor',fg_rank,
21299 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21300 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21301 !c        write (*,*) 'Processor',fg_rank,
21302 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21303 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21304         time00=MPI_Wtime()
21305         nbytes=-1
21306         do while (nbytes.le.0)
21307           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21308           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21309         enddo
21310 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21311         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21312          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21313         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21314 !c        write (*,*) 'Processor',fg_rank,
21315 !c     &' has received correlation contribution from processor',fg_rank+1,
21316 !c     & ' msglen=',msglen,' nbytes=',nbytes
21317 !c        write (*,*) 'The received BUFFER array:'
21318 !c        do i=1,max_cont
21319 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21320 !c        enddo
21321         if (msglen.eq.msglen1) then
21322           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21323         else if (msglen.eq.msglen2)  then
21324           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21325           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21326         else
21327           write (iout,*) &
21328       'ERROR!!!! message length changed while processing correlations.'
21329           write (*,*) &
21330       'ERROR!!!! message length changed while processing correlations.'
21331           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21332         endif ! msglen.eq.msglen1
21333       endif ! fg_rank.lt.nfgtasks-1
21334       if (ldone) goto 30
21335       ldone=.true.
21336       goto 10
21337    30 continue
21338 #endif
21339       if (lprn) then
21340         write (iout,'(a)') 'Contact function values:'
21341         do i=nnt_molec(2),nct_molec(2)-1
21342           write (iout,'(2i3,50(1x,i2,f5.2))') &
21343          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21344          j=1,num_cont_hb(i))
21345         enddo
21346       endif
21347       ecorr=0.0D0
21348       ecorr3=0.0d0
21349 !C Remove the loop below after debugging !!!
21350 !      do i=nnt_molec(2),nct_molec(2)
21351 !        do j=1,3
21352 !          gradcorr_nucl(j,i)=0.0D0
21353 !          gradxorr_nucl(j,i)=0.0D0
21354 !          gradcorr3_nucl(j,i)=0.0D0
21355 !          gradxorr3_nucl(j,i)=0.0D0
21356 !        enddo
21357 !      enddo
21358 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21359 !C Calculate the local-electrostatic correlation terms
21360       do i=iatsc_s_nucl,iatsc_e_nucl
21361         i1=i+1
21362         num_conti=num_cont_hb(i)
21363         num_conti1=num_cont_hb(i+1)
21364 !        print *,i,num_conti,num_conti1
21365         do jj=1,num_conti
21366           j=jcont_hb(jj,i)
21367           do kk=1,num_conti1
21368             j1=jcont_hb(kk,i1)
21369 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21370 !c     &         ' jj=',jj,' kk=',kk
21371             if (j1.eq.j+1 .or. j1.eq.j-1) then
21372 !C
21373 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21374 !C The system gains extra energy.
21375 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21376 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21377 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21378 !C
21379               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21380               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21381                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21382               n_corr=n_corr+1
21383             else if (j1.eq.j) then
21384 !C
21385 !C Contacts I-J and I-(J+1) occur simultaneously.
21386 !C The system loses extra energy.
21387 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21388 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21389 !C Need to implement full formulas 32 from Liwo et al., 1998.
21390 !C
21391 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21392 !c     &         ' jj=',jj,' kk=',kk
21393               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21394             endif
21395           enddo ! kk
21396           do kk=1,num_conti
21397             j1=jcont_hb(kk,i)
21398 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21399 !c     &         ' jj=',jj,' kk=',kk
21400             if (j1.eq.j+1) then
21401 !C Contacts I-J and (I+1)-J occur simultaneously.
21402 !C The system loses extra energy.
21403               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21404             endif ! j1==j+1
21405           enddo ! kk
21406         enddo ! jj
21407       enddo ! i
21408       return
21409       end subroutine multibody_hb_nucl
21410 !-----------------------------------------------------------
21411       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21412 !      implicit real*8 (a-h,o-z)
21413 !      include 'DIMENSIONS'
21414 !      include 'COMMON.IOUNITS'
21415 !      include 'COMMON.DERIV'
21416 !      include 'COMMON.INTERACT'
21417 !      include 'COMMON.CONTACTS'
21418       real(kind=8),dimension(3) :: gx,gx1
21419       logical :: lprn
21420 !el local variables
21421       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21422       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21423                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21424                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21425                    rlocshield
21426
21427       lprn=.false.
21428       eij=facont_hb(jj,i)
21429       ekl=facont_hb(kk,k)
21430       ees0pij=ees0p(jj,i)
21431       ees0pkl=ees0p(kk,k)
21432       ees0mij=ees0m(jj,i)
21433       ees0mkl=ees0m(kk,k)
21434       ekont=eij*ekl
21435       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21436 !      print *,"ehbcorr_nucl",ekont,ees
21437 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21438 !C Following 4 lines for diagnostics.
21439 !cd    ees0pkl=0.0D0
21440 !cd    ees0pij=1.0D0
21441 !cd    ees0mkl=0.0D0
21442 !cd    ees0mij=1.0D0
21443 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21444 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21445 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21446 !C Calculate the multi-body contribution to energy.
21447 !      ecorr_nucl=ecorr_nucl+ekont*ees
21448 !C Calculate multi-body contributions to the gradient.
21449       coeffpees0pij=coeffp*ees0pij
21450       coeffmees0mij=coeffm*ees0mij
21451       coeffpees0pkl=coeffp*ees0pkl
21452       coeffmees0mkl=coeffm*ees0mkl
21453       do ll=1,3
21454         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21455        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21456        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21457         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21458         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21459         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21460         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21461         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21462         coeffmees0mij*gacontm_hb1(ll,kk,k))
21463         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21464         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21465         coeffmees0mij*gacontm_hb2(ll,kk,k))
21466         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21467           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21468           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21469         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21470         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21471         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21472           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21473           coeffmees0mij*gacontm_hb3(ll,kk,k))
21474         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21475         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21476         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21477         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21478         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21479         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21480       enddo
21481       ehbcorr_nucl=ekont*ees
21482       return
21483       end function ehbcorr_nucl
21484 !-------------------------------------------------------------------------
21485
21486      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21487 !      implicit real*8 (a-h,o-z)
21488 !      include 'DIMENSIONS'
21489 !      include 'COMMON.IOUNITS'
21490 !      include 'COMMON.DERIV'
21491 !      include 'COMMON.INTERACT'
21492 !      include 'COMMON.CONTACTS'
21493       real(kind=8),dimension(3) :: gx,gx1
21494       logical :: lprn
21495 !el local variables
21496       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21497       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21498                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21499                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21500                    rlocshield
21501
21502       lprn=.false.
21503       eij=facont_hb(jj,i)
21504       ekl=facont_hb(kk,k)
21505       ees0pij=ees0p(jj,i)
21506       ees0pkl=ees0p(kk,k)
21507       ees0mij=ees0m(jj,i)
21508       ees0mkl=ees0m(kk,k)
21509       ekont=eij*ekl
21510       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21511 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21512 !C Following 4 lines for diagnostics.
21513 !cd    ees0pkl=0.0D0
21514 !cd    ees0pij=1.0D0
21515 !cd    ees0mkl=0.0D0
21516 !cd    ees0mij=1.0D0
21517 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21518 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21519 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21520 !C Calculate the multi-body contribution to energy.
21521 !      ecorr=ecorr+ekont*ees
21522 !C Calculate multi-body contributions to the gradient.
21523       coeffpees0pij=coeffp*ees0pij
21524       coeffmees0mij=coeffm*ees0mij
21525       coeffpees0pkl=coeffp*ees0pkl
21526       coeffmees0mkl=coeffm*ees0mkl
21527       do ll=1,3
21528         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21529        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21530        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21531         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21532         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21533         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21534         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21535         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21536         coeffmees0mij*gacontm_hb1(ll,kk,k))
21537         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21538         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21539         coeffmees0mij*gacontm_hb2(ll,kk,k))
21540         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21541           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21542           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21543         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21544         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21545         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21546           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21547           coeffmees0mij*gacontm_hb3(ll,kk,k))
21548         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21549         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21550         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21551         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21552         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21553         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21554       enddo
21555       ehbcorr3_nucl=ekont*ees
21556       return
21557       end function ehbcorr3_nucl
21558 #ifdef MPI
21559       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21560       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21561       real(kind=8):: buffer(dimen1,dimen2)
21562       num_kont=num_cont_hb(atom)
21563       do i=1,num_kont
21564         do k=1,8
21565           do j=1,3
21566             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21567           enddo ! j
21568         enddo ! k
21569         buffer(i,indx+25)=facont_hb(i,atom)
21570         buffer(i,indx+26)=ees0p(i,atom)
21571         buffer(i,indx+27)=ees0m(i,atom)
21572         buffer(i,indx+28)=d_cont(i,atom)
21573         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21574       enddo ! i
21575       buffer(1,indx+30)=dfloat(num_kont)
21576       return
21577       end subroutine pack_buffer
21578 !c------------------------------------------------------------------------------
21579       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21580       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21581       real(kind=8):: buffer(dimen1,dimen2)
21582 !      double precision zapas
21583 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21584 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21585 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21586 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21587       num_kont=buffer(1,indx+30)
21588       num_kont_old=num_cont_hb(atom)
21589       num_cont_hb(atom)=num_kont+num_kont_old
21590       do i=1,num_kont
21591         ii=i+num_kont_old
21592         do k=1,8
21593           do j=1,3
21594             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21595           enddo ! j
21596         enddo ! k
21597         facont_hb(ii,atom)=buffer(i,indx+25)
21598         ees0p(ii,atom)=buffer(i,indx+26)
21599         ees0m(ii,atom)=buffer(i,indx+27)
21600         d_cont(i,atom)=buffer(i,indx+28)
21601         jcont_hb(ii,atom)=buffer(i,indx+29)
21602       enddo ! i
21603       return
21604       end subroutine unpack_buffer
21605 !c------------------------------------------------------------------------------
21606 #endif
21607
21608 !----------------------------------------------------------------------------
21609 !-----------------------------------------------------------------------------
21610 !-----------------------------------------------------------------------------
21611       end module energy