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 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 131       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 132         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 133       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 134         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 135         g_corr6_loc     !(maxvar)
 136       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 137       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 138 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 139       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 140 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 141       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 142          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 143 !      integer :: nfl,icg
 144 !      common /deriv_loc/
 145       real(kind=8), dimension(:),allocatable :: fac_shield
 146       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 147 !      common /deriv_scloc/
 148       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 149        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 150        dZZ_XYZtab       !(3,maxres)
 151 !-----------------------------------------------------------------------------
 152 ! common.maxgrad
 153 !      common /maxgrad/
 154       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 155        gradb_max,ghpbc_max,&
 156        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 157        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 158        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 159        gsccorx_max,gsclocx_max
 160 !-----------------------------------------------------------------------------
 161 ! common.MD
 162 !      common /back_constr/
 163       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 164       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 165 !      common /qmeas/
 166       real(kind=8) :: Ucdfrag,Ucdpair
 167       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 168        dqwol,dxqwol     !(3,0:MAXRES)
 169 !-----------------------------------------------------------------------------
 170 ! common.sbridge
 171 !      common /dyn_ssbond/
 172       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 173 !-----------------------------------------------------------------------------
 174 ! common.sccor
 175 ! Parameters of the SCCOR term
 176 !      common/sccor/
 177       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 178        dcosomicron,domicron     !(3,3,3,maxres2)
 179 !-----------------------------------------------------------------------------
 180 ! common.vectors
 181 !      common /vectors/
 182       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 183       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 184 !-----------------------------------------------------------------------------
 185 ! common /przechowalnia/
 186       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 187       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 188 !-----------------------------------------------------------------------------
 189 !-----------------------------------------------------------------------------
 190 !
 191 !
 192 !-----------------------------------------------------------------------------
 193       contains
 194 !-----------------------------------------------------------------------------
 195 ! energy_p_new_barrier.F
 196 !-----------------------------------------------------------------------------
 197       subroutine etotal(energia)
 198 !      implicit real*8 (a-h,o-z)
 199 !      include 'DIMENSIONS'
 200       use MD_data
 201 #ifndef ISNAN
 202       external proc_proc
 203 #ifdef WINPGI
 204 !MS$ATTRIBUTES C ::  proc_proc
 205 #endif
 206 #endif
 207 #ifdef MPI
 208       include "mpif.h"
 209 #endif
 210 !      include 'COMMON.SETUP'
 211 !      include 'COMMON.IOUNITS'
 212       real(kind=8),dimension(0:n_ene) :: energia
 213 !      include 'COMMON.LOCAL'
 214 !      include 'COMMON.FFIELD'
 215 !      include 'COMMON.DERIV'
 216 !      include 'COMMON.INTERACT'
 217 !      include 'COMMON.SBRIDGE'
 218 !      include 'COMMON.CHAIN'
 219 !      include 'COMMON.VAR'
 220 !      include 'COMMON.MD'
 221 !      include 'COMMON.CONTROL'
 222 !      include 'COMMON.TIME1'
 223       real(kind=8) :: time00
 224 !el local variables
 225       integer :: n_corr,n_corr1,ierror
 226       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 227       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 228       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 229                       Eafmforce,ethetacnstr
 230       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 231 ! now energies for nulceic alone parameters
 232       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 233                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 234                       ecorr3_nucl
 235 #ifdef MPI
 236       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 237 ! shielding effect varibles for MPI
 238 !      real(kind=8)   fac_shieldbuf(maxres),
 239 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 240 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 241 !     & grad_shieldbuf(3,-1:maxres)
 242 !       integer ishield_listbuf(maxres),
 243 !     &shield_listbuf(maxcontsshi,maxres)
 244
 245 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 246 !     & " nfgtasks",nfgtasks
 247       if (nfgtasks.gt.1) then
 248         time00=MPI_Wtime()
 249 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 250         if (fg_rank.eq.0) then
 251           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 252 !          print *,"Processor",myrank," BROADCAST iorder"
 253 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 254 ! FG slaves as WEIGHTS array.
 255           weights_(1)=wsc
 256           weights_(2)=wscp
 257           weights_(3)=welec
 258           weights_(4)=wcorr
 259           weights_(5)=wcorr5
 260           weights_(6)=wcorr6
 261           weights_(7)=wel_loc
 262           weights_(8)=wturn3
 263           weights_(9)=wturn4
 264           weights_(10)=wturn6
 265           weights_(11)=wang
 266           weights_(12)=wscloc
 267           weights_(13)=wtor
 268           weights_(14)=wtor_d
 269           weights_(15)=wstrain
 270           weights_(16)=wvdwpp
 271           weights_(17)=wbond
 272           weights_(18)=scal14
 273           weights_(21)=wsccor
 274 ! FG Master broadcasts the WEIGHTS_ array
 275           call MPI_Bcast(weights_(1),n_ene,&
 276              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 277         else
 278 ! FG slaves receive the WEIGHTS array
 279           call MPI_Bcast(weights(1),n_ene,&
 280               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 281           wsc=weights(1)
 282           wscp=weights(2)
 283           welec=weights(3)
 284           wcorr=weights(4)
 285           wcorr5=weights(5)
 286           wcorr6=weights(6)
 287           wel_loc=weights(7)
 288           wturn3=weights(8)
 289           wturn4=weights(9)
 290           wturn6=weights(10)
 291           wang=weights(11)
 292           wscloc=weights(12)
 293           wtor=weights(13)
 294           wtor_d=weights(14)
 295           wstrain=weights(15)
 296           wvdwpp=weights(16)
 297           wbond=weights(17)
 298           scal14=weights(18)
 299           wsccor=weights(21)
 300         endif
 301         time_Bcast=time_Bcast+MPI_Wtime()-time00
 302         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 303 !        call chainbuild_cart
 304       endif
 305 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 306 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 307 #else
 308 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 309 !        call int_from_cart1(.false.)
 310 !      endif
 311 #endif
 312 #ifdef TIMING
 313       time00=MPI_Wtime()
 314 #endif
 315 !
 316 ! Compute the side-chain and electrostatic interaction energy
 317 !        print *, "Before EVDW"
 318 !      goto (101,102,103,104,105,106) ipot
 319       select case(ipot)
 320 ! Lennard-Jones potential.
 321 !  101 call elj(evdw)
 322        case (1)
 323          call elj(evdw)
 324 !d    print '(a)','Exit ELJcall el'
 325 !      goto 107
 326 ! Lennard-Jones-Kihara potential (shifted).
 327 !  102 call eljk(evdw)
 328        case (2)
 329          call eljk(evdw)
 330 !      goto 107
 331 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 332 !  103 call ebp(evdw)
 333        case (3)
 334          call ebp(evdw)
 335 !      goto 107
 336 ! Gay-Berne potential (shifted LJ, angular dependence).
 337 !  104 call egb(evdw)
 338        case (4)
 339          call egb(evdw)
 340 !      goto 107
 341 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 342 !  105 call egbv(evdw)
 343        case (5)
 344          call egbv(evdw)
 345 !      goto 107
 346 ! Soft-sphere potential
 347 !  106 call e_softsphere(evdw)
 348        case (6)
 349          call e_softsphere(evdw)
 350 !
 351 ! Calculate electrostatic (H-bonding) energy of the main chain.
 352 !
 353 !  107 continue
 354        case default
 355          write(iout,*)"Wrong ipot"
 356 !         return
 357 !   50 continue
 358       end select
 359 !      continue
 360 !        print *,"after EGB"
 361 ! shielding effect
 362        if (shield_mode.eq.2) then
 363                  call set_shield_fac2
 364        endif
 365        print *,"AFTER EGB",ipot,evdw
 366 !mc
 367 !mc Sep-06: egb takes care of dynamic ss bonds too
 368 !mc
 369 !      if (dyn_ss) call dyn_set_nss
 370 !      print *,"Processor",myrank," computed USCSC"
 371 #ifdef TIMING
 372       time01=MPI_Wtime()
 373 #endif
 374       call vec_and_deriv
 375 #ifdef TIMING
 376       time_vec=time_vec+MPI_Wtime()-time01
 377 #endif
 378 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 379       if (ipot.lt.6) then
 380 #ifdef SPLITELE
 381 !         print *,"after ipot if", ipot
 382          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 383              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 384              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 385              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 386 #else
 387          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 388              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 389              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 390              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 391 #endif
 392 !            print *,"just befor eelec call"
 393             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 394 !         write (iout,*) "ELEC calc"
 395          else
 396             ees=0.0d0
 397             evdw1=0.0d0
 398             eel_loc=0.0d0
 399             eello_turn3=0.0d0
 400             eello_turn4=0.0d0
 401          endif
 402       else
 403 !        write (iout,*) "Soft-spheer ELEC potential"
 404         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 405          eello_turn4)
 406       endif
 407 !      print *,"Processor",myrank," computed UELEC"
 408 !
 409 ! Calculate excluded-volume interaction energy between peptide groups
 410 ! and side chains.
 411 !
 412 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 413
 414       if (ipot.lt.6) then
 415        if(wscp.gt.0d0) then
 416         call escp(evdw2,evdw2_14)
 417        else
 418         evdw2=0
 419         evdw2_14=0
 420        endif
 421       else
 422 !        write (iout,*) "Soft-sphere SCP potential"
 423         call escp_soft_sphere(evdw2,evdw2_14)
 424       endif
 425 !       write(iout,*) "in etotal before ebond",ipot
 426
 427 !
 428 ! Calculate the bond-stretching energy
 429 !
 430       call ebond(estr)
 431        print *,"EBOND",estr
 432 !       write(iout,*) "in etotal afer ebond",ipot
 433
 434 !
 435 ! Calculate the disulfide-bridge and other energy and the contributions
 436 ! from other distance constraints.
 437 !      print *,'Calling EHPB'
 438       call edis(ehpb)
 439 !elwrite(iout,*) "in etotal afer edis",ipot
 440 !      print *,'EHPB exitted succesfully.'
 441 !
 442 ! Calculate the virtual-bond-angle energy.
 443 !
 444       if (wang.gt.0d0) then
 445         call ebend(ebe,ethetacnstr)
 446       else
 447         ebe=0
 448       endif
 449 !      print *,"Processor",myrank," computed UB"
 450 !
 451 ! Calculate the SC local energy.
 452 !
 453       call esc(escloc)
 454 !elwrite(iout,*) "in etotal afer esc",ipot
 455 !      print *,"Processor",myrank," computed USC"
 456 !
 457 ! Calculate the virtual-bond torsional energy.
 458 !
 459 !d    print *,'nterm=',nterm
 460       if (wtor.gt.0) then
 461        call etor(etors,edihcnstr)
 462       else
 463        etors=0
 464        edihcnstr=0
 465       endif
 466 !      print *,"Processor",myrank," computed Utor"
 467 !
 468 ! 6/23/01 Calculate double-torsional energy
 469 !
 470 !elwrite(iout,*) "in etotal",ipot
 471       if (wtor_d.gt.0) then
 472        call etor_d(etors_d)
 473       else
 474        etors_d=0
 475       endif
 476 !      print *,"Processor",myrank," computed Utord"
 477 !
 478 ! 21/5/07 Calculate local sicdechain correlation energy
 479 !
 480       if (wsccor.gt.0.0d0) then
 481         call eback_sc_corr(esccor)
 482       else
 483         esccor=0.0d0
 484       endif
 485 !      print *,"Processor",myrank," computed Usccorr"
 486 !
 487 ! 12/1/95 Multi-body terms
 488 !
 489       n_corr=0
 490       n_corr1=0
 491       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 492           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 493          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 494 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 495 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 496       else
 497          ecorr=0.0d0
 498          ecorr5=0.0d0
 499          ecorr6=0.0d0
 500          eturn6=0.0d0
 501       endif
 502 !elwrite(iout,*) "in etotal",ipot
 503       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 504          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 505 !d         write (iout,*) "multibody_hb ecorr",ecorr
 506       endif
 507 !elwrite(iout,*) "afeter  multibody hb"
 508
 509 !      print *,"Processor",myrank," computed Ucorr"
 510 !
 511 ! If performing constraint dynamics, call the constraint energy
 512 !  after the equilibration time
 513       if(usampl.and.totT.gt.eq_time) then
 514 !elwrite(iout,*) "afeter  multibody hb"
 515          call EconstrQ
 516 !elwrite(iout,*) "afeter  multibody hb"
 517          call Econstr_back
 518 !elwrite(iout,*) "afeter  multibody hb"
 519       else
 520          Uconst=0.0d0
 521          Uconst_back=0.0d0
 522       endif
 523       call flush(iout)
 524 !         write(iout,*) "after Econstr"
 525
 526       if (wliptran.gt.0) then
 527 !        print *,"PRZED WYWOLANIEM"
 528         call Eliptransfer(eliptran)
 529       else
 530        eliptran=0.0d0
 531       endif
 532       if (fg_rank.eq.0) then
 533       if (AFMlog.gt.0) then
 534         call AFMforce(Eafmforce)
 535       else if (selfguide.gt.0) then
 536         call AFMvel(Eafmforce)
 537       endif
 538       endif
 539       if (tubemode.eq.1) then
 540        call calctube(etube)
 541       else if (tubemode.eq.2) then
 542        call calctube2(etube)
 543       elseif (tubemode.eq.3) then
 544        call calcnano(etube)
 545       else
 546        etube=0.0d0
 547       endif
 548 !--------------------------------------------------------
 549       call ebond_nucl(estr_nucl)
 550       call ebend_nucl(ebe_nucl)
 551       print *,"after ebend", ebe_nucl
 552 #ifdef TIMING
 553       time_enecalc=time_enecalc+MPI_Wtime()-time00
 554 #endif
 555 !      print *,"Processor",myrank," computed Uconstr"
 556 #ifdef TIMING
 557       time00=MPI_Wtime()
 558 #endif
 559 !
 560 ! Sum the energies
 561 !
 562       energia(1)=evdw
 563 #ifdef SCP14
 564       energia(2)=evdw2-evdw2_14
 565       energia(18)=evdw2_14
 566 #else
 567       energia(2)=evdw2
 568       energia(18)=0.0d0
 569 #endif
 570 #ifdef SPLITELE
 571       energia(3)=ees
 572       energia(16)=evdw1
 573 #else
 574       energia(3)=ees+evdw1
 575       energia(16)=0.0d0
 576 #endif
 577       energia(4)=ecorr
 578       energia(5)=ecorr5
 579       energia(6)=ecorr6
 580       energia(7)=eel_loc
 581       energia(8)=eello_turn3
 582       energia(9)=eello_turn4
 583       energia(10)=eturn6
 584       energia(11)=ebe
 585       energia(12)=escloc
 586       energia(13)=etors
 587       energia(14)=etors_d
 588       energia(15)=ehpb
 589       energia(19)=edihcnstr
 590       energia(17)=estr
 591       energia(20)=Uconst+Uconst_back
 592       energia(21)=esccor
 593       energia(22)=eliptran
 594       energia(23)=Eafmforce
 595       energia(24)=ethetacnstr
 596       energia(25)=etube
 597 !---------------------------------------------------------------
 598       energia(26)=evdwpp
 599       energia(27)=eespp
 600       energia(28)=evdwpsb
 601       energia(29)=eelpsb
 602       energia(30)=evdwsb
 603       energia(31)=eelsb
 604       energia(32)=estr_nucl
 605       energia(33)=ebe_nucl
 606       energia(34)=esbloc
 607       energia(35)=etors_nucl
 608       energia(36)=etors_d_nucl
 609       energia(37)=ecorr_nucl
 610       energia(38)=ecorr3_nucl
 611 !----------------------------------------------------------------------
 612 !    Here are the energies showed per procesor if the are more processors
 613 !    per molecule then we sum it up in sum_energy subroutine
 614 !      print *," Processor",myrank," calls SUM_ENERGY"
 615       call sum_energy(energia,.true.)
 616       if (dyn_ss) call dyn_set_nss
 617 !      print *," Processor",myrank," left SUM_ENERGY"
 618 #ifdef TIMING
 619       time_sumene=time_sumene+MPI_Wtime()-time00
 620 #endif
 621 !el        call enerprint(energia)
 622 !elwrite(iout,*)"finish etotal"
 623       return
 624       end subroutine etotal
 625 !-----------------------------------------------------------------------------
 626       subroutine sum_energy(energia,reduce)
 627 !      implicit real*8 (a-h,o-z)
 628 !      include 'DIMENSIONS'
 629 #ifndef ISNAN
 630       external proc_proc
 631 #ifdef WINPGI
 632 !MS$ATTRIBUTES C ::  proc_proc
 633 #endif
 634 #endif
 635 #ifdef MPI
 636       include "mpif.h"
 637 #endif
 638 !      include 'COMMON.SETUP'
 639 !      include 'COMMON.IOUNITS'
 640       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 641 !      include 'COMMON.FFIELD'
 642 !      include 'COMMON.DERIV'
 643 !      include 'COMMON.INTERACT'
 644 !      include 'COMMON.SBRIDGE'
 645 !      include 'COMMON.CHAIN'
 646 !      include 'COMMON.VAR'
 647 !      include 'COMMON.CONTROL'
 648 !      include 'COMMON.TIME1'
 649       logical :: reduce
 650       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 651       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 652       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 653         eliptran,etube, Eafmforce,ethetacnstr
 654       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 655                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 656                       ecorr3_nucl
 657
 658       integer :: i
 659 #ifdef MPI
 660       integer :: ierr
 661       real(kind=8) :: time00
 662       if (nfgtasks.gt.1 .and. reduce) then
 663
 664 #ifdef DEBUG
 665         write (iout,*) "energies before REDUCE"
 666         call enerprint(energia)
 667         call flush(iout)
 668 #endif
 669         do i=0,n_ene
 670           enebuff(i)=energia(i)
 671         enddo
 672         time00=MPI_Wtime()
 673         call MPI_Barrier(FG_COMM,IERR)
 674         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 675         time00=MPI_Wtime()
 676         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 677           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 678 #ifdef DEBUG
 679         write (iout,*) "energies after REDUCE"
 680         call enerprint(energia)
 681         call flush(iout)
 682 #endif
 683         time_Reduce=time_Reduce+MPI_Wtime()-time00
 684       endif
 685       if (fg_rank.eq.0) then
 686 #endif
 687       evdw=energia(1)
 688 #ifdef SCP14
 689       evdw2=energia(2)+energia(18)
 690       evdw2_14=energia(18)
 691 #else
 692       evdw2=energia(2)
 693 #endif
 694 #ifdef SPLITELE
 695       ees=energia(3)
 696       evdw1=energia(16)
 697 #else
 698       ees=energia(3)
 699       evdw1=0.0d0
 700 #endif
 701       ecorr=energia(4)
 702       ecorr5=energia(5)
 703       ecorr6=energia(6)
 704       eel_loc=energia(7)
 705       eello_turn3=energia(8)
 706       eello_turn4=energia(9)
 707       eturn6=energia(10)
 708       ebe=energia(11)
 709       escloc=energia(12)
 710       etors=energia(13)
 711       etors_d=energia(14)
 712       ehpb=energia(15)
 713       edihcnstr=energia(19)
 714       estr=energia(17)
 715       Uconst=energia(20)
 716       esccor=energia(21)
 717       eliptran=energia(22)
 718       Eafmforce=energia(23)
 719       ethetacnstr=energia(24)
 720       etube=energia(25)
 721       estr_nucl=energia(32)
 722       ebe_nucl=energia(33)
 723
 724 #ifdef SPLITELE
 725       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 726        +wang*ebe+wtor*etors+wscloc*escloc &
 727        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 728        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 729        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 730        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 731        +Eafmforce+ethetacnstr  &
 732        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl
 733 #else
 734       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 735        +wang*ebe+wtor*etors+wscloc*escloc &
 736        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 737        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 738        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 739        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 740        +Eafmforce+ethetacnstr &
 741        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl
 742 #endif
 743       energia(0)=etot
 744 ! detecting NaNQ
 745 #ifdef ISNAN
 746 #ifdef AIX
 747       if (isnan(etot).ne.0) energia(0)=1.0d+99
 748 #else
 749       if (isnan(etot)) energia(0)=1.0d+99
 750 #endif
 751 #else
 752       i=0
 753 #ifdef WINPGI
 754       idumm=proc_proc(etot,i)
 755 #else
 756       call proc_proc(etot,i)
 757 #endif
 758       if(i.eq.1)energia(0)=1.0d+99
 759 #endif
 760 #ifdef MPI
 761       endif
 762 #endif
 763 !      call enerprint(energia)
 764       call flush(iout)
 765       return
 766       end subroutine sum_energy
 767 !-----------------------------------------------------------------------------
 768       subroutine rescale_weights(t_bath)
 769 !      implicit real*8 (a-h,o-z)
 770 #ifdef MPI
 771       include 'mpif.h'
 772 #endif
 773 !      include 'DIMENSIONS'
 774 !      include 'COMMON.IOUNITS'
 775 !      include 'COMMON.FFIELD'
 776 !      include 'COMMON.SBRIDGE'
 777       real(kind=8) :: kfac=2.4d0
 778       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 779 !el local variables
 780       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 781       real(kind=8) :: T0=3.0d2
 782       integer :: ierror
 783 !      facT=temp0/t_bath
 784 !      facT=2*temp0/(t_bath+temp0)
 785       if (rescale_mode.eq.0) then
 786         facT(1)=1.0d0
 787         facT(2)=1.0d0
 788         facT(3)=1.0d0
 789         facT(4)=1.0d0
 790         facT(5)=1.0d0
 791         facT(6)=1.0d0
 792       else if (rescale_mode.eq.1) then
 793         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 794         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 795         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 796         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 797         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 798 #ifdef WHAM_RUN
 799 !#if defined(WHAM_RUN) || defined(CLUSTER)
 800 #if defined(FUNCTH)
 801 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 802         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 803 #elif defined(FUNCT)
 804         facT(6)=t_bath/T0
 805 #else
 806         facT(6)=1.0d0
 807 #endif
 808 #endif
 809       else if (rescale_mode.eq.2) then
 810         x=t_bath/temp0
 811         x2=x*x
 812         x3=x2*x
 813         x4=x3*x
 814         x5=x4*x
 815         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 816         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 817         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 818         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 819         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 820 #ifdef WHAM_RUN
 821 !#if defined(WHAM_RUN) || defined(CLUSTER)
 822 #if defined(FUNCTH)
 823         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 824 #elif defined(FUNCT)
 825         facT(6)=t_bath/T0
 826 #else
 827         facT(6)=1.0d0
 828 #endif
 829 #endif
 830       else
 831         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 832         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 833 #ifdef MPI
 834        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 835 #endif
 836        stop 555
 837       endif
 838       welec=weights(3)*fact(1)
 839       wcorr=weights(4)*fact(3)
 840       wcorr5=weights(5)*fact(4)
 841       wcorr6=weights(6)*fact(5)
 842       wel_loc=weights(7)*fact(2)
 843       wturn3=weights(8)*fact(2)
 844       wturn4=weights(9)*fact(3)
 845       wturn6=weights(10)*fact(5)
 846       wtor=weights(13)*fact(1)
 847       wtor_d=weights(14)*fact(2)
 848       wsccor=weights(21)*fact(1)
 849
 850       return
 851       end subroutine rescale_weights
 852 !-----------------------------------------------------------------------------
 853       subroutine enerprint(energia)
 854 !      implicit real*8 (a-h,o-z)
 855 !      include 'DIMENSIONS'
 856 !      include 'COMMON.IOUNITS'
 857 !      include 'COMMON.FFIELD'
 858 !      include 'COMMON.SBRIDGE'
 859 !      include 'COMMON.MD'
 860       real(kind=8) :: energia(0:n_ene)
 861 !el local variables
 862       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 863       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 864       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 865        etube,ethetacnstr,Eafmforce
 866       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 867                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 868                       ecorr3_nucl
 869
 870       etot=energia(0)
 871       evdw=energia(1)
 872       evdw2=energia(2)
 873 #ifdef SCP14
 874       evdw2=energia(2)+energia(18)
 875 #else
 876       evdw2=energia(2)
 877 #endif
 878       ees=energia(3)
 879 #ifdef SPLITELE
 880       evdw1=energia(16)
 881 #endif
 882       ecorr=energia(4)
 883       ecorr5=energia(5)
 884       ecorr6=energia(6)
 885       eel_loc=energia(7)
 886       eello_turn3=energia(8)
 887       eello_turn4=energia(9)
 888       eello_turn6=energia(10)
 889       ebe=energia(11)
 890       escloc=energia(12)
 891       etors=energia(13)
 892       etors_d=energia(14)
 893       ehpb=energia(15)
 894       edihcnstr=energia(19)
 895       estr=energia(17)
 896       Uconst=energia(20)
 897       esccor=energia(21)
 898       eliptran=energia(22)
 899       Eafmforce=energia(23)
 900       ethetacnstr=energia(24)
 901       etube=energia(25)
 902       estr_nucl=energia(32)
 903       ebe_nucl=energia(33)
 904
 905 #ifdef SPLITELE
 906       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 907         estr,wbond,ebe,wang,&
 908         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 909         ecorr,wcorr,&
 910         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 911         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 912         edihcnstr,ethetacnstr,ebr*nss,&
 913         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
 914         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
 915         etot
 916    10 format (/'Virtual-chain energies:'// &
 917        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 918        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 919        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 920        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 921        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 922        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 923        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 924        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 925        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 926        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 927        ' (SS bridges & dist. cnstr.)'/ &
 928        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 929        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 930        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 931        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 932        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 933        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 934        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 935        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 936        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 937        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
 938        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 939        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 940        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
 941        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
 942        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 943        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
 944        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
 945        'ETOT=  ',1pE16.6,' (total)')
 946 #else
 947       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 948         estr,wbond,ebe,wang,&
 949         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 950         ecorr,wcorr,&
 951         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 952         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 953         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
 954         etube,wtube, &
 955         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
 956         etot
 957    10 format (/'Virtual-chain energies:'// &
 958        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 959        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 960        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 961        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 962        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 963        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 964        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 965        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 966        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 967        ' (SS bridges & dist. cnstr.)'/ &
 968        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 969        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 970        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 971        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 972        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 973        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 974        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 975        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 976        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 977        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
 978        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 979        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 980        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
 981        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
 982        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 983        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
 984        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
 985        'ETOT=  ',1pE16.6,' (total)')
 986 #endif
 987       return
 988       end subroutine enerprint
 989 !-----------------------------------------------------------------------------
 990       subroutine elj(evdw)
 991 !
 992 ! This subroutine calculates the interaction energy of nonbonded side chains
 993 ! assuming the LJ potential of interaction.
 994 !
 995 !      implicit real*8 (a-h,o-z)
 996 !      include 'DIMENSIONS'
 997       real(kind=8),parameter :: accur=1.0d-10
 998 !      include 'COMMON.GEO'
 999 !      include 'COMMON.VAR'
1000 !      include 'COMMON.LOCAL'
1001 !      include 'COMMON.CHAIN'
1002 !      include 'COMMON.DERIV'
1003 !      include 'COMMON.INTERACT'
1004 !      include 'COMMON.TORSION'
1005 !      include 'COMMON.SBRIDGE'
1006 !      include 'COMMON.NAMES'
1007 !      include 'COMMON.IOUNITS'
1008 !      include 'COMMON.CONTACTS'
1009       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1010       integer :: num_conti
1011 !el local variables
1012       integer :: i,itypi,iint,j,itypi1,itypj,k
1013       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1014       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1015       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1016
1017 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1018       evdw=0.0D0
1019 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1020 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1021 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
1022 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
1023
1024       do i=iatsc_s,iatsc_e
1025         itypi=iabs(itype(i,1))
1026         if (itypi.eq.ntyp1) cycle
1027         itypi1=iabs(itype(i+1,1))
1028         xi=c(1,nres+i)
1029         yi=c(2,nres+i)
1030         zi=c(3,nres+i)
1031 ! Change 12/1/95
1032         num_conti=0
1033 !
1034 ! Calculate SC interaction energy.
1035 !
1036         do iint=1,nint_gr(i)
1037 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1038 !d   &                  'iend=',iend(i,iint)
1039           do j=istart(i,iint),iend(i,iint)
1040             itypj=iabs(itype(j,1))
1041             if (itypj.eq.ntyp1) cycle
1042             xj=c(1,nres+j)-xi
1043             yj=c(2,nres+j)-yi
1044             zj=c(3,nres+j)-zi
1045 ! Change 12/1/95 to calculate four-body interactions
1046             rij=xj*xj+yj*yj+zj*zj
1047             rrij=1.0D0/rij
1048 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1049             eps0ij=eps(itypi,itypj)
1050             fac=rrij**expon2
1051             e1=fac*fac*aa_aq(itypi,itypj)
1052             e2=fac*bb_aq(itypi,itypj)
1053             evdwij=e1+e2
1054 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1055 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1056 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1057 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1058 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1059 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1060             evdw=evdw+evdwij
1061 !
1062 ! Calculate the components of the gradient in DC and X
1063 !
1064             fac=-rrij*(e1+evdwij)
1065             gg(1)=xj*fac
1066             gg(2)=yj*fac
1067             gg(3)=zj*fac
1068             do k=1,3
1069               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1070               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1071               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1072               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1073             enddo
1074 !grad            do k=i,j-1
1075 !grad              do l=1,3
1076 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1077 !grad              enddo
1078 !grad            enddo
1079 !
1080 ! 12/1/95, revised on 5/20/97
1081 !
1082 ! Calculate the contact function. The ith column of the array JCONT will
1083 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1084 ! greater than I). The arrays FACONT and GACONT will contain the values of
1085 ! the contact function and its derivative.
1086 !
1087 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1088 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1089 ! Uncomment next line, if the correlation interactions are contact function only
1090             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1091               rij=dsqrt(rij)
1092               sigij=sigma(itypi,itypj)
1093               r0ij=rs0(itypi,itypj)
1094 !
1095 ! Check whether the SC's are not too far to make a contact.
1096 !
1097               rcut=1.5d0*r0ij
1098               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1099 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1100 !
1101               if (fcont.gt.0.0D0) then
1102 ! If the SC-SC distance if close to sigma, apply spline.
1103 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1104 !Adam &             fcont1,fprimcont1)
1105 !Adam           fcont1=1.0d0-fcont1
1106 !Adam           if (fcont1.gt.0.0d0) then
1107 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1108 !Adam             fcont=fcont*fcont1
1109 !Adam           endif
1110 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1111 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1112 !ga             do k=1,3
1113 !ga               gg(k)=gg(k)*eps0ij
1114 !ga             enddo
1115 !ga             eps0ij=-evdwij*eps0ij
1116 ! Uncomment for AL's type of SC correlation interactions.
1117 !adam           eps0ij=-evdwij
1118                 num_conti=num_conti+1
1119                 jcont(num_conti,i)=j
1120                 facont(num_conti,i)=fcont*eps0ij
1121                 fprimcont=eps0ij*fprimcont/rij
1122                 fcont=expon*fcont
1123 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1124 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1125 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1126 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1127                 gacont(1,num_conti,i)=-fprimcont*xj
1128                 gacont(2,num_conti,i)=-fprimcont*yj
1129                 gacont(3,num_conti,i)=-fprimcont*zj
1130 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1131 !d              write (iout,'(2i3,3f10.5)')
1132 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1133               endif
1134             endif
1135           enddo      ! j
1136         enddo        ! iint
1137 ! Change 12/1/95
1138         num_cont(i)=num_conti
1139       enddo          ! i
1140       do i=1,nct
1141         do j=1,3
1142           gvdwc(j,i)=expon*gvdwc(j,i)
1143           gvdwx(j,i)=expon*gvdwx(j,i)
1144         enddo
1145       enddo
1146 !******************************************************************************
1147 !
1148 !                              N O T E !!!
1149 !
1150 ! To save time, the factor of EXPON has been extracted from ALL components
1151 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1152 ! use!
1153 !
1154 !******************************************************************************
1155       return
1156       end subroutine elj
1157 !-----------------------------------------------------------------------------
1158       subroutine eljk(evdw)
1159 !
1160 ! This subroutine calculates the interaction energy of nonbonded side chains
1161 ! assuming the LJK potential of interaction.
1162 !
1163 !      implicit real*8 (a-h,o-z)
1164 !      include 'DIMENSIONS'
1165 !      include 'COMMON.GEO'
1166 !      include 'COMMON.VAR'
1167 !      include 'COMMON.LOCAL'
1168 !      include 'COMMON.CHAIN'
1169 !      include 'COMMON.DERIV'
1170 !      include 'COMMON.INTERACT'
1171 !      include 'COMMON.IOUNITS'
1172 !      include 'COMMON.NAMES'
1173       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1174       logical :: scheck
1175 !el local variables
1176       integer :: i,iint,j,itypi,itypi1,k,itypj
1177       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1178       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1179
1180 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1181       evdw=0.0D0
1182       do i=iatsc_s,iatsc_e
1183         itypi=iabs(itype(i,1))
1184         if (itypi.eq.ntyp1) cycle
1185         itypi1=iabs(itype(i+1,1))
1186         xi=c(1,nres+i)
1187         yi=c(2,nres+i)
1188         zi=c(3,nres+i)
1189 !
1190 ! Calculate SC interaction energy.
1191 !
1192         do iint=1,nint_gr(i)
1193           do j=istart(i,iint),iend(i,iint)
1194             itypj=iabs(itype(j,1))
1195             if (itypj.eq.ntyp1) cycle
1196             xj=c(1,nres+j)-xi
1197             yj=c(2,nres+j)-yi
1198             zj=c(3,nres+j)-zi
1199             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1200             fac_augm=rrij**expon
1201             e_augm=augm(itypi,itypj)*fac_augm
1202             r_inv_ij=dsqrt(rrij)
1203             rij=1.0D0/r_inv_ij
1204             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1205             fac=r_shift_inv**expon
1206             e1=fac*fac*aa_aq(itypi,itypj)
1207             e2=fac*bb_aq(itypi,itypj)
1208             evdwij=e_augm+e1+e2
1209 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1210 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1211 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1212 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1213 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1214 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1215 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1216             evdw=evdw+evdwij
1217 !
1218 ! Calculate the components of the gradient in DC and X
1219 !
1220             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1221             gg(1)=xj*fac
1222             gg(2)=yj*fac
1223             gg(3)=zj*fac
1224             do k=1,3
1225               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1226               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1227               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1228               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1229             enddo
1230 !grad            do k=i,j-1
1231 !grad              do l=1,3
1232 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1233 !grad              enddo
1234 !grad            enddo
1235           enddo      ! j
1236         enddo        ! iint
1237       enddo          ! i
1238       do i=1,nct
1239         do j=1,3
1240           gvdwc(j,i)=expon*gvdwc(j,i)
1241           gvdwx(j,i)=expon*gvdwx(j,i)
1242         enddo
1243       enddo
1244       return
1245       end subroutine eljk
1246 !-----------------------------------------------------------------------------
1247       subroutine ebp(evdw)
1248 !
1249 ! This subroutine calculates the interaction energy of nonbonded side chains
1250 ! assuming the Berne-Pechukas potential of interaction.
1251 !
1252       use comm_srutu
1253       use calc_data
1254 !      implicit real*8 (a-h,o-z)
1255 !      include 'DIMENSIONS'
1256 !      include 'COMMON.GEO'
1257 !      include 'COMMON.VAR'
1258 !      include 'COMMON.LOCAL'
1259 !      include 'COMMON.CHAIN'
1260 !      include 'COMMON.DERIV'
1261 !      include 'COMMON.NAMES'
1262 !      include 'COMMON.INTERACT'
1263 !      include 'COMMON.IOUNITS'
1264 !      include 'COMMON.CALC'
1265       use comm_srutu
1266 !el      integer :: icall
1267 !el      common /srutu/ icall
1268 !     double precision rrsave(maxdim)
1269       logical :: lprn
1270 !el local variables
1271       integer :: iint,itypi,itypi1,itypj
1272       real(kind=8) :: rrij,xi,yi,zi
1273       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1274
1275 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1276       evdw=0.0D0
1277 !     if (icall.eq.0) then
1278 !       lprn=.true.
1279 !     else
1280         lprn=.false.
1281 !     endif
1282 !el      ind=0
1283       do i=iatsc_s,iatsc_e
1284         itypi=iabs(itype(i,1))
1285         if (itypi.eq.ntyp1) cycle
1286         itypi1=iabs(itype(i+1,1))
1287         xi=c(1,nres+i)
1288         yi=c(2,nres+i)
1289         zi=c(3,nres+i)
1290         dxi=dc_norm(1,nres+i)
1291         dyi=dc_norm(2,nres+i)
1292         dzi=dc_norm(3,nres+i)
1293 !        dsci_inv=dsc_inv(itypi)
1294         dsci_inv=vbld_inv(i+nres)
1295 !
1296 ! Calculate SC interaction energy.
1297 !
1298         do iint=1,nint_gr(i)
1299           do j=istart(i,iint),iend(i,iint)
1300 !el            ind=ind+1
1301             itypj=iabs(itype(j,1))
1302             if (itypj.eq.ntyp1) cycle
1303 !            dscj_inv=dsc_inv(itypj)
1304             dscj_inv=vbld_inv(j+nres)
1305             chi1=chi(itypi,itypj)
1306             chi2=chi(itypj,itypi)
1307             chi12=chi1*chi2
1308             chip1=chip(itypi)
1309             chip2=chip(itypj)
1310             chip12=chip1*chip2
1311             alf1=alp(itypi)
1312             alf2=alp(itypj)
1313             alf12=0.5D0*(alf1+alf2)
1314 ! For diagnostics only!!!
1315 !           chi1=0.0D0
1316 !           chi2=0.0D0
1317 !           chi12=0.0D0
1318 !           chip1=0.0D0
1319 !           chip2=0.0D0
1320 !           chip12=0.0D0
1321 !           alf1=0.0D0
1322 !           alf2=0.0D0
1323 !           alf12=0.0D0
1324             xj=c(1,nres+j)-xi
1325             yj=c(2,nres+j)-yi
1326             zj=c(3,nres+j)-zi
1327             dxj=dc_norm(1,nres+j)
1328             dyj=dc_norm(2,nres+j)
1329             dzj=dc_norm(3,nres+j)
1330             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1331 !d          if (icall.eq.0) then
1332 !d            rrsave(ind)=rrij
1333 !d          else
1334 !d            rrij=rrsave(ind)
1335 !d          endif
1336             rij=dsqrt(rrij)
1337 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1338             call sc_angular
1339 ! Calculate whole angle-dependent part of epsilon and contributions
1340 ! to its derivatives
1341             fac=(rrij*sigsq)**expon2
1342             e1=fac*fac*aa_aq(itypi,itypj)
1343             e2=fac*bb_aq(itypi,itypj)
1344             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1345             eps2der=evdwij*eps3rt
1346             eps3der=evdwij*eps2rt
1347             evdwij=evdwij*eps2rt*eps3rt
1348             evdw=evdw+evdwij
1349             if (lprn) then
1350             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1351             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1352 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1353 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1354 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1355 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1356 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1357 !d     &        evdwij
1358             endif
1359 ! Calculate gradient components.
1360             e1=e1*eps1*eps2rt**2*eps3rt**2
1361             fac=-expon*(e1+evdwij)
1362             sigder=fac/sigsq
1363             fac=rrij*fac
1364 ! Calculate radial part of the gradient
1365             gg(1)=xj*fac
1366             gg(2)=yj*fac
1367             gg(3)=zj*fac
1368 ! Calculate the angular part of the gradient and sum add the contributions
1369 ! to the appropriate components of the Cartesian gradient.
1370             call sc_grad
1371           enddo      ! j
1372         enddo        ! iint
1373       enddo          ! i
1374 !     stop
1375       return
1376       end subroutine ebp
1377 !-----------------------------------------------------------------------------
1378       subroutine egb(evdw)
1379 !
1380 ! This subroutine calculates the interaction energy of nonbonded side chains
1381 ! assuming the Gay-Berne potential of interaction.
1382 !
1383       use calc_data
1384 !      implicit real*8 (a-h,o-z)
1385 !      include 'DIMENSIONS'
1386 !      include 'COMMON.GEO'
1387 !      include 'COMMON.VAR'
1388 !      include 'COMMON.LOCAL'
1389 !      include 'COMMON.CHAIN'
1390 !      include 'COMMON.DERIV'
1391 !      include 'COMMON.NAMES'
1392 !      include 'COMMON.INTERACT'
1393 !      include 'COMMON.IOUNITS'
1394 !      include 'COMMON.CALC'
1395 !      include 'COMMON.CONTROL'
1396 !      include 'COMMON.SBRIDGE'
1397       logical :: lprn
1398 !el local variables
1399       integer :: iint,itypi,itypi1,itypj,subchap
1400       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1401       real(kind=8) :: evdw,sig0ij
1402       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1403                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1404                     sslipi,sslipj,faclip
1405       integer :: ii
1406       real(kind=8) :: fracinbuf
1407
1408 !cccc      energy_dec=.false.
1409 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1410       evdw=0.0D0
1411       lprn=.false.
1412 !     if (icall.eq.0) lprn=.false.
1413 !el      ind=0
1414       do i=iatsc_s,iatsc_e
1415 !C        print *,"I am in EVDW",i
1416         itypi=iabs(itype(i,1))
1417 !        if (i.ne.47) cycle
1418         if (itypi.eq.ntyp1) cycle
1419         itypi1=iabs(itype(i+1,1))
1420         xi=c(1,nres+i)
1421         yi=c(2,nres+i)
1422         zi=c(3,nres+i)
1423           xi=dmod(xi,boxxsize)
1424           if (xi.lt.0) xi=xi+boxxsize
1425           yi=dmod(yi,boxysize)
1426           if (yi.lt.0) yi=yi+boxysize
1427           zi=dmod(zi,boxzsize)
1428           if (zi.lt.0) zi=zi+boxzsize
1429
1430        if ((zi.gt.bordlipbot)  &
1431         .and.(zi.lt.bordliptop)) then
1432 !C the energy transfer exist
1433         if (zi.lt.buflipbot) then
1434 !C what fraction I am in
1435          fracinbuf=1.0d0-  &
1436               ((zi-bordlipbot)/lipbufthick)
1437 !C lipbufthick is thickenes of lipid buffore
1438          sslipi=sscalelip(fracinbuf)
1439          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1440         elseif (zi.gt.bufliptop) then
1441          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1442          sslipi=sscalelip(fracinbuf)
1443          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1444         else
1445          sslipi=1.0d0
1446          ssgradlipi=0.0
1447         endif
1448        else
1449          sslipi=0.0d0
1450          ssgradlipi=0.0
1451        endif
1452 !       print *, sslipi,ssgradlipi
1453         dxi=dc_norm(1,nres+i)
1454         dyi=dc_norm(2,nres+i)
1455         dzi=dc_norm(3,nres+i)
1456 !        dsci_inv=dsc_inv(itypi)
1457         dsci_inv=vbld_inv(i+nres)
1458 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1459 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1460 !
1461 ! Calculate SC interaction energy.
1462 !
1463         do iint=1,nint_gr(i)
1464           do j=istart(i,iint),iend(i,iint)
1465             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1466               call dyn_ssbond_ene(i,j,evdwij)
1467               evdw=evdw+evdwij
1468               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1469                               'evdw',i,j,evdwij,' ss'
1470 !              if (energy_dec) write (iout,*) &
1471 !                              'evdw',i,j,evdwij,' ss'
1472              do k=j+1,iend(i,iint)
1473 !C search over all next residues
1474               if (dyn_ss_mask(k)) then
1475 !C check if they are cysteins
1476 !C              write(iout,*) 'k=',k
1477
1478 !c              write(iout,*) "PRZED TRI", evdwij
1479 !               evdwij_przed_tri=evdwij
1480               call triple_ssbond_ene(i,j,k,evdwij)
1481 !c               if(evdwij_przed_tri.ne.evdwij) then
1482 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1483 !c               endif
1484
1485 !c              write(iout,*) "PO TRI", evdwij
1486 !C call the energy function that removes the artifical triple disulfide
1487 !C bond the soubroutine is located in ssMD.F
1488               evdw=evdw+evdwij
1489               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1490                             'evdw',i,j,evdwij,'tss'
1491               endif!dyn_ss_mask(k)
1492              enddo! k
1493             ELSE
1494 !el            ind=ind+1
1495             itypj=iabs(itype(j,1))
1496             if (itypj.eq.ntyp1) cycle
1497 !             if (j.ne.78) cycle
1498 !            dscj_inv=dsc_inv(itypj)
1499             dscj_inv=vbld_inv(j+nres)
1500 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1501 !              1.0d0/vbld(j+nres) !d
1502 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1503             sig0ij=sigma(itypi,itypj)
1504             chi1=chi(itypi,itypj)
1505             chi2=chi(itypj,itypi)
1506             chi12=chi1*chi2
1507             chip1=chip(itypi)
1508             chip2=chip(itypj)
1509             chip12=chip1*chip2
1510             alf1=alp(itypi)
1511             alf2=alp(itypj)
1512             alf12=0.5D0*(alf1+alf2)
1513 ! For diagnostics only!!!
1514 !           chi1=0.0D0
1515 !           chi2=0.0D0
1516 !           chi12=0.0D0
1517 !           chip1=0.0D0
1518 !           chip2=0.0D0
1519 !           chip12=0.0D0
1520 !           alf1=0.0D0
1521 !           alf2=0.0D0
1522 !           alf12=0.0D0
1523            xj=c(1,nres+j)
1524            yj=c(2,nres+j)
1525            zj=c(3,nres+j)
1526           xj=dmod(xj,boxxsize)
1527           if (xj.lt.0) xj=xj+boxxsize
1528           yj=dmod(yj,boxysize)
1529           if (yj.lt.0) yj=yj+boxysize
1530           zj=dmod(zj,boxzsize)
1531           if (zj.lt.0) zj=zj+boxzsize
1532 !          print *,"tu",xi,yi,zi,xj,yj,zj
1533 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1534 ! this fragment set correct epsilon for lipid phase
1535        if ((zj.gt.bordlipbot)  &
1536        .and.(zj.lt.bordliptop)) then
1537 !C the energy transfer exist
1538         if (zj.lt.buflipbot) then
1539 !C what fraction I am in
1540          fracinbuf=1.0d0-     &
1541              ((zj-bordlipbot)/lipbufthick)
1542 !C lipbufthick is thickenes of lipid buffore
1543          sslipj=sscalelip(fracinbuf)
1544          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1545         elseif (zj.gt.bufliptop) then
1546          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1547          sslipj=sscalelip(fracinbuf)
1548          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1549         else
1550          sslipj=1.0d0
1551          ssgradlipj=0.0
1552         endif
1553        else
1554          sslipj=0.0d0
1555          ssgradlipj=0.0
1556        endif
1557       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1558        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1559       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1560        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1561 !------------------------------------------------
1562       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1563       xj_safe=xj
1564       yj_safe=yj
1565       zj_safe=zj
1566       subchap=0
1567       do xshift=-1,1
1568       do yshift=-1,1
1569       do zshift=-1,1
1570           xj=xj_safe+xshift*boxxsize
1571           yj=yj_safe+yshift*boxysize
1572           zj=zj_safe+zshift*boxzsize
1573           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1574           if(dist_temp.lt.dist_init) then
1575             dist_init=dist_temp
1576             xj_temp=xj
1577             yj_temp=yj
1578             zj_temp=zj
1579             subchap=1
1580           endif
1581        enddo
1582        enddo
1583        enddo
1584        if (subchap.eq.1) then
1585           xj=xj_temp-xi
1586           yj=yj_temp-yi
1587           zj=zj_temp-zi
1588        else
1589           xj=xj_safe-xi
1590           yj=yj_safe-yi
1591           zj=zj_safe-zi
1592        endif
1593             dxj=dc_norm(1,nres+j)
1594             dyj=dc_norm(2,nres+j)
1595             dzj=dc_norm(3,nres+j)
1596 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1597 !            write (iout,*) "j",j," dc_norm",& !d
1598 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1599 !          write(iout,*)"rrij ",rrij
1600 !          write(iout,*)"xj yj zj ", xj, yj, zj
1601 !          write(iout,*)"xi yi zi ", xi, yi, zi
1602 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1603             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1604             rij=dsqrt(rrij)
1605             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1606             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1607 !            print *,sss_ele_cut,sss_ele_grad,&
1608 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1609             if (sss_ele_cut.le.0.0) cycle
1610 ! Calculate angle-dependent terms of energy and contributions to their
1611 ! derivatives.
1612             call sc_angular
1613             sigsq=1.0D0/sigsq
1614             sig=sig0ij*dsqrt(sigsq)
1615             rij_shift=1.0D0/rij-sig+sig0ij
1616 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1617 !            "sig0ij",sig0ij
1618 ! for diagnostics; uncomment
1619 !            rij_shift=1.2*sig0ij
1620 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1621             if (rij_shift.le.0.0D0) then
1622               evdw=1.0D20
1623 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1624 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1625 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1626               return
1627             endif
1628             sigder=-sig*sigsq
1629 !---------------------------------------------------------------
1630             rij_shift=1.0D0/rij_shift
1631             fac=rij_shift**expon
1632             faclip=fac
1633             e1=fac*fac*aa!(itypi,itypj)
1634             e2=fac*bb!(itypi,itypj)
1635             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1636             eps2der=evdwij*eps3rt
1637             eps3der=evdwij*eps2rt
1638 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1639 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1640 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1641             evdwij=evdwij*eps2rt*eps3rt
1642             evdw=evdw+evdwij*sss_ele_cut
1643             if (lprn) then
1644             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1645             epsi=bb**2/aa!(itypi,itypj)
1646             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1647               restyp(itypi,1),i,restyp(itypj,1),j, &
1648               epsi,sigm,chi1,chi2,chip1,chip2, &
1649               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1650               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1651               evdwij
1652             endif
1653
1654             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1655                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1656 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1657 !            if (energy_dec) write (iout,*) &
1658 !                             'evdw',i,j,evdwij
1659 !                       print *,"ZALAMKA", evdw
1660
1661 ! Calculate gradient components.
1662             e1=e1*eps1*eps2rt**2*eps3rt**2
1663             fac=-expon*(e1+evdwij)*rij_shift
1664             sigder=fac*sigder
1665             fac=rij*fac
1666 !            print *,'before fac',fac,rij,evdwij
1667             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1668             /sigma(itypi,itypj)*rij
1669 !            print *,'grad part scale',fac,   &
1670 !             evdwij*sss_ele_grad/sss_ele_cut &
1671 !            /sigma(itypi,itypj)*rij
1672 !            fac=0.0d0
1673 ! Calculate the radial part of the gradient
1674             gg(1)=xj*fac
1675             gg(2)=yj*fac
1676             gg(3)=zj*fac
1677 !C Calculate the radial part of the gradient
1678             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1679        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1680         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1681        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1682             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1683             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1684
1685 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1686 ! Calculate angular part of the gradient.
1687             call sc_grad
1688             ENDIF    ! dyn_ss
1689           enddo      ! j
1690         enddo        ! iint
1691       enddo          ! i
1692 !       print *,"ZALAMKA", evdw
1693 !      write (iout,*) "Number of loop steps in EGB:",ind
1694 !ccc      energy_dec=.false.
1695       return
1696       end subroutine egb
1697 !-----------------------------------------------------------------------------
1698       subroutine egbv(evdw)
1699 !
1700 ! This subroutine calculates the interaction energy of nonbonded side chains
1701 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1702 !
1703       use comm_srutu
1704       use calc_data
1705 !      implicit real*8 (a-h,o-z)
1706 !      include 'DIMENSIONS'
1707 !      include 'COMMON.GEO'
1708 !      include 'COMMON.VAR'
1709 !      include 'COMMON.LOCAL'
1710 !      include 'COMMON.CHAIN'
1711 !      include 'COMMON.DERIV'
1712 !      include 'COMMON.NAMES'
1713 !      include 'COMMON.INTERACT'
1714 !      include 'COMMON.IOUNITS'
1715 !      include 'COMMON.CALC'
1716       use comm_srutu
1717 !el      integer :: icall
1718 !el      common /srutu/ icall
1719       logical :: lprn
1720 !el local variables
1721       integer :: iint,itypi,itypi1,itypj
1722       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1723       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1724
1725 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1726       evdw=0.0D0
1727       lprn=.false.
1728 !     if (icall.eq.0) lprn=.true.
1729 !el      ind=0
1730       do i=iatsc_s,iatsc_e
1731         itypi=iabs(itype(i,1))
1732         if (itypi.eq.ntyp1) cycle
1733         itypi1=iabs(itype(i+1,1))
1734         xi=c(1,nres+i)
1735         yi=c(2,nres+i)
1736         zi=c(3,nres+i)
1737         dxi=dc_norm(1,nres+i)
1738         dyi=dc_norm(2,nres+i)
1739         dzi=dc_norm(3,nres+i)
1740 !        dsci_inv=dsc_inv(itypi)
1741         dsci_inv=vbld_inv(i+nres)
1742 !
1743 ! Calculate SC interaction energy.
1744 !
1745         do iint=1,nint_gr(i)
1746           do j=istart(i,iint),iend(i,iint)
1747 !el            ind=ind+1
1748             itypj=iabs(itype(j,1))
1749             if (itypj.eq.ntyp1) cycle
1750 !            dscj_inv=dsc_inv(itypj)
1751             dscj_inv=vbld_inv(j+nres)
1752             sig0ij=sigma(itypi,itypj)
1753             r0ij=r0(itypi,itypj)
1754             chi1=chi(itypi,itypj)
1755             chi2=chi(itypj,itypi)
1756             chi12=chi1*chi2
1757             chip1=chip(itypi)
1758             chip2=chip(itypj)
1759             chip12=chip1*chip2
1760             alf1=alp(itypi)
1761             alf2=alp(itypj)
1762             alf12=0.5D0*(alf1+alf2)
1763 ! For diagnostics only!!!
1764 !           chi1=0.0D0
1765 !           chi2=0.0D0
1766 !           chi12=0.0D0
1767 !           chip1=0.0D0
1768 !           chip2=0.0D0
1769 !           chip12=0.0D0
1770 !           alf1=0.0D0
1771 !           alf2=0.0D0
1772 !           alf12=0.0D0
1773             xj=c(1,nres+j)-xi
1774             yj=c(2,nres+j)-yi
1775             zj=c(3,nres+j)-zi
1776             dxj=dc_norm(1,nres+j)
1777             dyj=dc_norm(2,nres+j)
1778             dzj=dc_norm(3,nres+j)
1779             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1780             rij=dsqrt(rrij)
1781 ! Calculate angle-dependent terms of energy and contributions to their
1782 ! derivatives.
1783             call sc_angular
1784             sigsq=1.0D0/sigsq
1785             sig=sig0ij*dsqrt(sigsq)
1786             rij_shift=1.0D0/rij-sig+r0ij
1787 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1788             if (rij_shift.le.0.0D0) then
1789               evdw=1.0D20
1790               return
1791             endif
1792             sigder=-sig*sigsq
1793 !---------------------------------------------------------------
1794             rij_shift=1.0D0/rij_shift
1795             fac=rij_shift**expon
1796             e1=fac*fac*aa_aq(itypi,itypj)
1797             e2=fac*bb_aq(itypi,itypj)
1798             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1799             eps2der=evdwij*eps3rt
1800             eps3der=evdwij*eps2rt
1801             fac_augm=rrij**expon
1802             e_augm=augm(itypi,itypj)*fac_augm
1803             evdwij=evdwij*eps2rt*eps3rt
1804             evdw=evdw+evdwij+e_augm
1805             if (lprn) then
1806             sigm=dabs(aa_aq(itypi,itypj)/&
1807             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1808             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1809             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1810               restyp(itypi,1),i,restyp(itypj,1),j,&
1811               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1812               chi1,chi2,chip1,chip2,&
1813               eps1,eps2rt**2,eps3rt**2,&
1814               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1815               evdwij+e_augm
1816             endif
1817 ! Calculate gradient components.
1818             e1=e1*eps1*eps2rt**2*eps3rt**2
1819             fac=-expon*(e1+evdwij)*rij_shift
1820             sigder=fac*sigder
1821             fac=rij*fac-2*expon*rrij*e_augm
1822 ! Calculate the radial part of the gradient
1823             gg(1)=xj*fac
1824             gg(2)=yj*fac
1825             gg(3)=zj*fac
1826 ! Calculate angular part of the gradient.
1827             call sc_grad
1828           enddo      ! j
1829         enddo        ! iint
1830       enddo          ! i
1831       end subroutine egbv
1832 !-----------------------------------------------------------------------------
1833 !el      subroutine sc_angular in module geometry
1834 !-----------------------------------------------------------------------------
1835       subroutine e_softsphere(evdw)
1836 !
1837 ! This subroutine calculates the interaction energy of nonbonded side chains
1838 ! assuming the LJ potential of interaction.
1839 !
1840 !      implicit real*8 (a-h,o-z)
1841 !      include 'DIMENSIONS'
1842       real(kind=8),parameter :: accur=1.0d-10
1843 !      include 'COMMON.GEO'
1844 !      include 'COMMON.VAR'
1845 !      include 'COMMON.LOCAL'
1846 !      include 'COMMON.CHAIN'
1847 !      include 'COMMON.DERIV'
1848 !      include 'COMMON.INTERACT'
1849 !      include 'COMMON.TORSION'
1850 !      include 'COMMON.SBRIDGE'
1851 !      include 'COMMON.NAMES'
1852 !      include 'COMMON.IOUNITS'
1853 !      include 'COMMON.CONTACTS'
1854       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1855 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1856 !el local variables
1857       integer :: i,iint,j,itypi,itypi1,itypj,k
1858       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1859       real(kind=8) :: fac
1860
1861       evdw=0.0D0
1862       do i=iatsc_s,iatsc_e
1863         itypi=iabs(itype(i,1))
1864         if (itypi.eq.ntyp1) cycle
1865         itypi1=iabs(itype(i+1,1))
1866         xi=c(1,nres+i)
1867         yi=c(2,nres+i)
1868         zi=c(3,nres+i)
1869 !
1870 ! Calculate SC interaction energy.
1871 !
1872         do iint=1,nint_gr(i)
1873 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1874 !d   &                  'iend=',iend(i,iint)
1875           do j=istart(i,iint),iend(i,iint)
1876             itypj=iabs(itype(j,1))
1877             if (itypj.eq.ntyp1) cycle
1878             xj=c(1,nres+j)-xi
1879             yj=c(2,nres+j)-yi
1880             zj=c(3,nres+j)-zi
1881             rij=xj*xj+yj*yj+zj*zj
1882 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1883             r0ij=r0(itypi,itypj)
1884             r0ijsq=r0ij*r0ij
1885 !            print *,i,j,r0ij,dsqrt(rij)
1886             if (rij.lt.r0ijsq) then
1887               evdwij=0.25d0*(rij-r0ijsq)**2
1888               fac=rij-r0ijsq
1889             else
1890               evdwij=0.0d0
1891               fac=0.0d0
1892             endif
1893             evdw=evdw+evdwij
1894 !
1895 ! Calculate the components of the gradient in DC and X
1896 !
1897             gg(1)=xj*fac
1898             gg(2)=yj*fac
1899             gg(3)=zj*fac
1900             do k=1,3
1901               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1902               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1903               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1904               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1905             enddo
1906 !grad            do k=i,j-1
1907 !grad              do l=1,3
1908 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1909 !grad              enddo
1910 !grad            enddo
1911           enddo ! j
1912         enddo ! iint
1913       enddo ! i
1914       return
1915       end subroutine e_softsphere
1916 !-----------------------------------------------------------------------------
1917       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1918 !
1919 ! Soft-sphere potential of p-p interaction
1920 !
1921 !      implicit real*8 (a-h,o-z)
1922 !      include 'DIMENSIONS'
1923 !      include 'COMMON.CONTROL'
1924 !      include 'COMMON.IOUNITS'
1925 !      include 'COMMON.GEO'
1926 !      include 'COMMON.VAR'
1927 !      include 'COMMON.LOCAL'
1928 !      include 'COMMON.CHAIN'
1929 !      include 'COMMON.DERIV'
1930 !      include 'COMMON.INTERACT'
1931 !      include 'COMMON.CONTACTS'
1932 !      include 'COMMON.TORSION'
1933 !      include 'COMMON.VECTORS'
1934 !      include 'COMMON.FFIELD'
1935       real(kind=8),dimension(3) :: ggg
1936 !d      write(iout,*) 'In EELEC_soft_sphere'
1937 !el local variables
1938       integer :: i,j,k,num_conti,iteli,itelj
1939       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1940       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1941       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1942
1943       ees=0.0D0
1944       evdw1=0.0D0
1945       eel_loc=0.0d0
1946       eello_turn3=0.0d0
1947       eello_turn4=0.0d0
1948 !el      ind=0
1949       do i=iatel_s,iatel_e
1950         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
1951         dxi=dc(1,i)
1952         dyi=dc(2,i)
1953         dzi=dc(3,i)
1954         xmedi=c(1,i)+0.5d0*dxi
1955         ymedi=c(2,i)+0.5d0*dyi
1956         zmedi=c(3,i)+0.5d0*dzi
1957         num_conti=0
1958 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1959         do j=ielstart(i),ielend(i)
1960           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
1961 !el          ind=ind+1
1962           iteli=itel(i)
1963           itelj=itel(j)
1964           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1965           r0ij=rpp(iteli,itelj)
1966           r0ijsq=r0ij*r0ij
1967           dxj=dc(1,j)
1968           dyj=dc(2,j)
1969           dzj=dc(3,j)
1970           xj=c(1,j)+0.5D0*dxj-xmedi
1971           yj=c(2,j)+0.5D0*dyj-ymedi
1972           zj=c(3,j)+0.5D0*dzj-zmedi
1973           rij=xj*xj+yj*yj+zj*zj
1974           if (rij.lt.r0ijsq) then
1975             evdw1ij=0.25d0*(rij-r0ijsq)**2
1976             fac=rij-r0ijsq
1977           else
1978             evdw1ij=0.0d0
1979             fac=0.0d0
1980           endif
1981           evdw1=evdw1+evdw1ij
1982 !
1983 ! Calculate contributions to the Cartesian gradient.
1984 !
1985           ggg(1)=fac*xj
1986           ggg(2)=fac*yj
1987           ggg(3)=fac*zj
1988           do k=1,3
1989             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1990             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1991           enddo
1992 !
1993 ! Loop over residues i+1 thru j-1.
1994 !
1995 !grad          do k=i+1,j-1
1996 !grad            do l=1,3
1997 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1998 !grad            enddo
1999 !grad          enddo
2000         enddo ! j
2001       enddo   ! i
2002 !grad      do i=nnt,nct-1
2003 !grad        do k=1,3
2004 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2005 !grad        enddo
2006 !grad        do j=i+1,nct-1
2007 !grad          do k=1,3
2008 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2009 !grad          enddo
2010 !grad        enddo
2011 !grad      enddo
2012       return
2013       end subroutine eelec_soft_sphere
2014 !-----------------------------------------------------------------------------
2015       subroutine vec_and_deriv
2016 !      implicit real*8 (a-h,o-z)
2017 !      include 'DIMENSIONS'
2018 #ifdef MPI
2019       include 'mpif.h'
2020 #endif
2021 !      include 'COMMON.IOUNITS'
2022 !      include 'COMMON.GEO'
2023 !      include 'COMMON.VAR'
2024 !      include 'COMMON.LOCAL'
2025 !      include 'COMMON.CHAIN'
2026 !      include 'COMMON.VECTORS'
2027 !      include 'COMMON.SETUP'
2028 !      include 'COMMON.TIME1'
2029       real(kind=8),dimension(3,3,2) :: uyder,uzder
2030       real(kind=8),dimension(2) :: vbld_inv_temp
2031 ! Compute the local reference systems. For reference system (i), the
2032 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2033 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2034 !el local variables
2035       integer :: i,j,k,l
2036       real(kind=8) :: facy,fac,costh
2037
2038 #ifdef PARVEC
2039       do i=ivec_start,ivec_end
2040 #else
2041       do i=1,nres-1
2042 #endif
2043           if (i.eq.nres-1) then
2044 ! Case of the last full residue
2045 ! Compute the Z-axis
2046             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2047             costh=dcos(pi-theta(nres))
2048             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2049             do k=1,3
2050               uz(k,i)=fac*uz(k,i)
2051             enddo
2052 ! Compute the derivatives of uz
2053             uzder(1,1,1)= 0.0d0
2054             uzder(2,1,1)=-dc_norm(3,i-1)
2055             uzder(3,1,1)= dc_norm(2,i-1)
2056             uzder(1,2,1)= dc_norm(3,i-1)
2057             uzder(2,2,1)= 0.0d0
2058             uzder(3,2,1)=-dc_norm(1,i-1)
2059             uzder(1,3,1)=-dc_norm(2,i-1)
2060             uzder(2,3,1)= dc_norm(1,i-1)
2061             uzder(3,3,1)= 0.0d0
2062             uzder(1,1,2)= 0.0d0
2063             uzder(2,1,2)= dc_norm(3,i)
2064             uzder(3,1,2)=-dc_norm(2,i)
2065             uzder(1,2,2)=-dc_norm(3,i)
2066             uzder(2,2,2)= 0.0d0
2067             uzder(3,2,2)= dc_norm(1,i)
2068             uzder(1,3,2)= dc_norm(2,i)
2069             uzder(2,3,2)=-dc_norm(1,i)
2070             uzder(3,3,2)= 0.0d0
2071 ! Compute the Y-axis
2072             facy=fac
2073             do k=1,3
2074               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2075             enddo
2076 ! Compute the derivatives of uy
2077             do j=1,3
2078               do k=1,3
2079                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2080                               -dc_norm(k,i)*dc_norm(j,i-1)
2081                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2082               enddo
2083               uyder(j,j,1)=uyder(j,j,1)-costh
2084               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2085             enddo
2086             do j=1,2
2087               do k=1,3
2088                 do l=1,3
2089                   uygrad(l,k,j,i)=uyder(l,k,j)
2090                   uzgrad(l,k,j,i)=uzder(l,k,j)
2091                 enddo
2092               enddo
2093             enddo
2094             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2095             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2096             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2097             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2098           else
2099 ! Other residues
2100 ! Compute the Z-axis
2101             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2102             costh=dcos(pi-theta(i+2))
2103             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2104             do k=1,3
2105               uz(k,i)=fac*uz(k,i)
2106             enddo
2107 ! Compute the derivatives of uz
2108             uzder(1,1,1)= 0.0d0
2109             uzder(2,1,1)=-dc_norm(3,i+1)
2110             uzder(3,1,1)= dc_norm(2,i+1)
2111             uzder(1,2,1)= dc_norm(3,i+1)
2112             uzder(2,2,1)= 0.0d0
2113             uzder(3,2,1)=-dc_norm(1,i+1)
2114             uzder(1,3,1)=-dc_norm(2,i+1)
2115             uzder(2,3,1)= dc_norm(1,i+1)
2116             uzder(3,3,1)= 0.0d0
2117             uzder(1,1,2)= 0.0d0
2118             uzder(2,1,2)= dc_norm(3,i)
2119             uzder(3,1,2)=-dc_norm(2,i)
2120             uzder(1,2,2)=-dc_norm(3,i)
2121             uzder(2,2,2)= 0.0d0
2122             uzder(3,2,2)= dc_norm(1,i)
2123             uzder(1,3,2)= dc_norm(2,i)
2124             uzder(2,3,2)=-dc_norm(1,i)
2125             uzder(3,3,2)= 0.0d0
2126 ! Compute the Y-axis
2127             facy=fac
2128             do k=1,3
2129               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2130             enddo
2131 ! Compute the derivatives of uy
2132             do j=1,3
2133               do k=1,3
2134                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2135                               -dc_norm(k,i)*dc_norm(j,i+1)
2136                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2137               enddo
2138               uyder(j,j,1)=uyder(j,j,1)-costh
2139               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2140             enddo
2141             do j=1,2
2142               do k=1,3
2143                 do l=1,3
2144                   uygrad(l,k,j,i)=uyder(l,k,j)
2145                   uzgrad(l,k,j,i)=uzder(l,k,j)
2146                 enddo
2147               enddo
2148             enddo
2149             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2150             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2151             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2152             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2153           endif
2154       enddo
2155       do i=1,nres-1
2156         vbld_inv_temp(1)=vbld_inv(i+1)
2157         if (i.lt.nres-1) then
2158           vbld_inv_temp(2)=vbld_inv(i+2)
2159           else
2160           vbld_inv_temp(2)=vbld_inv(i)
2161           endif
2162         do j=1,2
2163           do k=1,3
2164             do l=1,3
2165               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2166               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2167             enddo
2168           enddo
2169         enddo
2170       enddo
2171 #if defined(PARVEC) && defined(MPI)
2172       if (nfgtasks1.gt.1) then
2173         time00=MPI_Wtime()
2174 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2175 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2176 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2177         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2178          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2179          FG_COMM1,IERR)
2180         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2181          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2182          FG_COMM1,IERR)
2183         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2184          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2185          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2186         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2187          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2188          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2189         time_gather=time_gather+MPI_Wtime()-time00
2190       endif
2191 !      if (fg_rank.eq.0) then
2192 !        write (iout,*) "Arrays UY and UZ"
2193 !        do i=1,nres-1
2194 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2195 !     &     (uz(k,i),k=1,3)
2196 !        enddo
2197 !      endif
2198 #endif
2199       return
2200       end subroutine vec_and_deriv
2201 !-----------------------------------------------------------------------------
2202       subroutine check_vecgrad
2203 !      implicit real*8 (a-h,o-z)
2204 !      include 'DIMENSIONS'
2205 !      include 'COMMON.IOUNITS'
2206 !      include 'COMMON.GEO'
2207 !      include 'COMMON.VAR'
2208 !      include 'COMMON.LOCAL'
2209 !      include 'COMMON.CHAIN'
2210 !      include 'COMMON.VECTORS'
2211       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2212       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2213       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2214       real(kind=8),dimension(3) :: erij
2215       real(kind=8) :: delta=1.0d-7
2216 !el local variables
2217       integer :: i,j,k,l
2218
2219       call vec_and_deriv
2220 !d      do i=1,nres
2221 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2222 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2223 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2224 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2225 !d     &     (dc_norm(if90,i),if90=1,3)
2226 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2227 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2228 !d          write(iout,'(a)')
2229 !d      enddo
2230       do i=1,nres
2231         do j=1,2
2232           do k=1,3
2233             do l=1,3
2234               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2235               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2236             enddo
2237           enddo
2238         enddo
2239       enddo
2240       call vec_and_deriv
2241       do i=1,nres
2242         do j=1,3
2243           uyt(j,i)=uy(j,i)
2244           uzt(j,i)=uz(j,i)
2245         enddo
2246       enddo
2247       do i=1,nres
2248 !d        write (iout,*) 'i=',i
2249         do k=1,3
2250           erij(k)=dc_norm(k,i)
2251         enddo
2252         do j=1,3
2253           do k=1,3
2254             dc_norm(k,i)=erij(k)
2255           enddo
2256           dc_norm(j,i)=dc_norm(j,i)+delta
2257 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2258 !          do k=1,3
2259 !            dc_norm(k,i)=dc_norm(k,i)/fac
2260 !          enddo
2261 !          write (iout,*) (dc_norm(k,i),k=1,3)
2262 !          write (iout,*) (erij(k),k=1,3)
2263           call vec_and_deriv
2264           do k=1,3
2265             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2266             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2267             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2268             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2269           enddo
2270 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2271 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2272 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2273         enddo
2274         do k=1,3
2275           dc_norm(k,i)=erij(k)
2276         enddo
2277 !d        do k=1,3
2278 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2279 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2280 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2281 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2282 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2283 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2284 !d          write (iout,'(a)')
2285 !d        enddo
2286       enddo
2287       return
2288       end subroutine check_vecgrad
2289 !-----------------------------------------------------------------------------
2290       subroutine set_matrices
2291 !      implicit real*8 (a-h,o-z)
2292 !      include 'DIMENSIONS'
2293 #ifdef MPI
2294       include "mpif.h"
2295 !      include "COMMON.SETUP"
2296       integer :: IERR
2297       integer :: status(MPI_STATUS_SIZE)
2298 #endif
2299 !      include 'COMMON.IOUNITS'
2300 !      include 'COMMON.GEO'
2301 !      include 'COMMON.VAR'
2302 !      include 'COMMON.LOCAL'
2303 !      include 'COMMON.CHAIN'
2304 !      include 'COMMON.DERIV'
2305 !      include 'COMMON.INTERACT'
2306 !      include 'COMMON.CONTACTS'
2307 !      include 'COMMON.TORSION'
2308 !      include 'COMMON.VECTORS'
2309 !      include 'COMMON.FFIELD'
2310       real(kind=8) :: auxvec(2),auxmat(2,2)
2311       integer :: i,iti1,iti,k,l
2312       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2313 !       print *,"in set matrices"
2314 !
2315 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2316 ! to calculate the el-loc multibody terms of various order.
2317 !
2318 !AL el      mu=0.0d0
2319 #ifdef PARMAT
2320       do i=ivec_start+2,ivec_end+2
2321 #else
2322       do i=3,nres+1
2323 #endif
2324 !      print *,i,"i"
2325         if (i .lt. nres+1) then
2326           sin1=dsin(phi(i))
2327           cos1=dcos(phi(i))
2328           sintab(i-2)=sin1
2329           costab(i-2)=cos1
2330           obrot(1,i-2)=cos1
2331           obrot(2,i-2)=sin1
2332           sin2=dsin(2*phi(i))
2333           cos2=dcos(2*phi(i))
2334           sintab2(i-2)=sin2
2335           costab2(i-2)=cos2
2336           obrot2(1,i-2)=cos2
2337           obrot2(2,i-2)=sin2
2338           Ug(1,1,i-2)=-cos1
2339           Ug(1,2,i-2)=-sin1
2340           Ug(2,1,i-2)=-sin1
2341           Ug(2,2,i-2)= cos1
2342           Ug2(1,1,i-2)=-cos2
2343           Ug2(1,2,i-2)=-sin2
2344           Ug2(2,1,i-2)=-sin2
2345           Ug2(2,2,i-2)= cos2
2346         else
2347           costab(i-2)=1.0d0
2348           sintab(i-2)=0.0d0
2349           obrot(1,i-2)=1.0d0
2350           obrot(2,i-2)=0.0d0
2351           obrot2(1,i-2)=0.0d0
2352           obrot2(2,i-2)=0.0d0
2353           Ug(1,1,i-2)=1.0d0
2354           Ug(1,2,i-2)=0.0d0
2355           Ug(2,1,i-2)=0.0d0
2356           Ug(2,2,i-2)=1.0d0
2357           Ug2(1,1,i-2)=0.0d0
2358           Ug2(1,2,i-2)=0.0d0
2359           Ug2(2,1,i-2)=0.0d0
2360           Ug2(2,2,i-2)=0.0d0
2361         endif
2362         if (i .gt. 3 .and. i .lt. nres+1) then
2363           obrot_der(1,i-2)=-sin1
2364           obrot_der(2,i-2)= cos1
2365           Ugder(1,1,i-2)= sin1
2366           Ugder(1,2,i-2)=-cos1
2367           Ugder(2,1,i-2)=-cos1
2368           Ugder(2,2,i-2)=-sin1
2369           dwacos2=cos2+cos2
2370           dwasin2=sin2+sin2
2371           obrot2_der(1,i-2)=-dwasin2
2372           obrot2_der(2,i-2)= dwacos2
2373           Ug2der(1,1,i-2)= dwasin2
2374           Ug2der(1,2,i-2)=-dwacos2
2375           Ug2der(2,1,i-2)=-dwacos2
2376           Ug2der(2,2,i-2)=-dwasin2
2377         else
2378           obrot_der(1,i-2)=0.0d0
2379           obrot_der(2,i-2)=0.0d0
2380           Ugder(1,1,i-2)=0.0d0
2381           Ugder(1,2,i-2)=0.0d0
2382           Ugder(2,1,i-2)=0.0d0
2383           Ugder(2,2,i-2)=0.0d0
2384           obrot2_der(1,i-2)=0.0d0
2385           obrot2_der(2,i-2)=0.0d0
2386           Ug2der(1,1,i-2)=0.0d0
2387           Ug2der(1,2,i-2)=0.0d0
2388           Ug2der(2,1,i-2)=0.0d0
2389           Ug2der(2,2,i-2)=0.0d0
2390         endif
2391 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2392         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2393           iti = itortyp(itype(i-2,1))
2394         else
2395           iti=ntortyp+1
2396         endif
2397 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2398         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2399           iti1 = itortyp(itype(i-1,1))
2400         else
2401           iti1=ntortyp+1
2402         endif
2403 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2404 !d        write (iout,*) '*******i',i,' iti1',iti
2405 !d        write (iout,*) 'b1',b1(:,iti)
2406 !d        write (iout,*) 'b2',b2(:,iti)
2407 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2408 !        if (i .gt. iatel_s+2) then
2409         if (i .gt. nnt+2) then
2410           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2411           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2412           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2413           then
2414           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2415           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2416           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2417           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2418           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2419           endif
2420         else
2421           do k=1,2
2422             Ub2(k,i-2)=0.0d0
2423             Ctobr(k,i-2)=0.0d0
2424             Dtobr2(k,i-2)=0.0d0
2425             do l=1,2
2426               EUg(l,k,i-2)=0.0d0
2427               CUg(l,k,i-2)=0.0d0
2428               DUg(l,k,i-2)=0.0d0
2429               DtUg2(l,k,i-2)=0.0d0
2430             enddo
2431           enddo
2432         endif
2433         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2434         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2435         do k=1,2
2436           muder(k,i-2)=Ub2der(k,i-2)
2437         enddo
2438 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2439         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2440           if (itype(i-1,1).le.ntyp) then
2441             iti1 = itortyp(itype(i-1,1))
2442           else
2443             iti1=ntortyp+1
2444           endif
2445         else
2446           iti1=ntortyp+1
2447         endif
2448         do k=1,2
2449           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2450         enddo
2451 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2452 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2453 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2454 !d        write (iout,*) 'mu1',mu1(:,i-2)
2455 !d        write (iout,*) 'mu2',mu2(:,i-2)
2456         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2457         then
2458         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2459         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2460         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2461         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2462         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2463 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2464         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2465         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2466         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2467         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2468         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2469         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2470         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2471         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2472         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2473         endif
2474       enddo
2475 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2476 ! The order of matrices is from left to right.
2477       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2478       then
2479 !      do i=max0(ivec_start,2),ivec_end
2480       do i=2,nres-1
2481         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2482         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2483         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2484         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2485         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2486         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2487         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2488         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2489       enddo
2490       endif
2491 #if defined(MPI) && defined(PARMAT)
2492 #ifdef DEBUG
2493 !      if (fg_rank.eq.0) then
2494         write (iout,*) "Arrays UG and UGDER before GATHER"
2495         do i=1,nres-1
2496           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2497            ((ug(l,k,i),l=1,2),k=1,2),&
2498            ((ugder(l,k,i),l=1,2),k=1,2)
2499         enddo
2500         write (iout,*) "Arrays UG2 and UG2DER"
2501         do i=1,nres-1
2502           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2503            ((ug2(l,k,i),l=1,2),k=1,2),&
2504            ((ug2der(l,k,i),l=1,2),k=1,2)
2505         enddo
2506         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2507         do i=1,nres-1
2508           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2509            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2510            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2511         enddo
2512         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2513         do i=1,nres-1
2514           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2515            costab(i),sintab(i),costab2(i),sintab2(i)
2516         enddo
2517         write (iout,*) "Array MUDER"
2518         do i=1,nres-1
2519           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2520         enddo
2521 !      endif
2522 #endif
2523       if (nfgtasks.gt.1) then
2524         time00=MPI_Wtime()
2525 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2526 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2527 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2528 #ifdef MATGATHER
2529         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2530          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2531          FG_COMM1,IERR)
2532         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2533          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2534          FG_COMM1,IERR)
2535         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2536          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2537          FG_COMM1,IERR)
2538         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2539          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2540          FG_COMM1,IERR)
2541         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2542          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2543          FG_COMM1,IERR)
2544         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2545          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2546          FG_COMM1,IERR)
2547         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2548          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2549          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2550         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2551          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2552          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2553         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2554          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2555          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2556         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2557          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2558          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2559         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2560         then
2561         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2562          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2563          FG_COMM1,IERR)
2564         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2565          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2566          FG_COMM1,IERR)
2567         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2568          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2569          FG_COMM1,IERR)
2570        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2571          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2572          FG_COMM1,IERR)
2573         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2574          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2575          FG_COMM1,IERR)
2576         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2577          ivec_count(fg_rank1),&
2578          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2579          FG_COMM1,IERR)
2580         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2581          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2582          FG_COMM1,IERR)
2583         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2584          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2585          FG_COMM1,IERR)
2586         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2587          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2588          FG_COMM1,IERR)
2589         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2590          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2591          FG_COMM1,IERR)
2592         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2593          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2594          FG_COMM1,IERR)
2595         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2596          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2597          FG_COMM1,IERR)
2598         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2599          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2600          FG_COMM1,IERR)
2601         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2602          ivec_count(fg_rank1),&
2603          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2604          FG_COMM1,IERR)
2605         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2606          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2607          FG_COMM1,IERR)
2608        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2609          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2610          FG_COMM1,IERR)
2611         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2612          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2613          FG_COMM1,IERR)
2614        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2615          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2616          FG_COMM1,IERR)
2617         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2618          ivec_count(fg_rank1),&
2619          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2620          FG_COMM1,IERR)
2621         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2622          ivec_count(fg_rank1),&
2623          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2624          FG_COMM1,IERR)
2625         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2626          ivec_count(fg_rank1),&
2627          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2628          MPI_MAT2,FG_COMM1,IERR)
2629         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2630          ivec_count(fg_rank1),&
2631          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2632          MPI_MAT2,FG_COMM1,IERR)
2633         endif
2634 #else
2635 ! Passes matrix info through the ring
2636       isend=fg_rank1
2637       irecv=fg_rank1-1
2638       if (irecv.lt.0) irecv=nfgtasks1-1
2639       iprev=irecv
2640       inext=fg_rank1+1
2641       if (inext.ge.nfgtasks1) inext=0
2642       do i=1,nfgtasks1-1
2643 !        write (iout,*) "isend",isend," irecv",irecv
2644 !        call flush(iout)
2645         lensend=lentyp(isend)
2646         lenrecv=lentyp(irecv)
2647 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2648 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2649 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2650 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2651 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2652 !        write (iout,*) "Gather ROTAT1"
2653 !        call flush(iout)
2654 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2655 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2656 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2657 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2658 !        write (iout,*) "Gather ROTAT2"
2659 !        call flush(iout)
2660         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2661          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2662          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2663          iprev,4400+irecv,FG_COMM,status,IERR)
2664 !        write (iout,*) "Gather ROTAT_OLD"
2665 !        call flush(iout)
2666         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2667          MPI_PRECOMP11(lensend),inext,5500+isend,&
2668          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2669          iprev,5500+irecv,FG_COMM,status,IERR)
2670 !        write (iout,*) "Gather PRECOMP11"
2671 !        call flush(iout)
2672         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2673          MPI_PRECOMP12(lensend),inext,6600+isend,&
2674          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2675          iprev,6600+irecv,FG_COMM,status,IERR)
2676 !        write (iout,*) "Gather PRECOMP12"
2677 !        call flush(iout)
2678         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2679         then
2680         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2681          MPI_ROTAT2(lensend),inext,7700+isend,&
2682          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2683          iprev,7700+irecv,FG_COMM,status,IERR)
2684 !        write (iout,*) "Gather PRECOMP21"
2685 !        call flush(iout)
2686         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2687          MPI_PRECOMP22(lensend),inext,8800+isend,&
2688          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2689          iprev,8800+irecv,FG_COMM,status,IERR)
2690 !        write (iout,*) "Gather PRECOMP22"
2691 !        call flush(iout)
2692         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2693          MPI_PRECOMP23(lensend),inext,9900+isend,&
2694          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2695          MPI_PRECOMP23(lenrecv),&
2696          iprev,9900+irecv,FG_COMM,status,IERR)
2697 !        write (iout,*) "Gather PRECOMP23"
2698 !        call flush(iout)
2699         endif
2700         isend=irecv
2701         irecv=irecv-1
2702         if (irecv.lt.0) irecv=nfgtasks1-1
2703       enddo
2704 #endif
2705         time_gather=time_gather+MPI_Wtime()-time00
2706       endif
2707 #ifdef DEBUG
2708 !      if (fg_rank.eq.0) then
2709         write (iout,*) "Arrays UG and UGDER"
2710         do i=1,nres-1
2711           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2712            ((ug(l,k,i),l=1,2),k=1,2),&
2713            ((ugder(l,k,i),l=1,2),k=1,2)
2714         enddo
2715         write (iout,*) "Arrays UG2 and UG2DER"
2716         do i=1,nres-1
2717           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2718            ((ug2(l,k,i),l=1,2),k=1,2),&
2719            ((ug2der(l,k,i),l=1,2),k=1,2)
2720         enddo
2721         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2722         do i=1,nres-1
2723           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2724            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2725            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2726         enddo
2727         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2728         do i=1,nres-1
2729           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2730            costab(i),sintab(i),costab2(i),sintab2(i)
2731         enddo
2732         write (iout,*) "Array MUDER"
2733         do i=1,nres-1
2734           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2735         enddo
2736 !      endif
2737 #endif
2738 #endif
2739 !d      do i=1,nres
2740 !d        iti = itortyp(itype(i,1))
2741 !d        write (iout,*) i
2742 !d        do j=1,2
2743 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2744 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2745 !d        enddo
2746 !d      enddo
2747       return
2748       end subroutine set_matrices
2749 !-----------------------------------------------------------------------------
2750       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2751 !
2752 ! This subroutine calculates the average interaction energy and its gradient
2753 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2754 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2755 ! The potential depends both on the distance of peptide-group centers and on
2756 ! the orientation of the CA-CA virtual bonds.
2757 !
2758       use comm_locel
2759 !      implicit real*8 (a-h,o-z)
2760 #ifdef MPI
2761       include 'mpif.h'
2762 #endif
2763 !      include 'DIMENSIONS'
2764 !      include 'COMMON.CONTROL'
2765 !      include 'COMMON.SETUP'
2766 !      include 'COMMON.IOUNITS'
2767 !      include 'COMMON.GEO'
2768 !      include 'COMMON.VAR'
2769 !      include 'COMMON.LOCAL'
2770 !      include 'COMMON.CHAIN'
2771 !      include 'COMMON.DERIV'
2772 !      include 'COMMON.INTERACT'
2773 !      include 'COMMON.CONTACTS'
2774 !      include 'COMMON.TORSION'
2775 !      include 'COMMON.VECTORS'
2776 !      include 'COMMON.FFIELD'
2777 !      include 'COMMON.TIME1'
2778       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2779       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2780       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2781 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2782       real(kind=8),dimension(4) :: muij
2783 !el      integer :: num_conti,j1,j2
2784 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2785 !el        dz_normi,xmedi,ymedi,zmedi
2786
2787 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2788 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2789 !el          num_conti,j1,j2
2790
2791 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2792 #ifdef MOMENT
2793       real(kind=8) :: scal_el=1.0d0
2794 #else
2795       real(kind=8) :: scal_el=0.5d0
2796 #endif
2797 ! 12/13/98
2798 ! 13-go grudnia roku pamietnego...
2799       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2800                                              0.0d0,1.0d0,0.0d0,&
2801                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2802 !el local variables
2803       integer :: i,k,j
2804       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2805       real(kind=8) :: fac,t_eelecij,fracinbuf
2806
2807
2808 !d      write(iout,*) 'In EELEC'
2809 !        print *,"IN EELEC"
2810 !d      do i=1,nloctyp
2811 !d        write(iout,*) 'Type',i
2812 !d        write(iout,*) 'B1',B1(:,i)
2813 !d        write(iout,*) 'B2',B2(:,i)
2814 !d        write(iout,*) 'CC',CC(:,:,i)
2815 !d        write(iout,*) 'DD',DD(:,:,i)
2816 !d        write(iout,*) 'EE',EE(:,:,i)
2817 !d      enddo
2818 !d      call check_vecgrad
2819 !d      stop
2820 !      ees=0.0d0  !AS
2821 !      evdw1=0.0d0
2822 !      eel_loc=0.0d0
2823 !      eello_turn3=0.0d0
2824 !      eello_turn4=0.0d0
2825       t_eelecij=0.0d0
2826       ees=0.0D0
2827       evdw1=0.0D0
2828       eel_loc=0.0d0
2829       eello_turn3=0.0d0
2830       eello_turn4=0.0d0
2831 !
2832
2833       if (icheckgrad.eq.1) then
2834 !el
2835 !        do i=0,2*nres+2
2836 !          dc_norm(1,i)=0.0d0
2837 !          dc_norm(2,i)=0.0d0
2838 !          dc_norm(3,i)=0.0d0
2839 !        enddo
2840         do i=1,nres-1
2841           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2842           do k=1,3
2843             dc_norm(k,i)=dc(k,i)*fac
2844           enddo
2845 !          write (iout,*) 'i',i,' fac',fac
2846         enddo
2847       endif
2848 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2849 !        wturn6
2850       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2851           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2852           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2853 !        call vec_and_deriv
2854 #ifdef TIMING
2855         time01=MPI_Wtime()
2856 #endif
2857 !        print *, "before set matrices"
2858         call set_matrices
2859 !        print *, "after set matrices"
2860
2861 #ifdef TIMING
2862         time_mat=time_mat+MPI_Wtime()-time01
2863 #endif
2864       endif
2865 !       print *, "after set matrices"
2866 !d      do i=1,nres-1
2867 !d        write (iout,*) 'i=',i
2868 !d        do k=1,3
2869 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2870 !d        enddo
2871 !d        do k=1,3
2872 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2873 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2874 !d        enddo
2875 !d      enddo
2876       t_eelecij=0.0d0
2877       ees=0.0D0
2878       evdw1=0.0D0
2879       eel_loc=0.0d0
2880       eello_turn3=0.0d0
2881       eello_turn4=0.0d0
2882 !el      ind=0
2883       do i=1,nres
2884         num_cont_hb(i)=0
2885       enddo
2886 !d      print '(a)','Enter EELEC'
2887 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2888 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2889 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2890       do i=1,nres
2891         gel_loc_loc(i)=0.0d0
2892         gcorr_loc(i)=0.0d0
2893       enddo
2894 !
2895 !
2896 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2897 !
2898 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2899 !
2900
2901
2902 !        print *,"before iturn3 loop"
2903       do i=iturn3_start,iturn3_end
2904         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
2905         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
2906         dxi=dc(1,i)
2907         dyi=dc(2,i)
2908         dzi=dc(3,i)
2909         dx_normi=dc_norm(1,i)
2910         dy_normi=dc_norm(2,i)
2911         dz_normi=dc_norm(3,i)
2912         xmedi=c(1,i)+0.5d0*dxi
2913         ymedi=c(2,i)+0.5d0*dyi
2914         zmedi=c(3,i)+0.5d0*dzi
2915           xmedi=dmod(xmedi,boxxsize)
2916           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2917           ymedi=dmod(ymedi,boxysize)
2918           if (ymedi.lt.0) ymedi=ymedi+boxysize
2919           zmedi=dmod(zmedi,boxzsize)
2920           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2921         num_conti=0
2922        if ((zmedi.gt.bordlipbot) &
2923         .and.(zmedi.lt.bordliptop)) then
2924 !C the energy transfer exist
2925         if (zmedi.lt.buflipbot) then
2926 !C what fraction I am in
2927          fracinbuf=1.0d0- &
2928                ((zmedi-bordlipbot)/lipbufthick)
2929 !C lipbufthick is thickenes of lipid buffore
2930          sslipi=sscalelip(fracinbuf)
2931          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2932         elseif (zmedi.gt.bufliptop) then
2933          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2934          sslipi=sscalelip(fracinbuf)
2935          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2936         else
2937          sslipi=1.0d0
2938          ssgradlipi=0.0
2939         endif
2940        else
2941          sslipi=0.0d0
2942          ssgradlipi=0.0
2943        endif
2944 !       print *,i,sslipi,ssgradlipi
2945        call eelecij(i,i+2,ees,evdw1,eel_loc)
2946         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2947         num_cont_hb(i)=num_conti
2948       enddo
2949       do i=iturn4_start,iturn4_end
2950         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
2951           .or. itype(i+3,1).eq.ntyp1 &
2952           .or. itype(i+4,1).eq.ntyp1) cycle
2953         dxi=dc(1,i)
2954         dyi=dc(2,i)
2955         dzi=dc(3,i)
2956         dx_normi=dc_norm(1,i)
2957         dy_normi=dc_norm(2,i)
2958         dz_normi=dc_norm(3,i)
2959         xmedi=c(1,i)+0.5d0*dxi
2960         ymedi=c(2,i)+0.5d0*dyi
2961         zmedi=c(3,i)+0.5d0*dzi
2962           xmedi=dmod(xmedi,boxxsize)
2963           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2964           ymedi=dmod(ymedi,boxysize)
2965           if (ymedi.lt.0) ymedi=ymedi+boxysize
2966           zmedi=dmod(zmedi,boxzsize)
2967           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2968        if ((zmedi.gt.bordlipbot)  &
2969        .and.(zmedi.lt.bordliptop)) then
2970 !C the energy transfer exist
2971         if (zmedi.lt.buflipbot) then
2972 !C what fraction I am in
2973          fracinbuf=1.0d0- &
2974              ((zmedi-bordlipbot)/lipbufthick)
2975 !C lipbufthick is thickenes of lipid buffore
2976          sslipi=sscalelip(fracinbuf)
2977          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2978         elseif (zmedi.gt.bufliptop) then
2979          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2980          sslipi=sscalelip(fracinbuf)
2981          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2982         else
2983          sslipi=1.0d0
2984          ssgradlipi=0.0
2985         endif
2986        else
2987          sslipi=0.0d0
2988          ssgradlipi=0.0
2989        endif
2990
2991         num_conti=num_cont_hb(i)
2992         call eelecij(i,i+3,ees,evdw1,eel_loc)
2993         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
2994          call eturn4(i,eello_turn4)
2995         num_cont_hb(i)=num_conti
2996       enddo   ! i
2997 !
2998 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2999 !
3000       do i=iatel_s,iatel_e
3001         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3002         dxi=dc(1,i)
3003         dyi=dc(2,i)
3004         dzi=dc(3,i)
3005         dx_normi=dc_norm(1,i)
3006         dy_normi=dc_norm(2,i)
3007         dz_normi=dc_norm(3,i)
3008         xmedi=c(1,i)+0.5d0*dxi
3009         ymedi=c(2,i)+0.5d0*dyi
3010         zmedi=c(3,i)+0.5d0*dzi
3011           xmedi=dmod(xmedi,boxxsize)
3012           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3013           ymedi=dmod(ymedi,boxysize)
3014           if (ymedi.lt.0) ymedi=ymedi+boxysize
3015           zmedi=dmod(zmedi,boxzsize)
3016           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3017        if ((zmedi.gt.bordlipbot)  &
3018         .and.(zmedi.lt.bordliptop)) then
3019 !C the energy transfer exist
3020         if (zmedi.lt.buflipbot) then
3021 !C what fraction I am in
3022          fracinbuf=1.0d0- &
3023              ((zmedi-bordlipbot)/lipbufthick)
3024 !C lipbufthick is thickenes of lipid buffore
3025          sslipi=sscalelip(fracinbuf)
3026          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3027         elseif (zmedi.gt.bufliptop) then
3028          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3029          sslipi=sscalelip(fracinbuf)
3030          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3031         else
3032          sslipi=1.0d0
3033          ssgradlipi=0.0
3034         endif
3035        else
3036          sslipi=0.0d0
3037          ssgradlipi=0.0
3038        endif
3039
3040 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3041         num_conti=num_cont_hb(i)
3042         do j=ielstart(i),ielend(i)
3043 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3044           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3045           call eelecij(i,j,ees,evdw1,eel_loc)
3046         enddo ! j
3047         num_cont_hb(i)=num_conti
3048       enddo   ! i
3049 !      write (iout,*) "Number of loop steps in EELEC:",ind
3050 !d      do i=1,nres
3051 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3052 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3053 !d      enddo
3054 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3055 !cc      eel_loc=eel_loc+eello_turn3
3056 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3057       return
3058       end subroutine eelec
3059 !-----------------------------------------------------------------------------
3060       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3061
3062       use comm_locel
3063 !      implicit real*8 (a-h,o-z)
3064 !      include 'DIMENSIONS'
3065 #ifdef MPI
3066       include "mpif.h"
3067 #endif
3068 !      include 'COMMON.CONTROL'
3069 !      include 'COMMON.IOUNITS'
3070 !      include 'COMMON.GEO'
3071 !      include 'COMMON.VAR'
3072 !      include 'COMMON.LOCAL'
3073 !      include 'COMMON.CHAIN'
3074 !      include 'COMMON.DERIV'
3075 !      include 'COMMON.INTERACT'
3076 !      include 'COMMON.CONTACTS'
3077 !      include 'COMMON.TORSION'
3078 !      include 'COMMON.VECTORS'
3079 !      include 'COMMON.FFIELD'
3080 !      include 'COMMON.TIME1'
3081       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3082       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3083       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3084 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3085       real(kind=8),dimension(4) :: muij
3086       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3087                     dist_temp, dist_init,rlocshield,fracinbuf
3088       integer xshift,yshift,zshift,ilist,iresshield
3089 !el      integer :: num_conti,j1,j2
3090 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3091 !el        dz_normi,xmedi,ymedi,zmedi
3092
3093 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3094 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3095 !el          num_conti,j1,j2
3096
3097 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3098 #ifdef MOMENT
3099       real(kind=8) :: scal_el=1.0d0
3100 #else
3101       real(kind=8) :: scal_el=0.5d0
3102 #endif
3103 ! 12/13/98
3104 ! 13-go grudnia roku pamietnego...
3105       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3106                                              0.0d0,1.0d0,0.0d0,&
3107                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3108 !      integer :: maxconts=nres/4
3109 !el local variables
3110       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3111       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3112       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3113       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3114                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3115                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3116                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3117                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3118                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3119                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3120                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3121 !      maxconts=nres/4
3122 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3123 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3124
3125 !          time00=MPI_Wtime()
3126 !d      write (iout,*) "eelecij",i,j
3127 !          ind=ind+1
3128           iteli=itel(i)
3129           itelj=itel(j)
3130           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3131           aaa=app(iteli,itelj)
3132           bbb=bpp(iteli,itelj)
3133           ael6i=ael6(iteli,itelj)
3134           ael3i=ael3(iteli,itelj)
3135           dxj=dc(1,j)
3136           dyj=dc(2,j)
3137           dzj=dc(3,j)
3138           dx_normj=dc_norm(1,j)
3139           dy_normj=dc_norm(2,j)
3140           dz_normj=dc_norm(3,j)
3141 !          xj=c(1,j)+0.5D0*dxj-xmedi
3142 !          yj=c(2,j)+0.5D0*dyj-ymedi
3143 !          zj=c(3,j)+0.5D0*dzj-zmedi
3144           xj=c(1,j)+0.5D0*dxj
3145           yj=c(2,j)+0.5D0*dyj
3146           zj=c(3,j)+0.5D0*dzj
3147           xj=mod(xj,boxxsize)
3148           if (xj.lt.0) xj=xj+boxxsize
3149           yj=mod(yj,boxysize)
3150           if (yj.lt.0) yj=yj+boxysize
3151           zj=mod(zj,boxzsize)
3152           if (zj.lt.0) zj=zj+boxzsize
3153        if ((zj.gt.bordlipbot)  &
3154        .and.(zj.lt.bordliptop)) then
3155 !C the energy transfer exist
3156         if (zj.lt.buflipbot) then
3157 !C what fraction I am in
3158          fracinbuf=1.0d0-     &
3159              ((zj-bordlipbot)/lipbufthick)
3160 !C lipbufthick is thickenes of lipid buffore
3161          sslipj=sscalelip(fracinbuf)
3162          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3163         elseif (zj.gt.bufliptop) then
3164          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3165          sslipj=sscalelip(fracinbuf)
3166          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3167         else
3168          sslipj=1.0d0
3169          ssgradlipj=0.0
3170         endif
3171        else
3172          sslipj=0.0d0
3173          ssgradlipj=0.0
3174        endif
3175
3176       isubchap=0
3177       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3178       xj_safe=xj
3179       yj_safe=yj
3180       zj_safe=zj
3181       do xshift=-1,1
3182       do yshift=-1,1
3183       do zshift=-1,1
3184           xj=xj_safe+xshift*boxxsize
3185           yj=yj_safe+yshift*boxysize
3186           zj=zj_safe+zshift*boxzsize
3187           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3188           if(dist_temp.lt.dist_init) then
3189             dist_init=dist_temp
3190             xj_temp=xj
3191             yj_temp=yj
3192             zj_temp=zj
3193             isubchap=1
3194           endif
3195        enddo
3196        enddo
3197        enddo
3198        if (isubchap.eq.1) then
3199 !C          print *,i,j
3200           xj=xj_temp-xmedi
3201           yj=yj_temp-ymedi
3202           zj=zj_temp-zmedi
3203        else
3204           xj=xj_safe-xmedi
3205           yj=yj_safe-ymedi
3206           zj=zj_safe-zmedi
3207        endif
3208
3209           rij=xj*xj+yj*yj+zj*zj
3210           rrmij=1.0D0/rij
3211           rij=dsqrt(rij)
3212 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3213             sss_ele_cut=sscale_ele(rij)
3214             sss_ele_grad=sscagrad_ele(rij)
3215 !             sss_ele_cut=1.0d0
3216 !             sss_ele_grad=0.0d0
3217 !            print *,sss_ele_cut,sss_ele_grad,&
3218 !            (rij),r_cut_ele,rlamb_ele
3219 !            if (sss_ele_cut.le.0.0) go to 128
3220
3221           rmij=1.0D0/rij
3222           r3ij=rrmij*rmij
3223           r6ij=r3ij*r3ij
3224           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3225           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3226           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3227           fac=cosa-3.0D0*cosb*cosg
3228           ev1=aaa*r6ij*r6ij
3229 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3230           if (j.eq.i+2) ev1=scal_el*ev1
3231           ev2=bbb*r6ij
3232           fac3=ael6i*r6ij
3233           fac4=ael3i*r3ij
3234           evdwij=ev1+ev2
3235           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3236           el2=fac4*fac
3237 !          eesij=el1+el2
3238           if (shield_mode.gt.0) then
3239 !C          fac_shield(i)=0.4
3240 !C          fac_shield(j)=0.6
3241           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3242           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3243           eesij=(el1+el2)
3244           ees=ees+eesij*sss_ele_cut
3245 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3246 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3247           else
3248           fac_shield(i)=1.0
3249           fac_shield(j)=1.0
3250           eesij=(el1+el2)
3251           ees=ees+eesij   &
3252             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3253 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3254           endif
3255
3256 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3257           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3258 !          ees=ees+eesij*sss_ele_cut
3259           evdw1=evdw1+evdwij*sss_ele_cut  &
3260            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3261 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3262 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3263 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3264 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3265
3266           if (energy_dec) then
3267 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3268 !                  'evdw1',i,j,evdwij,&
3269 !                  iteli,itelj,aaa,evdw1
3270               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3271               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3272           endif
3273 !
3274 ! Calculate contributions to the Cartesian gradient.
3275 !
3276 #ifdef SPLITELE
3277           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3278               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3279           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3280              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3281           fac1=fac
3282           erij(1)=xj*rmij
3283           erij(2)=yj*rmij
3284           erij(3)=zj*rmij
3285 !
3286 ! Radial derivatives. First process both termini of the fragment (i,j)
3287 !
3288           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3289           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3290           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3291            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3292           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3293             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3294
3295           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3296           (shield_mode.gt.0)) then
3297 !C          print *,i,j
3298           do ilist=1,ishield_list(i)
3299            iresshield=shield_list(ilist,i)
3300            do k=1,3
3301            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3302            *2.0*sss_ele_cut
3303            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3304                    rlocshield &
3305             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3306             *sss_ele_cut
3307             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3308            enddo
3309           enddo
3310           do ilist=1,ishield_list(j)
3311            iresshield=shield_list(ilist,j)
3312            do k=1,3
3313            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3314           *2.0*sss_ele_cut
3315            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3316                    rlocshield &
3317            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3318            *sss_ele_cut
3319            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3320            enddo
3321           enddo
3322           do k=1,3
3323             gshieldc(k,i)=gshieldc(k,i)+ &
3324                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3325            *sss_ele_cut
3326
3327             gshieldc(k,j)=gshieldc(k,j)+ &
3328                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3329            *sss_ele_cut
3330
3331             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3332                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3333            *sss_ele_cut
3334
3335             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3336                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3337            *sss_ele_cut
3338
3339            enddo
3340            endif
3341
3342
3343 !          do k=1,3
3344 !            ghalf=0.5D0*ggg(k)
3345 !            gelc(k,i)=gelc(k,i)+ghalf
3346 !            gelc(k,j)=gelc(k,j)+ghalf
3347 !          enddo
3348 ! 9/28/08 AL Gradient compotents will be summed only at the end
3349           do k=1,3
3350             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3351             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3352           enddo
3353             gelc_long(3,j)=gelc_long(3,j)+  &
3354           ssgradlipj*eesij/2.0d0*lipscale**2&
3355            *sss_ele_cut
3356
3357             gelc_long(3,i)=gelc_long(3,i)+  &
3358           ssgradlipi*eesij/2.0d0*lipscale**2&
3359            *sss_ele_cut
3360
3361
3362 !
3363 ! Loop over residues i+1 thru j-1.
3364 !
3365 !grad          do k=i+1,j-1
3366 !grad            do l=1,3
3367 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3368 !grad            enddo
3369 !grad          enddo
3370           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3371            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3372           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3373            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3374           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3375            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3376
3377 !          do k=1,3
3378 !            ghalf=0.5D0*ggg(k)
3379 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3380 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3381 !          enddo
3382 ! 9/28/08 AL Gradient compotents will be summed only at the end
3383           do k=1,3
3384             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3385             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3386           enddo
3387
3388 !C Lipidic part for scaling weight
3389            gvdwpp(3,j)=gvdwpp(3,j)+ &
3390           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3391            gvdwpp(3,i)=gvdwpp(3,i)+ &
3392           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3393 !! Loop over residues i+1 thru j-1.
3394 !
3395 !grad          do k=i+1,j-1
3396 !grad            do l=1,3
3397 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3398 !grad            enddo
3399 !grad          enddo
3400 #else
3401           facvdw=(ev1+evdwij)*sss_ele_cut &
3402            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3403
3404           facel=(el1+eesij)*sss_ele_cut
3405           fac1=fac
3406           fac=-3*rrmij*(facvdw+facvdw+facel)
3407           erij(1)=xj*rmij
3408           erij(2)=yj*rmij
3409           erij(3)=zj*rmij
3410 !
3411 ! Radial derivatives. First process both termini of the fragment (i,j)
3412 !
3413           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3414           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3415           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3416 !          do k=1,3
3417 !            ghalf=0.5D0*ggg(k)
3418 !            gelc(k,i)=gelc(k,i)+ghalf
3419 !            gelc(k,j)=gelc(k,j)+ghalf
3420 !          enddo
3421 ! 9/28/08 AL Gradient compotents will be summed only at the end
3422           do k=1,3
3423             gelc_long(k,j)=gelc(k,j)+ggg(k)
3424             gelc_long(k,i)=gelc(k,i)-ggg(k)
3425           enddo
3426 !
3427 ! Loop over residues i+1 thru j-1.
3428 !
3429 !grad          do k=i+1,j-1
3430 !grad            do l=1,3
3431 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3432 !grad            enddo
3433 !grad          enddo
3434 ! 9/28/08 AL Gradient compotents will be summed only at the end
3435           ggg(1)=facvdw*xj &
3436            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3437           ggg(2)=facvdw*yj &
3438            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3439           ggg(3)=facvdw*zj &
3440            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3441
3442           do k=1,3
3443             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3444             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3445           enddo
3446            gvdwpp(3,j)=gvdwpp(3,j)+ &
3447           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3448            gvdwpp(3,i)=gvdwpp(3,i)+ &
3449           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3450
3451 #endif
3452 !
3453 ! Angular part
3454 !
3455           ecosa=2.0D0*fac3*fac1+fac4
3456           fac4=-3.0D0*fac4
3457           fac3=-6.0D0*fac3
3458           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3459           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3460           do k=1,3
3461             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3462             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3463           enddo
3464 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3465 !d   &          (dcosg(k),k=1,3)
3466           do k=1,3
3467             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3468              *fac_shield(i)**2*fac_shield(j)**2 &
3469              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3470
3471           enddo
3472 !          do k=1,3
3473 !            ghalf=0.5D0*ggg(k)
3474 !            gelc(k,i)=gelc(k,i)+ghalf
3475 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3476 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3477 !            gelc(k,j)=gelc(k,j)+ghalf
3478 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3479 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3480 !          enddo
3481 !grad          do k=i+1,j-1
3482 !grad            do l=1,3
3483 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3484 !grad            enddo
3485 !grad          enddo
3486           do k=1,3
3487             gelc(k,i)=gelc(k,i) &
3488                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3489                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3490                      *sss_ele_cut &
3491                      *fac_shield(i)**2*fac_shield(j)**2 &
3492                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3493
3494             gelc(k,j)=gelc(k,j) &
3495                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3496                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3497                      *sss_ele_cut  &
3498                      *fac_shield(i)**2*fac_shield(j)**2  &
3499                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3500
3501             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3502             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3503           enddo
3504
3505           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3506               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3507               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3508 !
3509 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3510 !   energy of a peptide unit is assumed in the form of a second-order
3511 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3512 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3513 !   are computed for EVERY pair of non-contiguous peptide groups.
3514 !
3515           if (j.lt.nres-1) then
3516             j1=j+1
3517             j2=j-1
3518           else
3519             j1=j-1
3520             j2=j-2
3521           endif
3522           kkk=0
3523           do k=1,2
3524             do l=1,2
3525               kkk=kkk+1
3526               muij(kkk)=mu(k,i)*mu(l,j)
3527             enddo
3528           enddo
3529 !d         write (iout,*) 'EELEC: i',i,' j',j
3530 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3531 !d          write(iout,*) 'muij',muij
3532           ury=scalar(uy(1,i),erij)
3533           urz=scalar(uz(1,i),erij)
3534           vry=scalar(uy(1,j),erij)
3535           vrz=scalar(uz(1,j),erij)
3536           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3537           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3538           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3539           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3540           fac=dsqrt(-ael6i)*r3ij
3541           a22=a22*fac
3542           a23=a23*fac
3543           a32=a32*fac
3544           a33=a33*fac
3545 !d          write (iout,'(4i5,4f10.5)')
3546 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3547 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3548 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3549 !d     &      uy(:,j),uz(:,j)
3550 !d          write (iout,'(4f10.5)')
3551 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3552 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3553 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3554 !d           write (iout,'(9f10.5/)')
3555 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3556 ! Derivatives of the elements of A in virtual-bond vectors
3557           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3558           do k=1,3
3559             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3560             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3561             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3562             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3563             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3564             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3565             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3566             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3567             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3568             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3569             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3570             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3571           enddo
3572 ! Compute radial contributions to the gradient
3573           facr=-3.0d0*rrmij
3574           a22der=a22*facr
3575           a23der=a23*facr
3576           a32der=a32*facr
3577           a33der=a33*facr
3578           agg(1,1)=a22der*xj
3579           agg(2,1)=a22der*yj
3580           agg(3,1)=a22der*zj
3581           agg(1,2)=a23der*xj
3582           agg(2,2)=a23der*yj
3583           agg(3,2)=a23der*zj
3584           agg(1,3)=a32der*xj
3585           agg(2,3)=a32der*yj
3586           agg(3,3)=a32der*zj
3587           agg(1,4)=a33der*xj
3588           agg(2,4)=a33der*yj
3589           agg(3,4)=a33der*zj
3590 ! Add the contributions coming from er
3591           fac3=-3.0d0*fac
3592           do k=1,3
3593             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3594             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3595             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3596             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3597           enddo
3598           do k=1,3
3599 ! Derivatives in DC(i)
3600 !grad            ghalf1=0.5d0*agg(k,1)
3601 !grad            ghalf2=0.5d0*agg(k,2)
3602 !grad            ghalf3=0.5d0*agg(k,3)
3603 !grad            ghalf4=0.5d0*agg(k,4)
3604             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3605             -3.0d0*uryg(k,2)*vry)!+ghalf1
3606             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3607             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3608             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3609             -3.0d0*urzg(k,2)*vry)!+ghalf3
3610             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3611             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3612 ! Derivatives in DC(i+1)
3613             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3614             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3615             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3616             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3617             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3618             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3619             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3620             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3621 ! Derivatives in DC(j)
3622             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3623             -3.0d0*vryg(k,2)*ury)!+ghalf1
3624             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3625             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3626             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3627             -3.0d0*vryg(k,2)*urz)!+ghalf3
3628             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3629             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3630 ! Derivatives in DC(j+1) or DC(nres-1)
3631             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3632             -3.0d0*vryg(k,3)*ury)
3633             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3634             -3.0d0*vrzg(k,3)*ury)
3635             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3636             -3.0d0*vryg(k,3)*urz)
3637             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3638             -3.0d0*vrzg(k,3)*urz)
3639 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3640 !grad              do l=1,4
3641 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3642 !grad              enddo
3643 !grad            endif
3644           enddo
3645           acipa(1,1)=a22
3646           acipa(1,2)=a23
3647           acipa(2,1)=a32
3648           acipa(2,2)=a33
3649           a22=-a22
3650           a23=-a23
3651           do l=1,2
3652             do k=1,3
3653               agg(k,l)=-agg(k,l)
3654               aggi(k,l)=-aggi(k,l)
3655               aggi1(k,l)=-aggi1(k,l)
3656               aggj(k,l)=-aggj(k,l)
3657               aggj1(k,l)=-aggj1(k,l)
3658             enddo
3659           enddo
3660           if (j.lt.nres-1) then
3661             a22=-a22
3662             a32=-a32
3663             do l=1,3,2
3664               do k=1,3
3665                 agg(k,l)=-agg(k,l)
3666                 aggi(k,l)=-aggi(k,l)
3667                 aggi1(k,l)=-aggi1(k,l)
3668                 aggj(k,l)=-aggj(k,l)
3669                 aggj1(k,l)=-aggj1(k,l)
3670               enddo
3671             enddo
3672           else
3673             a22=-a22
3674             a23=-a23
3675             a32=-a32
3676             a33=-a33
3677             do l=1,4
3678               do k=1,3
3679                 agg(k,l)=-agg(k,l)
3680                 aggi(k,l)=-aggi(k,l)
3681                 aggi1(k,l)=-aggi1(k,l)
3682                 aggj(k,l)=-aggj(k,l)
3683                 aggj1(k,l)=-aggj1(k,l)
3684               enddo
3685             enddo
3686           endif
3687           ENDIF ! WCORR
3688           IF (wel_loc.gt.0.0d0) THEN
3689 ! Contribution to the local-electrostatic energy coming from the i-j pair
3690           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3691            +a33*muij(4)
3692           if (shield_mode.eq.0) then
3693            fac_shield(i)=1.0
3694            fac_shield(j)=1.0
3695           endif
3696           eel_loc_ij=eel_loc_ij &
3697          *fac_shield(i)*fac_shield(j) &
3698          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3699 !C Now derivative over eel_loc
3700           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3701          (shield_mode.gt.0)) then
3702 !C          print *,i,j
3703
3704           do ilist=1,ishield_list(i)
3705            iresshield=shield_list(ilist,i)
3706            do k=1,3
3707            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3708                                                 /fac_shield(i)&
3709            *sss_ele_cut
3710            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3711                    rlocshield  &
3712           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3713           *sss_ele_cut
3714
3715             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3716            +rlocshield
3717            enddo
3718           enddo
3719           do ilist=1,ishield_list(j)
3720            iresshield=shield_list(ilist,j)
3721            do k=1,3
3722            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3723                                             /fac_shield(j)   &
3724             *sss_ele_cut
3725            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3726                    rlocshield  &
3727       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3728        *sss_ele_cut
3729
3730            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3731                   +rlocshield
3732
3733            enddo
3734           enddo
3735
3736           do k=1,3
3737             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3738                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3739                     *sss_ele_cut
3740             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3741                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3742                     *sss_ele_cut
3743             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3744                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3745                     *sss_ele_cut
3746             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3747                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3748                     *sss_ele_cut
3749
3750            enddo
3751            endif
3752
3753
3754 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3755 !           eel_loc_ij=0.0
3756           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3757                   'eelloc',i,j,eel_loc_ij
3758 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3759 !          if (energy_dec) write (iout,*) "muij",muij
3760 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3761
3762           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3763 ! Partial derivatives in virtual-bond dihedral angles gamma
3764           if (i.gt.1) &
3765           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3766                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3767                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3768                  *sss_ele_cut  &
3769           *fac_shield(i)*fac_shield(j) &
3770           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3771
3772           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3773                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3774                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3775                  *sss_ele_cut &
3776           *fac_shield(i)*fac_shield(j) &
3777           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3778 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3779 !          do l=1,3
3780 !            ggg(1)=(agg(1,1)*muij(1)+ &
3781 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3782 !            *sss_ele_cut &
3783 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3784 !            ggg(2)=(agg(2,1)*muij(1)+ &
3785 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3786 !            *sss_ele_cut &
3787 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3788 !            ggg(3)=(agg(3,1)*muij(1)+ &
3789 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3790 !            *sss_ele_cut &
3791 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3792            xtemp(1)=xj
3793            xtemp(2)=yj
3794            xtemp(3)=zj
3795
3796            do l=1,3
3797             ggg(l)=(agg(l,1)*muij(1)+ &
3798                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3799             *sss_ele_cut &
3800           *fac_shield(i)*fac_shield(j) &
3801           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3802              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3803
3804
3805             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3806             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3807 !grad            ghalf=0.5d0*ggg(l)
3808 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3809 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3810           enddo
3811             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3812           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3813           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3814
3815             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3816           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3817           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3818
3819 !grad          do k=i+1,j2
3820 !grad            do l=1,3
3821 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3822 !grad            enddo
3823 !grad          enddo
3824 ! Remaining derivatives of eello
3825           do l=1,3
3826             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3827                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3828             *sss_ele_cut &
3829           *fac_shield(i)*fac_shield(j) &
3830           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3831
3832 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3833             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3834                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3835             +aggi1(l,4)*muij(4))&
3836             *sss_ele_cut &
3837           *fac_shield(i)*fac_shield(j) &
3838           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3839
3840 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3841             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3842                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3843             *sss_ele_cut &
3844           *fac_shield(i)*fac_shield(j) &
3845           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3846
3847 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3848             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3849                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3850             +aggj1(l,4)*muij(4))&
3851             *sss_ele_cut &
3852           *fac_shield(i)*fac_shield(j) &
3853           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3854
3855 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3856           enddo
3857           ENDIF
3858 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3859 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3860           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3861              .and. num_conti.le.maxconts) then
3862 !            write (iout,*) i,j," entered corr"
3863 !
3864 ! Calculate the contact function. The ith column of the array JCONT will
3865 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3866 ! greater than I). The arrays FACONT and GACONT will contain the values of
3867 ! the contact function and its derivative.
3868 !           r0ij=1.02D0*rpp(iteli,itelj)
3869 !           r0ij=1.11D0*rpp(iteli,itelj)
3870             r0ij=2.20D0*rpp(iteli,itelj)
3871 !           r0ij=1.55D0*rpp(iteli,itelj)
3872             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3873 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3874             if (fcont.gt.0.0D0) then
3875               num_conti=num_conti+1
3876               if (num_conti.gt.maxconts) then
3877 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3878 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3879                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3880                                ' will skip next contacts for this conf.', num_conti
3881               else
3882                 jcont_hb(num_conti,i)=j
3883 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3884 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3885                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3886                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3887 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3888 !  terms.
3889                 d_cont(num_conti,i)=rij
3890 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3891 !     --- Electrostatic-interaction matrix ---
3892                 a_chuj(1,1,num_conti,i)=a22
3893                 a_chuj(1,2,num_conti,i)=a23
3894                 a_chuj(2,1,num_conti,i)=a32
3895                 a_chuj(2,2,num_conti,i)=a33
3896 !     --- Gradient of rij
3897                 do kkk=1,3
3898                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3899                 enddo
3900                 kkll=0
3901                 do k=1,2
3902                   do l=1,2
3903                     kkll=kkll+1
3904                     do m=1,3
3905                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3906                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3907                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3908                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3909                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3910                     enddo
3911                   enddo
3912                 enddo
3913                 ENDIF
3914                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3915 ! Calculate contact energies
3916                 cosa4=4.0D0*cosa
3917                 wij=cosa-3.0D0*cosb*cosg
3918                 cosbg1=cosb+cosg
3919                 cosbg2=cosb-cosg
3920 !               fac3=dsqrt(-ael6i)/r0ij**3
3921                 fac3=dsqrt(-ael6i)*r3ij
3922 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3923                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3924                 if (ees0tmp.gt.0) then
3925                   ees0pij=dsqrt(ees0tmp)
3926                 else
3927                   ees0pij=0
3928                 endif
3929                 if (shield_mode.eq.0) then
3930                 fac_shield(i)=1.0d0
3931                 fac_shield(j)=1.0d0
3932                 else
3933                 ees0plist(num_conti,i)=j
3934                 endif
3935 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3936                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3937                 if (ees0tmp.gt.0) then
3938                   ees0mij=dsqrt(ees0tmp)
3939                 else
3940                   ees0mij=0
3941                 endif
3942 !               ees0mij=0.0D0
3943                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
3944                      *sss_ele_cut &
3945                      *fac_shield(i)*fac_shield(j)
3946
3947                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
3948                      *sss_ele_cut &
3949                      *fac_shield(i)*fac_shield(j)
3950
3951 ! Diagnostics. Comment out or remove after debugging!
3952 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3953 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3954 !               ees0m(num_conti,i)=0.0D0
3955 ! End diagnostics.
3956 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3957 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3958 ! Angular derivatives of the contact function
3959                 ees0pij1=fac3/ees0pij
3960                 ees0mij1=fac3/ees0mij
3961                 fac3p=-3.0D0*fac3*rrmij
3962                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3963                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3964 !               ees0mij1=0.0D0
3965                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3966                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3967                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3968                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3969                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3970                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3971                 ecosap=ecosa1+ecosa2
3972                 ecosbp=ecosb1+ecosb2
3973                 ecosgp=ecosg1+ecosg2
3974                 ecosam=ecosa1-ecosa2
3975                 ecosbm=ecosb1-ecosb2
3976                 ecosgm=ecosg1-ecosg2
3977 ! Diagnostics
3978 !               ecosap=ecosa1
3979 !               ecosbp=ecosb1
3980 !               ecosgp=ecosg1
3981 !               ecosam=0.0D0
3982 !               ecosbm=0.0D0
3983 !               ecosgm=0.0D0
3984 ! End diagnostics
3985                 facont_hb(num_conti,i)=fcont
3986                 fprimcont=fprimcont/rij
3987 !d              facont_hb(num_conti,i)=1.0D0
3988 ! Following line is for diagnostics.
3989 !d              fprimcont=0.0D0
3990                 do k=1,3
3991                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3992                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3993                 enddo
3994                 do k=1,3
3995                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3996                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3997                 enddo
3998                 gggp(1)=gggp(1)+ees0pijp*xj &
3999                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4000                 gggp(2)=gggp(2)+ees0pijp*yj &
4001                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4002                 gggp(3)=gggp(3)+ees0pijp*zj &
4003                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4004
4005                 gggm(1)=gggm(1)+ees0mijp*xj &
4006                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4007
4008                 gggm(2)=gggm(2)+ees0mijp*yj &
4009                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4010
4011                 gggm(3)=gggm(3)+ees0mijp*zj &
4012                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4013
4014 ! Derivatives due to the contact function
4015                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4016                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4017                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4018                 do k=1,3
4019 !
4020 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4021 !          following the change of gradient-summation algorithm.
4022 !
4023 !grad                  ghalfp=0.5D0*gggp(k)
4024 !grad                  ghalfm=0.5D0*gggm(k)
4025                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4026                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4027                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4028                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4029
4030                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4031                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4032                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4033                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4034
4035                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4036                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4037
4038                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4039                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4040                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4041                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4042
4043                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4044                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4045                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4046                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4047
4048                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4049                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4050
4051                 enddo
4052 ! Diagnostics. Comment out or remove after debugging!
4053 !diag           do k=1,3
4054 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4055 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4056 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4057 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4058 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4059 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4060 !diag           enddo
4061               ENDIF ! wcorr
4062               endif  ! num_conti.le.maxconts
4063             endif  ! fcont.gt.0
4064           endif    ! j.gt.i+1
4065           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4066             do k=1,4
4067               do l=1,3
4068                 ghalf=0.5d0*agg(l,k)
4069                 aggi(l,k)=aggi(l,k)+ghalf
4070                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4071                 aggj(l,k)=aggj(l,k)+ghalf
4072               enddo
4073             enddo
4074             if (j.eq.nres-1 .and. i.lt.j-2) then
4075               do k=1,4
4076                 do l=1,3
4077                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4078                 enddo
4079               enddo
4080             endif
4081           endif
4082  128  continue
4083 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4084       return
4085       end subroutine eelecij
4086 !-----------------------------------------------------------------------------
4087       subroutine eturn3(i,eello_turn3)
4088 ! Third- and fourth-order contributions from turns
4089
4090       use comm_locel
4091 !      implicit real*8 (a-h,o-z)
4092 !      include 'DIMENSIONS'
4093 !      include 'COMMON.IOUNITS'
4094 !      include 'COMMON.GEO'
4095 !      include 'COMMON.VAR'
4096 !      include 'COMMON.LOCAL'
4097 !      include 'COMMON.CHAIN'
4098 !      include 'COMMON.DERIV'
4099 !      include 'COMMON.INTERACT'
4100 !      include 'COMMON.CONTACTS'
4101 !      include 'COMMON.TORSION'
4102 !      include 'COMMON.VECTORS'
4103 !      include 'COMMON.FFIELD'
4104 !      include 'COMMON.CONTROL'
4105       real(kind=8),dimension(3) :: ggg
4106       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4107         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4108       real(kind=8),dimension(2) :: auxvec,auxvec1
4109 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4110       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4111 !el      integer :: num_conti,j1,j2
4112 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4113 !el        dz_normi,xmedi,ymedi,zmedi
4114
4115 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4116 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4117 !el         num_conti,j1,j2
4118 !el local variables
4119       integer :: i,j,l,k,ilist,iresshield
4120       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4121
4122       j=i+2
4123 !      write (iout,*) "eturn3",i,j,j1,j2
4124           zj=(c(3,j)+c(3,j+1))/2.0d0
4125           zj=mod(zj,boxzsize)
4126           if (zj.lt.0) zj=zj+boxzsize
4127           if ((zj.lt.0)) write (*,*) "CHUJ"
4128        if ((zj.gt.bordlipbot)  &
4129         .and.(zj.lt.bordliptop)) then
4130 !C the energy transfer exist
4131         if (zj.lt.buflipbot) then
4132 !C what fraction I am in
4133          fracinbuf=1.0d0-     &
4134              ((zj-bordlipbot)/lipbufthick)
4135 !C lipbufthick is thickenes of lipid buffore
4136          sslipj=sscalelip(fracinbuf)
4137          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4138         elseif (zj.gt.bufliptop) then
4139          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4140          sslipj=sscalelip(fracinbuf)
4141          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4142         else
4143          sslipj=1.0d0
4144          ssgradlipj=0.0
4145         endif
4146        else
4147          sslipj=0.0d0
4148          ssgradlipj=0.0
4149        endif
4150
4151       a_temp(1,1)=a22
4152       a_temp(1,2)=a23
4153       a_temp(2,1)=a32
4154       a_temp(2,2)=a33
4155 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4156 !
4157 !               Third-order contributions
4158 !
4159 !                 (i+2)o----(i+3)
4160 !                      | |
4161 !                      | |
4162 !                 (i+1)o----i
4163 !
4164 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4165 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4166         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4167         call transpose2(auxmat(1,1),auxmat1(1,1))
4168         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4169         if (shield_mode.eq.0) then
4170         fac_shield(i)=1.0d0
4171         fac_shield(j)=1.0d0
4172         endif
4173
4174         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4175          *fac_shield(i)*fac_shield(j)  &
4176          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4177         eello_t3= &
4178         0.5d0*(pizda(1,1)+pizda(2,2)) &
4179         *fac_shield(i)*fac_shield(j)
4180
4181         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4182                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4183           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4184        (shield_mode.gt.0)) then
4185 !C          print *,i,j
4186
4187           do ilist=1,ishield_list(i)
4188            iresshield=shield_list(ilist,i)
4189            do k=1,3
4190            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4191            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4192                    rlocshield &
4193            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4194             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4195              +rlocshield
4196            enddo
4197           enddo
4198           do ilist=1,ishield_list(j)
4199            iresshield=shield_list(ilist,j)
4200            do k=1,3
4201            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4202            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4203                    rlocshield &
4204            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4205            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4206                   +rlocshield
4207
4208            enddo
4209           enddo
4210
4211           do k=1,3
4212             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4213                    grad_shield(k,i)*eello_t3/fac_shield(i)
4214             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4215                    grad_shield(k,j)*eello_t3/fac_shield(j)
4216             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4217                    grad_shield(k,i)*eello_t3/fac_shield(i)
4218             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4219                    grad_shield(k,j)*eello_t3/fac_shield(j)
4220            enddo
4221            endif
4222
4223 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4224 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4225 !d     &    ' eello_turn3_num',4*eello_turn3_num
4226 ! Derivatives in gamma(i)
4227         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4228         call transpose2(auxmat2(1,1),auxmat3(1,1))
4229         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4230         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4231           *fac_shield(i)*fac_shield(j)        &
4232           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4233 ! Derivatives in gamma(i+1)
4234         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4235         call transpose2(auxmat2(1,1),auxmat3(1,1))
4236         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4237         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4238           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4239           *fac_shield(i)*fac_shield(j)        &
4240           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4241
4242 ! Cartesian derivatives
4243         do l=1,3
4244 !            ghalf1=0.5d0*agg(l,1)
4245 !            ghalf2=0.5d0*agg(l,2)
4246 !            ghalf3=0.5d0*agg(l,3)
4247 !            ghalf4=0.5d0*agg(l,4)
4248           a_temp(1,1)=aggi(l,1)!+ghalf1
4249           a_temp(1,2)=aggi(l,2)!+ghalf2
4250           a_temp(2,1)=aggi(l,3)!+ghalf3
4251           a_temp(2,2)=aggi(l,4)!+ghalf4
4252           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4253           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4254             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4255           *fac_shield(i)*fac_shield(j)      &
4256           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4257
4258           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4259           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4260           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4261           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4262           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4263           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4264             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4265           *fac_shield(i)*fac_shield(j)        &
4266           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4267
4268           a_temp(1,1)=aggj(l,1)!+ghalf1
4269           a_temp(1,2)=aggj(l,2)!+ghalf2
4270           a_temp(2,1)=aggj(l,3)!+ghalf3
4271           a_temp(2,2)=aggj(l,4)!+ghalf4
4272           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4273           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4274             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4275           *fac_shield(i)*fac_shield(j)      &
4276           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4277
4278           a_temp(1,1)=aggj1(l,1)
4279           a_temp(1,2)=aggj1(l,2)
4280           a_temp(2,1)=aggj1(l,3)
4281           a_temp(2,2)=aggj1(l,4)
4282           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4283           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4284             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4285           *fac_shield(i)*fac_shield(j)        &
4286           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4287         enddo
4288          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4289           ssgradlipi*eello_t3/4.0d0*lipscale
4290          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4291           ssgradlipj*eello_t3/4.0d0*lipscale
4292          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4293           ssgradlipi*eello_t3/4.0d0*lipscale
4294          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4295           ssgradlipj*eello_t3/4.0d0*lipscale
4296
4297       return
4298       end subroutine eturn3
4299 !-----------------------------------------------------------------------------
4300       subroutine eturn4(i,eello_turn4)
4301 ! Third- and fourth-order contributions from turns
4302
4303       use comm_locel
4304 !      implicit real*8 (a-h,o-z)
4305 !      include 'DIMENSIONS'
4306 !      include 'COMMON.IOUNITS'
4307 !      include 'COMMON.GEO'
4308 !      include 'COMMON.VAR'
4309 !      include 'COMMON.LOCAL'
4310 !      include 'COMMON.CHAIN'
4311 !      include 'COMMON.DERIV'
4312 !      include 'COMMON.INTERACT'
4313 !      include 'COMMON.CONTACTS'
4314 !      include 'COMMON.TORSION'
4315 !      include 'COMMON.VECTORS'
4316 !      include 'COMMON.FFIELD'
4317 !      include 'COMMON.CONTROL'
4318       real(kind=8),dimension(3) :: ggg
4319       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4320         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4321       real(kind=8),dimension(2) :: auxvec,auxvec1
4322 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4323       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4324 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4325 !el        dz_normi,xmedi,ymedi,zmedi
4326 !el      integer :: num_conti,j1,j2
4327 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4328 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4329 !el          num_conti,j1,j2
4330 !el local variables
4331       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4332       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4333          rlocshield
4334
4335       j=i+3
4336 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4337 !
4338 !               Fourth-order contributions
4339 !
4340 !                 (i+3)o----(i+4)
4341 !                     /  |
4342 !               (i+2)o   |
4343 !                     \  |
4344 !                 (i+1)o----i
4345 !
4346 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4347 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4348 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4349           zj=(c(3,j)+c(3,j+1))/2.0d0
4350           zj=mod(zj,boxzsize)
4351           if (zj.lt.0) zj=zj+boxzsize
4352        if ((zj.gt.bordlipbot)  &
4353         .and.(zj.lt.bordliptop)) then
4354 !C the energy transfer exist
4355         if (zj.lt.buflipbot) then
4356 !C what fraction I am in
4357          fracinbuf=1.0d0-     &
4358              ((zj-bordlipbot)/lipbufthick)
4359 !C lipbufthick is thickenes of lipid buffore
4360          sslipj=sscalelip(fracinbuf)
4361          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4362         elseif (zj.gt.bufliptop) then
4363          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4364          sslipj=sscalelip(fracinbuf)
4365          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4366         else
4367          sslipj=1.0d0
4368          ssgradlipj=0.0
4369         endif
4370        else
4371          sslipj=0.0d0
4372          ssgradlipj=0.0
4373        endif
4374
4375         a_temp(1,1)=a22
4376         a_temp(1,2)=a23
4377         a_temp(2,1)=a32
4378         a_temp(2,2)=a33
4379         iti1=itortyp(itype(i+1,1))
4380         iti2=itortyp(itype(i+2,1))
4381         iti3=itortyp(itype(i+3,1))
4382 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4383         call transpose2(EUg(1,1,i+1),e1t(1,1))
4384         call transpose2(Eug(1,1,i+2),e2t(1,1))
4385         call transpose2(Eug(1,1,i+3),e3t(1,1))
4386         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4387         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4388         s1=scalar2(b1(1,iti2),auxvec(1))
4389         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4390         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4391         s2=scalar2(b1(1,iti1),auxvec(1))
4392         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4393         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4394         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4395         if (shield_mode.eq.0) then
4396         fac_shield(i)=1.0
4397         fac_shield(j)=1.0
4398         endif
4399
4400         eello_turn4=eello_turn4-(s1+s2+s3) &
4401         *fac_shield(i)*fac_shield(j)       &
4402         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4403         eello_t4=-(s1+s2+s3)  &
4404           *fac_shield(i)*fac_shield(j)
4405 !C Now derivative over shield:
4406           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4407          (shield_mode.gt.0)) then
4408 !C          print *,i,j
4409
4410           do ilist=1,ishield_list(i)
4411            iresshield=shield_list(ilist,i)
4412            do k=1,3
4413            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4414            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4415                    rlocshield &
4416             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4417             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4418            +rlocshield
4419            enddo
4420           enddo
4421           do ilist=1,ishield_list(j)
4422            iresshield=shield_list(ilist,j)
4423            do k=1,3
4424            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4425            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4426                    rlocshield  &
4427            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4428            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4429                   +rlocshield
4430
4431            enddo
4432           enddo
4433
4434           do k=1,3
4435             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4436                    grad_shield(k,i)*eello_t4/fac_shield(i)
4437             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4438                    grad_shield(k,j)*eello_t4/fac_shield(j)
4439             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4440                    grad_shield(k,i)*eello_t4/fac_shield(i)
4441             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4442                    grad_shield(k,j)*eello_t4/fac_shield(j)
4443            enddo
4444            endif
4445
4446         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4447            'eturn4',i,j,-(s1+s2+s3)
4448 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4449 !d     &    ' eello_turn4_num',8*eello_turn4_num
4450 ! Derivatives in gamma(i)
4451         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4452         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4453         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4454         s1=scalar2(b1(1,iti2),auxvec(1))
4455         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4456         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4457         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4458        *fac_shield(i)*fac_shield(j)  &
4459        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4460
4461 ! Derivatives in gamma(i+1)
4462         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4463         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4464         s2=scalar2(b1(1,iti1),auxvec(1))
4465         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4466         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4467         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4468         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4469        *fac_shield(i)*fac_shield(j)  &
4470        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4471
4472 ! Derivatives in gamma(i+2)
4473         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4474         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4475         s1=scalar2(b1(1,iti2),auxvec(1))
4476         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4477         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4478         s2=scalar2(b1(1,iti1),auxvec(1))
4479         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4480         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4481         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4482         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4483        *fac_shield(i)*fac_shield(j)  &
4484        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4485
4486 ! Cartesian derivatives
4487 ! Derivatives of this turn contributions in DC(i+2)
4488         if (j.lt.nres-1) then
4489           do l=1,3
4490             a_temp(1,1)=agg(l,1)
4491             a_temp(1,2)=agg(l,2)
4492             a_temp(2,1)=agg(l,3)
4493             a_temp(2,2)=agg(l,4)
4494             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4495             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4496             s1=scalar2(b1(1,iti2),auxvec(1))
4497             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4498             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4499             s2=scalar2(b1(1,iti1),auxvec(1))
4500             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4501             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4502             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4503             ggg(l)=-(s1+s2+s3)
4504             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4505        *fac_shield(i)*fac_shield(j)  &
4506        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4507
4508           enddo
4509         endif
4510 ! Remaining derivatives of this turn contribution
4511         do l=1,3
4512           a_temp(1,1)=aggi(l,1)
4513           a_temp(1,2)=aggi(l,2)
4514           a_temp(2,1)=aggi(l,3)
4515           a_temp(2,2)=aggi(l,4)
4516           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4517           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4518           s1=scalar2(b1(1,iti2),auxvec(1))
4519           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4520           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4521           s2=scalar2(b1(1,iti1),auxvec(1))
4522           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4523           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4524           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4525           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4526          *fac_shield(i)*fac_shield(j)  &
4527          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4528
4529
4530           a_temp(1,1)=aggi1(l,1)
4531           a_temp(1,2)=aggi1(l,2)
4532           a_temp(2,1)=aggi1(l,3)
4533           a_temp(2,2)=aggi1(l,4)
4534           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4535           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4536           s1=scalar2(b1(1,iti2),auxvec(1))
4537           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4538           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4539           s2=scalar2(b1(1,iti1),auxvec(1))
4540           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4541           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4542           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4543           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4544          *fac_shield(i)*fac_shield(j)  &
4545          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4546
4547
4548           a_temp(1,1)=aggj(l,1)
4549           a_temp(1,2)=aggj(l,2)
4550           a_temp(2,1)=aggj(l,3)
4551           a_temp(2,2)=aggj(l,4)
4552           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4553           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4554           s1=scalar2(b1(1,iti2),auxvec(1))
4555           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4556           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4557           s2=scalar2(b1(1,iti1),auxvec(1))
4558           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4559           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4560           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4561           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4562          *fac_shield(i)*fac_shield(j)  &
4563          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4564
4565
4566           a_temp(1,1)=aggj1(l,1)
4567           a_temp(1,2)=aggj1(l,2)
4568           a_temp(2,1)=aggj1(l,3)
4569           a_temp(2,2)=aggj1(l,4)
4570           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4571           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4572           s1=scalar2(b1(1,iti2),auxvec(1))
4573           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4574           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4575           s2=scalar2(b1(1,iti1),auxvec(1))
4576           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4577           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4578           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4579 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4580           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4581          *fac_shield(i)*fac_shield(j)  &
4582          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4583
4584         enddo
4585          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4586           ssgradlipi*eello_t4/4.0d0*lipscale
4587          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4588           ssgradlipj*eello_t4/4.0d0*lipscale
4589          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4590           ssgradlipi*eello_t4/4.0d0*lipscale
4591          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4592           ssgradlipj*eello_t4/4.0d0*lipscale
4593
4594       return
4595       end subroutine eturn4
4596 !-----------------------------------------------------------------------------
4597       subroutine unormderiv(u,ugrad,unorm,ungrad)
4598 ! This subroutine computes the derivatives of a normalized vector u, given
4599 ! the derivatives computed without normalization conditions, ugrad. Returns
4600 ! ungrad.
4601 !      implicit none
4602       real(kind=8),dimension(3) :: u,vec
4603       real(kind=8),dimension(3,3) ::ugrad,ungrad
4604       real(kind=8) :: unorm     !,scalar
4605       integer :: i,j
4606 !      write (2,*) 'ugrad',ugrad
4607 !      write (2,*) 'u',u
4608       do i=1,3
4609         vec(i)=scalar(ugrad(1,i),u(1))
4610       enddo
4611 !      write (2,*) 'vec',vec
4612       do i=1,3
4613         do j=1,3
4614           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4615         enddo
4616       enddo
4617 !      write (2,*) 'ungrad',ungrad
4618       return
4619       end subroutine unormderiv
4620 !-----------------------------------------------------------------------------
4621       subroutine escp_soft_sphere(evdw2,evdw2_14)
4622 !
4623 ! This subroutine calculates the excluded-volume interaction energy between
4624 ! peptide-group centers and side chains and its gradient in virtual-bond and
4625 ! side-chain vectors.
4626 !
4627 !      implicit real*8 (a-h,o-z)
4628 !      include 'DIMENSIONS'
4629 !      include 'COMMON.GEO'
4630 !      include 'COMMON.VAR'
4631 !      include 'COMMON.LOCAL'
4632 !      include 'COMMON.CHAIN'
4633 !      include 'COMMON.DERIV'
4634 !      include 'COMMON.INTERACT'
4635 !      include 'COMMON.FFIELD'
4636 !      include 'COMMON.IOUNITS'
4637 !      include 'COMMON.CONTROL'
4638       real(kind=8),dimension(3) :: ggg
4639 !el local variables
4640       integer :: i,iint,j,k,iteli,itypj
4641       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4642                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4643
4644       evdw2=0.0D0
4645       evdw2_14=0.0d0
4646       r0_scp=4.5d0
4647 !d    print '(a)','Enter ESCP'
4648 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4649       do i=iatscp_s,iatscp_e
4650         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4651         iteli=itel(i)
4652         xi=0.5D0*(c(1,i)+c(1,i+1))
4653         yi=0.5D0*(c(2,i)+c(2,i+1))
4654         zi=0.5D0*(c(3,i)+c(3,i+1))
4655
4656         do iint=1,nscp_gr(i)
4657
4658         do j=iscpstart(i,iint),iscpend(i,iint)
4659           if (itype(j,1).eq.ntyp1) cycle
4660           itypj=iabs(itype(j,1))
4661 ! Uncomment following three lines for SC-p interactions
4662 !         xj=c(1,nres+j)-xi
4663 !         yj=c(2,nres+j)-yi
4664 !         zj=c(3,nres+j)-zi
4665 ! Uncomment following three lines for Ca-p interactions
4666           xj=c(1,j)-xi
4667           yj=c(2,j)-yi
4668           zj=c(3,j)-zi
4669           rij=xj*xj+yj*yj+zj*zj
4670           r0ij=r0_scp
4671           r0ijsq=r0ij*r0ij
4672           if (rij.lt.r0ijsq) then
4673             evdwij=0.25d0*(rij-r0ijsq)**2
4674             fac=rij-r0ijsq
4675           else
4676             evdwij=0.0d0
4677             fac=0.0d0
4678           endif
4679           evdw2=evdw2+evdwij
4680 !
4681 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4682 !
4683           ggg(1)=xj*fac
4684           ggg(2)=yj*fac
4685           ggg(3)=zj*fac
4686 !grad          if (j.lt.i) then
4687 !d          write (iout,*) 'j<i'
4688 ! Uncomment following three lines for SC-p interactions
4689 !           do k=1,3
4690 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4691 !           enddo
4692 !grad          else
4693 !d          write (iout,*) 'j>i'
4694 !grad            do k=1,3
4695 !grad              ggg(k)=-ggg(k)
4696 ! Uncomment following line for SC-p interactions
4697 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4698 !grad            enddo
4699 !grad          endif
4700 !grad          do k=1,3
4701 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4702 !grad          enddo
4703 !grad          kstart=min0(i+1,j)
4704 !grad          kend=max0(i-1,j-1)
4705 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4706 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4707 !grad          do k=kstart,kend
4708 !grad            do l=1,3
4709 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4710 !grad            enddo
4711 !grad          enddo
4712           do k=1,3
4713             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4714             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4715           enddo
4716         enddo
4717
4718         enddo ! iint
4719       enddo ! i
4720       return
4721       end subroutine escp_soft_sphere
4722 !-----------------------------------------------------------------------------
4723       subroutine escp(evdw2,evdw2_14)
4724 !
4725 ! This subroutine calculates the excluded-volume interaction energy between
4726 ! peptide-group centers and side chains and its gradient in virtual-bond and
4727 ! side-chain vectors.
4728 !
4729 !      implicit real*8 (a-h,o-z)
4730 !      include 'DIMENSIONS'
4731 !      include 'COMMON.GEO'
4732 !      include 'COMMON.VAR'
4733 !      include 'COMMON.LOCAL'
4734 !      include 'COMMON.CHAIN'
4735 !      include 'COMMON.DERIV'
4736 !      include 'COMMON.INTERACT'
4737 !      include 'COMMON.FFIELD'
4738 !      include 'COMMON.IOUNITS'
4739 !      include 'COMMON.CONTROL'
4740       real(kind=8),dimension(3) :: ggg
4741 !el local variables
4742       integer :: i,iint,j,k,iteli,itypj,subchap
4743       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4744                    e1,e2,evdwij,rij
4745       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4746                     dist_temp, dist_init
4747       integer xshift,yshift,zshift
4748
4749       evdw2=0.0D0
4750       evdw2_14=0.0d0
4751 !d    print '(a)','Enter ESCP'
4752 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4753       do i=iatscp_s,iatscp_e
4754         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4755         iteli=itel(i)
4756         xi=0.5D0*(c(1,i)+c(1,i+1))
4757         yi=0.5D0*(c(2,i)+c(2,i+1))
4758         zi=0.5D0*(c(3,i)+c(3,i+1))
4759           xi=mod(xi,boxxsize)
4760           if (xi.lt.0) xi=xi+boxxsize
4761           yi=mod(yi,boxysize)
4762           if (yi.lt.0) yi=yi+boxysize
4763           zi=mod(zi,boxzsize)
4764           if (zi.lt.0) zi=zi+boxzsize
4765
4766         do iint=1,nscp_gr(i)
4767
4768         do j=iscpstart(i,iint),iscpend(i,iint)
4769           itypj=iabs(itype(j,1))
4770           if (itypj.eq.ntyp1) cycle
4771 ! Uncomment following three lines for SC-p interactions
4772 !         xj=c(1,nres+j)-xi
4773 !         yj=c(2,nres+j)-yi
4774 !         zj=c(3,nres+j)-zi
4775 ! Uncomment following three lines for Ca-p interactions
4776 !          xj=c(1,j)-xi
4777 !          yj=c(2,j)-yi
4778 !          zj=c(3,j)-zi
4779           xj=c(1,j)
4780           yj=c(2,j)
4781           zj=c(3,j)
4782           xj=mod(xj,boxxsize)
4783           if (xj.lt.0) xj=xj+boxxsize
4784           yj=mod(yj,boxysize)
4785           if (yj.lt.0) yj=yj+boxysize
4786           zj=mod(zj,boxzsize)
4787           if (zj.lt.0) zj=zj+boxzsize
4788       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4789       xj_safe=xj
4790       yj_safe=yj
4791       zj_safe=zj
4792       subchap=0
4793       do xshift=-1,1
4794       do yshift=-1,1
4795       do zshift=-1,1
4796           xj=xj_safe+xshift*boxxsize
4797           yj=yj_safe+yshift*boxysize
4798           zj=zj_safe+zshift*boxzsize
4799           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4800           if(dist_temp.lt.dist_init) then
4801             dist_init=dist_temp
4802             xj_temp=xj
4803             yj_temp=yj
4804             zj_temp=zj
4805             subchap=1
4806           endif
4807        enddo
4808        enddo
4809        enddo
4810        if (subchap.eq.1) then
4811           xj=xj_temp-xi
4812           yj=yj_temp-yi
4813           zj=zj_temp-zi
4814        else
4815           xj=xj_safe-xi
4816           yj=yj_safe-yi
4817           zj=zj_safe-zi
4818        endif
4819
4820           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4821           rij=dsqrt(1.0d0/rrij)
4822             sss_ele_cut=sscale_ele(rij)
4823             sss_ele_grad=sscagrad_ele(rij)
4824 !            print *,sss_ele_cut,sss_ele_grad,&
4825 !            (rij),r_cut_ele,rlamb_ele
4826             if (sss_ele_cut.le.0.0) cycle
4827           fac=rrij**expon2
4828           e1=fac*fac*aad(itypj,iteli)
4829           e2=fac*bad(itypj,iteli)
4830           if (iabs(j-i) .le. 2) then
4831             e1=scal14*e1
4832             e2=scal14*e2
4833             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4834           endif
4835           evdwij=e1+e2
4836           evdw2=evdw2+evdwij*sss_ele_cut
4837 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4838 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4839           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4840              'evdw2',i,j,evdwij
4841 !
4842 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4843 !
4844           fac=-(evdwij+e1)*rrij*sss_ele_cut
4845           fac=fac+evdwij*sss_ele_grad/rij/expon
4846           ggg(1)=xj*fac
4847           ggg(2)=yj*fac
4848           ggg(3)=zj*fac
4849 !grad          if (j.lt.i) then
4850 !d          write (iout,*) 'j<i'
4851 ! Uncomment following three lines for SC-p interactions
4852 !           do k=1,3
4853 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4854 !           enddo
4855 !grad          else
4856 !d          write (iout,*) 'j>i'
4857 !grad            do k=1,3
4858 !grad              ggg(k)=-ggg(k)
4859 ! Uncomment following line for SC-p interactions
4860 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4861 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4862 !grad            enddo
4863 !grad          endif
4864 !grad          do k=1,3
4865 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4866 !grad          enddo
4867 !grad          kstart=min0(i+1,j)
4868 !grad          kend=max0(i-1,j-1)
4869 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4870 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4871 !grad          do k=kstart,kend
4872 !grad            do l=1,3
4873 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4874 !grad            enddo
4875 !grad          enddo
4876           do k=1,3
4877             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4878             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4879           enddo
4880         enddo
4881
4882         enddo ! iint
4883       enddo ! i
4884       do i=1,nct
4885         do j=1,3
4886           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4887           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4888           gradx_scp(j,i)=expon*gradx_scp(j,i)
4889         enddo
4890       enddo
4891 !******************************************************************************
4892 !
4893 !                              N O T E !!!
4894 !
4895 ! To save time the factor EXPON has been extracted from ALL components
4896 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4897 ! use!
4898 !
4899 !******************************************************************************
4900       return
4901       end subroutine escp
4902 !-----------------------------------------------------------------------------
4903       subroutine edis(ehpb)
4904 !
4905 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4906 !
4907 !      implicit real*8 (a-h,o-z)
4908 !      include 'DIMENSIONS'
4909 !      include 'COMMON.SBRIDGE'
4910 !      include 'COMMON.CHAIN'
4911 !      include 'COMMON.DERIV'
4912 !      include 'COMMON.VAR'
4913 !      include 'COMMON.INTERACT'
4914 !      include 'COMMON.IOUNITS'
4915       real(kind=8),dimension(3) :: ggg
4916 !el local variables
4917       integer :: i,j,ii,jj,iii,jjj,k
4918       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4919
4920       ehpb=0.0D0
4921 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4922 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4923       if (link_end.eq.0) return
4924       do i=link_start,link_end
4925 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4926 ! CA-CA distance used in regularization of structure.
4927         ii=ihpb(i)
4928         jj=jhpb(i)
4929 ! iii and jjj point to the residues for which the distance is assigned.
4930         if (ii.gt.nres) then
4931           iii=ii-nres
4932           jjj=jj-nres
4933         else
4934           iii=ii
4935           jjj=jj
4936         endif
4937 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4938 !     &    dhpb(i),dhpb1(i),forcon(i)
4939 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4940 !    distance and angle dependent SS bond potential.
4941 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4942 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4943         if (.not.dyn_ss .and. i.le.nss) then
4944 ! 15/02/13 CC dynamic SSbond - additional check
4945          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
4946         iabs(itype(jjj,1)).eq.1) then
4947           call ssbond_ene(iii,jjj,eij)
4948           ehpb=ehpb+2*eij
4949 !d          write (iout,*) "eij",eij
4950          endif
4951         else if (ii.gt.nres .and. jj.gt.nres) then
4952 !c Restraints from contact prediction
4953           dd=dist(ii,jj)
4954           if (constr_dist.eq.11) then
4955             ehpb=ehpb+fordepth(i)**4.0d0 &
4956                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4957             fac=fordepth(i)**4.0d0 &
4958                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4959           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
4960             ehpb,fordepth(i),dd
4961            else
4962           if (dhpb1(i).gt.0.0d0) then
4963             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4964             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4965 !c            write (iout,*) "beta nmr",
4966 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4967           else
4968             dd=dist(ii,jj)
4969             rdis=dd-dhpb(i)
4970 !C Get the force constant corresponding to this distance.
4971             waga=forcon(i)
4972 !C Calculate the contribution to energy.
4973             ehpb=ehpb+waga*rdis*rdis
4974 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4975 !C
4976 !C Evaluate gradient.
4977 !C
4978             fac=waga*rdis/dd
4979           endif
4980           endif
4981           do j=1,3
4982             ggg(j)=fac*(c(j,jj)-c(j,ii))
4983           enddo
4984           do j=1,3
4985             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4986             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4987           enddo
4988           do k=1,3
4989             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4990             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4991           enddo
4992         else
4993           dd=dist(ii,jj)
4994           if (constr_dist.eq.11) then
4995             ehpb=ehpb+fordepth(i)**4.0d0 &
4996                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4997             fac=fordepth(i)**4.0d0 &
4998                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4999           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5000          ehpb,fordepth(i),dd
5001            else
5002           if (dhpb1(i).gt.0.0d0) then
5003             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5004             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5005 !c            write (iout,*) "alph nmr",
5006 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5007           else
5008             rdis=dd-dhpb(i)
5009 !C Get the force constant corresponding to this distance.
5010             waga=forcon(i)
5011 !C Calculate the contribution to energy.
5012             ehpb=ehpb+waga*rdis*rdis
5013 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5014 !C
5015 !C Evaluate gradient.
5016 !C
5017             fac=waga*rdis/dd
5018           endif
5019           endif
5020
5021             do j=1,3
5022               ggg(j)=fac*(c(j,jj)-c(j,ii))
5023             enddo
5024 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5025 !C If this is a SC-SC distance, we need to calculate the contributions to the
5026 !C Cartesian gradient in the SC vectors (ghpbx).
5027           if (iii.lt.ii) then
5028           do j=1,3
5029             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5030             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5031           enddo
5032           endif
5033 !cgrad        do j=iii,jjj-1
5034 !cgrad          do k=1,3
5035 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5036 !cgrad          enddo
5037 !cgrad        enddo
5038           do k=1,3
5039             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5040             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5041           enddo
5042         endif
5043       enddo
5044       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5045
5046       return
5047       end subroutine edis
5048 !-----------------------------------------------------------------------------
5049       subroutine ssbond_ene(i,j,eij)
5050 !
5051 ! Calculate the distance and angle dependent SS-bond potential energy
5052 ! using a free-energy function derived based on RHF/6-31G** ab initio
5053 ! calculations of diethyl disulfide.
5054 !
5055 ! A. Liwo and U. Kozlowska, 11/24/03
5056 !
5057 !      implicit real*8 (a-h,o-z)
5058 !      include 'DIMENSIONS'
5059 !      include 'COMMON.SBRIDGE'
5060 !      include 'COMMON.CHAIN'
5061 !      include 'COMMON.DERIV'
5062 !      include 'COMMON.LOCAL'
5063 !      include 'COMMON.INTERACT'
5064 !      include 'COMMON.VAR'
5065 !      include 'COMMON.IOUNITS'
5066       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5067 !el local variables
5068       integer :: i,j,itypi,itypj,k
5069       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5070                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5071                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5072                    cosphi,ggk
5073
5074       itypi=iabs(itype(i,1))
5075       xi=c(1,nres+i)
5076       yi=c(2,nres+i)
5077       zi=c(3,nres+i)
5078       dxi=dc_norm(1,nres+i)
5079       dyi=dc_norm(2,nres+i)
5080       dzi=dc_norm(3,nres+i)
5081 !      dsci_inv=dsc_inv(itypi)
5082       dsci_inv=vbld_inv(nres+i)
5083       itypj=iabs(itype(j,1))
5084 !      dscj_inv=dsc_inv(itypj)
5085       dscj_inv=vbld_inv(nres+j)
5086       xj=c(1,nres+j)-xi
5087       yj=c(2,nres+j)-yi
5088       zj=c(3,nres+j)-zi
5089       dxj=dc_norm(1,nres+j)
5090       dyj=dc_norm(2,nres+j)
5091       dzj=dc_norm(3,nres+j)
5092       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5093       rij=dsqrt(rrij)
5094       erij(1)=xj*rij
5095       erij(2)=yj*rij
5096       erij(3)=zj*rij
5097       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5098       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5099       om12=dxi*dxj+dyi*dyj+dzi*dzj
5100       do k=1,3
5101         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5102         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5103       enddo
5104       rij=1.0d0/rij
5105       deltad=rij-d0cm
5106       deltat1=1.0d0-om1
5107       deltat2=1.0d0+om2
5108       deltat12=om2-om1+2.0d0
5109       cosphi=om12-om1*om2
5110       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5111         +akct*deltad*deltat12 &
5112         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5113 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5114 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5115 !     &  " deltat12",deltat12," eij",eij
5116       ed=2*akcm*deltad+akct*deltat12
5117       pom1=akct*deltad
5118       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5119       eom1=-2*akth*deltat1-pom1-om2*pom2
5120       eom2= 2*akth*deltat2+pom1-om1*pom2
5121       eom12=pom2
5122       do k=1,3
5123         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5124         ghpbx(k,i)=ghpbx(k,i)-ggk &
5125                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5126                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5127         ghpbx(k,j)=ghpbx(k,j)+ggk &
5128                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5129                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5130         ghpbc(k,i)=ghpbc(k,i)-ggk
5131         ghpbc(k,j)=ghpbc(k,j)+ggk
5132       enddo
5133 !
5134 ! Calculate the components of the gradient in DC and X
5135 !
5136 !grad      do k=i,j-1
5137 !grad        do l=1,3
5138 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5139 !grad        enddo
5140 !grad      enddo
5141       return
5142       end subroutine ssbond_ene
5143 !-----------------------------------------------------------------------------
5144       subroutine ebond(estr)
5145 !
5146 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5147 !
5148 !      implicit real*8 (a-h,o-z)
5149 !      include 'DIMENSIONS'
5150 !      include 'COMMON.LOCAL'
5151 !      include 'COMMON.GEO'
5152 !      include 'COMMON.INTERACT'
5153 !      include 'COMMON.DERIV'
5154 !      include 'COMMON.VAR'
5155 !      include 'COMMON.CHAIN'
5156 !      include 'COMMON.IOUNITS'
5157 !      include 'COMMON.NAMES'
5158 !      include 'COMMON.FFIELD'
5159 !      include 'COMMON.CONTROL'
5160 !      include 'COMMON.SETUP'
5161       real(kind=8),dimension(3) :: u,ud
5162 !el local variables
5163       integer :: i,j,iti,nbi,k
5164       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5165                    uprod1,uprod2
5166
5167       estr=0.0d0
5168       estr1=0.0d0
5169 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5170 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5171
5172       do i=ibondp_start,ibondp_end
5173         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5174         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5175 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5176 !C          do j=1,3
5177 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5178 !C            *dc(j,i-1)/vbld(i)
5179 !C          enddo
5180 !C          if (energy_dec) write(iout,*) &
5181 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5182         diff = vbld(i)-vbldpDUM
5183         else
5184         diff = vbld(i)-vbldp0
5185         endif
5186         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5187            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5188         estr=estr+diff*diff
5189         do j=1,3
5190           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5191         enddo
5192 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5193 !        endif
5194       enddo
5195       estr=0.5d0*AKP*estr+estr1
5196 !      print *,"estr_bb",estr,AKP
5197 !
5198 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5199 !
5200       do i=ibond_start,ibond_end
5201         iti=iabs(itype(i,1))
5202         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5203         if (iti.ne.10 .and. iti.ne.ntyp1) then
5204           nbi=nbondterm(iti)
5205           if (nbi.eq.1) then
5206             diff=vbld(i+nres)-vbldsc0(1,iti)
5207             if (energy_dec) write (iout,*) &
5208             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5209             AKSC(1,iti),AKSC(1,iti)*diff*diff
5210             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5211 !            print *,"estr_sc",estr
5212             do j=1,3
5213               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5214             enddo
5215           else
5216             do j=1,nbi
5217               diff=vbld(i+nres)-vbldsc0(j,iti)
5218               ud(j)=aksc(j,iti)*diff
5219               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5220             enddo
5221             uprod=u(1)
5222             do j=2,nbi
5223               uprod=uprod*u(j)
5224             enddo
5225             usum=0.0d0
5226             usumsqder=0.0d0
5227             do j=1,nbi
5228               uprod1=1.0d0
5229               uprod2=1.0d0
5230               do k=1,nbi
5231                 if (k.ne.j) then
5232                   uprod1=uprod1*u(k)
5233                   uprod2=uprod2*u(k)*u(k)
5234                 endif
5235               enddo
5236               usum=usum+uprod1
5237               usumsqder=usumsqder+ud(j)*uprod2
5238             enddo
5239             estr=estr+uprod/usum
5240 !            print *,"estr_sc",estr,i
5241
5242              if (energy_dec) write (iout,*) &
5243             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5244             AKSC(1,iti),uprod/usum
5245             do j=1,3
5246              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5247             enddo
5248           endif
5249         endif
5250       enddo
5251       return
5252       end subroutine ebond
5253 #ifdef CRYST_THETA
5254 !-----------------------------------------------------------------------------
5255       subroutine ebend(etheta)
5256 !
5257 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5258 ! angles gamma and its derivatives in consecutive thetas and gammas.
5259 !
5260       use comm_calcthet
5261 !      implicit real*8 (a-h,o-z)
5262 !      include 'DIMENSIONS'
5263 !      include 'COMMON.LOCAL'
5264 !      include 'COMMON.GEO'
5265 !      include 'COMMON.INTERACT'
5266 !      include 'COMMON.DERIV'
5267 !      include 'COMMON.VAR'
5268 !      include 'COMMON.CHAIN'
5269 !      include 'COMMON.IOUNITS'
5270 !      include 'COMMON.NAMES'
5271 !      include 'COMMON.FFIELD'
5272 !      include 'COMMON.CONTROL'
5273 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5274 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5275 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5276 !el      integer :: it
5277 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5278 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5279 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5280 !el local variables
5281       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5282        ichir21,ichir22
5283       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5284        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5285        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5286       real(kind=8),dimension(2) :: y,z
5287
5288       delta=0.02d0*pi
5289 !      time11=dexp(-2*time)
5290 !      time12=1.0d0
5291       etheta=0.0D0
5292 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5293       do i=ithet_start,ithet_end
5294         if (itype(i-1,1).eq.ntyp1) cycle
5295 ! Zero the energy function and its derivative at 0 or pi.
5296         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5297         it=itype(i-1,1)
5298         ichir1=isign(1,itype(i-2,1))
5299         ichir2=isign(1,itype(i,1))
5300          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5301          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5302          if (itype(i-1,1).eq.10) then
5303           itype1=isign(10,itype(i-2,1))
5304           ichir11=isign(1,itype(i-2,1))
5305           ichir12=isign(1,itype(i-2,1))
5306           itype2=isign(10,itype(i,1))
5307           ichir21=isign(1,itype(i,1))
5308           ichir22=isign(1,itype(i,1))
5309          endif
5310
5311         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5312 #ifdef OSF
5313           phii=phi(i)
5314           if (phii.ne.phii) phii=150.0
5315 #else
5316           phii=phi(i)
5317 #endif
5318           y(1)=dcos(phii)
5319           y(2)=dsin(phii)
5320         else
5321           y(1)=0.0D0
5322           y(2)=0.0D0
5323         endif
5324         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5325 #ifdef OSF
5326           phii1=phi(i+1)
5327           if (phii1.ne.phii1) phii1=150.0
5328           phii1=pinorm(phii1)
5329           z(1)=cos(phii1)
5330 #else
5331           phii1=phi(i+1)
5332           z(1)=dcos(phii1)
5333 #endif
5334           z(2)=dsin(phii1)
5335         else
5336           z(1)=0.0D0
5337           z(2)=0.0D0
5338         endif
5339 ! Calculate the "mean" value of theta from the part of the distribution
5340 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5341 ! In following comments this theta will be referred to as t_c.
5342         thet_pred_mean=0.0d0
5343         do k=1,2
5344             athetk=athet(k,it,ichir1,ichir2)
5345             bthetk=bthet(k,it,ichir1,ichir2)
5346           if (it.eq.10) then
5347              athetk=athet(k,itype1,ichir11,ichir12)
5348              bthetk=bthet(k,itype2,ichir21,ichir22)
5349           endif
5350          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5351         enddo
5352         dthett=thet_pred_mean*ssd
5353         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5354 ! Derivatives of the "mean" values in gamma1 and gamma2.
5355         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5356                +athet(2,it,ichir1,ichir2)*y(1))*ss
5357         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5358                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5359          if (it.eq.10) then
5360         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5361              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5362         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5363                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5364          endif
5365         if (theta(i).gt.pi-delta) then
5366           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5367                E_tc0)
5368           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5369           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5370           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5371               E_theta)
5372           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5373               E_tc)
5374         else if (theta(i).lt.delta) then
5375           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5376           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5377           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5378               E_theta)
5379           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5380           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5381               E_tc)
5382         else
5383           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5384               E_theta,E_tc)
5385         endif
5386         etheta=etheta+ethetai
5387         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5388             'ebend',i,ethetai
5389         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5390         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5391         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5392       enddo
5393 ! Ufff.... We've done all this!!!
5394       return
5395       end subroutine ebend
5396 !-----------------------------------------------------------------------------
5397       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5398
5399       use comm_calcthet
5400 !      implicit real*8 (a-h,o-z)
5401 !      include 'DIMENSIONS'
5402 !      include 'COMMON.LOCAL'
5403 !      include 'COMMON.IOUNITS'
5404 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5405 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5406 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5407       integer :: i,j,k
5408       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5409 !el      integer :: it
5410 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5411 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5412 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5413 !el local variables
5414       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5415        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5416
5417 ! Calculate the contributions to both Gaussian lobes.
5418 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5419 ! The "polynomial part" of the "standard deviation" of this part of
5420 ! the distribution.
5421         sig=polthet(3,it)
5422         do j=2,0,-1
5423           sig=sig*thet_pred_mean+polthet(j,it)
5424         enddo
5425 ! Derivative of the "interior part" of the "standard deviation of the"
5426 ! gamma-dependent Gaussian lobe in t_c.
5427         sigtc=3*polthet(3,it)
5428         do j=2,1,-1
5429           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5430         enddo
5431         sigtc=sig*sigtc
5432 ! Set the parameters of both Gaussian lobes of the distribution.
5433 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5434         fac=sig*sig+sigc0(it)
5435         sigcsq=fac+fac
5436         sigc=1.0D0/sigcsq
5437 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5438         sigsqtc=-4.0D0*sigcsq*sigtc
5439 !       print *,i,sig,sigtc,sigsqtc
5440 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5441         sigtc=-sigtc/(fac*fac)
5442 ! Following variable is sigma(t_c)**(-2)
5443         sigcsq=sigcsq*sigcsq
5444         sig0i=sig0(it)
5445         sig0inv=1.0D0/sig0i**2
5446         delthec=thetai-thet_pred_mean
5447         delthe0=thetai-theta0i
5448         term1=-0.5D0*sigcsq*delthec*delthec
5449         term2=-0.5D0*sig0inv*delthe0*delthe0
5450 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5451 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5452 ! to the energy (this being the log of the distribution) at the end of energy
5453 ! term evaluation for this virtual-bond angle.
5454         if (term1.gt.term2) then
5455           termm=term1
5456           term2=dexp(term2-termm)
5457           term1=1.0d0
5458         else
5459           termm=term2
5460           term1=dexp(term1-termm)
5461           term2=1.0d0
5462         endif
5463 ! The ratio between the gamma-independent and gamma-dependent lobes of
5464 ! the distribution is a Gaussian function of thet_pred_mean too.
5465         diffak=gthet(2,it)-thet_pred_mean
5466         ratak=diffak/gthet(3,it)**2
5467         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5468 ! Let's differentiate it in thet_pred_mean NOW.
5469         aktc=ak*ratak
5470 ! Now put together the distribution terms to make complete distribution.
5471         termexp=term1+ak*term2
5472         termpre=sigc+ak*sig0i
5473 ! Contribution of the bending energy from this theta is just the -log of
5474 ! the sum of the contributions from the two lobes and the pre-exponential
5475 ! factor. Simple enough, isn't it?
5476         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5477 ! NOW the derivatives!!!
5478 ! 6/6/97 Take into account the deformation.
5479         E_theta=(delthec*sigcsq*term1 &
5480              +ak*delthe0*sig0inv*term2)/termexp
5481         E_tc=((sigtc+aktc*sig0i)/termpre &
5482             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5483              aktc*term2)/termexp)
5484       return
5485       end subroutine theteng
5486 #else
5487 !-----------------------------------------------------------------------------
5488       subroutine ebend(etheta,ethetacnstr)
5489 !
5490 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5491 ! angles gamma and its derivatives in consecutive thetas and gammas.
5492 ! ab initio-derived potentials from
5493 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5494 !
5495 !      implicit real*8 (a-h,o-z)
5496 !      include 'DIMENSIONS'
5497 !      include 'COMMON.LOCAL'
5498 !      include 'COMMON.GEO'
5499 !      include 'COMMON.INTERACT'
5500 !      include 'COMMON.DERIV'
5501 !      include 'COMMON.VAR'
5502 !      include 'COMMON.CHAIN'
5503 !      include 'COMMON.IOUNITS'
5504 !      include 'COMMON.NAMES'
5505 !      include 'COMMON.FFIELD'
5506 !      include 'COMMON.CONTROL'
5507       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5508       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5509       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5510       logical :: lprn=.false., lprn1=.false.
5511 !el local variables
5512       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5513       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5514       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5515 ! local variables for constrains
5516       real(kind=8) :: difi,thetiii
5517        integer itheta
5518
5519       etheta=0.0D0
5520       do i=ithet_start,ithet_end
5521         if (itype(i-1,1).eq.ntyp1) cycle
5522         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5523         if (iabs(itype(i+1,1)).eq.20) iblock=2
5524         if (iabs(itype(i+1,1)).ne.20) iblock=1
5525         dethetai=0.0d0
5526         dephii=0.0d0
5527         dephii1=0.0d0
5528         theti2=0.5d0*theta(i)
5529         ityp2=ithetyp((itype(i-1,1)))
5530         do k=1,nntheterm
5531           coskt(k)=dcos(k*theti2)
5532           sinkt(k)=dsin(k*theti2)
5533         enddo
5534         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5535 #ifdef OSF
5536           phii=phi(i)
5537           if (phii.ne.phii) phii=150.0
5538 #else
5539           phii=phi(i)
5540 #endif
5541           ityp1=ithetyp((itype(i-2,1)))
5542 ! propagation of chirality for glycine type
5543           do k=1,nsingle
5544             cosph1(k)=dcos(k*phii)
5545             sinph1(k)=dsin(k*phii)
5546           enddo
5547         else
5548           phii=0.0d0
5549           ityp1=ithetyp(itype(i-2,1))
5550           do k=1,nsingle
5551             cosph1(k)=0.0d0
5552             sinph1(k)=0.0d0
5553           enddo
5554         endif
5555         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5556 #ifdef OSF
5557           phii1=phi(i+1)
5558           if (phii1.ne.phii1) phii1=150.0
5559           phii1=pinorm(phii1)
5560 #else
5561           phii1=phi(i+1)
5562 #endif
5563           ityp3=ithetyp((itype(i,1)))
5564           do k=1,nsingle
5565             cosph2(k)=dcos(k*phii1)
5566             sinph2(k)=dsin(k*phii1)
5567           enddo
5568         else
5569           phii1=0.0d0
5570           ityp3=ithetyp(itype(i,1))
5571           do k=1,nsingle
5572             cosph2(k)=0.0d0
5573             sinph2(k)=0.0d0
5574           enddo
5575         endif
5576         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5577         do k=1,ndouble
5578           do l=1,k-1
5579             ccl=cosph1(l)*cosph2(k-l)
5580             ssl=sinph1(l)*sinph2(k-l)
5581             scl=sinph1(l)*cosph2(k-l)
5582             csl=cosph1(l)*sinph2(k-l)
5583             cosph1ph2(l,k)=ccl-ssl
5584             cosph1ph2(k,l)=ccl+ssl
5585             sinph1ph2(l,k)=scl+csl
5586             sinph1ph2(k,l)=scl-csl
5587           enddo
5588         enddo
5589         if (lprn) then
5590         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5591           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5592         write (iout,*) "coskt and sinkt"
5593         do k=1,nntheterm
5594           write (iout,*) k,coskt(k),sinkt(k)
5595         enddo
5596         endif
5597         do k=1,ntheterm
5598           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5599           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5600             *coskt(k)
5601           if (lprn) &
5602           write (iout,*) "k",k,&
5603            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5604            " ethetai",ethetai
5605         enddo
5606         if (lprn) then
5607         write (iout,*) "cosph and sinph"
5608         do k=1,nsingle
5609           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5610         enddo
5611         write (iout,*) "cosph1ph2 and sinph2ph2"
5612         do k=2,ndouble
5613           do l=1,k-1
5614             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5615                sinph1ph2(l,k),sinph1ph2(k,l)
5616           enddo
5617         enddo
5618         write(iout,*) "ethetai",ethetai
5619         endif
5620         do m=1,ntheterm2
5621           do k=1,nsingle
5622             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5623                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5624                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5625                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5626             ethetai=ethetai+sinkt(m)*aux
5627             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5628             dephii=dephii+k*sinkt(m)* &
5629                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5630                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5631             dephii1=dephii1+k*sinkt(m)* &
5632                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5633                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5634             if (lprn) &
5635             write (iout,*) "m",m," k",k," bbthet", &
5636                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5637                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5638                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5639                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5640           enddo
5641         enddo
5642         if (lprn) &
5643         write(iout,*) "ethetai",ethetai
5644         do m=1,ntheterm3
5645           do k=2,ndouble
5646             do l=1,k-1
5647               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5648                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5649                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5650                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5651               ethetai=ethetai+sinkt(m)*aux
5652               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5653               dephii=dephii+l*sinkt(m)* &
5654                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5655                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5656                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5657                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5658               dephii1=dephii1+(k-l)*sinkt(m)* &
5659                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5660                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5661                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5662                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5663               if (lprn) then
5664               write (iout,*) "m",m," k",k," l",l," ffthet",&
5665                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5666                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5667                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5668                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5669                   " ethetai",ethetai
5670               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5671                   cosph1ph2(k,l)*sinkt(m),&
5672                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5673               endif
5674             enddo
5675           enddo
5676         enddo
5677 10      continue
5678 !        lprn1=.true.
5679         if (lprn1) &
5680           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5681          i,theta(i)*rad2deg,phii*rad2deg,&
5682          phii1*rad2deg,ethetai
5683 !        lprn1=.false.
5684         etheta=etheta+ethetai
5685         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5686                                     'ebend',i,ethetai
5687         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5688         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5689         gloc(nphi+i-2,icg)=wang*dethetai
5690       enddo
5691 !-----------thete constrains
5692 !      if (tor_mode.ne.2) then
5693       ethetacnstr=0.0d0
5694 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5695       do i=ithetaconstr_start,ithetaconstr_end
5696         itheta=itheta_constr(i)
5697         thetiii=theta(itheta)
5698         difi=pinorm(thetiii-theta_constr0(i))
5699         if (difi.gt.theta_drange(i)) then
5700           difi=difi-theta_drange(i)
5701           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5702           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5703          +for_thet_constr(i)*difi**3
5704         else if (difi.lt.-drange(i)) then
5705           difi=difi+drange(i)
5706           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5707           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5708          +for_thet_constr(i)*difi**3
5709         else
5710           difi=0.0
5711         endif
5712        if (energy_dec) then
5713         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5714          i,itheta,rad2deg*thetiii, &
5715          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5716          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5717          gloc(itheta+nphi-2,icg)
5718         endif
5719       enddo
5720 !      endif
5721
5722       return
5723       end subroutine ebend
5724 #endif
5725 #ifdef CRYST_SC
5726 !-----------------------------------------------------------------------------
5727       subroutine esc(escloc)
5728 ! Calculate the local energy of a side chain and its derivatives in the
5729 ! corresponding virtual-bond valence angles THETA and the spherical angles
5730 ! ALPHA and OMEGA.
5731 !
5732       use comm_sccalc
5733 !      implicit real*8 (a-h,o-z)
5734 !      include 'DIMENSIONS'
5735 !      include 'COMMON.GEO'
5736 !      include 'COMMON.LOCAL'
5737 !      include 'COMMON.VAR'
5738 !      include 'COMMON.INTERACT'
5739 !      include 'COMMON.DERIV'
5740 !      include 'COMMON.CHAIN'
5741 !      include 'COMMON.IOUNITS'
5742 !      include 'COMMON.NAMES'
5743 !      include 'COMMON.FFIELD'
5744 !      include 'COMMON.CONTROL'
5745       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5746          ddersc0,ddummy,xtemp,temp
5747 !el      real(kind=8) :: time11,time12,time112,theti
5748       real(kind=8) :: escloc,delta
5749 !el      integer :: it,nlobit
5750 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5751 !el local variables
5752       integer :: i,k
5753       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5754        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5755       delta=0.02d0*pi
5756       escloc=0.0D0
5757 !     write (iout,'(a)') 'ESC'
5758       do i=loc_start,loc_end
5759         it=itype(i,1)
5760         if (it.eq.ntyp1) cycle
5761         if (it.eq.10) goto 1
5762         nlobit=nlob(iabs(it))
5763 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5764 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5765         theti=theta(i+1)-pipol
5766         x(1)=dtan(theti)
5767         x(2)=alph(i)
5768         x(3)=omeg(i)
5769
5770         if (x(2).gt.pi-delta) then
5771           xtemp(1)=x(1)
5772           xtemp(2)=pi-delta
5773           xtemp(3)=x(3)
5774           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5775           xtemp(2)=pi
5776           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5777           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5778               escloci,dersc(2))
5779           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5780               ddersc0(1),dersc(1))
5781           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5782               ddersc0(3),dersc(3))
5783           xtemp(2)=pi-delta
5784           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5785           xtemp(2)=pi
5786           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5787           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5788                   dersc0(2),esclocbi,dersc02)
5789           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5790                   dersc12,dersc01)
5791           call splinthet(x(2),0.5d0*delta,ss,ssd)
5792           dersc0(1)=dersc01
5793           dersc0(2)=dersc02
5794           dersc0(3)=0.0d0
5795           do k=1,3
5796             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5797           enddo
5798           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5799 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5800 !    &             esclocbi,ss,ssd
5801           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5802 !         escloci=esclocbi
5803 !         write (iout,*) escloci
5804         else if (x(2).lt.delta) then
5805           xtemp(1)=x(1)
5806           xtemp(2)=delta
5807           xtemp(3)=x(3)
5808           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5809           xtemp(2)=0.0d0
5810           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5811           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5812               escloci,dersc(2))
5813           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5814               ddersc0(1),dersc(1))
5815           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5816               ddersc0(3),dersc(3))
5817           xtemp(2)=delta
5818           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5819           xtemp(2)=0.0d0
5820           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5821           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5822                   dersc0(2),esclocbi,dersc02)
5823           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5824                   dersc12,dersc01)
5825           dersc0(1)=dersc01
5826           dersc0(2)=dersc02
5827           dersc0(3)=0.0d0
5828           call splinthet(x(2),0.5d0*delta,ss,ssd)
5829           do k=1,3
5830             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5831           enddo
5832           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5833 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5834 !    &             esclocbi,ss,ssd
5835           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5836 !         write (iout,*) escloci
5837         else
5838           call enesc(x,escloci,dersc,ddummy,.false.)
5839         endif
5840
5841         escloc=escloc+escloci
5842         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5843            'escloc',i,escloci
5844 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5845
5846         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5847          wscloc*dersc(1)
5848         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5849         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5850     1   continue
5851       enddo
5852       return
5853       end subroutine esc
5854 !-----------------------------------------------------------------------------
5855       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5856
5857       use comm_sccalc
5858 !      implicit real*8 (a-h,o-z)
5859 !      include 'DIMENSIONS'
5860 !      include 'COMMON.GEO'
5861 !      include 'COMMON.LOCAL'
5862 !      include 'COMMON.IOUNITS'
5863 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5864       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5865       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5866       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5867       real(kind=8) :: escloci
5868       logical :: mixed
5869 !el local variables
5870       integer :: j,iii,l,k !el,it,nlobit
5871       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5872 !el       time11,time12,time112
5873 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5874         escloc_i=0.0D0
5875         do j=1,3
5876           dersc(j)=0.0D0
5877           if (mixed) ddersc(j)=0.0d0
5878         enddo
5879         x3=x(3)
5880
5881 ! Because of periodicity of the dependence of the SC energy in omega we have
5882 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5883 ! To avoid underflows, first compute & store the exponents.
5884
5885         do iii=-1,1
5886
5887           x(3)=x3+iii*dwapi
5888
5889           do j=1,nlobit
5890             do k=1,3
5891               z(k)=x(k)-censc(k,j,it)
5892             enddo
5893             do k=1,3
5894               Axk=0.0D0
5895               do l=1,3
5896                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5897               enddo
5898               Ax(k,j,iii)=Axk
5899             enddo
5900             expfac=0.0D0
5901             do k=1,3
5902               expfac=expfac+Ax(k,j,iii)*z(k)
5903             enddo
5904             contr(j,iii)=expfac
5905           enddo ! j
5906
5907         enddo ! iii
5908
5909         x(3)=x3
5910 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5911 ! subsequent NaNs and INFs in energy calculation.
5912 ! Find the largest exponent
5913         emin=contr(1,-1)
5914         do iii=-1,1
5915           do j=1,nlobit
5916             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5917           enddo
5918         enddo
5919         emin=0.5D0*emin
5920 !d      print *,'it=',it,' emin=',emin
5921
5922 ! Compute the contribution to SC energy and derivatives
5923         do iii=-1,1
5924
5925           do j=1,nlobit
5926 #ifdef OSF
5927             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5928             if(adexp.ne.adexp) adexp=1.0
5929             expfac=dexp(adexp)
5930 #else
5931             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5932 #endif
5933 !d          print *,'j=',j,' expfac=',expfac
5934             escloc_i=escloc_i+expfac
5935             do k=1,3
5936               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5937             enddo
5938             if (mixed) then
5939               do k=1,3,2
5940                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5941                   +gaussc(k,2,j,it))*expfac
5942               enddo
5943             endif
5944           enddo
5945
5946         enddo ! iii
5947
5948         dersc(1)=dersc(1)/cos(theti)**2
5949         ddersc(1)=ddersc(1)/cos(theti)**2
5950         ddersc(3)=ddersc(3)
5951
5952         escloci=-(dlog(escloc_i)-emin)
5953         do j=1,3
5954           dersc(j)=dersc(j)/escloc_i
5955         enddo
5956         if (mixed) then
5957           do j=1,3,2
5958             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5959           enddo
5960         endif
5961       return
5962       end subroutine enesc
5963 !-----------------------------------------------------------------------------
5964       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5965
5966       use comm_sccalc
5967 !      implicit real*8 (a-h,o-z)
5968 !      include 'DIMENSIONS'
5969 !      include 'COMMON.GEO'
5970 !      include 'COMMON.LOCAL'
5971 !      include 'COMMON.IOUNITS'
5972 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5973       real(kind=8),dimension(3) :: x,z,dersc
5974       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5975       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5976       real(kind=8) :: escloci,dersc12,emin
5977       logical :: mixed
5978 !el local varables
5979       integer :: j,k,l !el,it,nlobit
5980       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5981
5982       escloc_i=0.0D0
5983
5984       do j=1,3
5985         dersc(j)=0.0D0
5986       enddo
5987
5988       do j=1,nlobit
5989         do k=1,2
5990           z(k)=x(k)-censc(k,j,it)
5991         enddo
5992         z(3)=dwapi
5993         do k=1,3
5994           Axk=0.0D0
5995           do l=1,3
5996             Axk=Axk+gaussc(l,k,j,it)*z(l)
5997           enddo
5998           Ax(k,j)=Axk
5999         enddo
6000         expfac=0.0D0
6001         do k=1,3
6002           expfac=expfac+Ax(k,j)*z(k)
6003         enddo
6004         contr(j)=expfac
6005       enddo ! j
6006
6007 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6008 ! subsequent NaNs and INFs in energy calculation.
6009 ! Find the largest exponent
6010       emin=contr(1)
6011       do j=1,nlobit
6012         if (emin.gt.contr(j)) emin=contr(j)
6013       enddo
6014       emin=0.5D0*emin
6015
6016 ! Compute the contribution to SC energy and derivatives
6017
6018       dersc12=0.0d0
6019       do j=1,nlobit
6020         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6021         escloc_i=escloc_i+expfac
6022         do k=1,2
6023           dersc(k)=dersc(k)+Ax(k,j)*expfac
6024         enddo
6025         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6026                   +gaussc(1,2,j,it))*expfac
6027         dersc(3)=0.0d0
6028       enddo
6029
6030       dersc(1)=dersc(1)/cos(theti)**2
6031       dersc12=dersc12/cos(theti)**2
6032       escloci=-(dlog(escloc_i)-emin)
6033       do j=1,2
6034         dersc(j)=dersc(j)/escloc_i
6035       enddo
6036       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6037       return
6038       end subroutine enesc_bound
6039 #else
6040 !-----------------------------------------------------------------------------
6041       subroutine esc(escloc)
6042 ! Calculate the local energy of a side chain and its derivatives in the
6043 ! corresponding virtual-bond valence angles THETA and the spherical angles
6044 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6045 ! added by Urszula Kozlowska. 07/11/2007
6046 !
6047       use comm_sccalc
6048 !      implicit real*8 (a-h,o-z)
6049 !      include 'DIMENSIONS'
6050 !      include 'COMMON.GEO'
6051 !      include 'COMMON.LOCAL'
6052 !      include 'COMMON.VAR'
6053 !      include 'COMMON.SCROT'
6054 !      include 'COMMON.INTERACT'
6055 !      include 'COMMON.DERIV'
6056 !      include 'COMMON.CHAIN'
6057 !      include 'COMMON.IOUNITS'
6058 !      include 'COMMON.NAMES'
6059 !      include 'COMMON.FFIELD'
6060 !      include 'COMMON.CONTROL'
6061 !      include 'COMMON.VECTORS'
6062       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6063       real(kind=8),dimension(65) :: x
6064       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6065          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6066       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6067       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6068          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6069 !el local variables
6070       integer :: i,j,k !el,it,nlobit
6071       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6072 !el      real(kind=8) :: time11,time12,time112,theti
6073 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6074       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6075                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6076                    sumene1x,sumene2x,sumene3x,sumene4x,&
6077                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6078                    cosfac2xx,sinfac2yy
6079 #ifdef DEBUG
6080       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6081                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6082                    de_dt_num
6083 #endif
6084 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6085
6086       delta=0.02d0*pi
6087       escloc=0.0D0
6088       do i=loc_start,loc_end
6089         if (itype(i,1).eq.ntyp1) cycle
6090         costtab(i+1) =dcos(theta(i+1))
6091         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6092         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6093         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6094         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6095         cosfac=dsqrt(cosfac2)
6096         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6097         sinfac=dsqrt(sinfac2)
6098         it=iabs(itype(i,1))
6099         if (it.eq.10) goto 1
6100 !
6101 !  Compute the axes of tghe local cartesian coordinates system; store in
6102 !   x_prime, y_prime and z_prime
6103 !
6104         do j=1,3
6105           x_prime(j) = 0.00
6106           y_prime(j) = 0.00
6107           z_prime(j) = 0.00
6108         enddo
6109 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6110 !     &   dc_norm(3,i+nres)
6111         do j = 1,3
6112           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6113           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6114         enddo
6115         do j = 1,3
6116           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6117         enddo
6118 !       write (2,*) "i",i
6119 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6120 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6121 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6122 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6123 !      & " xy",scalar(x_prime(1),y_prime(1)),
6124 !      & " xz",scalar(x_prime(1),z_prime(1)),
6125 !      & " yy",scalar(y_prime(1),y_prime(1)),
6126 !      & " yz",scalar(y_prime(1),z_prime(1)),
6127 !      & " zz",scalar(z_prime(1),z_prime(1))
6128 !
6129 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6130 ! to local coordinate system. Store in xx, yy, zz.
6131 !
6132         xx=0.0d0
6133         yy=0.0d0
6134         zz=0.0d0
6135         do j = 1,3
6136           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6137           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6138           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6139         enddo
6140
6141         xxtab(i)=xx
6142         yytab(i)=yy
6143         zztab(i)=zz
6144 !
6145 ! Compute the energy of the ith side cbain
6146 !
6147 !        write (2,*) "xx",xx," yy",yy," zz",zz
6148         it=iabs(itype(i,1))
6149         do j = 1,65
6150           x(j) = sc_parmin(j,it)
6151         enddo
6152 #ifdef CHECK_COORD
6153 !c diagnostics - remove later
6154         xx1 = dcos(alph(2))
6155         yy1 = dsin(alph(2))*dcos(omeg(2))
6156         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6157         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6158           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6159           xx1,yy1,zz1
6160 !,"  --- ", xx_w,yy_w,zz_w
6161 ! end diagnostics
6162 #endif
6163         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6164          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6165          + x(10)*yy*zz
6166         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6167          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6168          + x(20)*yy*zz
6169         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6170          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6171          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6172          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6173          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6174          +x(40)*xx*yy*zz
6175         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6176          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6177          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6178          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6179          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6180          +x(60)*xx*yy*zz
6181         dsc_i   = 0.743d0+x(61)
6182         dp2_i   = 1.9d0+x(62)
6183         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6184                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6185         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6186                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6187         s1=(1+x(63))/(0.1d0 + dscp1)
6188         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6189         s2=(1+x(65))/(0.1d0 + dscp2)
6190         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6191         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6192       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6193 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6194 !     &   sumene4,
6195 !     &   dscp1,dscp2,sumene
6196 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6197         escloc = escloc + sumene
6198 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6199 !     & ,zz,xx,yy
6200 !#define DEBUG
6201 #ifdef DEBUG
6202 !
6203 ! This section to check the numerical derivatives of the energy of ith side
6204 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6205 ! #define DEBUG in the code to turn it on.
6206 !
6207         write (2,*) "sumene               =",sumene
6208         aincr=1.0d-7
6209         xxsave=xx
6210         xx=xx+aincr
6211         write (2,*) xx,yy,zz
6212         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6213         de_dxx_num=(sumenep-sumene)/aincr
6214         xx=xxsave
6215         write (2,*) "xx+ sumene from enesc=",sumenep
6216         yysave=yy
6217         yy=yy+aincr
6218         write (2,*) xx,yy,zz
6219         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6220         de_dyy_num=(sumenep-sumene)/aincr
6221         yy=yysave
6222         write (2,*) "yy+ sumene from enesc=",sumenep
6223         zzsave=zz
6224         zz=zz+aincr
6225         write (2,*) xx,yy,zz
6226         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6227         de_dzz_num=(sumenep-sumene)/aincr
6228         zz=zzsave
6229         write (2,*) "zz+ sumene from enesc=",sumenep
6230         costsave=cost2tab(i+1)
6231         sintsave=sint2tab(i+1)
6232         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6233         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6234         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6235         de_dt_num=(sumenep-sumene)/aincr
6236         write (2,*) " t+ sumene from enesc=",sumenep
6237         cost2tab(i+1)=costsave
6238         sint2tab(i+1)=sintsave
6239 ! End of diagnostics section.
6240 #endif
6241 !
6242 ! Compute the gradient of esc
6243 !
6244 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6245         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6246         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6247         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6248         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6249         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6250         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6251         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6252         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6253         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6254            *(pom_s1/dscp1+pom_s16*dscp1**4)
6255         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6256            *(pom_s2/dscp2+pom_s26*dscp2**4)
6257         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6258         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6259         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6260         +x(40)*yy*zz
6261         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6262         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6263         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6264         +x(60)*yy*zz
6265         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6266               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6267               +(pom1+pom2)*pom_dx
6268 #ifdef DEBUG
6269         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6270 #endif
6271 !
6272         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6273         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6274         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6275         +x(40)*xx*zz
6276         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6277         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6278         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6279         +x(59)*zz**2 +x(60)*xx*zz
6280         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6281               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6282               +(pom1-pom2)*pom_dy
6283 #ifdef DEBUG
6284         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6285 #endif
6286 !
6287         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6288         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6289         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6290         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6291         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6292         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6293         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6294         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6295 #ifdef DEBUG
6296         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6297 #endif
6298 !
6299         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6300         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6301         +pom1*pom_dt1+pom2*pom_dt2
6302 #ifdef DEBUG
6303         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6304 #endif
6305 !
6306 !
6307        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6308        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6309        cosfac2xx=cosfac2*xx
6310        sinfac2yy=sinfac2*yy
6311        do k = 1,3
6312          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6313             vbld_inv(i+1)
6314          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6315             vbld_inv(i)
6316          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6317          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6318 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6319 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6320 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6321 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6322          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6323          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6324          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6325          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6326          dZZ_Ci1(k)=0.0d0
6327          dZZ_Ci(k)=0.0d0
6328          do j=1,3
6329            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6330            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6331            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6332            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6333          enddo
6334
6335          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6336          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6337          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6338          (z_prime(k)-zz*dC_norm(k,i+nres))
6339 !
6340          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6341          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6342        enddo
6343
6344        do k=1,3
6345          dXX_Ctab(k,i)=dXX_Ci(k)
6346          dXX_C1tab(k,i)=dXX_Ci1(k)
6347          dYY_Ctab(k,i)=dYY_Ci(k)
6348          dYY_C1tab(k,i)=dYY_Ci1(k)
6349          dZZ_Ctab(k,i)=dZZ_Ci(k)
6350          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6351          dXX_XYZtab(k,i)=dXX_XYZ(k)
6352          dYY_XYZtab(k,i)=dYY_XYZ(k)
6353          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6354        enddo
6355
6356        do k = 1,3
6357 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6358 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6359 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6360 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6361 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6362 !     &    dt_dci(k)
6363 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6364 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6365          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6366           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6367          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6368           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6369          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6370           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6371        enddo
6372 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6373 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6374
6375 ! to check gradient call subroutine check_grad
6376
6377     1 continue
6378       enddo
6379       return
6380       end subroutine esc
6381 !-----------------------------------------------------------------------------
6382       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6383 !      implicit none
6384       real(kind=8),dimension(65) :: x
6385       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6386         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6387
6388       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6389         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6390         + x(10)*yy*zz
6391       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6392         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6393         + x(20)*yy*zz
6394       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6395         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6396         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6397         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6398         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6399         +x(40)*xx*yy*zz
6400       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6401         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6402         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6403         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6404         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6405         +x(60)*xx*yy*zz
6406       dsc_i   = 0.743d0+x(61)
6407       dp2_i   = 1.9d0+x(62)
6408       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6409                 *(xx*cost2+yy*sint2))
6410       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6411                 *(xx*cost2-yy*sint2))
6412       s1=(1+x(63))/(0.1d0 + dscp1)
6413       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6414       s2=(1+x(65))/(0.1d0 + dscp2)
6415       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6416       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6417        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6418       enesc=sumene
6419       return
6420       end function enesc
6421 #endif
6422 !-----------------------------------------------------------------------------
6423       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6424 !
6425 ! This procedure calculates two-body contact function g(rij) and its derivative:
6426 !
6427 !           eps0ij                                     !       x < -1
6428 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6429 !            0                                         !       x > 1
6430 !
6431 ! where x=(rij-r0ij)/delta
6432 !
6433 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6434 !
6435 !      implicit none
6436       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6437       real(kind=8) :: x,x2,x4,delta
6438 !     delta=0.02D0*r0ij
6439 !      delta=0.2D0*r0ij
6440       x=(rij-r0ij)/delta
6441       if (x.lt.-1.0D0) then
6442         fcont=eps0ij
6443         fprimcont=0.0D0
6444       else if (x.le.1.0D0) then
6445         x2=x*x
6446         x4=x2*x2
6447         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6448         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6449       else
6450         fcont=0.0D0
6451         fprimcont=0.0D0
6452       endif
6453       return
6454       end subroutine gcont
6455 !-----------------------------------------------------------------------------
6456       subroutine splinthet(theti,delta,ss,ssder)
6457 !      implicit real*8 (a-h,o-z)
6458 !      include 'DIMENSIONS'
6459 !      include 'COMMON.VAR'
6460 !      include 'COMMON.GEO'
6461       real(kind=8) :: theti,delta,ss,ssder
6462       real(kind=8) :: thetup,thetlow
6463       thetup=pi-delta
6464       thetlow=delta
6465       if (theti.gt.pipol) then
6466         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6467       else
6468         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6469         ssder=-ssder
6470       endif
6471       return
6472       end subroutine splinthet
6473 !-----------------------------------------------------------------------------
6474       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6475 !      implicit none
6476       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6477       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6478       a1=fprim0*delta/(f1-f0)
6479       a2=3.0d0-2.0d0*a1
6480       a3=a1-2.0d0
6481       ksi=(x-x0)/delta
6482       ksi2=ksi*ksi
6483       ksi3=ksi2*ksi
6484       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6485       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6486       return
6487       end subroutine spline1
6488 !-----------------------------------------------------------------------------
6489       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6490 !      implicit none
6491       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6492       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6493       ksi=(x-x0)/delta
6494       ksi2=ksi*ksi
6495       ksi3=ksi2*ksi
6496       a1=fprim0x*delta
6497       a2=3*(f1x-f0x)-2*fprim0x*delta
6498       a3=fprim0x*delta-2*(f1x-f0x)
6499       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6500       return
6501       end subroutine spline2
6502 !-----------------------------------------------------------------------------
6503 #ifdef CRYST_TOR
6504 !-----------------------------------------------------------------------------
6505       subroutine etor(etors,edihcnstr)
6506 !      implicit real*8 (a-h,o-z)
6507 !      include 'DIMENSIONS'
6508 !      include 'COMMON.VAR'
6509 !      include 'COMMON.GEO'
6510 !      include 'COMMON.LOCAL'
6511 !      include 'COMMON.TORSION'
6512 !      include 'COMMON.INTERACT'
6513 !      include 'COMMON.DERIV'
6514 !      include 'COMMON.CHAIN'
6515 !      include 'COMMON.NAMES'
6516 !      include 'COMMON.IOUNITS'
6517 !      include 'COMMON.FFIELD'
6518 !      include 'COMMON.TORCNSTR'
6519 !      include 'COMMON.CONTROL'
6520       real(kind=8) :: etors,edihcnstr
6521       logical :: lprn
6522 !el local variables
6523       integer :: i,j,
6524       real(kind=8) :: phii,fac,etors_ii
6525
6526 ! Set lprn=.true. for debugging
6527       lprn=.false.
6528 !      lprn=.true.
6529       etors=0.0D0
6530       do i=iphi_start,iphi_end
6531       etors_ii=0.0D0
6532         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6533             .or. itype(i,1).eq.ntyp1) cycle
6534         itori=itortyp(itype(i-2,1))
6535         itori1=itortyp(itype(i-1,1))
6536         phii=phi(i)
6537         gloci=0.0D0
6538 ! Proline-Proline pair is a special case...
6539         if (itori.eq.3 .and. itori1.eq.3) then
6540           if (phii.gt.-dwapi3) then
6541             cosphi=dcos(3*phii)
6542             fac=1.0D0/(1.0D0-cosphi)
6543             etorsi=v1(1,3,3)*fac
6544             etorsi=etorsi+etorsi
6545             etors=etors+etorsi-v1(1,3,3)
6546             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6547             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6548           endif
6549           do j=1,3
6550             v1ij=v1(j+1,itori,itori1)
6551             v2ij=v2(j+1,itori,itori1)
6552             cosphi=dcos(j*phii)
6553             sinphi=dsin(j*phii)
6554             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6555             if (energy_dec) etors_ii=etors_ii+ &
6556                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6557             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6558           enddo
6559         else
6560           do j=1,nterm_old
6561             v1ij=v1(j,itori,itori1)
6562             v2ij=v2(j,itori,itori1)
6563             cosphi=dcos(j*phii)
6564             sinphi=dsin(j*phii)
6565             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6566             if (energy_dec) etors_ii=etors_ii+ &
6567                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6568             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6569           enddo
6570         endif
6571         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6572              'etor',i,etors_ii
6573         if (lprn) &
6574         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6575         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6576         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6577         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6578 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6579       enddo
6580 ! 6/20/98 - dihedral angle constraints
6581       edihcnstr=0.0d0
6582       do i=1,ndih_constr
6583         itori=idih_constr(i)
6584         phii=phi(itori)
6585         difi=phii-phi0(i)
6586         if (difi.gt.drange(i)) then
6587           difi=difi-drange(i)
6588           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6589           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6590         else if (difi.lt.-drange(i)) then
6591           difi=difi+drange(i)
6592           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6593           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6594         endif
6595 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6596 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6597       enddo
6598 !      write (iout,*) 'edihcnstr',edihcnstr
6599       return
6600       end subroutine etor
6601 !-----------------------------------------------------------------------------
6602       subroutine etor_d(etors_d)
6603       real(kind=8) :: etors_d
6604       etors_d=0.0d0
6605       return
6606       end subroutine etor_d
6607 #else
6608 !-----------------------------------------------------------------------------
6609       subroutine etor(etors,edihcnstr)
6610 !      implicit real*8 (a-h,o-z)
6611 !      include 'DIMENSIONS'
6612 !      include 'COMMON.VAR'
6613 !      include 'COMMON.GEO'
6614 !      include 'COMMON.LOCAL'
6615 !      include 'COMMON.TORSION'
6616 !      include 'COMMON.INTERACT'
6617 !      include 'COMMON.DERIV'
6618 !      include 'COMMON.CHAIN'
6619 !      include 'COMMON.NAMES'
6620 !      include 'COMMON.IOUNITS'
6621 !      include 'COMMON.FFIELD'
6622 !      include 'COMMON.TORCNSTR'
6623 !      include 'COMMON.CONTROL'
6624       real(kind=8) :: etors,edihcnstr
6625       logical :: lprn
6626 !el local variables
6627       integer :: i,j,iblock,itori,itori1
6628       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6629                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6630 ! Set lprn=.true. for debugging
6631       lprn=.false.
6632 !     lprn=.true.
6633       etors=0.0D0
6634       do i=iphi_start,iphi_end
6635         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6636              .or. itype(i-3,1).eq.ntyp1 &
6637              .or. itype(i,1).eq.ntyp1) cycle
6638         etors_ii=0.0D0
6639          if (iabs(itype(i,1)).eq.20) then
6640          iblock=2
6641          else
6642          iblock=1
6643          endif
6644         itori=itortyp(itype(i-2,1))
6645         itori1=itortyp(itype(i-1,1))
6646         phii=phi(i)
6647         gloci=0.0D0
6648 ! Regular cosine and sine terms
6649         do j=1,nterm(itori,itori1,iblock)
6650           v1ij=v1(j,itori,itori1,iblock)
6651           v2ij=v2(j,itori,itori1,iblock)
6652           cosphi=dcos(j*phii)
6653           sinphi=dsin(j*phii)
6654           etors=etors+v1ij*cosphi+v2ij*sinphi
6655           if (energy_dec) etors_ii=etors_ii+ &
6656                      v1ij*cosphi+v2ij*sinphi
6657           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6658         enddo
6659 ! Lorentz terms
6660 !                         v1
6661 !  E = SUM ----------------------------------- - v1
6662 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6663 !
6664         cosphi=dcos(0.5d0*phii)
6665         sinphi=dsin(0.5d0*phii)
6666         do j=1,nlor(itori,itori1,iblock)
6667           vl1ij=vlor1(j,itori,itori1)
6668           vl2ij=vlor2(j,itori,itori1)
6669           vl3ij=vlor3(j,itori,itori1)
6670           pom=vl2ij*cosphi+vl3ij*sinphi
6671           pom1=1.0d0/(pom*pom+1.0d0)
6672           etors=etors+vl1ij*pom1
6673           if (energy_dec) etors_ii=etors_ii+ &
6674                      vl1ij*pom1
6675           pom=-pom*pom1*pom1
6676           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6677         enddo
6678 ! Subtract the constant term
6679         etors=etors-v0(itori,itori1,iblock)
6680           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6681                'etor',i,etors_ii-v0(itori,itori1,iblock)
6682         if (lprn) &
6683         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6684         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6685         (v1(j,itori,itori1,iblock),j=1,6),&
6686         (v2(j,itori,itori1,iblock),j=1,6)
6687         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6688 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6689       enddo
6690 ! 6/20/98 - dihedral angle constraints
6691       edihcnstr=0.0d0
6692 !      do i=1,ndih_constr
6693       do i=idihconstr_start,idihconstr_end
6694         itori=idih_constr(i)
6695         phii=phi(itori)
6696         difi=pinorm(phii-phi0(i))
6697         if (difi.gt.drange(i)) then
6698           difi=difi-drange(i)
6699           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6700           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6701         else if (difi.lt.-drange(i)) then
6702           difi=difi+drange(i)
6703           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6704           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6705         else
6706           difi=0.0
6707         endif
6708 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6709 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6710 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6711       enddo
6712 !d       write (iout,*) 'edihcnstr',edihcnstr
6713       return
6714       end subroutine etor
6715 !-----------------------------------------------------------------------------
6716       subroutine etor_d(etors_d)
6717 ! 6/23/01 Compute double torsional energy
6718 !      implicit real*8 (a-h,o-z)
6719 !      include 'DIMENSIONS'
6720 !      include 'COMMON.VAR'
6721 !      include 'COMMON.GEO'
6722 !      include 'COMMON.LOCAL'
6723 !      include 'COMMON.TORSION'
6724 !      include 'COMMON.INTERACT'
6725 !      include 'COMMON.DERIV'
6726 !      include 'COMMON.CHAIN'
6727 !      include 'COMMON.NAMES'
6728 !      include 'COMMON.IOUNITS'
6729 !      include 'COMMON.FFIELD'
6730 !      include 'COMMON.TORCNSTR'
6731       real(kind=8) :: etors_d,etors_d_ii
6732       logical :: lprn
6733 !el local variables
6734       integer :: i,j,k,l,itori,itori1,itori2,iblock
6735       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6736                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6737                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6738                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6739 ! Set lprn=.true. for debugging
6740       lprn=.false.
6741 !     lprn=.true.
6742       etors_d=0.0D0
6743 !      write(iout,*) "a tu??"
6744       do i=iphid_start,iphid_end
6745         etors_d_ii=0.0D0
6746         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6747             .or. itype(i-3,1).eq.ntyp1 &
6748             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6749         itori=itortyp(itype(i-2,1))
6750         itori1=itortyp(itype(i-1,1))
6751         itori2=itortyp(itype(i,1))
6752         phii=phi(i)
6753         phii1=phi(i+1)
6754         gloci1=0.0D0
6755         gloci2=0.0D0
6756         iblock=1
6757         if (iabs(itype(i+1,1)).eq.20) iblock=2
6758
6759 ! Regular cosine and sine terms
6760         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6761           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6762           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6763           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6764           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6765           cosphi1=dcos(j*phii)
6766           sinphi1=dsin(j*phii)
6767           cosphi2=dcos(j*phii1)
6768           sinphi2=dsin(j*phii1)
6769           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6770            v2cij*cosphi2+v2sij*sinphi2
6771           if (energy_dec) etors_d_ii=etors_d_ii+ &
6772            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6773           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6774           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6775         enddo
6776         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6777           do l=1,k-1
6778             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6779             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6780             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6781             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6782             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6783             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6784             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6785             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6786             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6787               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6788             if (energy_dec) etors_d_ii=etors_d_ii+ &
6789               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6790               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6791             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6792               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6793             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6794               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6795           enddo
6796         enddo
6797         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6798                             'etor_d',i,etors_d_ii
6799         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6800         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6801       enddo
6802       return
6803       end subroutine etor_d
6804 #endif
6805 !-----------------------------------------------------------------------------
6806       subroutine eback_sc_corr(esccor)
6807 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6808 !        conformational states; temporarily implemented as differences
6809 !        between UNRES torsional potentials (dependent on three types of
6810 !        residues) and the torsional potentials dependent on all 20 types
6811 !        of residues computed from AM1  energy surfaces of terminally-blocked
6812 !        amino-acid residues.
6813 !      implicit real*8 (a-h,o-z)
6814 !      include 'DIMENSIONS'
6815 !      include 'COMMON.VAR'
6816 !      include 'COMMON.GEO'
6817 !      include 'COMMON.LOCAL'
6818 !      include 'COMMON.TORSION'
6819 !      include 'COMMON.SCCOR'
6820 !      include 'COMMON.INTERACT'
6821 !      include 'COMMON.DERIV'
6822 !      include 'COMMON.CHAIN'
6823 !      include 'COMMON.NAMES'
6824 !      include 'COMMON.IOUNITS'
6825 !      include 'COMMON.FFIELD'
6826 !      include 'COMMON.CONTROL'
6827       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6828                    cosphi,sinphi
6829       logical :: lprn
6830       integer :: i,interty,j,isccori,isccori1,intertyp
6831 ! Set lprn=.true. for debugging
6832       lprn=.false.
6833 !      lprn=.true.
6834 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6835       esccor=0.0D0
6836       do i=itau_start,itau_end
6837         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
6838         esccor_ii=0.0D0
6839         isccori=isccortyp(itype(i-2,1))
6840         isccori1=isccortyp(itype(i-1,1))
6841
6842 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6843         phii=phi(i)
6844         do intertyp=1,3 !intertyp
6845          esccor_ii=0.0D0
6846 !c Added 09 May 2012 (Adasko)
6847 !c  Intertyp means interaction type of backbone mainchain correlation:
6848 !   1 = SC...Ca...Ca...Ca
6849 !   2 = Ca...Ca...Ca...SC
6850 !   3 = SC...Ca...Ca...SCi
6851         gloci=0.0D0
6852         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
6853             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
6854             (itype(i-1,1).eq.ntyp1))) &
6855           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
6856            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
6857            .or.(itype(i,1).eq.ntyp1))) &
6858           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
6859             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
6860             (itype(i-3,1).eq.ntyp1)))) cycle
6861         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
6862         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
6863        cycle
6864        do j=1,nterm_sccor(isccori,isccori1)
6865           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6866           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6867           cosphi=dcos(j*tauangle(intertyp,i))
6868           sinphi=dsin(j*tauangle(intertyp,i))
6869           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6870           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6871           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6872         enddo
6873         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6874                                 'esccor',i,intertyp,esccor_ii
6875 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6876         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6877         if (lprn) &
6878         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6879         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
6880         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6881         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6882         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6883        enddo !intertyp
6884       enddo
6885
6886       return
6887       end subroutine eback_sc_corr
6888 !-----------------------------------------------------------------------------
6889       subroutine multibody(ecorr)
6890 ! This subroutine calculates multi-body contributions to energy following
6891 ! the idea of Skolnick et al. If side chains I and J make a contact and
6892 ! at the same time side chains I+1 and J+1 make a contact, an extra
6893 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6894 !      implicit real*8 (a-h,o-z)
6895 !      include 'DIMENSIONS'
6896 !      include 'COMMON.IOUNITS'
6897 !      include 'COMMON.DERIV'
6898 !      include 'COMMON.INTERACT'
6899 !      include 'COMMON.CONTACTS'
6900       real(kind=8),dimension(3) :: gx,gx1
6901       logical :: lprn
6902       real(kind=8) :: ecorr
6903       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6904 ! Set lprn=.true. for debugging
6905       lprn=.false.
6906
6907       if (lprn) then
6908         write (iout,'(a)') 'Contact function values:'
6909         do i=nnt,nct-2
6910           write (iout,'(i2,20(1x,i2,f10.5))') &
6911               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6912         enddo
6913       endif
6914       ecorr=0.0D0
6915
6916 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6917 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6918       do i=nnt,nct
6919         do j=1,3
6920           gradcorr(j,i)=0.0D0
6921           gradxorr(j,i)=0.0D0
6922         enddo
6923       enddo
6924       do i=nnt,nct-2
6925
6926         DO ISHIFT = 3,4
6927
6928         i1=i+ishift
6929         num_conti=num_cont(i)
6930         num_conti1=num_cont(i1)
6931         do jj=1,num_conti
6932           j=jcont(jj,i)
6933           do kk=1,num_conti1
6934             j1=jcont(kk,i1)
6935             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6936 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6937 !d   &                   ' ishift=',ishift
6938 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6939 ! The system gains extra energy.
6940               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6941             endif   ! j1==j+-ishift
6942           enddo     ! kk
6943         enddo       ! jj
6944
6945         ENDDO ! ISHIFT
6946
6947       enddo         ! i
6948       return
6949       end subroutine multibody
6950 !-----------------------------------------------------------------------------
6951       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6952 !      implicit real*8 (a-h,o-z)
6953 !      include 'DIMENSIONS'
6954 !      include 'COMMON.IOUNITS'
6955 !      include 'COMMON.DERIV'
6956 !      include 'COMMON.INTERACT'
6957 !      include 'COMMON.CONTACTS'
6958       real(kind=8),dimension(3) :: gx,gx1
6959       logical :: lprn
6960       integer :: i,j,k,l,jj,kk,m,ll
6961       real(kind=8) :: eij,ekl
6962       lprn=.false.
6963       eij=facont(jj,i)
6964       ekl=facont(kk,k)
6965 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6966 ! Calculate the multi-body contribution to energy.
6967 ! Calculate multi-body contributions to the gradient.
6968 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6969 !d   & k,l,(gacont(m,kk,k),m=1,3)
6970       do m=1,3
6971         gx(m) =ekl*gacont(m,jj,i)
6972         gx1(m)=eij*gacont(m,kk,k)
6973         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6974         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6975         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6976         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6977       enddo
6978       do m=i,j-1
6979         do ll=1,3
6980           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6981         enddo
6982       enddo
6983       do m=k,l-1
6984         do ll=1,3
6985           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6986         enddo
6987       enddo
6988       esccorr=-eij*ekl
6989       return
6990       end function esccorr
6991 !-----------------------------------------------------------------------------
6992       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6993 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6994 !      implicit real*8 (a-h,o-z)
6995 !      include 'DIMENSIONS'
6996 !      include 'COMMON.IOUNITS'
6997 #ifdef MPI
6998       include "mpif.h"
6999 !      integer :: maxconts !max_cont=maxconts  =nres/4
7000       integer,parameter :: max_dim=26
7001       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7002       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7003 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7004 !el      common /przechowalnia/ zapas
7005       integer :: status(MPI_STATUS_SIZE)
7006       integer,dimension((nres/4)*2) :: req !maxconts*2
7007       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7008 #endif
7009 !      include 'COMMON.SETUP'
7010 !      include 'COMMON.FFIELD'
7011 !      include 'COMMON.DERIV'
7012 !      include 'COMMON.INTERACT'
7013 !      include 'COMMON.CONTACTS'
7014 !      include 'COMMON.CONTROL'
7015 !      include 'COMMON.LOCAL'
7016       real(kind=8),dimension(3) :: gx,gx1
7017       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7018       logical :: lprn,ldone
7019 !el local variables
7020       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7021               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7022
7023 ! Set lprn=.true. for debugging
7024       lprn=.false.
7025 #ifdef MPI
7026 !      maxconts=nres/4
7027       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7028       n_corr=0
7029       n_corr1=0
7030       if (nfgtasks.le.1) goto 30
7031       if (lprn) then
7032         write (iout,'(a)') 'Contact function values before RECEIVE:'
7033         do i=nnt,nct-2
7034           write (iout,'(2i3,50(1x,i2,f5.2))') &
7035           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7036           j=1,num_cont_hb(i))
7037         enddo
7038       endif
7039       call flush(iout)
7040       do i=1,ntask_cont_from
7041         ncont_recv(i)=0
7042       enddo
7043       do i=1,ntask_cont_to
7044         ncont_sent(i)=0
7045       enddo
7046 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7047 !     & ntask_cont_to
7048 ! Make the list of contacts to send to send to other procesors
7049 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7050 !      call flush(iout)
7051       do i=iturn3_start,iturn3_end
7052 !        write (iout,*) "make contact list turn3",i," num_cont",
7053 !     &    num_cont_hb(i)
7054         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7055       enddo
7056       do i=iturn4_start,iturn4_end
7057 !        write (iout,*) "make contact list turn4",i," num_cont",
7058 !     &   num_cont_hb(i)
7059         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7060       enddo
7061       do ii=1,nat_sent
7062         i=iat_sent(ii)
7063 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7064 !     &    num_cont_hb(i)
7065         do j=1,num_cont_hb(i)
7066         do k=1,4
7067           jjc=jcont_hb(j,i)
7068           iproc=iint_sent_local(k,jjc,ii)
7069 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7070           if (iproc.gt.0) then
7071             ncont_sent(iproc)=ncont_sent(iproc)+1
7072             nn=ncont_sent(iproc)
7073             zapas(1,nn,iproc)=i
7074             zapas(2,nn,iproc)=jjc
7075             zapas(3,nn,iproc)=facont_hb(j,i)
7076             zapas(4,nn,iproc)=ees0p(j,i)
7077             zapas(5,nn,iproc)=ees0m(j,i)
7078             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7079             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7080             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7081             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7082             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7083             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7084             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7085             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7086             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7087             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7088             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7089             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7090             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7091             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7092             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7093             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7094             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7095             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7096             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7097             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7098             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7099           endif
7100         enddo
7101         enddo
7102       enddo
7103       if (lprn) then
7104       write (iout,*) &
7105         "Numbers of contacts to be sent to other processors",&
7106         (ncont_sent(i),i=1,ntask_cont_to)
7107       write (iout,*) "Contacts sent"
7108       do ii=1,ntask_cont_to
7109         nn=ncont_sent(ii)
7110         iproc=itask_cont_to(ii)
7111         write (iout,*) nn," contacts to processor",iproc,&
7112          " of CONT_TO_COMM group"
7113         do i=1,nn
7114           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7115         enddo
7116       enddo
7117       call flush(iout)
7118       endif
7119       CorrelType=477
7120       CorrelID=fg_rank+1
7121       CorrelType1=478
7122       CorrelID1=nfgtasks+fg_rank+1
7123       ireq=0
7124 ! Receive the numbers of needed contacts from other processors
7125       do ii=1,ntask_cont_from
7126         iproc=itask_cont_from(ii)
7127         ireq=ireq+1
7128         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7129           FG_COMM,req(ireq),IERR)
7130       enddo
7131 !      write (iout,*) "IRECV ended"
7132 !      call flush(iout)
7133 ! Send the number of contacts needed by other processors
7134       do ii=1,ntask_cont_to
7135         iproc=itask_cont_to(ii)
7136         ireq=ireq+1
7137         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7138           FG_COMM,req(ireq),IERR)
7139       enddo
7140 !      write (iout,*) "ISEND ended"
7141 !      write (iout,*) "number of requests (nn)",ireq
7142       call flush(iout)
7143       if (ireq.gt.0) &
7144         call MPI_Waitall(ireq,req,status_array,ierr)
7145 !      write (iout,*)
7146 !     &  "Numbers of contacts to be received from other processors",
7147 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7148 !      call flush(iout)
7149 ! Receive contacts
7150       ireq=0
7151       do ii=1,ntask_cont_from
7152         iproc=itask_cont_from(ii)
7153         nn=ncont_recv(ii)
7154 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7155 !     &   " of CONT_TO_COMM group"
7156         call flush(iout)
7157         if (nn.gt.0) then
7158           ireq=ireq+1
7159           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7160           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7161 !          write (iout,*) "ireq,req",ireq,req(ireq)
7162         endif
7163       enddo
7164 ! Send the contacts to processors that need them
7165       do ii=1,ntask_cont_to
7166         iproc=itask_cont_to(ii)
7167         nn=ncont_sent(ii)
7168 !        write (iout,*) nn," contacts to processor",iproc,
7169 !     &   " of CONT_TO_COMM group"
7170         if (nn.gt.0) then
7171           ireq=ireq+1
7172           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7173             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7174 !          write (iout,*) "ireq,req",ireq,req(ireq)
7175 !          do i=1,nn
7176 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7177 !          enddo
7178         endif
7179       enddo
7180 !      write (iout,*) "number of requests (contacts)",ireq
7181 !      write (iout,*) "req",(req(i),i=1,4)
7182 !      call flush(iout)
7183       if (ireq.gt.0) &
7184        call MPI_Waitall(ireq,req,status_array,ierr)
7185       do iii=1,ntask_cont_from
7186         iproc=itask_cont_from(iii)
7187         nn=ncont_recv(iii)
7188         if (lprn) then
7189         write (iout,*) "Received",nn," contacts from processor",iproc,&
7190          " of CONT_FROM_COMM group"
7191         call flush(iout)
7192         do i=1,nn
7193           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7194         enddo
7195         call flush(iout)
7196         endif
7197         do i=1,nn
7198           ii=zapas_recv(1,i,iii)
7199 ! Flag the received contacts to prevent double-counting
7200           jj=-zapas_recv(2,i,iii)
7201 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7202 !          call flush(iout)
7203           nnn=num_cont_hb(ii)+1
7204           num_cont_hb(ii)=nnn
7205           jcont_hb(nnn,ii)=jj
7206           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7207           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7208           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7209           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7210           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7211           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7212           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7213           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7214           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7215           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7216           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7217           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7218           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7219           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7220           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7221           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7222           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7223           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7224           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7225           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7226           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7227           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7228           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7229           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7230         enddo
7231       enddo
7232       call flush(iout)
7233       if (lprn) then
7234         write (iout,'(a)') 'Contact function values after receive:'
7235         do i=nnt,nct-2
7236           write (iout,'(2i3,50(1x,i3,f5.2))') &
7237           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7238           j=1,num_cont_hb(i))
7239         enddo
7240         call flush(iout)
7241       endif
7242    30 continue
7243 #endif
7244       if (lprn) then
7245         write (iout,'(a)') 'Contact function values:'
7246         do i=nnt,nct-2
7247           write (iout,'(2i3,50(1x,i3,f5.2))') &
7248           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7249           j=1,num_cont_hb(i))
7250         enddo
7251       endif
7252       ecorr=0.0D0
7253
7254 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7255 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7256 ! Remove the loop below after debugging !!!
7257       do i=nnt,nct
7258         do j=1,3
7259           gradcorr(j,i)=0.0D0
7260           gradxorr(j,i)=0.0D0
7261         enddo
7262       enddo
7263 ! Calculate the local-electrostatic correlation terms
7264       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7265         i1=i+1
7266         num_conti=num_cont_hb(i)
7267         num_conti1=num_cont_hb(i+1)
7268         do jj=1,num_conti
7269           j=jcont_hb(jj,i)
7270           jp=iabs(j)
7271           do kk=1,num_conti1
7272             j1=jcont_hb(kk,i1)
7273             jp1=iabs(j1)
7274 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7275 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7276             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7277                 .or. j.lt.0 .and. j1.gt.0) .and. &
7278                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7279 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7280 ! The system gains extra energy.
7281               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7282               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7283                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7284               n_corr=n_corr+1
7285             else if (j1.eq.j) then
7286 ! Contacts I-J and I-(J+1) occur simultaneously.
7287 ! The system loses extra energy.
7288 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7289             endif
7290           enddo ! kk
7291           do kk=1,num_conti
7292             j1=jcont_hb(kk,i)
7293 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7294 !    &         ' jj=',jj,' kk=',kk
7295             if (j1.eq.j+1) then
7296 ! Contacts I-J and (I+1)-J occur simultaneously.
7297 ! The system loses extra energy.
7298 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7299             endif ! j1==j+1
7300           enddo ! kk
7301         enddo ! jj
7302       enddo ! i
7303       return
7304       end subroutine multibody_hb
7305 !-----------------------------------------------------------------------------
7306       subroutine add_hb_contact(ii,jj,itask)
7307 !      implicit real*8 (a-h,o-z)
7308 !      include "DIMENSIONS"
7309 !      include "COMMON.IOUNITS"
7310 !      include "COMMON.CONTACTS"
7311 !      integer,parameter :: maxconts=nres/4
7312       integer,parameter :: max_dim=26
7313       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7314 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7315 !      common /przechowalnia/ zapas
7316       integer :: i,j,ii,jj,iproc,nn,jjc
7317       integer,dimension(4) :: itask
7318 !      write (iout,*) "itask",itask
7319       do i=1,2
7320         iproc=itask(i)
7321         if (iproc.gt.0) then
7322           do j=1,num_cont_hb(ii)
7323             jjc=jcont_hb(j,ii)
7324 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7325             if (jjc.eq.jj) then
7326               ncont_sent(iproc)=ncont_sent(iproc)+1
7327               nn=ncont_sent(iproc)
7328               zapas(1,nn,iproc)=ii
7329               zapas(2,nn,iproc)=jjc
7330               zapas(3,nn,iproc)=facont_hb(j,ii)
7331               zapas(4,nn,iproc)=ees0p(j,ii)
7332               zapas(5,nn,iproc)=ees0m(j,ii)
7333               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7334               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7335               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7336               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7337               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7338               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7339               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7340               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7341               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7342               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7343               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7344               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7345               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7346               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7347               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7348               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7349               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7350               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7351               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7352               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7353               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7354               exit
7355             endif
7356           enddo
7357         endif
7358       enddo
7359       return
7360       end subroutine add_hb_contact
7361 !-----------------------------------------------------------------------------
7362       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7363 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7364 !      implicit real*8 (a-h,o-z)
7365 !      include 'DIMENSIONS'
7366 !      include 'COMMON.IOUNITS'
7367       integer,parameter :: max_dim=70
7368 #ifdef MPI
7369       include "mpif.h"
7370 !      integer :: maxconts !max_cont=maxconts=nres/4
7371       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7372       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7373 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7374 !      common /przechowalnia/ zapas
7375       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7376         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7377         ierr,iii,nnn
7378 #endif
7379 !      include 'COMMON.SETUP'
7380 !      include 'COMMON.FFIELD'
7381 !      include 'COMMON.DERIV'
7382 !      include 'COMMON.LOCAL'
7383 !      include 'COMMON.INTERACT'
7384 !      include 'COMMON.CONTACTS'
7385 !      include 'COMMON.CHAIN'
7386 !      include 'COMMON.CONTROL'
7387       real(kind=8),dimension(3) :: gx,gx1
7388       integer,dimension(nres) :: num_cont_hb_old
7389       logical :: lprn,ldone
7390 !EL      double precision eello4,eello5,eelo6,eello_turn6
7391 !EL      external eello4,eello5,eello6,eello_turn6
7392 !el local variables
7393       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7394               j1,jp1,i1,num_conti1
7395       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7396       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7397
7398 ! Set lprn=.true. for debugging
7399       lprn=.false.
7400       eturn6=0.0d0
7401 #ifdef MPI
7402 !      maxconts=nres/4
7403       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7404       do i=1,nres
7405         num_cont_hb_old(i)=num_cont_hb(i)
7406       enddo
7407       n_corr=0
7408       n_corr1=0
7409       if (nfgtasks.le.1) goto 30
7410       if (lprn) then
7411         write (iout,'(a)') 'Contact function values before RECEIVE:'
7412         do i=nnt,nct-2
7413           write (iout,'(2i3,50(1x,i2,f5.2))') &
7414           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7415           j=1,num_cont_hb(i))
7416         enddo
7417       endif
7418       call flush(iout)
7419       do i=1,ntask_cont_from
7420         ncont_recv(i)=0
7421       enddo
7422       do i=1,ntask_cont_to
7423         ncont_sent(i)=0
7424       enddo
7425 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7426 !     & ntask_cont_to
7427 ! Make the list of contacts to send to send to other procesors
7428       do i=iturn3_start,iturn3_end
7429 !        write (iout,*) "make contact list turn3",i," num_cont",
7430 !     &    num_cont_hb(i)
7431         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7432       enddo
7433       do i=iturn4_start,iturn4_end
7434 !        write (iout,*) "make contact list turn4",i," num_cont",
7435 !     &   num_cont_hb(i)
7436         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7437       enddo
7438       do ii=1,nat_sent
7439         i=iat_sent(ii)
7440 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7441 !     &    num_cont_hb(i)
7442         do j=1,num_cont_hb(i)
7443         do k=1,4
7444           jjc=jcont_hb(j,i)
7445           iproc=iint_sent_local(k,jjc,ii)
7446 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7447           if (iproc.ne.0) then
7448             ncont_sent(iproc)=ncont_sent(iproc)+1
7449             nn=ncont_sent(iproc)
7450             zapas(1,nn,iproc)=i
7451             zapas(2,nn,iproc)=jjc
7452             zapas(3,nn,iproc)=d_cont(j,i)
7453             ind=3
7454             do kk=1,3
7455               ind=ind+1
7456               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7457             enddo
7458             do kk=1,2
7459               do ll=1,2
7460                 ind=ind+1
7461                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7462               enddo
7463             enddo
7464             do jj=1,5
7465               do kk=1,3
7466                 do ll=1,2
7467                   do mm=1,2
7468                     ind=ind+1
7469                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7470                   enddo
7471                 enddo
7472               enddo
7473             enddo
7474           endif
7475         enddo
7476         enddo
7477       enddo
7478       if (lprn) then
7479       write (iout,*) &
7480         "Numbers of contacts to be sent to other processors",&
7481         (ncont_sent(i),i=1,ntask_cont_to)
7482       write (iout,*) "Contacts sent"
7483       do ii=1,ntask_cont_to
7484         nn=ncont_sent(ii)
7485         iproc=itask_cont_to(ii)
7486         write (iout,*) nn," contacts to processor",iproc,&
7487          " of CONT_TO_COMM group"
7488         do i=1,nn
7489           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7490         enddo
7491       enddo
7492       call flush(iout)
7493       endif
7494       CorrelType=477
7495       CorrelID=fg_rank+1
7496       CorrelType1=478
7497       CorrelID1=nfgtasks+fg_rank+1
7498       ireq=0
7499 ! Receive the numbers of needed contacts from other processors
7500       do ii=1,ntask_cont_from
7501         iproc=itask_cont_from(ii)
7502         ireq=ireq+1
7503         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7504           FG_COMM,req(ireq),IERR)
7505       enddo
7506 !      write (iout,*) "IRECV ended"
7507 !      call flush(iout)
7508 ! Send the number of contacts needed by other processors
7509       do ii=1,ntask_cont_to
7510         iproc=itask_cont_to(ii)
7511         ireq=ireq+1
7512         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7513           FG_COMM,req(ireq),IERR)
7514       enddo
7515 !      write (iout,*) "ISEND ended"
7516 !      write (iout,*) "number of requests (nn)",ireq
7517       call flush(iout)
7518       if (ireq.gt.0) &
7519         call MPI_Waitall(ireq,req,status_array,ierr)
7520 !      write (iout,*)
7521 !     &  "Numbers of contacts to be received from other processors",
7522 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7523 !      call flush(iout)
7524 ! Receive contacts
7525       ireq=0
7526       do ii=1,ntask_cont_from
7527         iproc=itask_cont_from(ii)
7528         nn=ncont_recv(ii)
7529 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7530 !     &   " of CONT_TO_COMM group"
7531         call flush(iout)
7532         if (nn.gt.0) then
7533           ireq=ireq+1
7534           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7535           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7536 !          write (iout,*) "ireq,req",ireq,req(ireq)
7537         endif
7538       enddo
7539 ! Send the contacts to processors that need them
7540       do ii=1,ntask_cont_to
7541         iproc=itask_cont_to(ii)
7542         nn=ncont_sent(ii)
7543 !        write (iout,*) nn," contacts to processor",iproc,
7544 !     &   " of CONT_TO_COMM group"
7545         if (nn.gt.0) then
7546           ireq=ireq+1
7547           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7548             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7549 !          write (iout,*) "ireq,req",ireq,req(ireq)
7550 !          do i=1,nn
7551 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7552 !          enddo
7553         endif
7554       enddo
7555 !      write (iout,*) "number of requests (contacts)",ireq
7556 !      write (iout,*) "req",(req(i),i=1,4)
7557 !      call flush(iout)
7558       if (ireq.gt.0) &
7559        call MPI_Waitall(ireq,req,status_array,ierr)
7560       do iii=1,ntask_cont_from
7561         iproc=itask_cont_from(iii)
7562         nn=ncont_recv(iii)
7563         if (lprn) then
7564         write (iout,*) "Received",nn," contacts from processor",iproc,&
7565          " of CONT_FROM_COMM group"
7566         call flush(iout)
7567         do i=1,nn
7568           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7569         enddo
7570         call flush(iout)
7571         endif
7572         do i=1,nn
7573           ii=zapas_recv(1,i,iii)
7574 ! Flag the received contacts to prevent double-counting
7575           jj=-zapas_recv(2,i,iii)
7576 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7577 !          call flush(iout)
7578           nnn=num_cont_hb(ii)+1
7579           num_cont_hb(ii)=nnn
7580           jcont_hb(nnn,ii)=jj
7581           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7582           ind=3
7583           do kk=1,3
7584             ind=ind+1
7585             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7586           enddo
7587           do kk=1,2
7588             do ll=1,2
7589               ind=ind+1
7590               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7591             enddo
7592           enddo
7593           do jj=1,5
7594             do kk=1,3
7595               do ll=1,2
7596                 do mm=1,2
7597                   ind=ind+1
7598                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7599                 enddo
7600               enddo
7601             enddo
7602           enddo
7603         enddo
7604       enddo
7605       call flush(iout)
7606       if (lprn) then
7607         write (iout,'(a)') 'Contact function values after receive:'
7608         do i=nnt,nct-2
7609           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7610           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7611           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7612         enddo
7613         call flush(iout)
7614       endif
7615    30 continue
7616 #endif
7617       if (lprn) then
7618         write (iout,'(a)') 'Contact function values:'
7619         do i=nnt,nct-2
7620           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7621           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7622           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7623         enddo
7624       endif
7625       ecorr=0.0D0
7626       ecorr5=0.0d0
7627       ecorr6=0.0d0
7628
7629 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7630 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7631 ! Remove the loop below after debugging !!!
7632       do i=nnt,nct
7633         do j=1,3
7634           gradcorr(j,i)=0.0D0
7635           gradxorr(j,i)=0.0D0
7636         enddo
7637       enddo
7638 ! Calculate the dipole-dipole interaction energies
7639       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7640       do i=iatel_s,iatel_e+1
7641         num_conti=num_cont_hb(i)
7642         do jj=1,num_conti
7643           j=jcont_hb(jj,i)
7644 #ifdef MOMENT
7645           call dipole(i,j,jj)
7646 #endif
7647         enddo
7648       enddo
7649       endif
7650 ! Calculate the local-electrostatic correlation terms
7651 !                write (iout,*) "gradcorr5 in eello5 before loop"
7652 !                do iii=1,nres
7653 !                  write (iout,'(i5,3f10.5)')
7654 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7655 !                enddo
7656       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7657 !        write (iout,*) "corr loop i",i
7658         i1=i+1
7659         num_conti=num_cont_hb(i)
7660         num_conti1=num_cont_hb(i+1)
7661         do jj=1,num_conti
7662           j=jcont_hb(jj,i)
7663           jp=iabs(j)
7664           do kk=1,num_conti1
7665             j1=jcont_hb(kk,i1)
7666             jp1=iabs(j1)
7667 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7668 !     &         ' jj=',jj,' kk=',kk
7669 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7670             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7671                 .or. j.lt.0 .and. j1.gt.0) .and. &
7672                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7673 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7674 ! The system gains extra energy.
7675               n_corr=n_corr+1
7676               sqd1=dsqrt(d_cont(jj,i))
7677               sqd2=dsqrt(d_cont(kk,i1))
7678               sred_geom = sqd1*sqd2
7679               IF (sred_geom.lt.cutoff_corr) THEN
7680                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7681                   ekont,fprimcont)
7682 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7683 !d     &         ' jj=',jj,' kk=',kk
7684                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7685                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7686                 do l=1,3
7687                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7688                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7689                 enddo
7690                 n_corr1=n_corr1+1
7691 !d               write (iout,*) 'sred_geom=',sred_geom,
7692 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7693 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7694 !d               write (iout,*) "g_contij",g_contij
7695 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7696 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7697                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7698                 if (wcorr4.gt.0.0d0) &
7699                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7700                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7701                        write (iout,'(a6,4i5,0pf7.3)') &
7702                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7703 !                write (iout,*) "gradcorr5 before eello5"
7704 !                do iii=1,nres
7705 !                  write (iout,'(i5,3f10.5)')
7706 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7707 !                enddo
7708                 if (wcorr5.gt.0.0d0) &
7709                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7710 !                write (iout,*) "gradcorr5 after eello5"
7711 !                do iii=1,nres
7712 !                  write (iout,'(i5,3f10.5)')
7713 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7714 !                enddo
7715                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7716                        write (iout,'(a6,4i5,0pf7.3)') &
7717                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7718 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7719 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7720                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7721                      .or. wturn6.eq.0.0d0))then
7722 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7723                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7724                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7725                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7726 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7727 !d     &            'ecorr6=',ecorr6
7728 !d                write (iout,'(4e15.5)') sred_geom,
7729 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7730 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7731 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7732                 else if (wturn6.gt.0.0d0 &
7733                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7734 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7735                   eturn6=eturn6+eello_turn6(i,jj,kk)
7736                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7737                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7738 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7739                 endif
7740               ENDIF
7741 1111          continue
7742             endif
7743           enddo ! kk
7744         enddo ! jj
7745       enddo ! i
7746       do i=1,nres
7747         num_cont_hb(i)=num_cont_hb_old(i)
7748       enddo
7749 !                write (iout,*) "gradcorr5 in eello5"
7750 !                do iii=1,nres
7751 !                  write (iout,'(i5,3f10.5)')
7752 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7753 !                enddo
7754       return
7755       end subroutine multibody_eello
7756 !-----------------------------------------------------------------------------
7757       subroutine add_hb_contact_eello(ii,jj,itask)
7758 !      implicit real*8 (a-h,o-z)
7759 !      include "DIMENSIONS"
7760 !      include "COMMON.IOUNITS"
7761 !      include "COMMON.CONTACTS"
7762 !      integer,parameter :: maxconts=nres/4
7763       integer,parameter :: max_dim=70
7764       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7765 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7766 !      common /przechowalnia/ zapas
7767
7768       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7769       integer,dimension(4) ::itask
7770 !      write (iout,*) "itask",itask
7771       do i=1,2
7772         iproc=itask(i)
7773         if (iproc.gt.0) then
7774           do j=1,num_cont_hb(ii)
7775             jjc=jcont_hb(j,ii)
7776 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7777             if (jjc.eq.jj) then
7778               ncont_sent(iproc)=ncont_sent(iproc)+1
7779               nn=ncont_sent(iproc)
7780               zapas(1,nn,iproc)=ii
7781               zapas(2,nn,iproc)=jjc
7782               zapas(3,nn,iproc)=d_cont(j,ii)
7783               ind=3
7784               do kk=1,3
7785                 ind=ind+1
7786                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7787               enddo
7788               do kk=1,2
7789                 do ll=1,2
7790                   ind=ind+1
7791                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7792                 enddo
7793               enddo
7794               do jj=1,5
7795                 do kk=1,3
7796                   do ll=1,2
7797                     do mm=1,2
7798                       ind=ind+1
7799                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7800                     enddo
7801                   enddo
7802                 enddo
7803               enddo
7804               exit
7805             endif
7806           enddo
7807         endif
7808       enddo
7809       return
7810       end subroutine add_hb_contact_eello
7811 !-----------------------------------------------------------------------------
7812       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7813 !      implicit real*8 (a-h,o-z)
7814 !      include 'DIMENSIONS'
7815 !      include 'COMMON.IOUNITS'
7816 !      include 'COMMON.DERIV'
7817 !      include 'COMMON.INTERACT'
7818 !      include 'COMMON.CONTACTS'
7819       real(kind=8),dimension(3) :: gx,gx1
7820       logical :: lprn
7821 !el local variables
7822       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7823       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7824                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7825                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7826                    rlocshield
7827
7828       lprn=.false.
7829       eij=facont_hb(jj,i)
7830       ekl=facont_hb(kk,k)
7831       ees0pij=ees0p(jj,i)
7832       ees0pkl=ees0p(kk,k)
7833       ees0mij=ees0m(jj,i)
7834       ees0mkl=ees0m(kk,k)
7835       ekont=eij*ekl
7836       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7837 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7838 ! Following 4 lines for diagnostics.
7839 !d    ees0pkl=0.0D0
7840 !d    ees0pij=1.0D0
7841 !d    ees0mkl=0.0D0
7842 !d    ees0mij=1.0D0
7843 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7844 !     & 'Contacts ',i,j,
7845 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7846 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7847 !     & 'gradcorr_long'
7848 ! Calculate the multi-body contribution to energy.
7849 !      ecorr=ecorr+ekont*ees
7850 ! Calculate multi-body contributions to the gradient.
7851       coeffpees0pij=coeffp*ees0pij
7852       coeffmees0mij=coeffm*ees0mij
7853       coeffpees0pkl=coeffp*ees0pkl
7854       coeffmees0mkl=coeffm*ees0mkl
7855       do ll=1,3
7856 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7857         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7858         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7859         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7860         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7861         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7862         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7863 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7864         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7865         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7866         coeffmees0mij*gacontm_hb1(ll,kk,k))
7867         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7868         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7869         coeffmees0mij*gacontm_hb2(ll,kk,k))
7870         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7871            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7872            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7873         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7874         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7875         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7876            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7877            coeffmees0mij*gacontm_hb3(ll,kk,k))
7878         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7879         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7880 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7881       enddo
7882 !      write (iout,*)
7883 !grad      do m=i+1,j-1
7884 !grad        do ll=1,3
7885 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7886 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7887 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7888 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7889 !grad        enddo
7890 !grad      enddo
7891 !grad      do m=k+1,l-1
7892 !grad        do ll=1,3
7893 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7894 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7895 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7896 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7897 !grad        enddo
7898 !grad      enddo
7899 !      write (iout,*) "ehbcorr",ekont*ees
7900       ehbcorr=ekont*ees
7901       if (shield_mode.gt.0) then
7902        j=ees0plist(jj,i)
7903        l=ees0plist(kk,k)
7904 !C        print *,i,j,fac_shield(i),fac_shield(j),
7905 !C     &fac_shield(k),fac_shield(l)
7906         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
7907            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7908           do ilist=1,ishield_list(i)
7909            iresshield=shield_list(ilist,i)
7910            do m=1,3
7911            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7912            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7913                    rlocshield  &
7914             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7915             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7916             +rlocshield
7917            enddo
7918           enddo
7919           do ilist=1,ishield_list(j)
7920            iresshield=shield_list(ilist,j)
7921            do m=1,3
7922            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7923            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7924                    rlocshield &
7925             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7926            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7927             +rlocshield
7928            enddo
7929           enddo
7930
7931           do ilist=1,ishield_list(k)
7932            iresshield=shield_list(ilist,k)
7933            do m=1,3
7934            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7935            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7936                    rlocshield &
7937             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7938            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7939             +rlocshield
7940            enddo
7941           enddo
7942           do ilist=1,ishield_list(l)
7943            iresshield=shield_list(ilist,l)
7944            do m=1,3
7945            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7946            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7947                    rlocshield &
7948             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7949            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7950             +rlocshield
7951            enddo
7952           enddo
7953           do m=1,3
7954             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
7955                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7956             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
7957                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7958             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
7959                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7960             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
7961                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7962
7963             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
7964                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7965             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
7966                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7967             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
7968                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7969             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
7970                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7971
7972            enddo
7973       endif
7974       endif
7975       return
7976       end function ehbcorr
7977 #ifdef MOMENT
7978 !-----------------------------------------------------------------------------
7979       subroutine dipole(i,j,jj)
7980 !      implicit real*8 (a-h,o-z)
7981 !      include 'DIMENSIONS'
7982 !      include 'COMMON.IOUNITS'
7983 !      include 'COMMON.CHAIN'
7984 !      include 'COMMON.FFIELD'
7985 !      include 'COMMON.DERIV'
7986 !      include 'COMMON.INTERACT'
7987 !      include 'COMMON.CONTACTS'
7988 !      include 'COMMON.TORSION'
7989 !      include 'COMMON.VAR'
7990 !      include 'COMMON.GEO'
7991       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7992       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7993       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7994
7995       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7996       allocate(dipderx(3,5,4,maxconts,nres))
7997 !
7998
7999       iti1 = itortyp(itype(i+1,1))
8000       if (j.lt.nres-1) then
8001         itj1 = itortyp(itype(j+1,1))
8002       else
8003         itj1=ntortyp+1
8004       endif
8005       do iii=1,2
8006         dipi(iii,1)=Ub2(iii,i)
8007         dipderi(iii)=Ub2der(iii,i)
8008         dipi(iii,2)=b1(iii,iti1)
8009         dipj(iii,1)=Ub2(iii,j)
8010         dipderj(iii)=Ub2der(iii,j)
8011         dipj(iii,2)=b1(iii,itj1)
8012       enddo
8013       kkk=0
8014       do iii=1,2
8015         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8016         do jjj=1,2
8017           kkk=kkk+1
8018           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8019         enddo
8020       enddo
8021       do kkk=1,5
8022         do lll=1,3
8023           mmm=0
8024           do iii=1,2
8025             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8026               auxvec(1))
8027             do jjj=1,2
8028               mmm=mmm+1
8029               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8030             enddo
8031           enddo
8032         enddo
8033       enddo
8034       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8035       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8036       do iii=1,2
8037         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8038       enddo
8039       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8040       do iii=1,2
8041         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8042       enddo
8043       return
8044       end subroutine dipole
8045 #endif
8046 !-----------------------------------------------------------------------------
8047       subroutine calc_eello(i,j,k,l,jj,kk)
8048 !
8049 ! This subroutine computes matrices and vectors needed to calculate
8050 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8051 !
8052       use comm_kut
8053 !      implicit real*8 (a-h,o-z)
8054 !      include 'DIMENSIONS'
8055 !      include 'COMMON.IOUNITS'
8056 !      include 'COMMON.CHAIN'
8057 !      include 'COMMON.DERIV'
8058 !      include 'COMMON.INTERACT'
8059 !      include 'COMMON.CONTACTS'
8060 !      include 'COMMON.TORSION'
8061 !      include 'COMMON.VAR'
8062 !      include 'COMMON.GEO'
8063 !      include 'COMMON.FFIELD'
8064       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8065       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8066       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8067               itj1
8068 !el      logical :: lprn
8069 !el      common /kutas/ lprn
8070 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8071 !d     & ' jj=',jj,' kk=',kk
8072 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8073 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8074 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8075       do iii=1,2
8076         do jjj=1,2
8077           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8078           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8079         enddo
8080       enddo
8081       call transpose2(aa1(1,1),aa1t(1,1))
8082       call transpose2(aa2(1,1),aa2t(1,1))
8083       do kkk=1,5
8084         do lll=1,3
8085           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8086             aa1tder(1,1,lll,kkk))
8087           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8088             aa2tder(1,1,lll,kkk))
8089         enddo
8090       enddo
8091       if (l.eq.j+1) then
8092 ! parallel orientation of the two CA-CA-CA frames.
8093         if (i.gt.1) then
8094           iti=itortyp(itype(i,1))
8095         else
8096           iti=ntortyp+1
8097         endif
8098         itk1=itortyp(itype(k+1,1))
8099         itj=itortyp(itype(j,1))
8100         if (l.lt.nres-1) then
8101           itl1=itortyp(itype(l+1,1))
8102         else
8103           itl1=ntortyp+1
8104         endif
8105 ! A1 kernel(j+1) A2T
8106 !d        do iii=1,2
8107 !d          write (iout,'(3f10.5,5x,3f10.5)')
8108 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8109 !d        enddo
8110         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8111          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8112          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8113 ! Following matrices are needed only for 6-th order cumulants
8114         IF (wcorr6.gt.0.0d0) THEN
8115         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8116          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8117          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8118         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8119          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8120          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8121          ADtEAderx(1,1,1,1,1,1))
8122         lprn=.false.
8123         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8124          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8125          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8126          ADtEA1derx(1,1,1,1,1,1))
8127         ENDIF
8128 ! End 6-th order cumulants
8129 !d        lprn=.false.
8130 !d        if (lprn) then
8131 !d        write (2,*) 'In calc_eello6'
8132 !d        do iii=1,2
8133 !d          write (2,*) 'iii=',iii
8134 !d          do kkk=1,5
8135 !d            write (2,*) 'kkk=',kkk
8136 !d            do jjj=1,2
8137 !d              write (2,'(3(2f10.5),5x)')
8138 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8139 !d            enddo
8140 !d          enddo
8141 !d        enddo
8142 !d        endif
8143         call transpose2(EUgder(1,1,k),auxmat(1,1))
8144         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8145         call transpose2(EUg(1,1,k),auxmat(1,1))
8146         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8147         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8148         do iii=1,2
8149           do kkk=1,5
8150             do lll=1,3
8151               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8152                 EAEAderx(1,1,lll,kkk,iii,1))
8153             enddo
8154           enddo
8155         enddo
8156 ! A1T kernel(i+1) A2
8157         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8158          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8159          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8160 ! Following matrices are needed only for 6-th order cumulants
8161         IF (wcorr6.gt.0.0d0) THEN
8162         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8163          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8164          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8165         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8166          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8167          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8168          ADtEAderx(1,1,1,1,1,2))
8169         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8170          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8171          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8172          ADtEA1derx(1,1,1,1,1,2))
8173         ENDIF
8174 ! End 6-th order cumulants
8175         call transpose2(EUgder(1,1,l),auxmat(1,1))
8176         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8177         call transpose2(EUg(1,1,l),auxmat(1,1))
8178         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8179         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8180         do iii=1,2
8181           do kkk=1,5
8182             do lll=1,3
8183               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8184                 EAEAderx(1,1,lll,kkk,iii,2))
8185             enddo
8186           enddo
8187         enddo
8188 ! AEAb1 and AEAb2
8189 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8190 ! They are needed only when the fifth- or the sixth-order cumulants are
8191 ! indluded.
8192         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8193         call transpose2(AEA(1,1,1),auxmat(1,1))
8194         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8195         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8196         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8197         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8198         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8199         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8200         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8201         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8202         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8203         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8204         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8205         call transpose2(AEA(1,1,2),auxmat(1,1))
8206         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8207         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8208         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8209         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8210         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8211         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8212         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8213         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8214         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8215         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8216         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8217 ! Calculate the Cartesian derivatives of the vectors.
8218         do iii=1,2
8219           do kkk=1,5
8220             do lll=1,3
8221               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8222               call matvec2(auxmat(1,1),b1(1,iti),&
8223                 AEAb1derx(1,lll,kkk,iii,1,1))
8224               call matvec2(auxmat(1,1),Ub2(1,i),&
8225                 AEAb2derx(1,lll,kkk,iii,1,1))
8226               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8227                 AEAb1derx(1,lll,kkk,iii,2,1))
8228               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8229                 AEAb2derx(1,lll,kkk,iii,2,1))
8230               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8231               call matvec2(auxmat(1,1),b1(1,itj),&
8232                 AEAb1derx(1,lll,kkk,iii,1,2))
8233               call matvec2(auxmat(1,1),Ub2(1,j),&
8234                 AEAb2derx(1,lll,kkk,iii,1,2))
8235               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8236                 AEAb1derx(1,lll,kkk,iii,2,2))
8237               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8238                 AEAb2derx(1,lll,kkk,iii,2,2))
8239             enddo
8240           enddo
8241         enddo
8242         ENDIF
8243 ! End vectors
8244       else
8245 ! Antiparallel orientation of the two CA-CA-CA frames.
8246         if (i.gt.1) then
8247           iti=itortyp(itype(i,1))
8248         else
8249           iti=ntortyp+1
8250         endif
8251         itk1=itortyp(itype(k+1,1))
8252         itl=itortyp(itype(l,1))
8253         itj=itortyp(itype(j,1))
8254         if (j.lt.nres-1) then
8255           itj1=itortyp(itype(j+1,1))
8256         else
8257           itj1=ntortyp+1
8258         endif
8259 ! A2 kernel(j-1)T A1T
8260         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8261          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8262          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8263 ! Following matrices are needed only for 6-th order cumulants
8264         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8265            j.eq.i+4 .and. l.eq.i+3)) THEN
8266         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8267          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8268          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8269         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8270          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8271          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8272          ADtEAderx(1,1,1,1,1,1))
8273         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8274          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8275          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8276          ADtEA1derx(1,1,1,1,1,1))
8277         ENDIF
8278 ! End 6-th order cumulants
8279         call transpose2(EUgder(1,1,k),auxmat(1,1))
8280         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8281         call transpose2(EUg(1,1,k),auxmat(1,1))
8282         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8283         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8284         do iii=1,2
8285           do kkk=1,5
8286             do lll=1,3
8287               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8288                 EAEAderx(1,1,lll,kkk,iii,1))
8289             enddo
8290           enddo
8291         enddo
8292 ! A2T kernel(i+1)T A1
8293         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8294          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8295          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8296 ! Following matrices are needed only for 6-th order cumulants
8297         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8298            j.eq.i+4 .and. l.eq.i+3)) THEN
8299         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8300          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8301          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8302         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8303          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8304          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8305          ADtEAderx(1,1,1,1,1,2))
8306         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8307          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8308          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8309          ADtEA1derx(1,1,1,1,1,2))
8310         ENDIF
8311 ! End 6-th order cumulants
8312         call transpose2(EUgder(1,1,j),auxmat(1,1))
8313         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8314         call transpose2(EUg(1,1,j),auxmat(1,1))
8315         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8316         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8317         do iii=1,2
8318           do kkk=1,5
8319             do lll=1,3
8320               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8321                 EAEAderx(1,1,lll,kkk,iii,2))
8322             enddo
8323           enddo
8324         enddo
8325 ! AEAb1 and AEAb2
8326 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8327 ! They are needed only when the fifth- or the sixth-order cumulants are
8328 ! indluded.
8329         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8330           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8331         call transpose2(AEA(1,1,1),auxmat(1,1))
8332         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8333         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8334         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8335         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8336         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8337         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8338         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8339         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8340         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8341         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8342         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8343         call transpose2(AEA(1,1,2),auxmat(1,1))
8344         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8345         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8346         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8347         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8348         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8349         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8350         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8351         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8352         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8353         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8354         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8355 ! Calculate the Cartesian derivatives of the vectors.
8356         do iii=1,2
8357           do kkk=1,5
8358             do lll=1,3
8359               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8360               call matvec2(auxmat(1,1),b1(1,iti),&
8361                 AEAb1derx(1,lll,kkk,iii,1,1))
8362               call matvec2(auxmat(1,1),Ub2(1,i),&
8363                 AEAb2derx(1,lll,kkk,iii,1,1))
8364               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8365                 AEAb1derx(1,lll,kkk,iii,2,1))
8366               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8367                 AEAb2derx(1,lll,kkk,iii,2,1))
8368               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8369               call matvec2(auxmat(1,1),b1(1,itl),&
8370                 AEAb1derx(1,lll,kkk,iii,1,2))
8371               call matvec2(auxmat(1,1),Ub2(1,l),&
8372                 AEAb2derx(1,lll,kkk,iii,1,2))
8373               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8374                 AEAb1derx(1,lll,kkk,iii,2,2))
8375               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8376                 AEAb2derx(1,lll,kkk,iii,2,2))
8377             enddo
8378           enddo
8379         enddo
8380         ENDIF
8381 ! End vectors
8382       endif
8383       return
8384       end subroutine calc_eello
8385 !-----------------------------------------------------------------------------
8386       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8387       use comm_kut
8388       implicit none
8389       integer :: nderg
8390       logical :: transp
8391       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8392       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8393       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8394       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8395       integer :: iii,kkk,lll
8396       integer :: jjj,mmm
8397 !el      logical :: lprn
8398 !el      common /kutas/ lprn
8399       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8400       do iii=1,nderg
8401         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8402           AKAderg(1,1,iii))
8403       enddo
8404 !d      if (lprn) write (2,*) 'In kernel'
8405       do kkk=1,5
8406 !d        if (lprn) write (2,*) 'kkk=',kkk
8407         do lll=1,3
8408           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8409             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8410 !d          if (lprn) then
8411 !d            write (2,*) 'lll=',lll
8412 !d            write (2,*) 'iii=1'
8413 !d            do jjj=1,2
8414 !d              write (2,'(3(2f10.5),5x)')
8415 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8416 !d            enddo
8417 !d          endif
8418           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8419             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8420 !d          if (lprn) then
8421 !d            write (2,*) 'lll=',lll
8422 !d            write (2,*) 'iii=2'
8423 !d            do jjj=1,2
8424 !d              write (2,'(3(2f10.5),5x)')
8425 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8426 !d            enddo
8427 !d          endif
8428         enddo
8429       enddo
8430       return
8431       end subroutine kernel
8432 !-----------------------------------------------------------------------------
8433       real(kind=8) function eello4(i,j,k,l,jj,kk)
8434 !      implicit real*8 (a-h,o-z)
8435 !      include 'DIMENSIONS'
8436 !      include 'COMMON.IOUNITS'
8437 !      include 'COMMON.CHAIN'
8438 !      include 'COMMON.DERIV'
8439 !      include 'COMMON.INTERACT'
8440 !      include 'COMMON.CONTACTS'
8441 !      include 'COMMON.TORSION'
8442 !      include 'COMMON.VAR'
8443 !      include 'COMMON.GEO'
8444       real(kind=8),dimension(2,2) :: pizda
8445       real(kind=8),dimension(3) :: ggg1,ggg2
8446       real(kind=8) ::  eel4,glongij,glongkl
8447       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8448 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8449 !d        eello4=0.0d0
8450 !d        return
8451 !d      endif
8452 !d      print *,'eello4:',i,j,k,l,jj,kk
8453 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8454 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8455 !old      eij=facont_hb(jj,i)
8456 !old      ekl=facont_hb(kk,k)
8457 !old      ekont=eij*ekl
8458       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8459 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8460       gcorr_loc(k-1)=gcorr_loc(k-1) &
8461          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8462       if (l.eq.j+1) then
8463         gcorr_loc(l-1)=gcorr_loc(l-1) &
8464            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8465       else
8466         gcorr_loc(j-1)=gcorr_loc(j-1) &
8467            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8468       endif
8469       do iii=1,2
8470         do kkk=1,5
8471           do lll=1,3
8472             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8473                               -EAEAderx(2,2,lll,kkk,iii,1)
8474 !d            derx(lll,kkk,iii)=0.0d0
8475           enddo
8476         enddo
8477       enddo
8478 !d      gcorr_loc(l-1)=0.0d0
8479 !d      gcorr_loc(j-1)=0.0d0
8480 !d      gcorr_loc(k-1)=0.0d0
8481 !d      eel4=1.0d0
8482 !d      write (iout,*)'Contacts have occurred for peptide groups',
8483 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8484 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8485       if (j.lt.nres-1) then
8486         j1=j+1
8487         j2=j-1
8488       else
8489         j1=j-1
8490         j2=j-2
8491       endif
8492       if (l.lt.nres-1) then
8493         l1=l+1
8494         l2=l-1
8495       else
8496         l1=l-1
8497         l2=l-2
8498       endif
8499       do ll=1,3
8500 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8501 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8502         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8503         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8504 !grad        ghalf=0.5d0*ggg1(ll)
8505         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8506         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8507         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8508         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8509         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8510         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8511 !grad        ghalf=0.5d0*ggg2(ll)
8512         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8513         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8514         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8515         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8516         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8517         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8518       enddo
8519 !grad      do m=i+1,j-1
8520 !grad        do ll=1,3
8521 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8522 !grad        enddo
8523 !grad      enddo
8524 !grad      do m=k+1,l-1
8525 !grad        do ll=1,3
8526 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8527 !grad        enddo
8528 !grad      enddo
8529 !grad      do m=i+2,j2
8530 !grad        do ll=1,3
8531 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8532 !grad        enddo
8533 !grad      enddo
8534 !grad      do m=k+2,l2
8535 !grad        do ll=1,3
8536 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8537 !grad        enddo
8538 !grad      enddo
8539 !d      do iii=1,nres-3
8540 !d        write (2,*) iii,gcorr_loc(iii)
8541 !d      enddo
8542       eello4=ekont*eel4
8543 !d      write (2,*) 'ekont',ekont
8544 !d      write (iout,*) 'eello4',ekont*eel4
8545       return
8546       end function eello4
8547 !-----------------------------------------------------------------------------
8548       real(kind=8) function eello5(i,j,k,l,jj,kk)
8549 !      implicit real*8 (a-h,o-z)
8550 !      include 'DIMENSIONS'
8551 !      include 'COMMON.IOUNITS'
8552 !      include 'COMMON.CHAIN'
8553 !      include 'COMMON.DERIV'
8554 !      include 'COMMON.INTERACT'
8555 !      include 'COMMON.CONTACTS'
8556 !      include 'COMMON.TORSION'
8557 !      include 'COMMON.VAR'
8558 !      include 'COMMON.GEO'
8559       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8560       real(kind=8),dimension(2) :: vv
8561       real(kind=8),dimension(3) :: ggg1,ggg2
8562       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8563       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8564       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8565 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8566 !                                                                              C
8567 !                            Parallel chains                                   C
8568 !                                                                              C
8569 !          o             o                   o             o                   C
8570 !         /l\           / \             \   / \           / \   /              C
8571 !        /   \         /   \             \ /   \         /   \ /               C
8572 !       j| o |l1       | o |              o| o |         | o |o                C
8573 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8574 !      \i/   \         /   \ /             /   \         /   \                 C
8575 !       o    k1             o                                                  C
8576 !         (I)          (II)                (III)          (IV)                 C
8577 !                                                                              C
8578 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8579 !                                                                              C
8580 !                            Antiparallel chains                               C
8581 !                                                                              C
8582 !          o             o                   o             o                   C
8583 !         /j\           / \             \   / \           / \   /              C
8584 !        /   \         /   \             \ /   \         /   \ /               C
8585 !      j1| o |l        | o |              o| o |         | o |o                C
8586 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8587 !      \i/   \         /   \ /             /   \         /   \                 C
8588 !       o     k1            o                                                  C
8589 !         (I)          (II)                (III)          (IV)                 C
8590 !                                                                              C
8591 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8592 !                                                                              C
8593 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8594 !                                                                              C
8595 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8596 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8597 !d        eello5=0.0d0
8598 !d        return
8599 !d      endif
8600 !d      write (iout,*)
8601 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8602 !d     &   ' and',k,l
8603       itk=itortyp(itype(k,1))
8604       itl=itortyp(itype(l,1))
8605       itj=itortyp(itype(j,1))
8606       eello5_1=0.0d0
8607       eello5_2=0.0d0
8608       eello5_3=0.0d0
8609       eello5_4=0.0d0
8610 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8611 !d     &   eel5_3_num,eel5_4_num)
8612       do iii=1,2
8613         do kkk=1,5
8614           do lll=1,3
8615             derx(lll,kkk,iii)=0.0d0
8616           enddo
8617         enddo
8618       enddo
8619 !d      eij=facont_hb(jj,i)
8620 !d      ekl=facont_hb(kk,k)
8621 !d      ekont=eij*ekl
8622 !d      write (iout,*)'Contacts have occurred for peptide groups',
8623 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8624 !d      goto 1111
8625 ! Contribution from the graph I.
8626 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8627 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8628       call transpose2(EUg(1,1,k),auxmat(1,1))
8629       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8630       vv(1)=pizda(1,1)-pizda(2,2)
8631       vv(2)=pizda(1,2)+pizda(2,1)
8632       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8633        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8634 ! Explicit gradient in virtual-dihedral angles.
8635       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8636        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8637        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8638       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8639       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8640       vv(1)=pizda(1,1)-pizda(2,2)
8641       vv(2)=pizda(1,2)+pizda(2,1)
8642       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8643        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8644        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8645       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8646       vv(1)=pizda(1,1)-pizda(2,2)
8647       vv(2)=pizda(1,2)+pizda(2,1)
8648       if (l.eq.j+1) then
8649         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8650          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8651          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8652       else
8653         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8654          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8655          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8656       endif
8657 ! Cartesian gradient
8658       do iii=1,2
8659         do kkk=1,5
8660           do lll=1,3
8661             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8662               pizda(1,1))
8663             vv(1)=pizda(1,1)-pizda(2,2)
8664             vv(2)=pizda(1,2)+pizda(2,1)
8665             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8666              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8667              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8668           enddo
8669         enddo
8670       enddo
8671 !      goto 1112
8672 !1111  continue
8673 ! Contribution from graph II
8674       call transpose2(EE(1,1,itk),auxmat(1,1))
8675       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8676       vv(1)=pizda(1,1)+pizda(2,2)
8677       vv(2)=pizda(2,1)-pizda(1,2)
8678       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8679        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8680 ! Explicit gradient in virtual-dihedral angles.
8681       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8682        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8683       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8684       vv(1)=pizda(1,1)+pizda(2,2)
8685       vv(2)=pizda(2,1)-pizda(1,2)
8686       if (l.eq.j+1) then
8687         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8688          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8689          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8690       else
8691         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8692          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8693          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8694       endif
8695 ! Cartesian gradient
8696       do iii=1,2
8697         do kkk=1,5
8698           do lll=1,3
8699             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8700               pizda(1,1))
8701             vv(1)=pizda(1,1)+pizda(2,2)
8702             vv(2)=pizda(2,1)-pizda(1,2)
8703             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8704              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8705              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8706           enddo
8707         enddo
8708       enddo
8709 !d      goto 1112
8710 !d1111  continue
8711       if (l.eq.j+1) then
8712 !d        goto 1110
8713 ! Parallel orientation
8714 ! Contribution from graph III
8715         call transpose2(EUg(1,1,l),auxmat(1,1))
8716         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8717         vv(1)=pizda(1,1)-pizda(2,2)
8718         vv(2)=pizda(1,2)+pizda(2,1)
8719         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8720          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8721 ! Explicit gradient in virtual-dihedral angles.
8722         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8723          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8724          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8725         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8726         vv(1)=pizda(1,1)-pizda(2,2)
8727         vv(2)=pizda(1,2)+pizda(2,1)
8728         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8729          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8730          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8731         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8732         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8733         vv(1)=pizda(1,1)-pizda(2,2)
8734         vv(2)=pizda(1,2)+pizda(2,1)
8735         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8736          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8737          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8738 ! Cartesian gradient
8739         do iii=1,2
8740           do kkk=1,5
8741             do lll=1,3
8742               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8743                 pizda(1,1))
8744               vv(1)=pizda(1,1)-pizda(2,2)
8745               vv(2)=pizda(1,2)+pizda(2,1)
8746               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8747                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8748                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8749             enddo
8750           enddo
8751         enddo
8752 !d        goto 1112
8753 ! Contribution from graph IV
8754 !d1110    continue
8755         call transpose2(EE(1,1,itl),auxmat(1,1))
8756         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8757         vv(1)=pizda(1,1)+pizda(2,2)
8758         vv(2)=pizda(2,1)-pizda(1,2)
8759         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8760          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8761 ! Explicit gradient in virtual-dihedral angles.
8762         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8763          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8764         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8765         vv(1)=pizda(1,1)+pizda(2,2)
8766         vv(2)=pizda(2,1)-pizda(1,2)
8767         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8768          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8769          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8770 ! Cartesian gradient
8771         do iii=1,2
8772           do kkk=1,5
8773             do lll=1,3
8774               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8775                 pizda(1,1))
8776               vv(1)=pizda(1,1)+pizda(2,2)
8777               vv(2)=pizda(2,1)-pizda(1,2)
8778               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8779                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8780                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8781             enddo
8782           enddo
8783         enddo
8784       else
8785 ! Antiparallel orientation
8786 ! Contribution from graph III
8787 !        goto 1110
8788         call transpose2(EUg(1,1,j),auxmat(1,1))
8789         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8790         vv(1)=pizda(1,1)-pizda(2,2)
8791         vv(2)=pizda(1,2)+pizda(2,1)
8792         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8793          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8794 ! Explicit gradient in virtual-dihedral angles.
8795         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8796          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8797          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8798         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8799         vv(1)=pizda(1,1)-pizda(2,2)
8800         vv(2)=pizda(1,2)+pizda(2,1)
8801         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8802          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8803          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8804         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8805         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8806         vv(1)=pizda(1,1)-pizda(2,2)
8807         vv(2)=pizda(1,2)+pizda(2,1)
8808         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8809          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8810          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8811 ! Cartesian gradient
8812         do iii=1,2
8813           do kkk=1,5
8814             do lll=1,3
8815               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8816                 pizda(1,1))
8817               vv(1)=pizda(1,1)-pizda(2,2)
8818               vv(2)=pizda(1,2)+pizda(2,1)
8819               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8820                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8821                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8822             enddo
8823           enddo
8824         enddo
8825 !d        goto 1112
8826 ! Contribution from graph IV
8827 1110    continue
8828         call transpose2(EE(1,1,itj),auxmat(1,1))
8829         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8830         vv(1)=pizda(1,1)+pizda(2,2)
8831         vv(2)=pizda(2,1)-pizda(1,2)
8832         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8833          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8834 ! Explicit gradient in virtual-dihedral angles.
8835         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8836          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8837         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8838         vv(1)=pizda(1,1)+pizda(2,2)
8839         vv(2)=pizda(2,1)-pizda(1,2)
8840         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8841          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8842          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8843 ! Cartesian gradient
8844         do iii=1,2
8845           do kkk=1,5
8846             do lll=1,3
8847               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8848                 pizda(1,1))
8849               vv(1)=pizda(1,1)+pizda(2,2)
8850               vv(2)=pizda(2,1)-pizda(1,2)
8851               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8852                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8853                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8854             enddo
8855           enddo
8856         enddo
8857       endif
8858 1112  continue
8859       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8860 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8861 !d        write (2,*) 'ijkl',i,j,k,l
8862 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8863 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8864 !d      endif
8865 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8866 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8867 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8868 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8869       if (j.lt.nres-1) then
8870         j1=j+1
8871         j2=j-1
8872       else
8873         j1=j-1
8874         j2=j-2
8875       endif
8876       if (l.lt.nres-1) then
8877         l1=l+1
8878         l2=l-1
8879       else
8880         l1=l-1
8881         l2=l-2
8882       endif
8883 !d      eij=1.0d0
8884 !d      ekl=1.0d0
8885 !d      ekont=1.0d0
8886 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8887 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8888 !        summed up outside the subrouine as for the other subroutines
8889 !        handling long-range interactions. The old code is commented out
8890 !        with "cgrad" to keep track of changes.
8891       do ll=1,3
8892 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8893 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8894         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8895         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8896 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8897 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8898 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8899 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8900 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8901 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8902 !     &   gradcorr5ij,
8903 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8904 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8905 !grad        ghalf=0.5d0*ggg1(ll)
8906 !d        ghalf=0.0d0
8907         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8908         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8909         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8910         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8911         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8912         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8913 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8914 !grad        ghalf=0.5d0*ggg2(ll)
8915         ghalf=0.0d0
8916         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8917         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8918         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8919         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8920         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8921         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8922       enddo
8923 !d      goto 1112
8924 !grad      do m=i+1,j-1
8925 !grad        do ll=1,3
8926 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8927 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8928 !grad        enddo
8929 !grad      enddo
8930 !grad      do m=k+1,l-1
8931 !grad        do ll=1,3
8932 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8933 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8934 !grad        enddo
8935 !grad      enddo
8936 !1112  continue
8937 !grad      do m=i+2,j2
8938 !grad        do ll=1,3
8939 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8940 !grad        enddo
8941 !grad      enddo
8942 !grad      do m=k+2,l2
8943 !grad        do ll=1,3
8944 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8945 !grad        enddo
8946 !grad      enddo
8947 !d      do iii=1,nres-3
8948 !d        write (2,*) iii,g_corr5_loc(iii)
8949 !d      enddo
8950       eello5=ekont*eel5
8951 !d      write (2,*) 'ekont',ekont
8952 !d      write (iout,*) 'eello5',ekont*eel5
8953       return
8954       end function eello5
8955 !-----------------------------------------------------------------------------
8956       real(kind=8) function eello6(i,j,k,l,jj,kk)
8957 !      implicit real*8 (a-h,o-z)
8958 !      include 'DIMENSIONS'
8959 !      include 'COMMON.IOUNITS'
8960 !      include 'COMMON.CHAIN'
8961 !      include 'COMMON.DERIV'
8962 !      include 'COMMON.INTERACT'
8963 !      include 'COMMON.CONTACTS'
8964 !      include 'COMMON.TORSION'
8965 !      include 'COMMON.VAR'
8966 !      include 'COMMON.GEO'
8967 !      include 'COMMON.FFIELD'
8968       real(kind=8),dimension(3) :: ggg1,ggg2
8969       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
8970                    eello6_6,eel6
8971       real(kind=8) :: gradcorr6ij,gradcorr6kl
8972       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8973 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8974 !d        eello6=0.0d0
8975 !d        return
8976 !d      endif
8977 !d      write (iout,*)
8978 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8979 !d     &   ' and',k,l
8980       eello6_1=0.0d0
8981       eello6_2=0.0d0
8982       eello6_3=0.0d0
8983       eello6_4=0.0d0
8984       eello6_5=0.0d0
8985       eello6_6=0.0d0
8986 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8987 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8988       do iii=1,2
8989         do kkk=1,5
8990           do lll=1,3
8991             derx(lll,kkk,iii)=0.0d0
8992           enddo
8993         enddo
8994       enddo
8995 !d      eij=facont_hb(jj,i)
8996 !d      ekl=facont_hb(kk,k)
8997 !d      ekont=eij*ekl
8998 !d      eij=1.0d0
8999 !d      ekl=1.0d0
9000 !d      ekont=1.0d0
9001       if (l.eq.j+1) then
9002         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9003         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9004         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9005         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9006         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9007         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9008       else
9009         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9010         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9011         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9012         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9013         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9014           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9015         else
9016           eello6_5=0.0d0
9017         endif
9018         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9019       endif
9020 ! If turn contributions are considered, they will be handled separately.
9021       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9022 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9023 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9024 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9025 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9026 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9027 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9028 !d      goto 1112
9029       if (j.lt.nres-1) then
9030         j1=j+1
9031         j2=j-1
9032       else
9033         j1=j-1
9034         j2=j-2
9035       endif
9036       if (l.lt.nres-1) then
9037         l1=l+1
9038         l2=l-1
9039       else
9040         l1=l-1
9041         l2=l-2
9042       endif
9043       do ll=1,3
9044 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9045 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9046 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9047 !grad        ghalf=0.5d0*ggg1(ll)
9048 !d        ghalf=0.0d0
9049         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9050         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9051         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9052         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9053         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9054         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9055         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9056         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9057 !grad        ghalf=0.5d0*ggg2(ll)
9058 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9059 !d        ghalf=0.0d0
9060         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9061         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9062         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9063         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9064         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9065         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9066       enddo
9067 !d      goto 1112
9068 !grad      do m=i+1,j-1
9069 !grad        do ll=1,3
9070 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9071 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9072 !grad        enddo
9073 !grad      enddo
9074 !grad      do m=k+1,l-1
9075 !grad        do ll=1,3
9076 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9077 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9078 !grad        enddo
9079 !grad      enddo
9080 !grad1112  continue
9081 !grad      do m=i+2,j2
9082 !grad        do ll=1,3
9083 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9084 !grad        enddo
9085 !grad      enddo
9086 !grad      do m=k+2,l2
9087 !grad        do ll=1,3
9088 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9089 !grad        enddo
9090 !grad      enddo
9091 !d      do iii=1,nres-3
9092 !d        write (2,*) iii,g_corr6_loc(iii)
9093 !d      enddo
9094       eello6=ekont*eel6
9095 !d      write (2,*) 'ekont',ekont
9096 !d      write (iout,*) 'eello6',ekont*eel6
9097       return
9098       end function eello6
9099 !-----------------------------------------------------------------------------
9100       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9101       use comm_kut
9102 !      implicit real*8 (a-h,o-z)
9103 !      include 'DIMENSIONS'
9104 !      include 'COMMON.IOUNITS'
9105 !      include 'COMMON.CHAIN'
9106 !      include 'COMMON.DERIV'
9107 !      include 'COMMON.INTERACT'
9108 !      include 'COMMON.CONTACTS'
9109 !      include 'COMMON.TORSION'
9110 !      include 'COMMON.VAR'
9111 !      include 'COMMON.GEO'
9112       real(kind=8),dimension(2) :: vv,vv1
9113       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9114       logical :: swap
9115 !el      logical :: lprn
9116 !el      common /kutas/ lprn
9117       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9118       real(kind=8) :: s1,s2,s3,s4,s5
9119 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9120 !                                                                              C
9121 !      Parallel       Antiparallel                                             C
9122 !                                                                              C
9123 !          o             o                                                     C
9124 !         /l\           /j\                                                    C
9125 !        /   \         /   \                                                   C
9126 !       /| o |         | o |\                                                  C
9127 !     \ j|/k\|  /   \  |/k\|l /                                                C
9128 !      \ /   \ /     \ /   \ /                                                 C
9129 !       o     o       o     o                                                  C
9130 !       i             i                                                        C
9131 !                                                                              C
9132 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9133       itk=itortyp(itype(k,1))
9134       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9135       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9136       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9137       call transpose2(EUgC(1,1,k),auxmat(1,1))
9138       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9139       vv1(1)=pizda1(1,1)-pizda1(2,2)
9140       vv1(2)=pizda1(1,2)+pizda1(2,1)
9141       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9142       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9143       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9144       s5=scalar2(vv(1),Dtobr2(1,i))
9145 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9146       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9147       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9148        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9149        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9150        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9151        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9152        +scalar2(vv(1),Dtobr2der(1,i)))
9153       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9154       vv1(1)=pizda1(1,1)-pizda1(2,2)
9155       vv1(2)=pizda1(1,2)+pizda1(2,1)
9156       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9157       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9158       if (l.eq.j+1) then
9159         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9160        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9161        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9162        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9163        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9164       else
9165         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9166        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9167        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9168        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9169        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9170       endif
9171       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9172       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9173       vv1(1)=pizda1(1,1)-pizda1(2,2)
9174       vv1(2)=pizda1(1,2)+pizda1(2,1)
9175       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9176        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9177        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9178        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9179       do iii=1,2
9180         if (swap) then
9181           ind=3-iii
9182         else
9183           ind=iii
9184         endif
9185         do kkk=1,5
9186           do lll=1,3
9187             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9188             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9189             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9190             call transpose2(EUgC(1,1,k),auxmat(1,1))
9191             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9192               pizda1(1,1))
9193             vv1(1)=pizda1(1,1)-pizda1(2,2)
9194             vv1(2)=pizda1(1,2)+pizda1(2,1)
9195             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9196             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9197              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9198             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9199              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9200             s5=scalar2(vv(1),Dtobr2(1,i))
9201             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9202           enddo
9203         enddo
9204       enddo
9205       return
9206       end function eello6_graph1
9207 !-----------------------------------------------------------------------------
9208       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9209       use comm_kut
9210 !      implicit real*8 (a-h,o-z)
9211 !      include 'DIMENSIONS'
9212 !      include 'COMMON.IOUNITS'
9213 !      include 'COMMON.CHAIN'
9214 !      include 'COMMON.DERIV'
9215 !      include 'COMMON.INTERACT'
9216 !      include 'COMMON.CONTACTS'
9217 !      include 'COMMON.TORSION'
9218 !      include 'COMMON.VAR'
9219 !      include 'COMMON.GEO'
9220       logical :: swap
9221       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9222       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9223 !el      logical :: lprn
9224 !el      common /kutas/ lprn
9225       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9226       real(kind=8) :: s2,s3,s4
9227 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9228 !                                                                              C
9229 !      Parallel       Antiparallel                                             C
9230 !                                                                              C
9231 !          o             o                                                     C
9232 !     \   /l\           /j\   /                                                C
9233 !      \ /   \         /   \ /                                                 C
9234 !       o| o |         | o |o                                                  C
9235 !     \ j|/k\|      \  |/k\|l                                                  C
9236 !      \ /   \       \ /   \                                                   C
9237 !       o             o                                                        C
9238 !       i             i                                                        C
9239 !                                                                              C
9240 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9241 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9242 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9243 !           but not in a cluster cumulant
9244 #ifdef MOMENT
9245       s1=dip(1,jj,i)*dip(1,kk,k)
9246 #endif
9247       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9248       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9249       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9250       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9251       call transpose2(EUg(1,1,k),auxmat(1,1))
9252       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9253       vv(1)=pizda(1,1)-pizda(2,2)
9254       vv(2)=pizda(1,2)+pizda(2,1)
9255       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9256 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9257 #ifdef MOMENT
9258       eello6_graph2=-(s1+s2+s3+s4)
9259 #else
9260       eello6_graph2=-(s2+s3+s4)
9261 #endif
9262 !      eello6_graph2=-s3
9263 ! Derivatives in gamma(i-1)
9264       if (i.gt.1) then
9265 #ifdef MOMENT
9266         s1=dipderg(1,jj,i)*dip(1,kk,k)
9267 #endif
9268         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9269         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9270         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9271         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9272 #ifdef MOMENT
9273         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9274 #else
9275         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9276 #endif
9277 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9278       endif
9279 ! Derivatives in gamma(k-1)
9280 #ifdef MOMENT
9281       s1=dip(1,jj,i)*dipderg(1,kk,k)
9282 #endif
9283       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9284       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9285       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9286       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9287       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9288       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9289       vv(1)=pizda(1,1)-pizda(2,2)
9290       vv(2)=pizda(1,2)+pizda(2,1)
9291       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9292 #ifdef MOMENT
9293       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9294 #else
9295       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9296 #endif
9297 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9298 ! Derivatives in gamma(j-1) or gamma(l-1)
9299       if (j.gt.1) then
9300 #ifdef MOMENT
9301         s1=dipderg(3,jj,i)*dip(1,kk,k)
9302 #endif
9303         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9304         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9305         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9306         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9307         vv(1)=pizda(1,1)-pizda(2,2)
9308         vv(2)=pizda(1,2)+pizda(2,1)
9309         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9310 #ifdef MOMENT
9311         if (swap) then
9312           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9313         else
9314           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9315         endif
9316 #endif
9317         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9318 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9319       endif
9320 ! Derivatives in gamma(l-1) or gamma(j-1)
9321       if (l.gt.1) then
9322 #ifdef MOMENT
9323         s1=dip(1,jj,i)*dipderg(3,kk,k)
9324 #endif
9325         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9326         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9327         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9328         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9329         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9330         vv(1)=pizda(1,1)-pizda(2,2)
9331         vv(2)=pizda(1,2)+pizda(2,1)
9332         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9333 #ifdef MOMENT
9334         if (swap) then
9335           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9336         else
9337           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9338         endif
9339 #endif
9340         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9341 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9342       endif
9343 ! Cartesian derivatives.
9344       if (lprn) then
9345         write (2,*) 'In eello6_graph2'
9346         do iii=1,2
9347           write (2,*) 'iii=',iii
9348           do kkk=1,5
9349             write (2,*) 'kkk=',kkk
9350             do jjj=1,2
9351               write (2,'(3(2f10.5),5x)') &
9352               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9353             enddo
9354           enddo
9355         enddo
9356       endif
9357       do iii=1,2
9358         do kkk=1,5
9359           do lll=1,3
9360 #ifdef MOMENT
9361             if (iii.eq.1) then
9362               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9363             else
9364               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9365             endif
9366 #endif
9367             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9368               auxvec(1))
9369             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9370             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9371               auxvec(1))
9372             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9373             call transpose2(EUg(1,1,k),auxmat(1,1))
9374             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9375               pizda(1,1))
9376             vv(1)=pizda(1,1)-pizda(2,2)
9377             vv(2)=pizda(1,2)+pizda(2,1)
9378             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9379 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9380 #ifdef MOMENT
9381             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9382 #else
9383             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9384 #endif
9385             if (swap) then
9386               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9387             else
9388               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9389             endif
9390           enddo
9391         enddo
9392       enddo
9393       return
9394       end function eello6_graph2
9395 !-----------------------------------------------------------------------------
9396       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9397 !      implicit real*8 (a-h,o-z)
9398 !      include 'DIMENSIONS'
9399 !      include 'COMMON.IOUNITS'
9400 !      include 'COMMON.CHAIN'
9401 !      include 'COMMON.DERIV'
9402 !      include 'COMMON.INTERACT'
9403 !      include 'COMMON.CONTACTS'
9404 !      include 'COMMON.TORSION'
9405 !      include 'COMMON.VAR'
9406 !      include 'COMMON.GEO'
9407       real(kind=8),dimension(2) :: vv,auxvec
9408       real(kind=8),dimension(2,2) :: pizda,auxmat
9409       logical :: swap
9410       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9411       real(kind=8) :: s1,s2,s3,s4
9412 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9413 !                                                                              C
9414 !      Parallel       Antiparallel                                             C
9415 !                                                                              C
9416 !          o             o                                                     C
9417 !         /l\   /   \   /j\                                                    C
9418 !        /   \ /     \ /   \                                                   C
9419 !       /| o |o       o| o |\                                                  C
9420 !       j|/k\|  /      |/k\|l /                                                C
9421 !        /   \ /       /   \ /                                                 C
9422 !       /     o       /     o                                                  C
9423 !       i             i                                                        C
9424 !                                                                              C
9425 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9426 !
9427 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9428 !           energy moment and not to the cluster cumulant.
9429       iti=itortyp(itype(i,1))
9430       if (j.lt.nres-1) then
9431         itj1=itortyp(itype(j+1,1))
9432       else
9433         itj1=ntortyp+1
9434       endif
9435       itk=itortyp(itype(k,1))
9436       itk1=itortyp(itype(k+1,1))
9437       if (l.lt.nres-1) then
9438         itl1=itortyp(itype(l+1,1))
9439       else
9440         itl1=ntortyp+1
9441       endif
9442 #ifdef MOMENT
9443       s1=dip(4,jj,i)*dip(4,kk,k)
9444 #endif
9445       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9446       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9447       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9448       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9449       call transpose2(EE(1,1,itk),auxmat(1,1))
9450       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9451       vv(1)=pizda(1,1)+pizda(2,2)
9452       vv(2)=pizda(2,1)-pizda(1,2)
9453       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9454 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9455 !d     & "sum",-(s2+s3+s4)
9456 #ifdef MOMENT
9457       eello6_graph3=-(s1+s2+s3+s4)
9458 #else
9459       eello6_graph3=-(s2+s3+s4)
9460 #endif
9461 !      eello6_graph3=-s4
9462 ! Derivatives in gamma(k-1)
9463       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9464       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9465       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9466       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9467 ! Derivatives in gamma(l-1)
9468       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9469       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9470       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9471       vv(1)=pizda(1,1)+pizda(2,2)
9472       vv(2)=pizda(2,1)-pizda(1,2)
9473       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9474       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9475 ! Cartesian derivatives.
9476       do iii=1,2
9477         do kkk=1,5
9478           do lll=1,3
9479 #ifdef MOMENT
9480             if (iii.eq.1) then
9481               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9482             else
9483               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9484             endif
9485 #endif
9486             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9487               auxvec(1))
9488             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9489             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9490               auxvec(1))
9491             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9492             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9493               pizda(1,1))
9494             vv(1)=pizda(1,1)+pizda(2,2)
9495             vv(2)=pizda(2,1)-pizda(1,2)
9496             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9497 #ifdef MOMENT
9498             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9499 #else
9500             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9501 #endif
9502             if (swap) then
9503               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9504             else
9505               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9506             endif
9507 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9508           enddo
9509         enddo
9510       enddo
9511       return
9512       end function eello6_graph3
9513 !-----------------------------------------------------------------------------
9514       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9515 !      implicit real*8 (a-h,o-z)
9516 !      include 'DIMENSIONS'
9517 !      include 'COMMON.IOUNITS'
9518 !      include 'COMMON.CHAIN'
9519 !      include 'COMMON.DERIV'
9520 !      include 'COMMON.INTERACT'
9521 !      include 'COMMON.CONTACTS'
9522 !      include 'COMMON.TORSION'
9523 !      include 'COMMON.VAR'
9524 !      include 'COMMON.GEO'
9525 !      include 'COMMON.FFIELD'
9526       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9527       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9528       logical :: swap
9529       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9530               iii,kkk,lll
9531       real(kind=8) :: s1,s2,s3,s4
9532 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9533 !                                                                              C
9534 !      Parallel       Antiparallel                                             C
9535 !                                                                              C
9536 !          o             o                                                     C
9537 !         /l\   /   \   /j\                                                    C
9538 !        /   \ /     \ /   \                                                   C
9539 !       /| o |o       o| o |\                                                  C
9540 !     \ j|/k\|      \  |/k\|l                                                  C
9541 !      \ /   \       \ /   \                                                   C
9542 !       o     \       o     \                                                  C
9543 !       i             i                                                        C
9544 !                                                                              C
9545 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9546 !
9547 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9548 !           energy moment and not to the cluster cumulant.
9549 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9550       iti=itortyp(itype(i,1))
9551       itj=itortyp(itype(j,1))
9552       if (j.lt.nres-1) then
9553         itj1=itortyp(itype(j+1,1))
9554       else
9555         itj1=ntortyp+1
9556       endif
9557       itk=itortyp(itype(k,1))
9558       if (k.lt.nres-1) then
9559         itk1=itortyp(itype(k+1,1))
9560       else
9561         itk1=ntortyp+1
9562       endif
9563       itl=itortyp(itype(l,1))
9564       if (l.lt.nres-1) then
9565         itl1=itortyp(itype(l+1,1))
9566       else
9567         itl1=ntortyp+1
9568       endif
9569 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9570 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9571 !d     & ' itl',itl,' itl1',itl1
9572 #ifdef MOMENT
9573       if (imat.eq.1) then
9574         s1=dip(3,jj,i)*dip(3,kk,k)
9575       else
9576         s1=dip(2,jj,j)*dip(2,kk,l)
9577       endif
9578 #endif
9579       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9580       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9581       if (j.eq.l+1) then
9582         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9583         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9584       else
9585         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9586         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9587       endif
9588       call transpose2(EUg(1,1,k),auxmat(1,1))
9589       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9590       vv(1)=pizda(1,1)-pizda(2,2)
9591       vv(2)=pizda(2,1)+pizda(1,2)
9592       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9593 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9594 #ifdef MOMENT
9595       eello6_graph4=-(s1+s2+s3+s4)
9596 #else
9597       eello6_graph4=-(s2+s3+s4)
9598 #endif
9599 ! Derivatives in gamma(i-1)
9600       if (i.gt.1) then
9601 #ifdef MOMENT
9602         if (imat.eq.1) then
9603           s1=dipderg(2,jj,i)*dip(3,kk,k)
9604         else
9605           s1=dipderg(4,jj,j)*dip(2,kk,l)
9606         endif
9607 #endif
9608         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9609         if (j.eq.l+1) then
9610           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9611           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9612         else
9613           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9614           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9615         endif
9616         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9617         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9618 !d          write (2,*) 'turn6 derivatives'
9619 #ifdef MOMENT
9620           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9621 #else
9622           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9623 #endif
9624         else
9625 #ifdef MOMENT
9626           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9627 #else
9628           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9629 #endif
9630         endif
9631       endif
9632 ! Derivatives in gamma(k-1)
9633 #ifdef MOMENT
9634       if (imat.eq.1) then
9635         s1=dip(3,jj,i)*dipderg(2,kk,k)
9636       else
9637         s1=dip(2,jj,j)*dipderg(4,kk,l)
9638       endif
9639 #endif
9640       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9641       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9642       if (j.eq.l+1) then
9643         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9644         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9645       else
9646         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9647         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9648       endif
9649       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9650       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9651       vv(1)=pizda(1,1)-pizda(2,2)
9652       vv(2)=pizda(2,1)+pizda(1,2)
9653       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9654       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9655 #ifdef MOMENT
9656         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9657 #else
9658         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9659 #endif
9660       else
9661 #ifdef MOMENT
9662         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9663 #else
9664         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9665 #endif
9666       endif
9667 ! Derivatives in gamma(j-1) or gamma(l-1)
9668       if (l.eq.j+1 .and. l.gt.1) then
9669         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9670         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9671         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9672         vv(1)=pizda(1,1)-pizda(2,2)
9673         vv(2)=pizda(2,1)+pizda(1,2)
9674         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9675         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9676       else if (j.gt.1) then
9677         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9678         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9679         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9680         vv(1)=pizda(1,1)-pizda(2,2)
9681         vv(2)=pizda(2,1)+pizda(1,2)
9682         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9683         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9684           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9685         else
9686           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9687         endif
9688       endif
9689 ! Cartesian derivatives.
9690       do iii=1,2
9691         do kkk=1,5
9692           do lll=1,3
9693 #ifdef MOMENT
9694             if (iii.eq.1) then
9695               if (imat.eq.1) then
9696                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9697               else
9698                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9699               endif
9700             else
9701               if (imat.eq.1) then
9702                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9703               else
9704                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9705               endif
9706             endif
9707 #endif
9708             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9709               auxvec(1))
9710             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9711             if (j.eq.l+1) then
9712               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9713                 b1(1,itj1),auxvec(1))
9714               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9715             else
9716               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9717                 b1(1,itl1),auxvec(1))
9718               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9719             endif
9720             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9721               pizda(1,1))
9722             vv(1)=pizda(1,1)-pizda(2,2)
9723             vv(2)=pizda(2,1)+pizda(1,2)
9724             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9725             if (swap) then
9726               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9727 #ifdef MOMENT
9728                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9729                    -(s1+s2+s4)
9730 #else
9731                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9732                    -(s2+s4)
9733 #endif
9734                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9735               else
9736 #ifdef MOMENT
9737                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9738 #else
9739                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9740 #endif
9741                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9742               endif
9743             else
9744 #ifdef MOMENT
9745               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9746 #else
9747               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9748 #endif
9749               if (l.eq.j+1) then
9750                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9751               else
9752                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9753               endif
9754             endif
9755           enddo
9756         enddo
9757       enddo
9758       return
9759       end function eello6_graph4
9760 !-----------------------------------------------------------------------------
9761       real(kind=8) function eello_turn6(i,jj,kk)
9762 !      implicit real*8 (a-h,o-z)
9763 !      include 'DIMENSIONS'
9764 !      include 'COMMON.IOUNITS'
9765 !      include 'COMMON.CHAIN'
9766 !      include 'COMMON.DERIV'
9767 !      include 'COMMON.INTERACT'
9768 !      include 'COMMON.CONTACTS'
9769 !      include 'COMMON.TORSION'
9770 !      include 'COMMON.VAR'
9771 !      include 'COMMON.GEO'
9772       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9773       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9774       real(kind=8),dimension(3) :: ggg1,ggg2
9775       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9776       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9777 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9778 !           the respective energy moment and not to the cluster cumulant.
9779 !el local variables
9780       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9781       integer :: j1,j2,l1,l2,ll
9782       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9783       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9784       s1=0.0d0
9785       s8=0.0d0
9786       s13=0.0d0
9787 !
9788       eello_turn6=0.0d0
9789       j=i+4
9790       k=i+1
9791       l=i+3
9792       iti=itortyp(itype(i,1))
9793       itk=itortyp(itype(k,1))
9794       itk1=itortyp(itype(k+1,1))
9795       itl=itortyp(itype(l,1))
9796       itj=itortyp(itype(j,1))
9797 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9798 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9799 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9800 !d        eello6=0.0d0
9801 !d        return
9802 !d      endif
9803 !d      write (iout,*)
9804 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9805 !d     &   ' and',k,l
9806 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9807       do iii=1,2
9808         do kkk=1,5
9809           do lll=1,3
9810             derx_turn(lll,kkk,iii)=0.0d0
9811           enddo
9812         enddo
9813       enddo
9814 !d      eij=1.0d0
9815 !d      ekl=1.0d0
9816 !d      ekont=1.0d0
9817       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9818 !d      eello6_5=0.0d0
9819 !d      write (2,*) 'eello6_5',eello6_5
9820 #ifdef MOMENT
9821       call transpose2(AEA(1,1,1),auxmat(1,1))
9822       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9823       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9824       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9825 #endif
9826       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9827       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9828       s2 = scalar2(b1(1,itk),vtemp1(1))
9829 #ifdef MOMENT
9830       call transpose2(AEA(1,1,2),atemp(1,1))
9831       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9832       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9833       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9834 #endif
9835       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9836       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9837       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9838 #ifdef MOMENT
9839       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9840       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9841       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9842       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9843       ss13 = scalar2(b1(1,itk),vtemp4(1))
9844       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9845 #endif
9846 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9847 !      s1=0.0d0
9848 !      s2=0.0d0
9849 !      s8=0.0d0
9850 !      s12=0.0d0
9851 !      s13=0.0d0
9852       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9853 ! Derivatives in gamma(i+2)
9854       s1d =0.0d0
9855       s8d =0.0d0
9856 #ifdef MOMENT
9857       call transpose2(AEA(1,1,1),auxmatd(1,1))
9858       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9859       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9860       call transpose2(AEAderg(1,1,2),atempd(1,1))
9861       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9862       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9863 #endif
9864       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9865       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9866       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9867 !      s1d=0.0d0
9868 !      s2d=0.0d0
9869 !      s8d=0.0d0
9870 !      s12d=0.0d0
9871 !      s13d=0.0d0
9872       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9873 ! Derivatives in gamma(i+3)
9874 #ifdef MOMENT
9875       call transpose2(AEA(1,1,1),auxmatd(1,1))
9876       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9877       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9878       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9879 #endif
9880       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9881       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9882       s2d = scalar2(b1(1,itk),vtemp1d(1))
9883 #ifdef MOMENT
9884       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9885       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9886 #endif
9887       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9888 #ifdef MOMENT
9889       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9890       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9891       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9892 #endif
9893 !      s1d=0.0d0
9894 !      s2d=0.0d0
9895 !      s8d=0.0d0
9896 !      s12d=0.0d0
9897 !      s13d=0.0d0
9898 #ifdef MOMENT
9899       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9900                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9901 #else
9902       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9903                     -0.5d0*ekont*(s2d+s12d)
9904 #endif
9905 ! Derivatives in gamma(i+4)
9906       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9907       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9908       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9909 #ifdef MOMENT
9910       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9911       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9912       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9913 #endif
9914 !      s1d=0.0d0
9915 !      s2d=0.0d0
9916 !      s8d=0.0d0
9917 !      s12d=0.0d0
9918 !      s13d=0.0d0
9919 #ifdef MOMENT
9920       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9921 #else
9922       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9923 #endif
9924 ! Derivatives in gamma(i+5)
9925 #ifdef MOMENT
9926       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9927       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9928       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9929 #endif
9930       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9931       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9932       s2d = scalar2(b1(1,itk),vtemp1d(1))
9933 #ifdef MOMENT
9934       call transpose2(AEA(1,1,2),atempd(1,1))
9935       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9936       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9937 #endif
9938       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9939       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9940 #ifdef MOMENT
9941       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9942       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9943       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9944 #endif
9945 !      s1d=0.0d0
9946 !      s2d=0.0d0
9947 !      s8d=0.0d0
9948 !      s12d=0.0d0
9949 !      s13d=0.0d0
9950 #ifdef MOMENT
9951       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9952                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9953 #else
9954       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9955                     -0.5d0*ekont*(s2d+s12d)
9956 #endif
9957 ! Cartesian derivatives
9958       do iii=1,2
9959         do kkk=1,5
9960           do lll=1,3
9961 #ifdef MOMENT
9962             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9963             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9964             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9965 #endif
9966             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9967             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
9968                 vtemp1d(1))
9969             s2d = scalar2(b1(1,itk),vtemp1d(1))
9970 #ifdef MOMENT
9971             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9972             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9973             s8d = -(atempd(1,1)+atempd(2,2))* &
9974                  scalar2(cc(1,1,itl),vtemp2(1))
9975 #endif
9976             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
9977                  auxmatd(1,1))
9978             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9979             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9980 !      s1d=0.0d0
9981 !      s2d=0.0d0
9982 !      s8d=0.0d0
9983 !      s12d=0.0d0
9984 !      s13d=0.0d0
9985 #ifdef MOMENT
9986             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9987               - 0.5d0*(s1d+s2d)
9988 #else
9989             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9990               - 0.5d0*s2d
9991 #endif
9992 #ifdef MOMENT
9993             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9994               - 0.5d0*(s8d+s12d)
9995 #else
9996             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9997               - 0.5d0*s12d
9998 #endif
9999           enddo
10000         enddo
10001       enddo
10002 #ifdef MOMENT
10003       do kkk=1,5
10004         do lll=1,3
10005           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10006             achuj_tempd(1,1))
10007           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10008           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10009           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10010           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10011           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10012             vtemp4d(1))
10013           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10014           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10015           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10016         enddo
10017       enddo
10018 #endif
10019 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10020 !d     &  16*eel_turn6_num
10021 !d      goto 1112
10022       if (j.lt.nres-1) then
10023         j1=j+1
10024         j2=j-1
10025       else
10026         j1=j-1
10027         j2=j-2
10028       endif
10029       if (l.lt.nres-1) then
10030         l1=l+1
10031         l2=l-1
10032       else
10033         l1=l-1
10034         l2=l-2
10035       endif
10036       do ll=1,3
10037 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10038 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10039 !grad        ghalf=0.5d0*ggg1(ll)
10040 !d        ghalf=0.0d0
10041         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10042         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10043         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10044           +ekont*derx_turn(ll,2,1)
10045         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10046         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10047           +ekont*derx_turn(ll,4,1)
10048         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10049         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10050         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10051 !grad        ghalf=0.5d0*ggg2(ll)
10052 !d        ghalf=0.0d0
10053         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10054           +ekont*derx_turn(ll,2,2)
10055         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10056         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10057           +ekont*derx_turn(ll,4,2)
10058         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10059         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10060         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10061       enddo
10062 !d      goto 1112
10063 !grad      do m=i+1,j-1
10064 !grad        do ll=1,3
10065 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10066 !grad        enddo
10067 !grad      enddo
10068 !grad      do m=k+1,l-1
10069 !grad        do ll=1,3
10070 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10071 !grad        enddo
10072 !grad      enddo
10073 !grad1112  continue
10074 !grad      do m=i+2,j2
10075 !grad        do ll=1,3
10076 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10077 !grad        enddo
10078 !grad      enddo
10079 !grad      do m=k+2,l2
10080 !grad        do ll=1,3
10081 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10082 !grad        enddo
10083 !grad      enddo
10084 !d      do iii=1,nres-3
10085 !d        write (2,*) iii,g_corr6_loc(iii)
10086 !d      enddo
10087       eello_turn6=ekont*eel_turn6
10088 !d      write (2,*) 'ekont',ekont
10089 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10090       return
10091       end function eello_turn6
10092 !-----------------------------------------------------------------------------
10093       subroutine MATVEC2(A1,V1,V2)
10094 !DIR$ INLINEALWAYS MATVEC2
10095 #ifndef OSF
10096 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10097 #endif
10098 !      implicit real*8 (a-h,o-z)
10099 !      include 'DIMENSIONS'
10100       real(kind=8),dimension(2) :: V1,V2
10101       real(kind=8),dimension(2,2) :: A1
10102       real(kind=8) :: vaux1,vaux2
10103 !      DO 1 I=1,2
10104 !        VI=0.0
10105 !        DO 3 K=1,2
10106 !    3     VI=VI+A1(I,K)*V1(K)
10107 !        Vaux(I)=VI
10108 !    1 CONTINUE
10109
10110       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10111       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10112
10113       v2(1)=vaux1
10114       v2(2)=vaux2
10115       end subroutine MATVEC2
10116 !-----------------------------------------------------------------------------
10117       subroutine MATMAT2(A1,A2,A3)
10118 #ifndef OSF
10119 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10120 #endif
10121 !      implicit real*8 (a-h,o-z)
10122 !      include 'DIMENSIONS'
10123       real(kind=8),dimension(2,2) :: A1,A2,A3
10124       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10125 !      DIMENSION AI3(2,2)
10126 !        DO  J=1,2
10127 !          A3IJ=0.0
10128 !          DO K=1,2
10129 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10130 !          enddo
10131 !          A3(I,J)=A3IJ
10132 !       enddo
10133 !      enddo
10134
10135       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10136       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10137       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10138       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10139
10140       A3(1,1)=AI3_11
10141       A3(2,1)=AI3_21
10142       A3(1,2)=AI3_12
10143       A3(2,2)=AI3_22
10144       end subroutine MATMAT2
10145 !-----------------------------------------------------------------------------
10146       real(kind=8) function scalar2(u,v)
10147 !DIR$ INLINEALWAYS scalar2
10148       implicit none
10149       real(kind=8),dimension(2) :: u,v
10150       real(kind=8) :: sc
10151       integer :: i
10152       scalar2=u(1)*v(1)+u(2)*v(2)
10153       return
10154       end function scalar2
10155 !-----------------------------------------------------------------------------
10156       subroutine transpose2(a,at)
10157 !DIR$ INLINEALWAYS transpose2
10158 #ifndef OSF
10159 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10160 #endif
10161       implicit none
10162       real(kind=8),dimension(2,2) :: a,at
10163       at(1,1)=a(1,1)
10164       at(1,2)=a(2,1)
10165       at(2,1)=a(1,2)
10166       at(2,2)=a(2,2)
10167       return
10168       end subroutine transpose2
10169 !-----------------------------------------------------------------------------
10170       subroutine transpose(n,a,at)
10171       implicit none
10172       integer :: n,i,j
10173       real(kind=8),dimension(n,n) :: a,at
10174       do i=1,n
10175         do j=1,n
10176           at(j,i)=a(i,j)
10177         enddo
10178       enddo
10179       return
10180       end subroutine transpose
10181 !-----------------------------------------------------------------------------
10182       subroutine prodmat3(a1,a2,kk,transp,prod)
10183 !DIR$ INLINEALWAYS prodmat3
10184 #ifndef OSF
10185 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10186 #endif
10187       implicit none
10188       integer :: i,j
10189       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10190       logical :: transp
10191 !rc      double precision auxmat(2,2),prod_(2,2)
10192
10193       if (transp) then
10194 !rc        call transpose2(kk(1,1),auxmat(1,1))
10195 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10196 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10197
10198            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10199        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10200            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10201        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10202            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10203        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10204            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10205        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10206
10207       else
10208 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10209 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10210
10211            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10212         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10213            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10214         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10215            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10216         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10217            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10218         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10219
10220       endif
10221 !      call transpose2(a2(1,1),a2t(1,1))
10222
10223 !rc      print *,transp
10224 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10225 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10226
10227       return
10228       end subroutine prodmat3
10229 !-----------------------------------------------------------------------------
10230 ! energy_p_new_barrier.F
10231 !-----------------------------------------------------------------------------
10232       subroutine sum_gradient
10233 !      implicit real*8 (a-h,o-z)
10234       use io_base, only: pdbout
10235 !      include 'DIMENSIONS'
10236 #ifndef ISNAN
10237       external proc_proc
10238 #ifdef WINPGI
10239 !MS$ATTRIBUTES C ::  proc_proc
10240 #endif
10241 #endif
10242 #ifdef MPI
10243       include 'mpif.h'
10244 #endif
10245       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10246                    gloc_scbuf !(3,maxres)
10247
10248       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10249 !#endif
10250 !el local variables
10251       integer :: i,j,k,ierror,ierr
10252       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10253                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10254                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10255                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10256                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10257                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10258                    gsccorr_max,gsccorrx_max,time00
10259
10260 !      include 'COMMON.SETUP'
10261 !      include 'COMMON.IOUNITS'
10262 !      include 'COMMON.FFIELD'
10263 !      include 'COMMON.DERIV'
10264 !      include 'COMMON.INTERACT'
10265 !      include 'COMMON.SBRIDGE'
10266 !      include 'COMMON.CHAIN'
10267 !      include 'COMMON.VAR'
10268 !      include 'COMMON.CONTROL'
10269 !      include 'COMMON.TIME1'
10270 !      include 'COMMON.MAXGRAD'
10271 !      include 'COMMON.SCCOR'
10272 #ifdef TIMING
10273       time01=MPI_Wtime()
10274 #endif
10275 #ifdef DEBUG
10276       write (iout,*) "sum_gradient gvdwc, gvdwx"
10277       do i=1,nres
10278         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10279          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10280       enddo
10281       call flush(iout)
10282 #endif
10283 #ifdef MPI
10284         gradbufc=0.0d0
10285         gradbufx=0.0d0
10286         gradbufc_sum=0.0d0
10287         gloc_scbuf=0.0d0
10288         glocbuf=0.0d0
10289 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10290         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10291           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10292 #endif
10293 !
10294 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10295 !            in virtual-bond-vector coordinates
10296 !
10297 #ifdef DEBUG
10298 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10299 !      do i=1,nres-1
10300 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10301 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10302 !      enddo
10303 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10304 !      do i=1,nres-1
10305 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10306 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10307 !      enddo
10308       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10309       do i=1,nres
10310         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10311          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10312          (gvdwc_scpp(j,i),j=1,3)
10313       enddo
10314       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10315       do i=1,nres
10316         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10317          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10318          (gelc_loc_long(j,i),j=1,3)
10319       enddo
10320       call flush(iout)
10321 #endif
10322 #ifdef SPLITELE
10323       do i=0,nct
10324         do j=1,3
10325           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10326                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10327                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10328                       wel_loc*gel_loc_long(j,i)+ &
10329                       wcorr*gradcorr_long(j,i)+ &
10330                       wcorr5*gradcorr5_long(j,i)+ &
10331                       wcorr6*gradcorr6_long(j,i)+ &
10332                       wturn6*gcorr6_turn_long(j,i)+ &
10333                       wstrain*ghpbc(j,i) &
10334                      +wliptran*gliptranc(j,i) &
10335                      +gradafm(j,i) &
10336                      +welec*gshieldc(j,i) &
10337                      +wcorr*gshieldc_ec(j,i) &
10338                      +wturn3*gshieldc_t3(j,i)&
10339                      +wturn4*gshieldc_t4(j,i)&
10340                      +wel_loc*gshieldc_ll(j,i)&
10341                      +wtube*gg_tube(j,i) &
10342                      +wbond_nucl*gradb_nucl(j,i)
10343         enddo
10344       enddo
10345 #else
10346       do i=0,nct
10347         do j=1,3
10348           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10349                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10350                       welec*gelc_long(j,i)+ &
10351                       wbond*gradb(j,i)+ &
10352                       wel_loc*gel_loc_long(j,i)+ &
10353                       wcorr*gradcorr_long(j,i)+ &
10354                       wcorr5*gradcorr5_long(j,i)+ &
10355                       wcorr6*gradcorr6_long(j,i)+ &
10356                       wturn6*gcorr6_turn_long(j,i)+ &
10357                       wstrain*ghpbc(j,i) &
10358                      +wliptran*gliptranc(j,i) &
10359                      +gradafm(j,i) &
10360                      +welec*gshieldc(j,i)&
10361                      +wcorr*gshieldc_ec(j,i) &
10362                      +wturn4*gshieldc_t4(j,i) &
10363                      +wel_loc*gshieldc_ll(j,i)&
10364                      +wtube*gg_tube(j,i) &
10365                      +wbond_nucl*gradb_nucl(j,i)
10366
10367         enddo
10368       enddo
10369 #endif
10370 #ifdef MPI
10371       if (nfgtasks.gt.1) then
10372       time00=MPI_Wtime()
10373 #ifdef DEBUG
10374       write (iout,*) "gradbufc before allreduce"
10375       do i=1,nres
10376         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10377       enddo
10378       call flush(iout)
10379 #endif
10380       do i=0,nres
10381         do j=1,3
10382           gradbufc_sum(j,i)=gradbufc(j,i)
10383         enddo
10384       enddo
10385 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10386 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10387 !      time_reduce=time_reduce+MPI_Wtime()-time00
10388 #ifdef DEBUG
10389 !      write (iout,*) "gradbufc_sum after allreduce"
10390 !      do i=1,nres
10391 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10392 !      enddo
10393 !      call flush(iout)
10394 #endif
10395 #ifdef TIMING
10396 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10397 #endif
10398       do i=0,nres
10399         do k=1,3
10400           gradbufc(k,i)=0.0d0
10401         enddo
10402       enddo
10403 #ifdef DEBUG
10404       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10405       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10406                         " jgrad_end  ",jgrad_end(i),&
10407                         i=igrad_start,igrad_end)
10408 #endif
10409 !
10410 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10411 ! do not parallelize this part.
10412 !
10413 !      do i=igrad_start,igrad_end
10414 !        do j=jgrad_start(i),jgrad_end(i)
10415 !          do k=1,3
10416 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10417 !          enddo
10418 !        enddo
10419 !      enddo
10420       do j=1,3
10421         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10422       enddo
10423       do i=nres-2,-1,-1
10424         do j=1,3
10425           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10426         enddo
10427       enddo
10428 #ifdef DEBUG
10429       write (iout,*) "gradbufc after summing"
10430       do i=1,nres
10431         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10432       enddo
10433       call flush(iout)
10434 #endif
10435       else
10436 #endif
10437 !el#define DEBUG
10438 #ifdef DEBUG
10439       write (iout,*) "gradbufc"
10440       do i=1,nres
10441         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10442       enddo
10443       call flush(iout)
10444 #endif
10445 !el#undef DEBUG
10446       do i=-1,nres
10447         do j=1,3
10448           gradbufc_sum(j,i)=gradbufc(j,i)
10449           gradbufc(j,i)=0.0d0
10450         enddo
10451       enddo
10452       do j=1,3
10453         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10454       enddo
10455       do i=nres-2,-1,-1
10456         do j=1,3
10457           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10458         enddo
10459       enddo
10460 !      do i=nnt,nres-1
10461 !        do k=1,3
10462 !          gradbufc(k,i)=0.0d0
10463 !        enddo
10464 !        do j=i+1,nres
10465 !          do k=1,3
10466 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10467 !          enddo
10468 !        enddo
10469 !      enddo
10470 !el#define DEBUG
10471 #ifdef DEBUG
10472       write (iout,*) "gradbufc after summing"
10473       do i=1,nres
10474         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10475       enddo
10476       call flush(iout)
10477 #endif
10478 !el#undef DEBUG
10479 #ifdef MPI
10480       endif
10481 #endif
10482       do k=1,3
10483         gradbufc(k,nres)=0.0d0
10484       enddo
10485 !el----------------
10486 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10487 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10488 !el-----------------
10489       do i=-1,nct
10490         do j=1,3
10491 #ifdef SPLITELE
10492           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10493                       wel_loc*gel_loc(j,i)+ &
10494                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10495                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10496                       wel_loc*gel_loc_long(j,i)+ &
10497                       wcorr*gradcorr_long(j,i)+ &
10498                       wcorr5*gradcorr5_long(j,i)+ &
10499                       wcorr6*gradcorr6_long(j,i)+ &
10500                       wturn6*gcorr6_turn_long(j,i))+ &
10501                       wbond*gradb(j,i)+ &
10502                       wcorr*gradcorr(j,i)+ &
10503                       wturn3*gcorr3_turn(j,i)+ &
10504                       wturn4*gcorr4_turn(j,i)+ &
10505                       wcorr5*gradcorr5(j,i)+ &
10506                       wcorr6*gradcorr6(j,i)+ &
10507                       wturn6*gcorr6_turn(j,i)+ &
10508                       wsccor*gsccorc(j,i) &
10509                      +wscloc*gscloc(j,i)  &
10510                      +wliptran*gliptranc(j,i) &
10511                      +gradafm(j,i) &
10512                      +welec*gshieldc(j,i) &
10513                      +welec*gshieldc_loc(j,i) &
10514                      +wcorr*gshieldc_ec(j,i) &
10515                      +wcorr*gshieldc_loc_ec(j,i) &
10516                      +wturn3*gshieldc_t3(j,i) &
10517                      +wturn3*gshieldc_loc_t3(j,i) &
10518                      +wturn4*gshieldc_t4(j,i) &
10519                      +wturn4*gshieldc_loc_t4(j,i) &
10520                      +wel_loc*gshieldc_ll(j,i) &
10521                      +wel_loc*gshieldc_loc_ll(j,i) &
10522                      +wtube*gg_tube(j,i) &
10523                      +wbond_nucl*gradb_nucl(j,i)
10524
10525
10526
10527 #else
10528           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10529                       wel_loc*gel_loc(j,i)+ &
10530                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10531                       welec*gelc_long(j,i)+ &
10532                       wel_loc*gel_loc_long(j,i)+ &
10533 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10534                       wcorr5*gradcorr5_long(j,i)+ &
10535                       wcorr6*gradcorr6_long(j,i)+ &
10536                       wturn6*gcorr6_turn_long(j,i))+ &
10537                       wbond*gradb(j,i)+ &
10538                       wcorr*gradcorr(j,i)+ &
10539                       wturn3*gcorr3_turn(j,i)+ &
10540                       wturn4*gcorr4_turn(j,i)+ &
10541                       wcorr5*gradcorr5(j,i)+ &
10542                       wcorr6*gradcorr6(j,i)+ &
10543                       wturn6*gcorr6_turn(j,i)+ &
10544                       wsccor*gsccorc(j,i) &
10545                      +wscloc*gscloc(j,i) &
10546                      +gradafm(j,i) &
10547                      +wliptran*gliptranc(j,i) &
10548                      +welec*gshieldc(j,i) &
10549                      +welec*gshieldc_loc(j,) &
10550                      +wcorr*gshieldc_ec(j,i) &
10551                      +wcorr*gshieldc_loc_ec(j,i) &
10552                      +wturn3*gshieldc_t3(j,i) &
10553                      +wturn3*gshieldc_loc_t3(j,i) &
10554                      +wturn4*gshieldc_t4(j,i) &
10555                      +wturn4*gshieldc_loc_t4(j,i) &
10556                      +wel_loc*gshieldc_ll(j,i) &
10557                      +wel_loc*gshieldc_loc_ll(j,i) &
10558                      +wtube*gg_tube(j,i) &
10559                      +wbond_nucl*gradb_nucl(j,i)
10560
10561
10562
10563
10564 #endif
10565           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10566                         wbond*gradbx(j,i)+ &
10567                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10568                         wsccor*gsccorx(j,i) &
10569                        +wscloc*gsclocx(j,i) &
10570                        +wliptran*gliptranx(j,i) &
10571                        +welec*gshieldx(j,i)     &
10572                        +wcorr*gshieldx_ec(j,i)  &
10573                        +wturn3*gshieldx_t3(j,i) &
10574                        +wturn4*gshieldx_t4(j,i) &
10575                        +wel_loc*gshieldx_ll(j,i)&
10576                        +wtube*gg_tube_sc(j,i)   &
10577                        +wbond_nucl*gradbx_nucl(j,i)
10578
10579
10580
10581         enddo
10582       enddo
10583 #ifdef DEBUG
10584       write (iout,*) "gloc before adding corr"
10585       do i=1,4*nres
10586         write (iout,*) i,gloc(i,icg)
10587       enddo
10588 #endif
10589       do i=1,nres-3
10590         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10591          +wcorr5*g_corr5_loc(i) &
10592          +wcorr6*g_corr6_loc(i) &
10593          +wturn4*gel_loc_turn4(i) &
10594          +wturn3*gel_loc_turn3(i) &
10595          +wturn6*gel_loc_turn6(i) &
10596          +wel_loc*gel_loc_loc(i)
10597       enddo
10598 #ifdef DEBUG
10599       write (iout,*) "gloc after adding corr"
10600       do i=1,4*nres
10601         write (iout,*) i,gloc(i,icg)
10602       enddo
10603 #endif
10604 #ifdef MPI
10605       if (nfgtasks.gt.1) then
10606         do j=1,3
10607           do i=1,nres
10608             gradbufc(j,i)=gradc(j,i,icg)
10609             gradbufx(j,i)=gradx(j,i,icg)
10610           enddo
10611         enddo
10612         do i=1,4*nres
10613           glocbuf(i)=gloc(i,icg)
10614         enddo
10615 !#define DEBUG
10616 #ifdef DEBUG
10617       write (iout,*) "gloc_sc before reduce"
10618       do i=1,nres
10619        do j=1,1
10620         write (iout,*) i,j,gloc_sc(j,i,icg)
10621        enddo
10622       enddo
10623 #endif
10624 !#undef DEBUG
10625         do i=1,nres
10626          do j=1,3
10627           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10628          enddo
10629         enddo
10630         time00=MPI_Wtime()
10631         call MPI_Barrier(FG_COMM,IERR)
10632         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10633         time00=MPI_Wtime()
10634         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10635           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10636         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
10637           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10638         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10639           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10640         time_reduce=time_reduce+MPI_Wtime()-time00
10641         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10642           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10643         time_reduce=time_reduce+MPI_Wtime()-time00
10644 !#define DEBUG
10645 #ifdef DEBUG
10646       write (iout,*) "gloc_sc after reduce"
10647       do i=1,nres
10648        do j=1,1
10649         write (iout,*) i,j,gloc_sc(j,i,icg)
10650        enddo
10651       enddo
10652 #endif
10653 !#undef DEBUG
10654 #ifdef DEBUG
10655       write (iout,*) "gloc after reduce"
10656       do i=1,4*nres
10657         write (iout,*) i,gloc(i,icg)
10658       enddo
10659 #endif
10660       endif
10661 #endif
10662       if (gnorm_check) then
10663 !
10664 ! Compute the maximum elements of the gradient
10665 !
10666       gvdwc_max=0.0d0
10667       gvdwc_scp_max=0.0d0
10668       gelc_max=0.0d0
10669       gvdwpp_max=0.0d0
10670       gradb_max=0.0d0
10671       ghpbc_max=0.0d0
10672       gradcorr_max=0.0d0
10673       gel_loc_max=0.0d0
10674       gcorr3_turn_max=0.0d0
10675       gcorr4_turn_max=0.0d0
10676       gradcorr5_max=0.0d0
10677       gradcorr6_max=0.0d0
10678       gcorr6_turn_max=0.0d0
10679       gsccorc_max=0.0d0
10680       gscloc_max=0.0d0
10681       gvdwx_max=0.0d0
10682       gradx_scp_max=0.0d0
10683       ghpbx_max=0.0d0
10684       gradxorr_max=0.0d0
10685       gsccorx_max=0.0d0
10686       gsclocx_max=0.0d0
10687       do i=1,nct
10688         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10689         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10690         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10691         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10692          gvdwc_scp_max=gvdwc_scp_norm
10693         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10694         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10695         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10696         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10697         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10698         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10699         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10700         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10701         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10702         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10703         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10704         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10705         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10706           gcorr3_turn(1,i)))
10707         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10708           gcorr3_turn_max=gcorr3_turn_norm
10709         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10710           gcorr4_turn(1,i)))
10711         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10712           gcorr4_turn_max=gcorr4_turn_norm
10713         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10714         if (gradcorr5_norm.gt.gradcorr5_max) &
10715           gradcorr5_max=gradcorr5_norm
10716         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10717         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10718         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10719           gcorr6_turn(1,i)))
10720         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10721           gcorr6_turn_max=gcorr6_turn_norm
10722         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10723         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10724         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10725         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10726         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10727         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10728         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10729         if (gradx_scp_norm.gt.gradx_scp_max) &
10730           gradx_scp_max=gradx_scp_norm
10731         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10732         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10733         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10734         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10735         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10736         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10737         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10738         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10739       enddo
10740       if (gradout) then
10741 #ifdef AIX
10742         open(istat,file=statname,position="append")
10743 #else
10744         open(istat,file=statname,access="append")
10745 #endif
10746         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10747            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10748            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10749            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10750            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10751            gsccorx_max,gsclocx_max
10752         close(istat)
10753         if (gvdwc_max.gt.1.0d4) then
10754           write (iout,*) "gvdwc gvdwx gradb gradbx"
10755           do i=nnt,nct
10756             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10757               gradb(j,i),gradbx(j,i),j=1,3)
10758           enddo
10759           call pdbout(0.0d0,'cipiszcze',iout)
10760           call flush(iout)
10761         endif
10762       endif
10763       endif
10764 !el#define DEBUG
10765 #ifdef DEBUG
10766       write (iout,*) "gradc gradx gloc"
10767       do i=1,nres
10768         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10769          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10770       enddo
10771 #endif
10772 !el#undef DEBUG
10773 #ifdef TIMING
10774       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10775 #endif
10776       return
10777       end subroutine sum_gradient
10778 !-----------------------------------------------------------------------------
10779       subroutine sc_grad
10780 !      implicit real*8 (a-h,o-z)
10781       use calc_data
10782 !      include 'DIMENSIONS'
10783 !      include 'COMMON.CHAIN'
10784 !      include 'COMMON.DERIV'
10785 !      include 'COMMON.CALC'
10786 !      include 'COMMON.IOUNITS'
10787       real(kind=8), dimension(3) :: dcosom1,dcosom2
10788 !      print *,"wchodze"
10789       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10790       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10791       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10792            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10793 ! diagnostics only
10794 !      eom1=0.0d0
10795 !      eom2=0.0d0
10796 !      eom12=evdwij*eps1_om12
10797 ! end diagnostics
10798 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10799 !       " sigder",sigder
10800 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10801 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10802 !C      print *,sss_ele_cut,'in sc_grad'
10803       do k=1,3
10804         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10805         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10806       enddo
10807       do k=1,3
10808         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10809 !C      print *,'gg',k,gg(k)
10810        enddo
10811 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10812 !      write (iout,*) "gg",(gg(k),k=1,3)
10813       do k=1,3
10814         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10815                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10816                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10817                   *sss_ele_cut
10818
10819         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10820                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10821                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10822                   *sss_ele_cut
10823
10824 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10825 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10826 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10827 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10828       enddo
10829 !
10830 ! Calculate the components of the gradient in DC and X
10831 !
10832 !grad      do k=i,j-1
10833 !grad        do l=1,3
10834 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10835 !grad        enddo
10836 !grad      enddo
10837       do l=1,3
10838         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10839         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10840       enddo
10841       return
10842       end subroutine sc_grad
10843 #ifdef CRYST_THETA
10844 !-----------------------------------------------------------------------------
10845       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
10846
10847       use comm_calcthet
10848 !      implicit real*8 (a-h,o-z)
10849 !      include 'DIMENSIONS'
10850 !      include 'COMMON.LOCAL'
10851 !      include 'COMMON.IOUNITS'
10852 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
10853 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10854 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
10855       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
10856       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
10857 !el      integer :: it
10858 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
10859 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10860 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
10861 !el local variables
10862
10863       delthec=thetai-thet_pred_mean
10864       delthe0=thetai-theta0i
10865 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
10866       t3 = thetai-thet_pred_mean
10867       t6 = t3**2
10868       t9 = term1
10869       t12 = t3*sigcsq
10870       t14 = t12+t6*sigsqtc
10871       t16 = 1.0d0
10872       t21 = thetai-theta0i
10873       t23 = t21**2
10874       t26 = term2
10875       t27 = t21*t26
10876       t32 = termexp
10877       t40 = t32**2
10878       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
10879        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
10880        *(-t12*t9-ak*sig0inv*t27)
10881       return
10882       end subroutine mixder
10883 #endif
10884 !-----------------------------------------------------------------------------
10885 ! cartder.F
10886 !-----------------------------------------------------------------------------
10887       subroutine cartder
10888 !-----------------------------------------------------------------------------
10889 ! This subroutine calculates the derivatives of the consecutive virtual
10890 ! bond vectors and the SC vectors in the virtual-bond angles theta and
10891 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
10892 ! in the angles alpha and omega, describing the location of a side chain
10893 ! in its local coordinate system.
10894 !
10895 ! The derivatives are stored in the following arrays:
10896 !
10897 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
10898 ! The structure is as follows:
10899 !
10900 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
10901 ! 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)
10902 !         . . . . . . . . . . . .  . . . . . .
10903 ! 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)
10904 !                          .
10905 !                          .
10906 !                          .
10907 ! 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)
10908 !
10909 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
10910 ! The structure is same as above.
10911 !
10912 ! DCDS - the derivatives of the side chain vectors in the local spherical
10913 ! andgles alph and omega:
10914 !
10915 ! 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)
10916 ! 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)
10917 !                          .
10918 !                          .
10919 !                          .
10920 ! 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)
10921 !
10922 ! Version of March '95, based on an early version of November '91.
10923 !
10924 !**********************************************************************
10925 !      implicit real*8 (a-h,o-z)
10926 !      include 'DIMENSIONS'
10927 !      include 'COMMON.VAR'
10928 !      include 'COMMON.CHAIN'
10929 !      include 'COMMON.DERIV'
10930 !      include 'COMMON.GEO'
10931 !      include 'COMMON.LOCAL'
10932 !      include 'COMMON.INTERACT'
10933       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
10934       real(kind=8),dimension(3,3) :: dp,temp
10935 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
10936       real(kind=8),dimension(3) :: xx,xx1
10937 !el local variables
10938       integer :: i,k,l,j,m,ind,ind1,jjj
10939       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
10940                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
10941                  sint2,xp,yp,xxp,yyp,zzp,dj
10942
10943 !      common /przechowalnia/ fromto
10944       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
10945 ! get the position of the jth ijth fragment of the chain coordinate system
10946 ! in the fromto array.
10947 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10948 !
10949 !      maxdim=(nres-1)*(nres-2)/2
10950 !      allocate(dcdv(6,maxdim),dxds(6,nres))
10951 ! calculate the derivatives of transformation matrix elements in theta
10952 !
10953
10954 !el      call flush(iout) !el
10955       do i=1,nres-2
10956         rdt(1,1,i)=-rt(1,2,i)
10957         rdt(1,2,i)= rt(1,1,i)
10958         rdt(1,3,i)= 0.0d0
10959         rdt(2,1,i)=-rt(2,2,i)
10960         rdt(2,2,i)= rt(2,1,i)
10961         rdt(2,3,i)= 0.0d0
10962         rdt(3,1,i)=-rt(3,2,i)
10963         rdt(3,2,i)= rt(3,1,i)
10964         rdt(3,3,i)= 0.0d0
10965       enddo
10966 !
10967 ! derivatives in phi
10968 !
10969       do i=2,nres-2
10970         drt(1,1,i)= 0.0d0
10971         drt(1,2,i)= 0.0d0
10972         drt(1,3,i)= 0.0d0
10973         drt(2,1,i)= rt(3,1,i)
10974         drt(2,2,i)= rt(3,2,i)
10975         drt(2,3,i)= rt(3,3,i)
10976         drt(3,1,i)=-rt(2,1,i)
10977         drt(3,2,i)=-rt(2,2,i)
10978         drt(3,3,i)=-rt(2,3,i)
10979       enddo
10980 !
10981 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
10982 !
10983       do i=2,nres-2
10984         ind=indmat(i,i+1)
10985         do k=1,3
10986           do l=1,3
10987             temp(k,l)=rt(k,l,i)
10988           enddo
10989         enddo
10990         do k=1,3
10991           do l=1,3
10992             fromto(k,l,ind)=temp(k,l)
10993           enddo
10994         enddo
10995         do j=i+1,nres-2
10996           ind=indmat(i,j+1)
10997           do k=1,3
10998             do l=1,3
10999               dpkl=0.0d0
11000               do m=1,3
11001                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11002               enddo
11003               dp(k,l)=dpkl
11004               fromto(k,l,ind)=dpkl
11005             enddo
11006           enddo
11007           do k=1,3
11008             do l=1,3
11009               temp(k,l)=dp(k,l)
11010             enddo
11011           enddo
11012         enddo
11013       enddo
11014 !
11015 ! Calculate derivatives.
11016 !
11017       ind1=0
11018       do i=1,nres-2
11019         ind1=ind1+1
11020 !
11021 ! Derivatives of DC(i+1) in theta(i+2)
11022 !
11023         do j=1,3
11024           do k=1,2
11025             dpjk=0.0D0
11026             do l=1,3
11027               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11028             enddo
11029             dp(j,k)=dpjk
11030             prordt(j,k,i)=dp(j,k)
11031           enddo
11032           dp(j,3)=0.0D0
11033           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11034         enddo
11035 !
11036 ! Derivatives of SC(i+1) in theta(i+2)
11037 !
11038         xx1(1)=-0.5D0*xloc(2,i+1)
11039         xx1(2)= 0.5D0*xloc(1,i+1)
11040         do j=1,3
11041           xj=0.0D0
11042           do k=1,2
11043             xj=xj+r(j,k,i)*xx1(k)
11044           enddo
11045           xx(j)=xj
11046         enddo
11047         do j=1,3
11048           rj=0.0D0
11049           do k=1,3
11050             rj=rj+prod(j,k,i)*xx(k)
11051           enddo
11052           dxdv(j,ind1)=rj
11053         enddo
11054 !
11055 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11056 ! than the other off-diagonal derivatives.
11057 !
11058         do j=1,3
11059           dxoiij=0.0D0
11060           do k=1,3
11061             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11062           enddo
11063           dxdv(j,ind1+1)=dxoiij
11064         enddo
11065 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11066 !
11067 ! Derivatives of DC(i+1) in phi(i+2)
11068 !
11069         do j=1,3
11070           do k=1,3
11071             dpjk=0.0
11072             do l=2,3
11073               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11074             enddo
11075             dp(j,k)=dpjk
11076             prodrt(j,k,i)=dp(j,k)
11077           enddo
11078           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11079         enddo
11080 !
11081 ! Derivatives of SC(i+1) in phi(i+2)
11082 !
11083         xx(1)= 0.0D0
11084         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11085         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11086         do j=1,3
11087           rj=0.0D0
11088           do k=2,3
11089             rj=rj+prod(j,k,i)*xx(k)
11090           enddo
11091           dxdv(j+3,ind1)=-rj
11092         enddo
11093 !
11094 ! Derivatives of SC(i+1) in phi(i+3).
11095 !
11096         do j=1,3
11097           dxoiij=0.0D0
11098           do k=1,3
11099             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11100           enddo
11101           dxdv(j+3,ind1+1)=dxoiij
11102         enddo
11103 !
11104 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11105 ! theta(nres) and phi(i+3) thru phi(nres).
11106 !
11107         do j=i+1,nres-2
11108           ind1=ind1+1
11109           ind=indmat(i+1,j+1)
11110 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11111           do k=1,3
11112             do l=1,3
11113               tempkl=0.0D0
11114               do m=1,2
11115                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11116               enddo
11117               temp(k,l)=tempkl
11118             enddo
11119           enddo
11120 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11121 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11122 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11123 ! Derivatives of virtual-bond vectors in theta
11124           do k=1,3
11125             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11126           enddo
11127 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11128 ! Derivatives of SC vectors in theta
11129           do k=1,3
11130             dxoijk=0.0D0
11131             do l=1,3
11132               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11133             enddo
11134             dxdv(k,ind1+1)=dxoijk
11135           enddo
11136 !
11137 !--- Calculate the derivatives in phi
11138 !
11139           do k=1,3
11140             do l=1,3
11141               tempkl=0.0D0
11142               do m=1,3
11143                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11144               enddo
11145               temp(k,l)=tempkl
11146             enddo
11147           enddo
11148           do k=1,3
11149             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11150           enddo
11151           do k=1,3
11152             dxoijk=0.0D0
11153             do l=1,3
11154               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11155             enddo
11156             dxdv(k+3,ind1+1)=dxoijk
11157           enddo
11158         enddo
11159       enddo
11160 !
11161 ! Derivatives in alpha and omega:
11162 !
11163       do i=2,nres-1
11164 !       dsci=dsc(itype(i,1))
11165         dsci=vbld(i+nres)
11166 #ifdef OSF
11167         alphi=alph(i)
11168         omegi=omeg(i)
11169         if(alphi.ne.alphi) alphi=100.0
11170         if(omegi.ne.omegi) omegi=-100.0
11171 #else
11172         alphi=alph(i)
11173         omegi=omeg(i)
11174 #endif
11175 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11176         cosalphi=dcos(alphi)
11177         sinalphi=dsin(alphi)
11178         cosomegi=dcos(omegi)
11179         sinomegi=dsin(omegi)
11180         temp(1,1)=-dsci*sinalphi
11181         temp(2,1)= dsci*cosalphi*cosomegi
11182         temp(3,1)=-dsci*cosalphi*sinomegi
11183         temp(1,2)=0.0D0
11184         temp(2,2)=-dsci*sinalphi*sinomegi
11185         temp(3,2)=-dsci*sinalphi*cosomegi
11186         theta2=pi-0.5D0*theta(i+1)
11187         cost2=dcos(theta2)
11188         sint2=dsin(theta2)
11189         jjj=0
11190 !d      print *,((temp(l,k),l=1,3),k=1,2)
11191         do j=1,2
11192           xp=temp(1,j)
11193           yp=temp(2,j)
11194           xxp= xp*cost2+yp*sint2
11195           yyp=-xp*sint2+yp*cost2
11196           zzp=temp(3,j)
11197           xx(1)=xxp
11198           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11199           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11200           do k=1,3
11201             dj=0.0D0
11202             do l=1,3
11203               dj=dj+prod(k,l,i-1)*xx(l)
11204             enddo
11205             dxds(jjj+k,i)=dj
11206           enddo
11207           jjj=jjj+3
11208         enddo
11209       enddo
11210       return
11211       end subroutine cartder
11212 !-----------------------------------------------------------------------------
11213 ! checkder_p.F
11214 !-----------------------------------------------------------------------------
11215       subroutine check_cartgrad
11216 ! Check the gradient of Cartesian coordinates in internal coordinates.
11217 !      implicit real*8 (a-h,o-z)
11218 !      include 'DIMENSIONS'
11219 !      include 'COMMON.IOUNITS'
11220 !      include 'COMMON.VAR'
11221 !      include 'COMMON.CHAIN'
11222 !      include 'COMMON.GEO'
11223 !      include 'COMMON.LOCAL'
11224 !      include 'COMMON.DERIV'
11225       real(kind=8),dimension(6,nres) :: temp
11226       real(kind=8),dimension(3) :: xx,gg
11227       integer :: i,k,j,ii
11228       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11229 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11230 !
11231 ! Check the gradient of the virtual-bond and SC vectors in the internal
11232 ! coordinates.
11233 !
11234       aincr=1.0d-6
11235       aincr2=5.0d-7
11236       call cartder
11237       write (iout,'(a)') '**************** dx/dalpha'
11238       write (iout,'(a)')
11239       do i=2,nres-1
11240         alphi=alph(i)
11241         alph(i)=alph(i)+aincr
11242         do k=1,3
11243           temp(k,i)=dc(k,nres+i)
11244         enddo
11245         call chainbuild
11246         do k=1,3
11247           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11248           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11249         enddo
11250         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11251         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11252         write (iout,'(a)')
11253         alph(i)=alphi
11254         call chainbuild
11255       enddo
11256       write (iout,'(a)')
11257       write (iout,'(a)') '**************** dx/domega'
11258       write (iout,'(a)')
11259       do i=2,nres-1
11260         omegi=omeg(i)
11261         omeg(i)=omeg(i)+aincr
11262         do k=1,3
11263           temp(k,i)=dc(k,nres+i)
11264         enddo
11265         call chainbuild
11266         do k=1,3
11267           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11268           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11269                 (aincr*dabs(dxds(k+3,i))+aincr))
11270         enddo
11271         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11272             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11273         write (iout,'(a)')
11274         omeg(i)=omegi
11275         call chainbuild
11276       enddo
11277       write (iout,'(a)')
11278       write (iout,'(a)') '**************** dx/dtheta'
11279       write (iout,'(a)')
11280       do i=3,nres
11281         theti=theta(i)
11282         theta(i)=theta(i)+aincr
11283         do j=i-1,nres-1
11284           do k=1,3
11285             temp(k,j)=dc(k,nres+j)
11286           enddo
11287         enddo
11288         call chainbuild
11289         do j=i-1,nres-1
11290           ii = indmat(i-2,j)
11291 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11292           do k=1,3
11293             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11294             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11295                   (aincr*dabs(dxdv(k,ii))+aincr))
11296           enddo
11297           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11298               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11299           write(iout,'(a)')
11300         enddo
11301         write (iout,'(a)')
11302         theta(i)=theti
11303         call chainbuild
11304       enddo
11305       write (iout,'(a)') '***************** dx/dphi'
11306       write (iout,'(a)')
11307       do i=4,nres
11308         phi(i)=phi(i)+aincr
11309         do j=i-1,nres-1
11310           do k=1,3
11311             temp(k,j)=dc(k,nres+j)
11312           enddo
11313         enddo
11314         call chainbuild
11315         do j=i-1,nres-1
11316           ii = indmat(i-2,j)
11317 !         print *,'ii=',ii
11318           do k=1,3
11319             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11320             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11321                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11322           enddo
11323           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11324               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11325           write(iout,'(a)')
11326         enddo
11327         phi(i)=phi(i)-aincr
11328         call chainbuild
11329       enddo
11330       write (iout,'(a)') '****************** ddc/dtheta'
11331       do i=1,nres-2
11332         thet=theta(i+2)
11333         theta(i+2)=thet+aincr
11334         do j=i,nres
11335           do k=1,3
11336             temp(k,j)=dc(k,j)
11337           enddo
11338         enddo
11339         call chainbuild
11340         do j=i+1,nres-1
11341           ii = indmat(i,j)
11342 !         print *,'ii=',ii
11343           do k=1,3
11344             gg(k)=(dc(k,j)-temp(k,j))/aincr
11345             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11346                  (aincr*dabs(dcdv(k,ii))+aincr))
11347           enddo
11348           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11349                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11350           write (iout,'(a)')
11351         enddo
11352         do j=1,nres
11353           do k=1,3
11354             dc(k,j)=temp(k,j)
11355           enddo
11356         enddo
11357         theta(i+2)=thet
11358       enddo
11359       write (iout,'(a)') '******************* ddc/dphi'
11360       do i=1,nres-3
11361         phii=phi(i+3)
11362         phi(i+3)=phii+aincr
11363         do j=1,nres
11364           do k=1,3
11365             temp(k,j)=dc(k,j)
11366           enddo
11367         enddo
11368         call chainbuild
11369         do j=i+2,nres-1
11370           ii = indmat(i+1,j)
11371 !         print *,'ii=',ii
11372           do k=1,3
11373             gg(k)=(dc(k,j)-temp(k,j))/aincr
11374             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11375                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11376           enddo
11377           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11378                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11379           write (iout,'(a)')
11380         enddo
11381         do j=1,nres
11382           do k=1,3
11383             dc(k,j)=temp(k,j)
11384           enddo
11385         enddo
11386         phi(i+3)=phii
11387       enddo
11388       return
11389       end subroutine check_cartgrad
11390 !-----------------------------------------------------------------------------
11391       subroutine check_ecart
11392 ! Check the gradient of the energy in Cartesian coordinates.
11393 !     implicit real*8 (a-h,o-z)
11394 !     include 'DIMENSIONS'
11395 !     include 'COMMON.CHAIN'
11396 !     include 'COMMON.DERIV'
11397 !     include 'COMMON.IOUNITS'
11398 !     include 'COMMON.VAR'
11399 !     include 'COMMON.CONTACTS'
11400       use comm_srutu
11401 !el      integer :: icall
11402 !el      common /srutu/ icall
11403       real(kind=8),dimension(6) :: ggg
11404       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11405       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11406       real(kind=8),dimension(6,nres) :: grad_s
11407       real(kind=8),dimension(0:n_ene) :: energia,energia1
11408       integer :: uiparm(1)
11409       real(kind=8) :: urparm(1)
11410 !EL      external fdum
11411       integer :: nf,i,j,k
11412       real(kind=8) :: aincr,etot,etot1
11413       icg=1
11414       nf=0
11415       nfl=0
11416       call zerograd
11417       aincr=1.0D-5
11418       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11419       nf=0
11420       icall=0
11421       call geom_to_var(nvar,x)
11422       call etotal(energia)
11423       etot=energia(0)
11424 !el      call enerprint(energia)
11425       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11426       icall =1
11427       do i=1,nres
11428         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11429       enddo
11430       do i=1,nres
11431         do j=1,3
11432           grad_s(j,i)=gradc(j,i,icg)
11433           grad_s(j+3,i)=gradx(j,i,icg)
11434         enddo
11435       enddo
11436       call flush(iout)
11437       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11438       do i=1,nres
11439         do j=1,3
11440           xx(j)=c(j,i+nres)
11441           ddc(j)=dc(j,i)
11442           ddx(j)=dc(j,i+nres)
11443         enddo
11444         do j=1,3
11445           dc(j,i)=dc(j,i)+aincr
11446           do k=i+1,nres
11447             c(j,k)=c(j,k)+aincr
11448             c(j,k+nres)=c(j,k+nres)+aincr
11449           enddo
11450           call etotal(energia1)
11451           etot1=energia1(0)
11452           ggg(j)=(etot1-etot)/aincr
11453           dc(j,i)=ddc(j)
11454           do k=i+1,nres
11455             c(j,k)=c(j,k)-aincr
11456             c(j,k+nres)=c(j,k+nres)-aincr
11457           enddo
11458         enddo
11459         do j=1,3
11460           c(j,i+nres)=c(j,i+nres)+aincr
11461           dc(j,i+nres)=dc(j,i+nres)+aincr
11462           call etotal(energia1)
11463           etot1=energia1(0)
11464           ggg(j+3)=(etot1-etot)/aincr
11465           c(j,i+nres)=xx(j)
11466           dc(j,i+nres)=ddx(j)
11467         enddo
11468         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11469          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11470       enddo
11471       return
11472       end subroutine check_ecart
11473 #ifdef CARGRAD
11474 !-----------------------------------------------------------------------------
11475       subroutine check_ecartint
11476 ! Check the gradient of the energy in Cartesian coordinates.
11477       use io_base, only: intout
11478 !      implicit real*8 (a-h,o-z)
11479 !      include 'DIMENSIONS'
11480 !      include 'COMMON.CONTROL'
11481 !      include 'COMMON.CHAIN'
11482 !      include 'COMMON.DERIV'
11483 !      include 'COMMON.IOUNITS'
11484 !      include 'COMMON.VAR'
11485 !      include 'COMMON.CONTACTS'
11486 !      include 'COMMON.MD'
11487 !      include 'COMMON.LOCAL'
11488 !      include 'COMMON.SPLITELE'
11489       use comm_srutu
11490 !el      integer :: icall
11491 !el      common /srutu/ icall
11492       real(kind=8),dimension(6) :: ggg,ggg1
11493       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11494       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11495       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11496       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11497       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11498       real(kind=8),dimension(0:n_ene) :: energia,energia1
11499       integer :: uiparm(1)
11500       real(kind=8) :: urparm(1)
11501 !EL      external fdum
11502       integer :: i,j,k,nf
11503       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11504                    etot21,etot22
11505       r_cut=2.0d0
11506       rlambd=0.3d0
11507       icg=1
11508       nf=0
11509       nfl=0
11510       call intout
11511 !      call intcartderiv
11512 !      call checkintcartgrad
11513       call zerograd
11514       aincr=1.0D-5
11515       write(iout,*) 'Calling CHECK_ECARTINT.'
11516       nf=0
11517       icall=0
11518       write (iout,*) "Before geom_to_var"
11519       call geom_to_var(nvar,x)
11520       write (iout,*) "after geom_to_var"
11521       write (iout,*) "split_ene ",split_ene
11522       call flush(iout)
11523       if (.not.split_ene) then
11524         write(iout,*) 'Calling CHECK_ECARTINT if'
11525         call etotal(energia)
11526 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11527         etot=energia(0)
11528         write (iout,*) "etot",etot
11529         call flush(iout)
11530 !el        call enerprint(energia)
11531 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11532         call flush(iout)
11533         write (iout,*) "enter cartgrad"
11534         call flush(iout)
11535         call cartgrad
11536 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11537         write (iout,*) "exit cartgrad"
11538         call flush(iout)
11539         icall =1
11540         do i=1,nres
11541           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11542         enddo
11543         do j=1,3
11544           grad_s(j,0)=gcart(j,0)
11545         enddo
11546 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11547         do i=1,nres
11548           do j=1,3
11549             grad_s(j,i)=gcart(j,i)
11550             grad_s(j+3,i)=gxcart(j,i)
11551           enddo
11552         enddo
11553       else
11554 write(iout,*) 'Calling CHECK_ECARTIN else.'
11555 !- split gradient check
11556         call zerograd
11557         call etotal_long(energia)
11558 !el        call enerprint(energia)
11559         call flush(iout)
11560         write (iout,*) "enter cartgrad"
11561         call flush(iout)
11562         call cartgrad
11563         write (iout,*) "exit cartgrad"
11564         call flush(iout)
11565         icall =1
11566         write (iout,*) "longrange grad"
11567         do i=1,nres
11568           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11569           (gxcart(j,i),j=1,3)
11570         enddo
11571         do j=1,3
11572           grad_s(j,0)=gcart(j,0)
11573         enddo
11574         do i=1,nres
11575           do j=1,3
11576             grad_s(j,i)=gcart(j,i)
11577             grad_s(j+3,i)=gxcart(j,i)
11578           enddo
11579         enddo
11580         call zerograd
11581         call etotal_short(energia)
11582 !el        call enerprint(energia)
11583         call flush(iout)
11584         write (iout,*) "enter cartgrad"
11585         call flush(iout)
11586         call cartgrad
11587         write (iout,*) "exit cartgrad"
11588         call flush(iout)
11589         icall =1
11590         write (iout,*) "shortrange grad"
11591         do i=1,nres
11592           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11593           (gxcart(j,i),j=1,3)
11594         enddo
11595         do j=1,3
11596           grad_s1(j,0)=gcart(j,0)
11597         enddo
11598         do i=1,nres
11599           do j=1,3
11600             grad_s1(j,i)=gcart(j,i)
11601             grad_s1(j+3,i)=gxcart(j,i)
11602           enddo
11603         enddo
11604       endif
11605       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11606 !      do i=1,nres
11607       do i=nnt,nct
11608         do j=1,3
11609           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11610           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11611           ddc(j)=c(j,i)
11612           ddx(j)=c(j,i+nres)
11613           dcnorm_safe1(j)=dc_norm(j,i-1)
11614           dcnorm_safe2(j)=dc_norm(j,i)
11615           dxnorm_safe(j)=dc_norm(j,i+nres)
11616         enddo
11617         do j=1,3
11618           c(j,i)=ddc(j)+aincr
11619           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11620           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11621           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11622           dc(j,i)=c(j,i+1)-c(j,i)
11623           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11624           call int_from_cart1(.false.)
11625           if (.not.split_ene) then
11626             call etotal(energia1)
11627             etot1=energia1(0)
11628             write (iout,*) "ij",i,j," etot1",etot1
11629           else
11630 !- split gradient
11631             call etotal_long(energia1)
11632             etot11=energia1(0)
11633             call etotal_short(energia1)
11634             etot12=energia1(0)
11635           endif
11636 !- end split gradient
11637 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11638           c(j,i)=ddc(j)-aincr
11639           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11640           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11641           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11642           dc(j,i)=c(j,i+1)-c(j,i)
11643           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11644           call int_from_cart1(.false.)
11645           if (.not.split_ene) then
11646             call etotal(energia1)
11647             etot2=energia1(0)
11648             write (iout,*) "ij",i,j," etot2",etot2
11649             ggg(j)=(etot1-etot2)/(2*aincr)
11650           else
11651 !- split gradient
11652             call etotal_long(energia1)
11653             etot21=energia1(0)
11654             ggg(j)=(etot11-etot21)/(2*aincr)
11655             call etotal_short(energia1)
11656             etot22=energia1(0)
11657             ggg1(j)=(etot12-etot22)/(2*aincr)
11658 !- end split gradient
11659 !            write (iout,*) "etot21",etot21," etot22",etot22
11660           endif
11661 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11662           c(j,i)=ddc(j)
11663           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11664           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11665           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11666           dc(j,i)=c(j,i+1)-c(j,i)
11667           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11668           dc_norm(j,i-1)=dcnorm_safe1(j)
11669           dc_norm(j,i)=dcnorm_safe2(j)
11670           dc_norm(j,i+nres)=dxnorm_safe(j)
11671         enddo
11672         do j=1,3
11673           c(j,i+nres)=ddx(j)+aincr
11674           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11675           call int_from_cart1(.false.)
11676           if (.not.split_ene) then
11677             call etotal(energia1)
11678             etot1=energia1(0)
11679           else
11680 !- split gradient
11681             call etotal_long(energia1)
11682             etot11=energia1(0)
11683             call etotal_short(energia1)
11684             etot12=energia1(0)
11685           endif
11686 !- end split gradient
11687           c(j,i+nres)=ddx(j)-aincr
11688           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11689           call int_from_cart1(.false.)
11690           if (.not.split_ene) then
11691             call etotal(energia1)
11692             etot2=energia1(0)
11693             ggg(j+3)=(etot1-etot2)/(2*aincr)
11694           else
11695 !- split gradient
11696             call etotal_long(energia1)
11697             etot21=energia1(0)
11698             ggg(j+3)=(etot11-etot21)/(2*aincr)
11699             call etotal_short(energia1)
11700             etot22=energia1(0)
11701             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11702 !- end split gradient
11703           endif
11704 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11705           c(j,i+nres)=ddx(j)
11706           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11707           dc_norm(j,i+nres)=dxnorm_safe(j)
11708           call int_from_cart1(.false.)
11709         enddo
11710         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11711          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11712         if (split_ene) then
11713           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11714          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11715          k=1,6)
11716          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11717          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11718          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11719         endif
11720       enddo
11721       return
11722       end subroutine check_ecartint
11723 #else
11724 !-----------------------------------------------------------------------------
11725       subroutine check_ecartint
11726 ! Check the gradient of the energy in Cartesian coordinates.
11727       use io_base, only: intout
11728 !      implicit real*8 (a-h,o-z)
11729 !      include 'DIMENSIONS'
11730 !      include 'COMMON.CONTROL'
11731 !      include 'COMMON.CHAIN'
11732 !      include 'COMMON.DERIV'
11733 !      include 'COMMON.IOUNITS'
11734 !      include 'COMMON.VAR'
11735 !      include 'COMMON.CONTACTS'
11736 !      include 'COMMON.MD'
11737 !      include 'COMMON.LOCAL'
11738 !      include 'COMMON.SPLITELE'
11739       use comm_srutu
11740 !el      integer :: icall
11741 !el      common /srutu/ icall
11742       real(kind=8),dimension(6) :: ggg,ggg1
11743       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11744       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11745       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11746       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11747       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11748       real(kind=8),dimension(0:n_ene) :: energia,energia1
11749       integer :: uiparm(1)
11750       real(kind=8) :: urparm(1)
11751 !EL      external fdum
11752       integer :: i,j,k,nf
11753       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11754                    etot21,etot22
11755       r_cut=2.0d0
11756       rlambd=0.3d0
11757       icg=1
11758       nf=0
11759       nfl=0
11760       call intout
11761 !      call intcartderiv
11762 !      call checkintcartgrad
11763       call zerograd
11764       aincr=2.0D-5
11765       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11766       nf=0
11767       icall=0
11768       call geom_to_var(nvar,x)
11769       if (.not.split_ene) then
11770         call etotal(energia)
11771         etot=energia(0)
11772 !el        call enerprint(energia)
11773         call flush(iout)
11774         write (iout,*) "enter cartgrad"
11775         call flush(iout)
11776         call cartgrad
11777         write (iout,*) "exit cartgrad"
11778         call flush(iout)
11779         icall =1
11780         do i=1,nres
11781           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11782         enddo
11783         do j=1,3
11784           grad_s(j,0)=gcart(j,0)
11785         enddo
11786         do i=1,nres
11787           do j=1,3
11788             grad_s(j,i)=gcart(j,i)
11789             grad_s(j+3,i)=gxcart(j,i)
11790           enddo
11791         enddo
11792       else
11793 !- split gradient check
11794         call zerograd
11795         call etotal_long(energia)
11796 !el        call enerprint(energia)
11797         call flush(iout)
11798         write (iout,*) "enter cartgrad"
11799         call flush(iout)
11800         call cartgrad
11801         write (iout,*) "exit cartgrad"
11802         call flush(iout)
11803         icall =1
11804         write (iout,*) "longrange grad"
11805         do i=1,nres
11806           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11807           (gxcart(j,i),j=1,3)
11808         enddo
11809         do j=1,3
11810           grad_s(j,0)=gcart(j,0)
11811         enddo
11812         do i=1,nres
11813           do j=1,3
11814             grad_s(j,i)=gcart(j,i)
11815             grad_s(j+3,i)=gxcart(j,i)
11816           enddo
11817         enddo
11818         call zerograd
11819         call etotal_short(energia)
11820 !el        call enerprint(energia)
11821         call flush(iout)
11822         write (iout,*) "enter cartgrad"
11823         call flush(iout)
11824         call cartgrad
11825         write (iout,*) "exit cartgrad"
11826         call flush(iout)
11827         icall =1
11828         write (iout,*) "shortrange grad"
11829         do i=1,nres
11830           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11831           (gxcart(j,i),j=1,3)
11832         enddo
11833         do j=1,3
11834           grad_s1(j,0)=gcart(j,0)
11835         enddo
11836         do i=1,nres
11837           do j=1,3
11838             grad_s1(j,i)=gcart(j,i)
11839             grad_s1(j+3,i)=gxcart(j,i)
11840           enddo
11841         enddo
11842       endif
11843       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11844       do i=0,nres
11845         do j=1,3
11846           xx(j)=c(j,i+nres)
11847           ddc(j)=dc(j,i)
11848           ddx(j)=dc(j,i+nres)
11849           do k=1,3
11850             dcnorm_safe(k)=dc_norm(k,i)
11851             dxnorm_safe(k)=dc_norm(k,i+nres)
11852           enddo
11853         enddo
11854         do j=1,3
11855           dc(j,i)=ddc(j)+aincr
11856           call chainbuild_cart
11857 #ifdef MPI
11858 ! Broadcast the order to compute internal coordinates to the slaves.
11859 !          if (nfgtasks.gt.1)
11860 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
11861 #endif
11862 !          call int_from_cart1(.false.)
11863           if (.not.split_ene) then
11864             call etotal(energia1)
11865             etot1=energia1(0)
11866           else
11867 !- split gradient
11868             call etotal_long(energia1)
11869             etot11=energia1(0)
11870             call etotal_short(energia1)
11871             etot12=energia1(0)
11872 !            write (iout,*) "etot11",etot11," etot12",etot12
11873           endif
11874 !- end split gradient
11875 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11876           dc(j,i)=ddc(j)-aincr
11877           call chainbuild_cart
11878 !          call int_from_cart1(.false.)
11879           if (.not.split_ene) then
11880             call etotal(energia1)
11881             etot2=energia1(0)
11882             ggg(j)=(etot1-etot2)/(2*aincr)
11883           else
11884 !- split gradient
11885             call etotal_long(energia1)
11886             etot21=energia1(0)
11887             ggg(j)=(etot11-etot21)/(2*aincr)
11888             call etotal_short(energia1)
11889             etot22=energia1(0)
11890             ggg1(j)=(etot12-etot22)/(2*aincr)
11891 !- end split gradient
11892 !            write (iout,*) "etot21",etot21," etot22",etot22
11893           endif
11894 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11895           dc(j,i)=ddc(j)
11896           call chainbuild_cart
11897         enddo
11898         do j=1,3
11899           dc(j,i+nres)=ddx(j)+aincr
11900           call chainbuild_cart
11901 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
11902 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11903 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11904 !          write (iout,*) "dxnormnorm",dsqrt(
11905 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11906 !          write (iout,*) "dxnormnormsafe",dsqrt(
11907 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11908 !          write (iout,*)
11909           if (.not.split_ene) then
11910             call etotal(energia1)
11911             etot1=energia1(0)
11912           else
11913 !- split gradient
11914             call etotal_long(energia1)
11915             etot11=energia1(0)
11916             call etotal_short(energia1)
11917             etot12=energia1(0)
11918           endif
11919 !- end split gradient
11920 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11921           dc(j,i+nres)=ddx(j)-aincr
11922           call chainbuild_cart
11923 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
11924 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11925 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11926 !          write (iout,*)
11927 !          write (iout,*) "dxnormnorm",dsqrt(
11928 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11929 !          write (iout,*) "dxnormnormsafe",dsqrt(
11930 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11931           if (.not.split_ene) then
11932             call etotal(energia1)
11933             etot2=energia1(0)
11934             ggg(j+3)=(etot1-etot2)/(2*aincr)
11935           else
11936 !- split gradient
11937             call etotal_long(energia1)
11938             etot21=energia1(0)
11939             ggg(j+3)=(etot11-etot21)/(2*aincr)
11940             call etotal_short(energia1)
11941             etot22=energia1(0)
11942             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11943 !- end split gradient
11944           endif
11945 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11946           dc(j,i+nres)=ddx(j)
11947           call chainbuild_cart
11948         enddo
11949         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11950          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11951         if (split_ene) then
11952           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11953          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11954          k=1,6)
11955          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11956          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11957          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11958         endif
11959       enddo
11960       return
11961       end subroutine check_ecartint
11962 #endif
11963 !-----------------------------------------------------------------------------
11964       subroutine check_eint
11965 ! Check the gradient of energy in internal coordinates.
11966 !      implicit real*8 (a-h,o-z)
11967 !      include 'DIMENSIONS'
11968 !      include 'COMMON.CHAIN'
11969 !      include 'COMMON.DERIV'
11970 !      include 'COMMON.IOUNITS'
11971 !      include 'COMMON.VAR'
11972 !      include 'COMMON.GEO'
11973       use comm_srutu
11974 !el      integer :: icall
11975 !el      common /srutu/ icall
11976       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
11977       integer :: uiparm(1)
11978       real(kind=8) :: urparm(1)
11979       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
11980       character(len=6) :: key
11981 !EL      external fdum
11982       integer :: i,ii,nf
11983       real(kind=8) :: xi,aincr,etot,etot1,etot2
11984       call zerograd
11985       aincr=1.0D-7
11986       print '(a)','Calling CHECK_INT.'
11987       nf=0
11988       nfl=0
11989       icg=1
11990       call geom_to_var(nvar,x)
11991       call var_to_geom(nvar,x)
11992       call chainbuild
11993       icall=1
11994       print *,'ICG=',ICG
11995       call etotal(energia)
11996       etot = energia(0)
11997 !el      call enerprint(energia)
11998       print *,'ICG=',ICG
11999 #ifdef MPL
12000       if (MyID.ne.BossID) then
12001         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12002         nf=x(nvar+1)
12003         nfl=x(nvar+2)
12004         icg=x(nvar+3)
12005       endif
12006 #endif
12007       nf=1
12008       nfl=3
12009 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12010       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12011 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12012       icall=1
12013       do i=1,nvar
12014         xi=x(i)
12015         x(i)=xi-0.5D0*aincr
12016         call var_to_geom(nvar,x)
12017         call chainbuild
12018         call etotal(energia1)
12019         etot1=energia1(0)
12020         x(i)=xi+0.5D0*aincr
12021         call var_to_geom(nvar,x)
12022         call chainbuild
12023         call etotal(energia2)
12024         etot2=energia2(0)
12025         gg(i)=(etot2-etot1)/aincr
12026         write (iout,*) i,etot1,etot2
12027         x(i)=xi
12028       enddo
12029       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12030           '     RelDiff*100% '
12031       do i=1,nvar
12032         if (i.le.nphi) then
12033           ii=i
12034           key = ' phi'
12035         else if (i.le.nphi+ntheta) then
12036           ii=i-nphi
12037           key=' theta'
12038         else if (i.le.nphi+ntheta+nside) then
12039            ii=i-(nphi+ntheta)
12040            key=' alpha'
12041         else
12042            ii=i-(nphi+ntheta+nside)
12043            key=' omega'
12044         endif
12045         write (iout,'(i3,a,i3,3(1pd16.6))') &
12046        i,key,ii,gg(i),gana(i),&
12047        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12048       enddo
12049       return
12050       end subroutine check_eint
12051 !-----------------------------------------------------------------------------
12052 ! econstr_local.F
12053 !-----------------------------------------------------------------------------
12054       subroutine Econstr_back
12055 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12056 !      implicit real*8 (a-h,o-z)
12057 !      include 'DIMENSIONS'
12058 !      include 'COMMON.CONTROL'
12059 !      include 'COMMON.VAR'
12060 !      include 'COMMON.MD'
12061       use MD_data
12062 !#ifndef LANG0
12063 !      include 'COMMON.LANGEVIN'
12064 !#else
12065 !      include 'COMMON.LANGEVIN.lang0'
12066 !#endif
12067 !      include 'COMMON.CHAIN'
12068 !      include 'COMMON.DERIV'
12069 !      include 'COMMON.GEO'
12070 !      include 'COMMON.LOCAL'
12071 !      include 'COMMON.INTERACT'
12072 !      include 'COMMON.IOUNITS'
12073 !      include 'COMMON.NAMES'
12074 !      include 'COMMON.TIME1'
12075       integer :: i,j,ii,k
12076       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12077
12078       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12079       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12080       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12081
12082       Uconst_back=0.0d0
12083       do i=1,nres
12084         dutheta(i)=0.0d0
12085         dugamma(i)=0.0d0
12086         do j=1,3
12087           duscdiff(j,i)=0.0d0
12088           duscdiffx(j,i)=0.0d0
12089         enddo
12090       enddo
12091       do i=1,nfrag_back
12092         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12093 !
12094 ! Deviations from theta angles
12095 !
12096         utheta_i=0.0d0
12097         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12098           dtheta_i=theta(j)-thetaref(j)
12099           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12100           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12101         enddo
12102         utheta(i)=utheta_i/(ii-1)
12103 !
12104 ! Deviations from gamma angles
12105 !
12106         ugamma_i=0.0d0
12107         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12108           dgamma_i=pinorm(phi(j)-phiref(j))
12109 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12110           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12111           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12112 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12113         enddo
12114         ugamma(i)=ugamma_i/(ii-2)
12115 !
12116 ! Deviations from local SC geometry
12117 !
12118         uscdiff(i)=0.0d0
12119         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12120           dxx=xxtab(j)-xxref(j)
12121           dyy=yytab(j)-yyref(j)
12122           dzz=zztab(j)-zzref(j)
12123           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12124           do k=1,3
12125             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12126              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12127              (ii-1)
12128             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12129              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12130              (ii-1)
12131             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12132            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12133             /(ii-1)
12134           enddo
12135 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12136 !     &      xxref(j),yyref(j),zzref(j)
12137         enddo
12138         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12139 !        write (iout,*) i," uscdiff",uscdiff(i)
12140 !
12141 ! Put together deviations from local geometry
12142 !
12143         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12144           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12145 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12146 !     &   " uconst_back",uconst_back
12147         utheta(i)=dsqrt(utheta(i))
12148         ugamma(i)=dsqrt(ugamma(i))
12149         uscdiff(i)=dsqrt(uscdiff(i))
12150       enddo
12151       return
12152       end subroutine Econstr_back
12153 !-----------------------------------------------------------------------------
12154 ! energy_p_new-sep_barrier.F
12155 !-----------------------------------------------------------------------------
12156       real(kind=8) function sscale(r)
12157 !      include "COMMON.SPLITELE"
12158       real(kind=8) :: r,gamm
12159       if(r.lt.r_cut-rlamb) then
12160         sscale=1.0d0
12161       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12162         gamm=(r-(r_cut-rlamb))/rlamb
12163         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12164       else
12165         sscale=0d0
12166       endif
12167       return
12168       end function sscale
12169       real(kind=8) function sscale_grad(r)
12170 !      include "COMMON.SPLITELE"
12171       real(kind=8) :: r,gamm
12172       if(r.lt.r_cut-rlamb) then
12173         sscale_grad=0.0d0
12174       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12175         gamm=(r-(r_cut-rlamb))/rlamb
12176         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12177       else
12178         sscale_grad=0d0
12179       endif
12180       return
12181       end function sscale_grad
12182
12183 !!!!!!!!!! PBCSCALE
12184       real(kind=8) function sscale_ele(r)
12185 !      include "COMMON.SPLITELE"
12186       real(kind=8) :: r,gamm
12187       if(r.lt.r_cut_ele-rlamb_ele) then
12188         sscale_ele=1.0d0
12189       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12190         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12191         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12192       else
12193         sscale_ele=0d0
12194       endif
12195       return
12196       end function sscale_ele
12197
12198       real(kind=8)  function sscagrad_ele(r)
12199       real(kind=8) :: r,gamm
12200 !      include "COMMON.SPLITELE"
12201       if(r.lt.r_cut_ele-rlamb_ele) then
12202         sscagrad_ele=0.0d0
12203       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12204         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12205         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12206       else
12207         sscagrad_ele=0.0d0
12208       endif
12209       return
12210       end function sscagrad_ele
12211       real(kind=8) function sscalelip(r)
12212       real(kind=8) r,gamm
12213         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12214       return
12215       end function sscalelip
12216 !C-----------------------------------------------------------------------
12217       real(kind=8) function sscagradlip(r)
12218       real(kind=8) r,gamm
12219         sscagradlip=r*(6.0d0*r-6.0d0)
12220       return
12221       end function sscagradlip
12222
12223 !!!!!!!!!!!!!!!
12224 !-----------------------------------------------------------------------------
12225       subroutine elj_long(evdw)
12226 !
12227 ! This subroutine calculates the interaction energy of nonbonded side chains
12228 ! assuming the LJ potential of interaction.
12229 !
12230 !      implicit real*8 (a-h,o-z)
12231 !      include 'DIMENSIONS'
12232 !      include 'COMMON.GEO'
12233 !      include 'COMMON.VAR'
12234 !      include 'COMMON.LOCAL'
12235 !      include 'COMMON.CHAIN'
12236 !      include 'COMMON.DERIV'
12237 !      include 'COMMON.INTERACT'
12238 !      include 'COMMON.TORSION'
12239 !      include 'COMMON.SBRIDGE'
12240 !      include 'COMMON.NAMES'
12241 !      include 'COMMON.IOUNITS'
12242 !      include 'COMMON.CONTACTS'
12243       real(kind=8),parameter :: accur=1.0d-10
12244       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12245 !el local variables
12246       integer :: i,iint,j,k,itypi,itypi1,itypj
12247       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12248       real(kind=8) :: e1,e2,evdwij,evdw
12249 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12250       evdw=0.0D0
12251       do i=iatsc_s,iatsc_e
12252         itypi=itype(i,1)
12253         if (itypi.eq.ntyp1) cycle
12254         itypi1=itype(i+1,1)
12255         xi=c(1,nres+i)
12256         yi=c(2,nres+i)
12257         zi=c(3,nres+i)
12258 !
12259 ! Calculate SC interaction energy.
12260 !
12261         do iint=1,nint_gr(i)
12262 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12263 !d   &                  'iend=',iend(i,iint)
12264           do j=istart(i,iint),iend(i,iint)
12265             itypj=itype(j,1)
12266             if (itypj.eq.ntyp1) cycle
12267             xj=c(1,nres+j)-xi
12268             yj=c(2,nres+j)-yi
12269             zj=c(3,nres+j)-zi
12270             rij=xj*xj+yj*yj+zj*zj
12271             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12272             if (sss.lt.1.0d0) then
12273               rrij=1.0D0/rij
12274               eps0ij=eps(itypi,itypj)
12275               fac=rrij**expon2
12276               e1=fac*fac*aa_aq(itypi,itypj)
12277               e2=fac*bb_aq(itypi,itypj)
12278               evdwij=e1+e2
12279               evdw=evdw+(1.0d0-sss)*evdwij
12280 !
12281 ! Calculate the components of the gradient in DC and X
12282 !
12283               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12284               gg(1)=xj*fac
12285               gg(2)=yj*fac
12286               gg(3)=zj*fac
12287               do k=1,3
12288                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12289                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12290                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12291                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12292               enddo
12293             endif
12294           enddo      ! j
12295         enddo        ! iint
12296       enddo          ! i
12297       do i=1,nct
12298         do j=1,3
12299           gvdwc(j,i)=expon*gvdwc(j,i)
12300           gvdwx(j,i)=expon*gvdwx(j,i)
12301         enddo
12302       enddo
12303 !******************************************************************************
12304 !
12305 !                              N O T E !!!
12306 !
12307 ! To save time, the factor of EXPON has been extracted from ALL components
12308 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12309 ! use!
12310 !
12311 !******************************************************************************
12312       return
12313       end subroutine elj_long
12314 !-----------------------------------------------------------------------------
12315       subroutine elj_short(evdw)
12316 !
12317 ! This subroutine calculates the interaction energy of nonbonded side chains
12318 ! assuming the LJ potential of interaction.
12319 !
12320 !      implicit real*8 (a-h,o-z)
12321 !      include 'DIMENSIONS'
12322 !      include 'COMMON.GEO'
12323 !      include 'COMMON.VAR'
12324 !      include 'COMMON.LOCAL'
12325 !      include 'COMMON.CHAIN'
12326 !      include 'COMMON.DERIV'
12327 !      include 'COMMON.INTERACT'
12328 !      include 'COMMON.TORSION'
12329 !      include 'COMMON.SBRIDGE'
12330 !      include 'COMMON.NAMES'
12331 !      include 'COMMON.IOUNITS'
12332 !      include 'COMMON.CONTACTS'
12333       real(kind=8),parameter :: accur=1.0d-10
12334       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12335 !el local variables
12336       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12337       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12338       real(kind=8) :: e1,e2,evdwij,evdw
12339 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12340       evdw=0.0D0
12341       do i=iatsc_s,iatsc_e
12342         itypi=itype(i,1)
12343         if (itypi.eq.ntyp1) cycle
12344         itypi1=itype(i+1,1)
12345         xi=c(1,nres+i)
12346         yi=c(2,nres+i)
12347         zi=c(3,nres+i)
12348 ! Change 12/1/95
12349         num_conti=0
12350 !
12351 ! Calculate SC interaction energy.
12352 !
12353         do iint=1,nint_gr(i)
12354 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12355 !d   &                  'iend=',iend(i,iint)
12356           do j=istart(i,iint),iend(i,iint)
12357             itypj=itype(j,1)
12358             if (itypj.eq.ntyp1) cycle
12359             xj=c(1,nres+j)-xi
12360             yj=c(2,nres+j)-yi
12361             zj=c(3,nres+j)-zi
12362 ! Change 12/1/95 to calculate four-body interactions
12363             rij=xj*xj+yj*yj+zj*zj
12364             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12365             if (sss.gt.0.0d0) then
12366               rrij=1.0D0/rij
12367               eps0ij=eps(itypi,itypj)
12368               fac=rrij**expon2
12369               e1=fac*fac*aa_aq(itypi,itypj)
12370               e2=fac*bb_aq(itypi,itypj)
12371               evdwij=e1+e2
12372               evdw=evdw+sss*evdwij
12373 !
12374 ! Calculate the components of the gradient in DC and X
12375 !
12376               fac=-rrij*(e1+evdwij)*sss
12377               gg(1)=xj*fac
12378               gg(2)=yj*fac
12379               gg(3)=zj*fac
12380               do k=1,3
12381                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12382                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12383                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12384                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12385               enddo
12386             endif
12387           enddo      ! j
12388         enddo        ! iint
12389       enddo          ! i
12390       do i=1,nct
12391         do j=1,3
12392           gvdwc(j,i)=expon*gvdwc(j,i)
12393           gvdwx(j,i)=expon*gvdwx(j,i)
12394         enddo
12395       enddo
12396 !******************************************************************************
12397 !
12398 !                              N O T E !!!
12399 !
12400 ! To save time, the factor of EXPON has been extracted from ALL components
12401 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12402 ! use!
12403 !
12404 !******************************************************************************
12405       return
12406       end subroutine elj_short
12407 !-----------------------------------------------------------------------------
12408       subroutine eljk_long(evdw)
12409 !
12410 ! This subroutine calculates the interaction energy of nonbonded side chains
12411 ! assuming the LJK potential of interaction.
12412 !
12413 !      implicit real*8 (a-h,o-z)
12414 !      include 'DIMENSIONS'
12415 !      include 'COMMON.GEO'
12416 !      include 'COMMON.VAR'
12417 !      include 'COMMON.LOCAL'
12418 !      include 'COMMON.CHAIN'
12419 !      include 'COMMON.DERIV'
12420 !      include 'COMMON.INTERACT'
12421 !      include 'COMMON.IOUNITS'
12422 !      include 'COMMON.NAMES'
12423       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12424       logical :: scheck
12425 !el local variables
12426       integer :: i,iint,j,k,itypi,itypi1,itypj
12427       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12428                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12429 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12430       evdw=0.0D0
12431       do i=iatsc_s,iatsc_e
12432         itypi=itype(i,1)
12433         if (itypi.eq.ntyp1) cycle
12434         itypi1=itype(i+1,1)
12435         xi=c(1,nres+i)
12436         yi=c(2,nres+i)
12437         zi=c(3,nres+i)
12438 !
12439 ! Calculate SC interaction energy.
12440 !
12441         do iint=1,nint_gr(i)
12442           do j=istart(i,iint),iend(i,iint)
12443             itypj=itype(j,1)
12444             if (itypj.eq.ntyp1) cycle
12445             xj=c(1,nres+j)-xi
12446             yj=c(2,nres+j)-yi
12447             zj=c(3,nres+j)-zi
12448             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12449             fac_augm=rrij**expon
12450             e_augm=augm(itypi,itypj)*fac_augm
12451             r_inv_ij=dsqrt(rrij)
12452             rij=1.0D0/r_inv_ij
12453             sss=sscale(rij/sigma(itypi,itypj))
12454             if (sss.lt.1.0d0) then
12455               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12456               fac=r_shift_inv**expon
12457               e1=fac*fac*aa_aq(itypi,itypj)
12458               e2=fac*bb_aq(itypi,itypj)
12459               evdwij=e_augm+e1+e2
12460 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12461 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12462 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12463 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12464 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12465 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12466 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12467               evdw=evdw+(1.0d0-sss)*evdwij
12468 !
12469 ! Calculate the components of the gradient in DC and X
12470 !
12471               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12472               fac=fac*(1.0d0-sss)
12473               gg(1)=xj*fac
12474               gg(2)=yj*fac
12475               gg(3)=zj*fac
12476               do k=1,3
12477                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12478                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12479                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12480                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12481               enddo
12482             endif
12483           enddo      ! j
12484         enddo        ! iint
12485       enddo          ! i
12486       do i=1,nct
12487         do j=1,3
12488           gvdwc(j,i)=expon*gvdwc(j,i)
12489           gvdwx(j,i)=expon*gvdwx(j,i)
12490         enddo
12491       enddo
12492       return
12493       end subroutine eljk_long
12494 !-----------------------------------------------------------------------------
12495       subroutine eljk_short(evdw)
12496 !
12497 ! This subroutine calculates the interaction energy of nonbonded side chains
12498 ! assuming the LJK potential of interaction.
12499 !
12500 !      implicit real*8 (a-h,o-z)
12501 !      include 'DIMENSIONS'
12502 !      include 'COMMON.GEO'
12503 !      include 'COMMON.VAR'
12504 !      include 'COMMON.LOCAL'
12505 !      include 'COMMON.CHAIN'
12506 !      include 'COMMON.DERIV'
12507 !      include 'COMMON.INTERACT'
12508 !      include 'COMMON.IOUNITS'
12509 !      include 'COMMON.NAMES'
12510       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12511       logical :: scheck
12512 !el local variables
12513       integer :: i,iint,j,k,itypi,itypi1,itypj
12514       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12515                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12516 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12517       evdw=0.0D0
12518       do i=iatsc_s,iatsc_e
12519         itypi=itype(i,1)
12520         if (itypi.eq.ntyp1) cycle
12521         itypi1=itype(i+1,1)
12522         xi=c(1,nres+i)
12523         yi=c(2,nres+i)
12524         zi=c(3,nres+i)
12525 !
12526 ! Calculate SC interaction energy.
12527 !
12528         do iint=1,nint_gr(i)
12529           do j=istart(i,iint),iend(i,iint)
12530             itypj=itype(j,1)
12531             if (itypj.eq.ntyp1) cycle
12532             xj=c(1,nres+j)-xi
12533             yj=c(2,nres+j)-yi
12534             zj=c(3,nres+j)-zi
12535             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12536             fac_augm=rrij**expon
12537             e_augm=augm(itypi,itypj)*fac_augm
12538             r_inv_ij=dsqrt(rrij)
12539             rij=1.0D0/r_inv_ij
12540             sss=sscale(rij/sigma(itypi,itypj))
12541             if (sss.gt.0.0d0) then
12542               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12543               fac=r_shift_inv**expon
12544               e1=fac*fac*aa_aq(itypi,itypj)
12545               e2=fac*bb_aq(itypi,itypj)
12546               evdwij=e_augm+e1+e2
12547 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12548 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12549 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12550 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12551 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12552 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12553 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12554               evdw=evdw+sss*evdwij
12555 !
12556 ! Calculate the components of the gradient in DC and X
12557 !
12558               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12559               fac=fac*sss
12560               gg(1)=xj*fac
12561               gg(2)=yj*fac
12562               gg(3)=zj*fac
12563               do k=1,3
12564                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12565                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12566                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12567                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12568               enddo
12569             endif
12570           enddo      ! j
12571         enddo        ! iint
12572       enddo          ! i
12573       do i=1,nct
12574         do j=1,3
12575           gvdwc(j,i)=expon*gvdwc(j,i)
12576           gvdwx(j,i)=expon*gvdwx(j,i)
12577         enddo
12578       enddo
12579       return
12580       end subroutine eljk_short
12581 !-----------------------------------------------------------------------------
12582       subroutine ebp_long(evdw)
12583 !
12584 ! This subroutine calculates the interaction energy of nonbonded side chains
12585 ! assuming the Berne-Pechukas potential of interaction.
12586 !
12587       use calc_data
12588 !      implicit real*8 (a-h,o-z)
12589 !      include 'DIMENSIONS'
12590 !      include 'COMMON.GEO'
12591 !      include 'COMMON.VAR'
12592 !      include 'COMMON.LOCAL'
12593 !      include 'COMMON.CHAIN'
12594 !      include 'COMMON.DERIV'
12595 !      include 'COMMON.NAMES'
12596 !      include 'COMMON.INTERACT'
12597 !      include 'COMMON.IOUNITS'
12598 !      include 'COMMON.CALC'
12599       use comm_srutu
12600 !el      integer :: icall
12601 !el      common /srutu/ icall
12602 !     double precision rrsave(maxdim)
12603       logical :: lprn
12604 !el local variables
12605       integer :: iint,itypi,itypi1,itypj
12606       real(kind=8) :: rrij,xi,yi,zi,fac
12607       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12608       evdw=0.0D0
12609 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12610       evdw=0.0D0
12611 !     if (icall.eq.0) then
12612 !       lprn=.true.
12613 !     else
12614         lprn=.false.
12615 !     endif
12616 !el      ind=0
12617       do i=iatsc_s,iatsc_e
12618         itypi=itype(i,1)
12619         if (itypi.eq.ntyp1) cycle
12620         itypi1=itype(i+1,1)
12621         xi=c(1,nres+i)
12622         yi=c(2,nres+i)
12623         zi=c(3,nres+i)
12624         dxi=dc_norm(1,nres+i)
12625         dyi=dc_norm(2,nres+i)
12626         dzi=dc_norm(3,nres+i)
12627 !        dsci_inv=dsc_inv(itypi)
12628         dsci_inv=vbld_inv(i+nres)
12629 !
12630 ! Calculate SC interaction energy.
12631 !
12632         do iint=1,nint_gr(i)
12633           do j=istart(i,iint),iend(i,iint)
12634 !el            ind=ind+1
12635             itypj=itype(j,1)
12636             if (itypj.eq.ntyp1) cycle
12637 !            dscj_inv=dsc_inv(itypj)
12638             dscj_inv=vbld_inv(j+nres)
12639             chi1=chi(itypi,itypj)
12640             chi2=chi(itypj,itypi)
12641             chi12=chi1*chi2
12642             chip1=chip(itypi)
12643             chip2=chip(itypj)
12644             chip12=chip1*chip2
12645             alf1=alp(itypi)
12646             alf2=alp(itypj)
12647             alf12=0.5D0*(alf1+alf2)
12648             xj=c(1,nres+j)-xi
12649             yj=c(2,nres+j)-yi
12650             zj=c(3,nres+j)-zi
12651             dxj=dc_norm(1,nres+j)
12652             dyj=dc_norm(2,nres+j)
12653             dzj=dc_norm(3,nres+j)
12654             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12655             rij=dsqrt(rrij)
12656             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12657
12658             if (sss.lt.1.0d0) then
12659
12660 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12661               call sc_angular
12662 ! Calculate whole angle-dependent part of epsilon and contributions
12663 ! to its derivatives
12664               fac=(rrij*sigsq)**expon2
12665               e1=fac*fac*aa_aq(itypi,itypj)
12666               e2=fac*bb_aq(itypi,itypj)
12667               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12668               eps2der=evdwij*eps3rt
12669               eps3der=evdwij*eps2rt
12670               evdwij=evdwij*eps2rt*eps3rt
12671               evdw=evdw+evdwij*(1.0d0-sss)
12672               if (lprn) then
12673               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12674               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12675 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12676 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12677 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12678 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12679 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12680 !d     &          evdwij
12681               endif
12682 ! Calculate gradient components.
12683               e1=e1*eps1*eps2rt**2*eps3rt**2
12684               fac=-expon*(e1+evdwij)
12685               sigder=fac/sigsq
12686               fac=rrij*fac
12687 ! Calculate radial part of the gradient
12688               gg(1)=xj*fac
12689               gg(2)=yj*fac
12690               gg(3)=zj*fac
12691 ! Calculate the angular part of the gradient and sum add the contributions
12692 ! to the appropriate components of the Cartesian gradient.
12693               call sc_grad_scale(1.0d0-sss)
12694             endif
12695           enddo      ! j
12696         enddo        ! iint
12697       enddo          ! i
12698 !     stop
12699       return
12700       end subroutine ebp_long
12701 !-----------------------------------------------------------------------------
12702       subroutine ebp_short(evdw)
12703 !
12704 ! This subroutine calculates the interaction energy of nonbonded side chains
12705 ! assuming the Berne-Pechukas potential of interaction.
12706 !
12707       use calc_data
12708 !      implicit real*8 (a-h,o-z)
12709 !      include 'DIMENSIONS'
12710 !      include 'COMMON.GEO'
12711 !      include 'COMMON.VAR'
12712 !      include 'COMMON.LOCAL'
12713 !      include 'COMMON.CHAIN'
12714 !      include 'COMMON.DERIV'
12715 !      include 'COMMON.NAMES'
12716 !      include 'COMMON.INTERACT'
12717 !      include 'COMMON.IOUNITS'
12718 !      include 'COMMON.CALC'
12719       use comm_srutu
12720 !el      integer :: icall
12721 !el      common /srutu/ icall
12722 !     double precision rrsave(maxdim)
12723       logical :: lprn
12724 !el local variables
12725       integer :: iint,itypi,itypi1,itypj
12726       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12727       real(kind=8) :: sss,e1,e2,evdw
12728       evdw=0.0D0
12729 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12730       evdw=0.0D0
12731 !     if (icall.eq.0) then
12732 !       lprn=.true.
12733 !     else
12734         lprn=.false.
12735 !     endif
12736 !el      ind=0
12737       do i=iatsc_s,iatsc_e
12738         itypi=itype(i,1)
12739         if (itypi.eq.ntyp1) cycle
12740         itypi1=itype(i+1,1)
12741         xi=c(1,nres+i)
12742         yi=c(2,nres+i)
12743         zi=c(3,nres+i)
12744         dxi=dc_norm(1,nres+i)
12745         dyi=dc_norm(2,nres+i)
12746         dzi=dc_norm(3,nres+i)
12747 !        dsci_inv=dsc_inv(itypi)
12748         dsci_inv=vbld_inv(i+nres)
12749 !
12750 ! Calculate SC interaction energy.
12751 !
12752         do iint=1,nint_gr(i)
12753           do j=istart(i,iint),iend(i,iint)
12754 !el            ind=ind+1
12755             itypj=itype(j,1)
12756             if (itypj.eq.ntyp1) cycle
12757 !            dscj_inv=dsc_inv(itypj)
12758             dscj_inv=vbld_inv(j+nres)
12759             chi1=chi(itypi,itypj)
12760             chi2=chi(itypj,itypi)
12761             chi12=chi1*chi2
12762             chip1=chip(itypi)
12763             chip2=chip(itypj)
12764             chip12=chip1*chip2
12765             alf1=alp(itypi)
12766             alf2=alp(itypj)
12767             alf12=0.5D0*(alf1+alf2)
12768             xj=c(1,nres+j)-xi
12769             yj=c(2,nres+j)-yi
12770             zj=c(3,nres+j)-zi
12771             dxj=dc_norm(1,nres+j)
12772             dyj=dc_norm(2,nres+j)
12773             dzj=dc_norm(3,nres+j)
12774             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12775             rij=dsqrt(rrij)
12776             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12777
12778             if (sss.gt.0.0d0) then
12779
12780 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12781               call sc_angular
12782 ! Calculate whole angle-dependent part of epsilon and contributions
12783 ! to its derivatives
12784               fac=(rrij*sigsq)**expon2
12785               e1=fac*fac*aa_aq(itypi,itypj)
12786               e2=fac*bb_aq(itypi,itypj)
12787               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12788               eps2der=evdwij*eps3rt
12789               eps3der=evdwij*eps2rt
12790               evdwij=evdwij*eps2rt*eps3rt
12791               evdw=evdw+evdwij*sss
12792               if (lprn) then
12793               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12794               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12795 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12796 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12797 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12798 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12799 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12800 !d     &          evdwij
12801               endif
12802 ! Calculate gradient components.
12803               e1=e1*eps1*eps2rt**2*eps3rt**2
12804               fac=-expon*(e1+evdwij)
12805               sigder=fac/sigsq
12806               fac=rrij*fac
12807 ! Calculate radial part of the gradient
12808               gg(1)=xj*fac
12809               gg(2)=yj*fac
12810               gg(3)=zj*fac
12811 ! Calculate the angular part of the gradient and sum add the contributions
12812 ! to the appropriate components of the Cartesian gradient.
12813               call sc_grad_scale(sss)
12814             endif
12815           enddo      ! j
12816         enddo        ! iint
12817       enddo          ! i
12818 !     stop
12819       return
12820       end subroutine ebp_short
12821 !-----------------------------------------------------------------------------
12822       subroutine egb_long(evdw)
12823 !
12824 ! This subroutine calculates the interaction energy of nonbonded side chains
12825 ! assuming the Gay-Berne potential of interaction.
12826 !
12827       use calc_data
12828 !      implicit real*8 (a-h,o-z)
12829 !      include 'DIMENSIONS'
12830 !      include 'COMMON.GEO'
12831 !      include 'COMMON.VAR'
12832 !      include 'COMMON.LOCAL'
12833 !      include 'COMMON.CHAIN'
12834 !      include 'COMMON.DERIV'
12835 !      include 'COMMON.NAMES'
12836 !      include 'COMMON.INTERACT'
12837 !      include 'COMMON.IOUNITS'
12838 !      include 'COMMON.CALC'
12839 !      include 'COMMON.CONTROL'
12840       logical :: lprn
12841 !el local variables
12842       integer :: iint,itypi,itypi1,itypj,subchap
12843       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
12844       real(kind=8) :: sss,e1,e2,evdw,sss_grad
12845       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12846                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12847                     ssgradlipi,ssgradlipj
12848
12849
12850       evdw=0.0D0
12851 !cccc      energy_dec=.false.
12852 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12853       evdw=0.0D0
12854       lprn=.false.
12855 !     if (icall.eq.0) lprn=.false.
12856 !el      ind=0
12857       do i=iatsc_s,iatsc_e
12858         itypi=itype(i,1)
12859         if (itypi.eq.ntyp1) cycle
12860         itypi1=itype(i+1,1)
12861         xi=c(1,nres+i)
12862         yi=c(2,nres+i)
12863         zi=c(3,nres+i)
12864           xi=mod(xi,boxxsize)
12865           if (xi.lt.0) xi=xi+boxxsize
12866           yi=mod(yi,boxysize)
12867           if (yi.lt.0) yi=yi+boxysize
12868           zi=mod(zi,boxzsize)
12869           if (zi.lt.0) zi=zi+boxzsize
12870        if ((zi.gt.bordlipbot)    &
12871         .and.(zi.lt.bordliptop)) then
12872 !C the energy transfer exist
12873         if (zi.lt.buflipbot) then
12874 !C what fraction I am in
12875          fracinbuf=1.0d0-    &
12876              ((zi-bordlipbot)/lipbufthick)
12877 !C lipbufthick is thickenes of lipid buffore
12878          sslipi=sscalelip(fracinbuf)
12879          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12880         elseif (zi.gt.bufliptop) then
12881          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12882          sslipi=sscalelip(fracinbuf)
12883          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12884         else
12885          sslipi=1.0d0
12886          ssgradlipi=0.0
12887         endif
12888        else
12889          sslipi=0.0d0
12890          ssgradlipi=0.0
12891        endif
12892
12893         dxi=dc_norm(1,nres+i)
12894         dyi=dc_norm(2,nres+i)
12895         dzi=dc_norm(3,nres+i)
12896 !        dsci_inv=dsc_inv(itypi)
12897         dsci_inv=vbld_inv(i+nres)
12898 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12899 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12900 !
12901 ! Calculate SC interaction energy.
12902 !
12903         do iint=1,nint_gr(i)
12904           do j=istart(i,iint),iend(i,iint)
12905             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12906 !              call dyn_ssbond_ene(i,j,evdwij)
12907 !              evdw=evdw+evdwij
12908 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12909 !                              'evdw',i,j,evdwij,' ss'
12910 !              if (energy_dec) write (iout,*) &
12911 !                              'evdw',i,j,evdwij,' ss'
12912 !             do k=j+1,iend(i,iint)
12913 !C search over all next residues
12914 !              if (dyn_ss_mask(k)) then
12915 !C check if they are cysteins
12916 !C              write(iout,*) 'k=',k
12917
12918 !c              write(iout,*) "PRZED TRI", evdwij
12919 !               evdwij_przed_tri=evdwij
12920 !              call triple_ssbond_ene(i,j,k,evdwij)
12921 !c               if(evdwij_przed_tri.ne.evdwij) then
12922 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
12923 !c               endif
12924
12925 !c              write(iout,*) "PO TRI", evdwij
12926 !C call the energy function that removes the artifical triple disulfide
12927 !C bond the soubroutine is located in ssMD.F
12928 !              evdw=evdw+evdwij
12929               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12930                             'evdw',i,j,evdwij,'tss'
12931 !              endif!dyn_ss_mask(k)
12932 !             enddo! k
12933
12934             ELSE
12935 !el            ind=ind+1
12936             itypj=itype(j,1)
12937             if (itypj.eq.ntyp1) cycle
12938 !            dscj_inv=dsc_inv(itypj)
12939             dscj_inv=vbld_inv(j+nres)
12940 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12941 !     &       1.0d0/vbld(j+nres)
12942 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
12943             sig0ij=sigma(itypi,itypj)
12944             chi1=chi(itypi,itypj)
12945             chi2=chi(itypj,itypi)
12946             chi12=chi1*chi2
12947             chip1=chip(itypi)
12948             chip2=chip(itypj)
12949             chip12=chip1*chip2
12950             alf1=alp(itypi)
12951             alf2=alp(itypj)
12952             alf12=0.5D0*(alf1+alf2)
12953             xj=c(1,nres+j)
12954             yj=c(2,nres+j)
12955             zj=c(3,nres+j)
12956 ! Searching for nearest neighbour
12957           xj=mod(xj,boxxsize)
12958           if (xj.lt.0) xj=xj+boxxsize
12959           yj=mod(yj,boxysize)
12960           if (yj.lt.0) yj=yj+boxysize
12961           zj=mod(zj,boxzsize)
12962           if (zj.lt.0) zj=zj+boxzsize
12963        if ((zj.gt.bordlipbot)   &
12964       .and.(zj.lt.bordliptop)) then
12965 !C the energy transfer exist
12966         if (zj.lt.buflipbot) then
12967 !C what fraction I am in
12968          fracinbuf=1.0d0-  &
12969              ((zj-bordlipbot)/lipbufthick)
12970 !C lipbufthick is thickenes of lipid buffore
12971          sslipj=sscalelip(fracinbuf)
12972          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
12973         elseif (zj.gt.bufliptop) then
12974          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
12975          sslipj=sscalelip(fracinbuf)
12976          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
12977         else
12978          sslipj=1.0d0
12979          ssgradlipj=0.0
12980         endif
12981        else
12982          sslipj=0.0d0
12983          ssgradlipj=0.0
12984        endif
12985       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12986        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12987       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12988        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12989
12990           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12991           xj_safe=xj
12992           yj_safe=yj
12993           zj_safe=zj
12994           subchap=0
12995           do xshift=-1,1
12996           do yshift=-1,1
12997           do zshift=-1,1
12998           xj=xj_safe+xshift*boxxsize
12999           yj=yj_safe+yshift*boxysize
13000           zj=zj_safe+zshift*boxzsize
13001           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13002           if(dist_temp.lt.dist_init) then
13003             dist_init=dist_temp
13004             xj_temp=xj
13005             yj_temp=yj
13006             zj_temp=zj
13007             subchap=1
13008           endif
13009           enddo
13010           enddo
13011           enddo
13012           if (subchap.eq.1) then
13013           xj=xj_temp-xi
13014           yj=yj_temp-yi
13015           zj=zj_temp-zi
13016           else
13017           xj=xj_safe-xi
13018           yj=yj_safe-yi
13019           zj=zj_safe-zi
13020           endif
13021
13022             dxj=dc_norm(1,nres+j)
13023             dyj=dc_norm(2,nres+j)
13024             dzj=dc_norm(3,nres+j)
13025             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13026             rij=dsqrt(rrij)
13027             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13028             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13029             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13030             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13031             if (sss_ele_cut.le.0.0) cycle
13032             if (sss.lt.1.0d0) then
13033
13034 ! Calculate angle-dependent terms of energy and contributions to their
13035 ! derivatives.
13036               call sc_angular
13037               sigsq=1.0D0/sigsq
13038               sig=sig0ij*dsqrt(sigsq)
13039               rij_shift=1.0D0/rij-sig+sig0ij
13040 ! for diagnostics; uncomment
13041 !              rij_shift=1.2*sig0ij
13042 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13043               if (rij_shift.le.0.0D0) then
13044                 evdw=1.0D20
13045 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13046 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13047 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13048                 return
13049               endif
13050               sigder=-sig*sigsq
13051 !---------------------------------------------------------------
13052               rij_shift=1.0D0/rij_shift
13053               fac=rij_shift**expon
13054               e1=fac*fac*aa
13055               e2=fac*bb
13056               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13057               eps2der=evdwij*eps3rt
13058               eps3der=evdwij*eps2rt
13059 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13060 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13061               evdwij=evdwij*eps2rt*eps3rt
13062               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13063               if (lprn) then
13064               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13065               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13066               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13067                 restyp(itypi,1),i,restyp(itypj,1),j,&
13068                 epsi,sigm,chi1,chi2,chip1,chip2,&
13069                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13070                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13071                 evdwij
13072               endif
13073
13074               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13075                               'evdw',i,j,evdwij
13076 !              if (energy_dec) write (iout,*) &
13077 !                              'evdw',i,j,evdwij,"egb_long"
13078
13079 ! Calculate gradient components.
13080               e1=e1*eps1*eps2rt**2*eps3rt**2
13081               fac=-expon*(e1+evdwij)*rij_shift
13082               sigder=fac*sigder
13083               fac=rij*fac
13084               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13085             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13086             /sigmaii(itypi,itypj))
13087 !              fac=0.0d0
13088 ! Calculate the radial part of the gradient
13089               gg(1)=xj*fac
13090               gg(2)=yj*fac
13091               gg(3)=zj*fac
13092 ! Calculate angular part of the gradient.
13093               call sc_grad_scale(1.0d0-sss)
13094             ENDIF    !mask_dyn_ss
13095             endif
13096           enddo      ! j
13097         enddo        ! iint
13098       enddo          ! i
13099 !      write (iout,*) "Number of loop steps in EGB:",ind
13100 !ccc      energy_dec=.false.
13101       return
13102       end subroutine egb_long
13103 !-----------------------------------------------------------------------------
13104       subroutine egb_short(evdw)
13105 !
13106 ! This subroutine calculates the interaction energy of nonbonded side chains
13107 ! assuming the Gay-Berne potential of interaction.
13108 !
13109       use calc_data
13110 !      implicit real*8 (a-h,o-z)
13111 !      include 'DIMENSIONS'
13112 !      include 'COMMON.GEO'
13113 !      include 'COMMON.VAR'
13114 !      include 'COMMON.LOCAL'
13115 !      include 'COMMON.CHAIN'
13116 !      include 'COMMON.DERIV'
13117 !      include 'COMMON.NAMES'
13118 !      include 'COMMON.INTERACT'
13119 !      include 'COMMON.IOUNITS'
13120 !      include 'COMMON.CALC'
13121 !      include 'COMMON.CONTROL'
13122       logical :: lprn
13123 !el local variables
13124       integer :: iint,itypi,itypi1,itypj,subchap
13125       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13126       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13127       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13128                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13129                     ssgradlipi,ssgradlipj
13130       evdw=0.0D0
13131 !cccc      energy_dec=.false.
13132 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13133       evdw=0.0D0
13134       lprn=.false.
13135 !     if (icall.eq.0) lprn=.false.
13136 !el      ind=0
13137       do i=iatsc_s,iatsc_e
13138         itypi=itype(i,1)
13139         if (itypi.eq.ntyp1) cycle
13140         itypi1=itype(i+1,1)
13141         xi=c(1,nres+i)
13142         yi=c(2,nres+i)
13143         zi=c(3,nres+i)
13144           xi=mod(xi,boxxsize)
13145           if (xi.lt.0) xi=xi+boxxsize
13146           yi=mod(yi,boxysize)
13147           if (yi.lt.0) yi=yi+boxysize
13148           zi=mod(zi,boxzsize)
13149           if (zi.lt.0) zi=zi+boxzsize
13150        if ((zi.gt.bordlipbot)    &
13151         .and.(zi.lt.bordliptop)) then
13152 !C the energy transfer exist
13153         if (zi.lt.buflipbot) then
13154 !C what fraction I am in
13155          fracinbuf=1.0d0-    &
13156              ((zi-bordlipbot)/lipbufthick)
13157 !C lipbufthick is thickenes of lipid buffore
13158          sslipi=sscalelip(fracinbuf)
13159          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13160         elseif (zi.gt.bufliptop) then
13161          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13162          sslipi=sscalelip(fracinbuf)
13163          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13164         else
13165          sslipi=1.0d0
13166          ssgradlipi=0.0
13167         endif
13168        else
13169          sslipi=0.0d0
13170          ssgradlipi=0.0
13171        endif
13172
13173         dxi=dc_norm(1,nres+i)
13174         dyi=dc_norm(2,nres+i)
13175         dzi=dc_norm(3,nres+i)
13176 !        dsci_inv=dsc_inv(itypi)
13177         dsci_inv=vbld_inv(i+nres)
13178
13179         dxi=dc_norm(1,nres+i)
13180         dyi=dc_norm(2,nres+i)
13181         dzi=dc_norm(3,nres+i)
13182 !        dsci_inv=dsc_inv(itypi)
13183         dsci_inv=vbld_inv(i+nres)
13184 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13185 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13186 !
13187 ! Calculate SC interaction energy.
13188 !
13189         do iint=1,nint_gr(i)
13190           do j=istart(i,iint),iend(i,iint)
13191             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13192               call dyn_ssbond_ene(i,j,evdwij)
13193               evdw=evdw+evdwij
13194               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13195                               'evdw',i,j,evdwij,' ss'
13196              do k=j+1,iend(i,iint)
13197 !C search over all next residues
13198               if (dyn_ss_mask(k)) then
13199 !C check if they are cysteins
13200 !C              write(iout,*) 'k=',k
13201
13202 !c              write(iout,*) "PRZED TRI", evdwij
13203 !               evdwij_przed_tri=evdwij
13204               call triple_ssbond_ene(i,j,k,evdwij)
13205 !c               if(evdwij_przed_tri.ne.evdwij) then
13206 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13207 !c               endif
13208
13209 !c              write(iout,*) "PO TRI", evdwij
13210 !C call the energy function that removes the artifical triple disulfide
13211 !C bond the soubroutine is located in ssMD.F
13212               evdw=evdw+evdwij
13213               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13214                             'evdw',i,j,evdwij,'tss'
13215               endif!dyn_ss_mask(k)
13216              enddo! k
13217
13218 !              if (energy_dec) write (iout,*) &
13219 !                              'evdw',i,j,evdwij,' ss'
13220             ELSE
13221 !el            ind=ind+1
13222             itypj=itype(j,1)
13223             if (itypj.eq.ntyp1) cycle
13224 !            dscj_inv=dsc_inv(itypj)
13225             dscj_inv=vbld_inv(j+nres)
13226 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13227 !     &       1.0d0/vbld(j+nres)
13228 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13229             sig0ij=sigma(itypi,itypj)
13230             chi1=chi(itypi,itypj)
13231             chi2=chi(itypj,itypi)
13232             chi12=chi1*chi2
13233             chip1=chip(itypi)
13234             chip2=chip(itypj)
13235             chip12=chip1*chip2
13236             alf1=alp(itypi)
13237             alf2=alp(itypj)
13238             alf12=0.5D0*(alf1+alf2)
13239 !            xj=c(1,nres+j)-xi
13240 !            yj=c(2,nres+j)-yi
13241 !            zj=c(3,nres+j)-zi
13242             xj=c(1,nres+j)
13243             yj=c(2,nres+j)
13244             zj=c(3,nres+j)
13245 ! Searching for nearest neighbour
13246           xj=mod(xj,boxxsize)
13247           if (xj.lt.0) xj=xj+boxxsize
13248           yj=mod(yj,boxysize)
13249           if (yj.lt.0) yj=yj+boxysize
13250           zj=mod(zj,boxzsize)
13251           if (zj.lt.0) zj=zj+boxzsize
13252        if ((zj.gt.bordlipbot)   &
13253       .and.(zj.lt.bordliptop)) then
13254 !C the energy transfer exist
13255         if (zj.lt.buflipbot) then
13256 !C what fraction I am in
13257          fracinbuf=1.0d0-  &
13258              ((zj-bordlipbot)/lipbufthick)
13259 !C lipbufthick is thickenes of lipid buffore
13260          sslipj=sscalelip(fracinbuf)
13261          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13262         elseif (zj.gt.bufliptop) then
13263          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13264          sslipj=sscalelip(fracinbuf)
13265          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13266         else
13267          sslipj=1.0d0
13268          ssgradlipj=0.0
13269         endif
13270        else
13271          sslipj=0.0d0
13272          ssgradlipj=0.0
13273        endif
13274       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13275        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13276       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13277        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13278
13279           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13280           xj_safe=xj
13281           yj_safe=yj
13282           zj_safe=zj
13283           subchap=0
13284
13285           do xshift=-1,1
13286           do yshift=-1,1
13287           do zshift=-1,1
13288           xj=xj_safe+xshift*boxxsize
13289           yj=yj_safe+yshift*boxysize
13290           zj=zj_safe+zshift*boxzsize
13291           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13292           if(dist_temp.lt.dist_init) then
13293             dist_init=dist_temp
13294             xj_temp=xj
13295             yj_temp=yj
13296             zj_temp=zj
13297             subchap=1
13298           endif
13299           enddo
13300           enddo
13301           enddo
13302           if (subchap.eq.1) then
13303           xj=xj_temp-xi
13304           yj=yj_temp-yi
13305           zj=zj_temp-zi
13306           else
13307           xj=xj_safe-xi
13308           yj=yj_safe-yi
13309           zj=zj_safe-zi
13310           endif
13311
13312             dxj=dc_norm(1,nres+j)
13313             dyj=dc_norm(2,nres+j)
13314             dzj=dc_norm(3,nres+j)
13315             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13316             rij=dsqrt(rrij)
13317             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13318             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13319             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13320             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13321             if (sss_ele_cut.le.0.0) cycle
13322
13323             if (sss.gt.0.0d0) then
13324
13325 ! Calculate angle-dependent terms of energy and contributions to their
13326 ! derivatives.
13327               call sc_angular
13328               sigsq=1.0D0/sigsq
13329               sig=sig0ij*dsqrt(sigsq)
13330               rij_shift=1.0D0/rij-sig+sig0ij
13331 ! for diagnostics; uncomment
13332 !              rij_shift=1.2*sig0ij
13333 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13334               if (rij_shift.le.0.0D0) then
13335                 evdw=1.0D20
13336 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13337 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13338 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13339                 return
13340               endif
13341               sigder=-sig*sigsq
13342 !---------------------------------------------------------------
13343               rij_shift=1.0D0/rij_shift
13344               fac=rij_shift**expon
13345               e1=fac*fac*aa
13346               e2=fac*bb
13347               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13348               eps2der=evdwij*eps3rt
13349               eps3der=evdwij*eps2rt
13350 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13351 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13352               evdwij=evdwij*eps2rt*eps3rt
13353               evdw=evdw+evdwij*sss*sss_ele_cut
13354               if (lprn) then
13355               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13356               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13357               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13358                 restyp(itypi,1),i,restyp(itypj,1),j,&
13359                 epsi,sigm,chi1,chi2,chip1,chip2,&
13360                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13361                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13362                 evdwij
13363               endif
13364
13365               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13366                               'evdw',i,j,evdwij
13367 !              if (energy_dec) write (iout,*) &
13368 !                              'evdw',i,j,evdwij,"egb_short"
13369
13370 ! Calculate gradient components.
13371               e1=e1*eps1*eps2rt**2*eps3rt**2
13372               fac=-expon*(e1+evdwij)*rij_shift
13373               sigder=fac*sigder
13374               fac=rij*fac
13375               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13376             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13377             /sigmaii(itypi,itypj))
13378
13379 !              fac=0.0d0
13380 ! Calculate the radial part of the gradient
13381               gg(1)=xj*fac
13382               gg(2)=yj*fac
13383               gg(3)=zj*fac
13384 ! Calculate angular part of the gradient.
13385               call sc_grad_scale(sss)
13386             endif
13387           ENDIF !mask_dyn_ss
13388           enddo      ! j
13389         enddo        ! iint
13390       enddo          ! i
13391 !      write (iout,*) "Number of loop steps in EGB:",ind
13392 !ccc      energy_dec=.false.
13393       return
13394       end subroutine egb_short
13395 !-----------------------------------------------------------------------------
13396       subroutine egbv_long(evdw)
13397 !
13398 ! This subroutine calculates the interaction energy of nonbonded side chains
13399 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13400 !
13401       use calc_data
13402 !      implicit real*8 (a-h,o-z)
13403 !      include 'DIMENSIONS'
13404 !      include 'COMMON.GEO'
13405 !      include 'COMMON.VAR'
13406 !      include 'COMMON.LOCAL'
13407 !      include 'COMMON.CHAIN'
13408 !      include 'COMMON.DERIV'
13409 !      include 'COMMON.NAMES'
13410 !      include 'COMMON.INTERACT'
13411 !      include 'COMMON.IOUNITS'
13412 !      include 'COMMON.CALC'
13413       use comm_srutu
13414 !el      integer :: icall
13415 !el      common /srutu/ icall
13416       logical :: lprn
13417 !el local variables
13418       integer :: iint,itypi,itypi1,itypj
13419       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13420       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13421       evdw=0.0D0
13422 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13423       evdw=0.0D0
13424       lprn=.false.
13425 !     if (icall.eq.0) lprn=.true.
13426 !el      ind=0
13427       do i=iatsc_s,iatsc_e
13428         itypi=itype(i,1)
13429         if (itypi.eq.ntyp1) cycle
13430         itypi1=itype(i+1,1)
13431         xi=c(1,nres+i)
13432         yi=c(2,nres+i)
13433         zi=c(3,nres+i)
13434         dxi=dc_norm(1,nres+i)
13435         dyi=dc_norm(2,nres+i)
13436         dzi=dc_norm(3,nres+i)
13437 !        dsci_inv=dsc_inv(itypi)
13438         dsci_inv=vbld_inv(i+nres)
13439 !
13440 ! Calculate SC interaction energy.
13441 !
13442         do iint=1,nint_gr(i)
13443           do j=istart(i,iint),iend(i,iint)
13444 !el            ind=ind+1
13445             itypj=itype(j,1)
13446             if (itypj.eq.ntyp1) cycle
13447 !            dscj_inv=dsc_inv(itypj)
13448             dscj_inv=vbld_inv(j+nres)
13449             sig0ij=sigma(itypi,itypj)
13450             r0ij=r0(itypi,itypj)
13451             chi1=chi(itypi,itypj)
13452             chi2=chi(itypj,itypi)
13453             chi12=chi1*chi2
13454             chip1=chip(itypi)
13455             chip2=chip(itypj)
13456             chip12=chip1*chip2
13457             alf1=alp(itypi)
13458             alf2=alp(itypj)
13459             alf12=0.5D0*(alf1+alf2)
13460             xj=c(1,nres+j)-xi
13461             yj=c(2,nres+j)-yi
13462             zj=c(3,nres+j)-zi
13463             dxj=dc_norm(1,nres+j)
13464             dyj=dc_norm(2,nres+j)
13465             dzj=dc_norm(3,nres+j)
13466             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13467             rij=dsqrt(rrij)
13468
13469             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13470
13471             if (sss.lt.1.0d0) then
13472
13473 ! Calculate angle-dependent terms of energy and contributions to their
13474 ! derivatives.
13475               call sc_angular
13476               sigsq=1.0D0/sigsq
13477               sig=sig0ij*dsqrt(sigsq)
13478               rij_shift=1.0D0/rij-sig+r0ij
13479 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13480               if (rij_shift.le.0.0D0) then
13481                 evdw=1.0D20
13482                 return
13483               endif
13484               sigder=-sig*sigsq
13485 !---------------------------------------------------------------
13486               rij_shift=1.0D0/rij_shift
13487               fac=rij_shift**expon
13488               e1=fac*fac*aa_aq(itypi,itypj)
13489               e2=fac*bb_aq(itypi,itypj)
13490               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13491               eps2der=evdwij*eps3rt
13492               eps3der=evdwij*eps2rt
13493               fac_augm=rrij**expon
13494               e_augm=augm(itypi,itypj)*fac_augm
13495               evdwij=evdwij*eps2rt*eps3rt
13496               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13497               if (lprn) then
13498               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13499               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13500               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13501                 restyp(itypi,1),i,restyp(itypj,1),j,&
13502                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13503                 chi1,chi2,chip1,chip2,&
13504                 eps1,eps2rt**2,eps3rt**2,&
13505                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13506                 evdwij+e_augm
13507               endif
13508 ! Calculate gradient components.
13509               e1=e1*eps1*eps2rt**2*eps3rt**2
13510               fac=-expon*(e1+evdwij)*rij_shift
13511               sigder=fac*sigder
13512               fac=rij*fac-2*expon*rrij*e_augm
13513 ! Calculate the radial part of the gradient
13514               gg(1)=xj*fac
13515               gg(2)=yj*fac
13516               gg(3)=zj*fac
13517 ! Calculate angular part of the gradient.
13518               call sc_grad_scale(1.0d0-sss)
13519             endif
13520           enddo      ! j
13521         enddo        ! iint
13522       enddo          ! i
13523       end subroutine egbv_long
13524 !-----------------------------------------------------------------------------
13525       subroutine egbv_short(evdw)
13526 !
13527 ! This subroutine calculates the interaction energy of nonbonded side chains
13528 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13529 !
13530       use calc_data
13531 !      implicit real*8 (a-h,o-z)
13532 !      include 'DIMENSIONS'
13533 !      include 'COMMON.GEO'
13534 !      include 'COMMON.VAR'
13535 !      include 'COMMON.LOCAL'
13536 !      include 'COMMON.CHAIN'
13537 !      include 'COMMON.DERIV'
13538 !      include 'COMMON.NAMES'
13539 !      include 'COMMON.INTERACT'
13540 !      include 'COMMON.IOUNITS'
13541 !      include 'COMMON.CALC'
13542       use comm_srutu
13543 !el      integer :: icall
13544 !el      common /srutu/ icall
13545       logical :: lprn
13546 !el local variables
13547       integer :: iint,itypi,itypi1,itypj
13548       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13549       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13550       evdw=0.0D0
13551 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13552       evdw=0.0D0
13553       lprn=.false.
13554 !     if (icall.eq.0) lprn=.true.
13555 !el      ind=0
13556       do i=iatsc_s,iatsc_e
13557         itypi=itype(i,1)
13558         if (itypi.eq.ntyp1) cycle
13559         itypi1=itype(i+1,1)
13560         xi=c(1,nres+i)
13561         yi=c(2,nres+i)
13562         zi=c(3,nres+i)
13563         dxi=dc_norm(1,nres+i)
13564         dyi=dc_norm(2,nres+i)
13565         dzi=dc_norm(3,nres+i)
13566 !        dsci_inv=dsc_inv(itypi)
13567         dsci_inv=vbld_inv(i+nres)
13568 !
13569 ! Calculate SC interaction energy.
13570 !
13571         do iint=1,nint_gr(i)
13572           do j=istart(i,iint),iend(i,iint)
13573 !el            ind=ind+1
13574             itypj=itype(j,1)
13575             if (itypj.eq.ntyp1) cycle
13576 !            dscj_inv=dsc_inv(itypj)
13577             dscj_inv=vbld_inv(j+nres)
13578             sig0ij=sigma(itypi,itypj)
13579             r0ij=r0(itypi,itypj)
13580             chi1=chi(itypi,itypj)
13581             chi2=chi(itypj,itypi)
13582             chi12=chi1*chi2
13583             chip1=chip(itypi)
13584             chip2=chip(itypj)
13585             chip12=chip1*chip2
13586             alf1=alp(itypi)
13587             alf2=alp(itypj)
13588             alf12=0.5D0*(alf1+alf2)
13589             xj=c(1,nres+j)-xi
13590             yj=c(2,nres+j)-yi
13591             zj=c(3,nres+j)-zi
13592             dxj=dc_norm(1,nres+j)
13593             dyj=dc_norm(2,nres+j)
13594             dzj=dc_norm(3,nres+j)
13595             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13596             rij=dsqrt(rrij)
13597
13598             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13599
13600             if (sss.gt.0.0d0) then
13601
13602 ! Calculate angle-dependent terms of energy and contributions to their
13603 ! derivatives.
13604               call sc_angular
13605               sigsq=1.0D0/sigsq
13606               sig=sig0ij*dsqrt(sigsq)
13607               rij_shift=1.0D0/rij-sig+r0ij
13608 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13609               if (rij_shift.le.0.0D0) then
13610                 evdw=1.0D20
13611                 return
13612               endif
13613               sigder=-sig*sigsq
13614 !---------------------------------------------------------------
13615               rij_shift=1.0D0/rij_shift
13616               fac=rij_shift**expon
13617               e1=fac*fac*aa_aq(itypi,itypj)
13618               e2=fac*bb_aq(itypi,itypj)
13619               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13620               eps2der=evdwij*eps3rt
13621               eps3der=evdwij*eps2rt
13622               fac_augm=rrij**expon
13623               e_augm=augm(itypi,itypj)*fac_augm
13624               evdwij=evdwij*eps2rt*eps3rt
13625               evdw=evdw+(evdwij+e_augm)*sss
13626               if (lprn) then
13627               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13628               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13629               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13630                 restyp(itypi,1),i,restyp(itypj,1),j,&
13631                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13632                 chi1,chi2,chip1,chip2,&
13633                 eps1,eps2rt**2,eps3rt**2,&
13634                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13635                 evdwij+e_augm
13636               endif
13637 ! Calculate gradient components.
13638               e1=e1*eps1*eps2rt**2*eps3rt**2
13639               fac=-expon*(e1+evdwij)*rij_shift
13640               sigder=fac*sigder
13641               fac=rij*fac-2*expon*rrij*e_augm
13642 ! Calculate the radial part of the gradient
13643               gg(1)=xj*fac
13644               gg(2)=yj*fac
13645               gg(3)=zj*fac
13646 ! Calculate angular part of the gradient.
13647               call sc_grad_scale(sss)
13648             endif
13649           enddo      ! j
13650         enddo        ! iint
13651       enddo          ! i
13652       end subroutine egbv_short
13653 !-----------------------------------------------------------------------------
13654       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13655 !
13656 ! This subroutine calculates the average interaction energy and its gradient
13657 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13658 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13659 ! The potential depends both on the distance of peptide-group centers and on
13660 ! the orientation of the CA-CA virtual bonds.
13661 !
13662 !      implicit real*8 (a-h,o-z)
13663
13664       use comm_locel
13665 #ifdef MPI
13666       include 'mpif.h'
13667 #endif
13668 !      include 'DIMENSIONS'
13669 !      include 'COMMON.CONTROL'
13670 !      include 'COMMON.SETUP'
13671 !      include 'COMMON.IOUNITS'
13672 !      include 'COMMON.GEO'
13673 !      include 'COMMON.VAR'
13674 !      include 'COMMON.LOCAL'
13675 !      include 'COMMON.CHAIN'
13676 !      include 'COMMON.DERIV'
13677 !      include 'COMMON.INTERACT'
13678 !      include 'COMMON.CONTACTS'
13679 !      include 'COMMON.TORSION'
13680 !      include 'COMMON.VECTORS'
13681 !      include 'COMMON.FFIELD'
13682 !      include 'COMMON.TIME1'
13683       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13684       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13685       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13686 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13687       real(kind=8),dimension(4) :: muij
13688 !el      integer :: num_conti,j1,j2
13689 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13690 !el                   dz_normi,xmedi,ymedi,zmedi
13691 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13692 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13693 !el          num_conti,j1,j2
13694 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13695 #ifdef MOMENT
13696       real(kind=8) :: scal_el=1.0d0
13697 #else
13698       real(kind=8) :: scal_el=0.5d0
13699 #endif
13700 ! 12/13/98
13701 ! 13-go grudnia roku pamietnego...
13702       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13703                                              0.0d0,1.0d0,0.0d0,&
13704                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13705 !el local variables
13706       integer :: i,j,k
13707       real(kind=8) :: fac
13708       real(kind=8) :: dxj,dyj,dzj
13709       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13710
13711 !      allocate(num_cont_hb(nres)) !(maxres)
13712 !d      write(iout,*) 'In EELEC'
13713 !d      do i=1,nloctyp
13714 !d        write(iout,*) 'Type',i
13715 !d        write(iout,*) 'B1',B1(:,i)
13716 !d        write(iout,*) 'B2',B2(:,i)
13717 !d        write(iout,*) 'CC',CC(:,:,i)
13718 !d        write(iout,*) 'DD',DD(:,:,i)
13719 !d        write(iout,*) 'EE',EE(:,:,i)
13720 !d      enddo
13721 !d      call check_vecgrad
13722 !d      stop
13723       if (icheckgrad.eq.1) then
13724         do i=1,nres-1
13725           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13726           do k=1,3
13727             dc_norm(k,i)=dc(k,i)*fac
13728           enddo
13729 !          write (iout,*) 'i',i,' fac',fac
13730         enddo
13731       endif
13732       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13733           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13734           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13735 !        call vec_and_deriv
13736 #ifdef TIMING
13737         time01=MPI_Wtime()
13738 #endif
13739 !        print *, "before set matrices"
13740         call set_matrices
13741 !        print *,"after set martices"
13742 #ifdef TIMING
13743         time_mat=time_mat+MPI_Wtime()-time01
13744 #endif
13745       endif
13746 !d      do i=1,nres-1
13747 !d        write (iout,*) 'i=',i
13748 !d        do k=1,3
13749 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13750 !d        enddo
13751 !d        do k=1,3
13752 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13753 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13754 !d        enddo
13755 !d      enddo
13756       t_eelecij=0.0d0
13757       ees=0.0D0
13758       evdw1=0.0D0
13759       eel_loc=0.0d0
13760       eello_turn3=0.0d0
13761       eello_turn4=0.0d0
13762 !el      ind=0
13763       do i=1,nres
13764         num_cont_hb(i)=0
13765       enddo
13766 !d      print '(a)','Enter EELEC'
13767 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13768 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13769 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13770       do i=1,nres
13771         gel_loc_loc(i)=0.0d0
13772         gcorr_loc(i)=0.0d0
13773       enddo
13774 !
13775 !
13776 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13777 !
13778 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13779 !
13780       do i=iturn3_start,iturn3_end
13781         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
13782         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
13783         dxi=dc(1,i)
13784         dyi=dc(2,i)
13785         dzi=dc(3,i)
13786         dx_normi=dc_norm(1,i)
13787         dy_normi=dc_norm(2,i)
13788         dz_normi=dc_norm(3,i)
13789         xmedi=c(1,i)+0.5d0*dxi
13790         ymedi=c(2,i)+0.5d0*dyi
13791         zmedi=c(3,i)+0.5d0*dzi
13792           xmedi=dmod(xmedi,boxxsize)
13793           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13794           ymedi=dmod(ymedi,boxysize)
13795           if (ymedi.lt.0) ymedi=ymedi+boxysize
13796           zmedi=dmod(zmedi,boxzsize)
13797           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13798         num_conti=0
13799         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13800         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13801         num_cont_hb(i)=num_conti
13802       enddo
13803       do i=iturn4_start,iturn4_end
13804         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
13805           .or. itype(i+3,1).eq.ntyp1 &
13806           .or. itype(i+4,1).eq.ntyp1) cycle
13807         dxi=dc(1,i)
13808         dyi=dc(2,i)
13809         dzi=dc(3,i)
13810         dx_normi=dc_norm(1,i)
13811         dy_normi=dc_norm(2,i)
13812         dz_normi=dc_norm(3,i)
13813         xmedi=c(1,i)+0.5d0*dxi
13814         ymedi=c(2,i)+0.5d0*dyi
13815         zmedi=c(3,i)+0.5d0*dzi
13816           xmedi=dmod(xmedi,boxxsize)
13817           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13818           ymedi=dmod(ymedi,boxysize)
13819           if (ymedi.lt.0) ymedi=ymedi+boxysize
13820           zmedi=dmod(zmedi,boxzsize)
13821           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13822         num_conti=num_cont_hb(i)
13823         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13824         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
13825           call eturn4(i,eello_turn4)
13826         num_cont_hb(i)=num_conti
13827       enddo   ! i
13828 !
13829 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13830 !
13831       do i=iatel_s,iatel_e
13832         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
13833         dxi=dc(1,i)
13834         dyi=dc(2,i)
13835         dzi=dc(3,i)
13836         dx_normi=dc_norm(1,i)
13837         dy_normi=dc_norm(2,i)
13838         dz_normi=dc_norm(3,i)
13839         xmedi=c(1,i)+0.5d0*dxi
13840         ymedi=c(2,i)+0.5d0*dyi
13841         zmedi=c(3,i)+0.5d0*dzi
13842           xmedi=dmod(xmedi,boxxsize)
13843           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13844           ymedi=dmod(ymedi,boxysize)
13845           if (ymedi.lt.0) ymedi=ymedi+boxysize
13846           zmedi=dmod(zmedi,boxzsize)
13847           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13848 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
13849         num_conti=num_cont_hb(i)
13850         do j=ielstart(i),ielend(i)
13851           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
13852           call eelecij_scale(i,j,ees,evdw1,eel_loc)
13853         enddo ! j
13854         num_cont_hb(i)=num_conti
13855       enddo   ! i
13856 !      write (iout,*) "Number of loop steps in EELEC:",ind
13857 !d      do i=1,nres
13858 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
13859 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
13860 !d      enddo
13861 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
13862 !cc      eel_loc=eel_loc+eello_turn3
13863 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
13864       return
13865       end subroutine eelec_scale
13866 !-----------------------------------------------------------------------------
13867       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
13868 !      implicit real*8 (a-h,o-z)
13869
13870       use comm_locel
13871 !      include 'DIMENSIONS'
13872 #ifdef MPI
13873       include "mpif.h"
13874 #endif
13875 !      include 'COMMON.CONTROL'
13876 !      include 'COMMON.IOUNITS'
13877 !      include 'COMMON.GEO'
13878 !      include 'COMMON.VAR'
13879 !      include 'COMMON.LOCAL'
13880 !      include 'COMMON.CHAIN'
13881 !      include 'COMMON.DERIV'
13882 !      include 'COMMON.INTERACT'
13883 !      include 'COMMON.CONTACTS'
13884 !      include 'COMMON.TORSION'
13885 !      include 'COMMON.VECTORS'
13886 !      include 'COMMON.FFIELD'
13887 !      include 'COMMON.TIME1'
13888       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
13889       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
13890       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13891 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13892       real(kind=8),dimension(4) :: muij
13893       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13894                     dist_temp, dist_init,sss_grad
13895       integer xshift,yshift,zshift
13896
13897 !el      integer :: num_conti,j1,j2
13898 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13899 !el                   dz_normi,xmedi,ymedi,zmedi
13900 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13901 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13902 !el          num_conti,j1,j2
13903 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13904 #ifdef MOMENT
13905       real(kind=8) :: scal_el=1.0d0
13906 #else
13907       real(kind=8) :: scal_el=0.5d0
13908 #endif
13909 ! 12/13/98
13910 ! 13-go grudnia roku pamietnego...
13911       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13912                                              0.0d0,1.0d0,0.0d0,&
13913                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13914 !el local variables
13915       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
13916       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
13917       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
13918       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
13919       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
13920       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
13921       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
13922                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
13923                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
13924                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
13925                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
13926                   ecosam,ecosbm,ecosgm,ghalf,time00
13927 !      integer :: maxconts
13928 !      maxconts = nres/4
13929 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13930 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13931 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13932 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13933 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13934 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13935 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13936 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13937 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
13938 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
13939 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
13940 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
13941 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
13942
13943 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
13944 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
13945
13946 #ifdef MPI
13947           time00=MPI_Wtime()
13948 #endif
13949 !d      write (iout,*) "eelecij",i,j
13950 !el          ind=ind+1
13951           iteli=itel(i)
13952           itelj=itel(j)
13953           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13954           aaa=app(iteli,itelj)
13955           bbb=bpp(iteli,itelj)
13956           ael6i=ael6(iteli,itelj)
13957           ael3i=ael3(iteli,itelj)
13958           dxj=dc(1,j)
13959           dyj=dc(2,j)
13960           dzj=dc(3,j)
13961           dx_normj=dc_norm(1,j)
13962           dy_normj=dc_norm(2,j)
13963           dz_normj=dc_norm(3,j)
13964 !          xj=c(1,j)+0.5D0*dxj-xmedi
13965 !          yj=c(2,j)+0.5D0*dyj-ymedi
13966 !          zj=c(3,j)+0.5D0*dzj-zmedi
13967           xj=c(1,j)+0.5D0*dxj
13968           yj=c(2,j)+0.5D0*dyj
13969           zj=c(3,j)+0.5D0*dzj
13970           xj=mod(xj,boxxsize)
13971           if (xj.lt.0) xj=xj+boxxsize
13972           yj=mod(yj,boxysize)
13973           if (yj.lt.0) yj=yj+boxysize
13974           zj=mod(zj,boxzsize)
13975           if (zj.lt.0) zj=zj+boxzsize
13976       isubchap=0
13977       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13978       xj_safe=xj
13979       yj_safe=yj
13980       zj_safe=zj
13981       do xshift=-1,1
13982       do yshift=-1,1
13983       do zshift=-1,1
13984           xj=xj_safe+xshift*boxxsize
13985           yj=yj_safe+yshift*boxysize
13986           zj=zj_safe+zshift*boxzsize
13987           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13988           if(dist_temp.lt.dist_init) then
13989             dist_init=dist_temp
13990             xj_temp=xj
13991             yj_temp=yj
13992             zj_temp=zj
13993             isubchap=1
13994           endif
13995        enddo
13996        enddo
13997        enddo
13998        if (isubchap.eq.1) then
13999 !C          print *,i,j
14000           xj=xj_temp-xmedi
14001           yj=yj_temp-ymedi
14002           zj=zj_temp-zmedi
14003        else
14004           xj=xj_safe-xmedi
14005           yj=yj_safe-ymedi
14006           zj=zj_safe-zmedi
14007        endif
14008
14009           rij=xj*xj+yj*yj+zj*zj
14010           rrmij=1.0D0/rij
14011           rij=dsqrt(rij)
14012           rmij=1.0D0/rij
14013 ! For extracting the short-range part of Evdwpp
14014           sss=sscale(rij/rpp(iteli,itelj))
14015             sss_ele_cut=sscale_ele(rij)
14016             sss_ele_grad=sscagrad_ele(rij)
14017             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14018 !             sss_ele_cut=1.0d0
14019 !             sss_ele_grad=0.0d0
14020             if (sss_ele_cut.le.0.0) go to 128
14021
14022           r3ij=rrmij*rmij
14023           r6ij=r3ij*r3ij
14024           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14025           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14026           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14027           fac=cosa-3.0D0*cosb*cosg
14028           ev1=aaa*r6ij*r6ij
14029 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14030           if (j.eq.i+2) ev1=scal_el*ev1
14031           ev2=bbb*r6ij
14032           fac3=ael6i*r6ij
14033           fac4=ael3i*r3ij
14034           evdwij=ev1+ev2
14035           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14036           el2=fac4*fac
14037           eesij=el1+el2
14038 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14039           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14040           ees=ees+eesij*sss_ele_cut
14041           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14042 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14043 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14044 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14045 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14046
14047           if (energy_dec) then
14048               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14049               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14050           endif
14051
14052 !
14053 ! Calculate contributions to the Cartesian gradient.
14054 !
14055 #ifdef SPLITELE
14056           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14057           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14058           fac1=fac
14059           erij(1)=xj*rmij
14060           erij(2)=yj*rmij
14061           erij(3)=zj*rmij
14062 !
14063 ! Radial derivatives. First process both termini of the fragment (i,j)
14064 !
14065           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14066           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14067           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14068 !          do k=1,3
14069 !            ghalf=0.5D0*ggg(k)
14070 !            gelc(k,i)=gelc(k,i)+ghalf
14071 !            gelc(k,j)=gelc(k,j)+ghalf
14072 !          enddo
14073 ! 9/28/08 AL Gradient compotents will be summed only at the end
14074           do k=1,3
14075             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14076             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14077           enddo
14078 !
14079 ! Loop over residues i+1 thru j-1.
14080 !
14081 !grad          do k=i+1,j-1
14082 !grad            do l=1,3
14083 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14084 !grad            enddo
14085 !grad          enddo
14086           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14087           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14088           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14089           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14090           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14091           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14092 !          do k=1,3
14093 !            ghalf=0.5D0*ggg(k)
14094 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14095 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14096 !          enddo
14097 ! 9/28/08 AL Gradient compotents will be summed only at the end
14098           do k=1,3
14099             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14100             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14101           enddo
14102 !
14103 ! Loop over residues i+1 thru j-1.
14104 !
14105 !grad          do k=i+1,j-1
14106 !grad            do l=1,3
14107 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14108 !grad            enddo
14109 !grad          enddo
14110 #else
14111           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14112           facel=(el1+eesij)*sss_ele_cut
14113           fac1=fac
14114           fac=-3*rrmij*(facvdw+facvdw+facel)
14115           erij(1)=xj*rmij
14116           erij(2)=yj*rmij
14117           erij(3)=zj*rmij
14118 !
14119 ! Radial derivatives. First process both termini of the fragment (i,j)
14120 !
14121           ggg(1)=fac*xj
14122           ggg(2)=fac*yj
14123           ggg(3)=fac*zj
14124 !          do k=1,3
14125 !            ghalf=0.5D0*ggg(k)
14126 !            gelc(k,i)=gelc(k,i)+ghalf
14127 !            gelc(k,j)=gelc(k,j)+ghalf
14128 !          enddo
14129 ! 9/28/08 AL Gradient compotents will be summed only at the end
14130           do k=1,3
14131             gelc_long(k,j)=gelc(k,j)+ggg(k)
14132             gelc_long(k,i)=gelc(k,i)-ggg(k)
14133           enddo
14134 !
14135 ! Loop over residues i+1 thru j-1.
14136 !
14137 !grad          do k=i+1,j-1
14138 !grad            do l=1,3
14139 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14140 !grad            enddo
14141 !grad          enddo
14142 ! 9/28/08 AL Gradient compotents will be summed only at the end
14143           ggg(1)=facvdw*xj
14144           ggg(2)=facvdw*yj
14145           ggg(3)=facvdw*zj
14146           do k=1,3
14147             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14148             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14149           enddo
14150 #endif
14151 !
14152 ! Angular part
14153 !
14154           ecosa=2.0D0*fac3*fac1+fac4
14155           fac4=-3.0D0*fac4
14156           fac3=-6.0D0*fac3
14157           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14158           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14159           do k=1,3
14160             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14161             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14162           enddo
14163 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14164 !d   &          (dcosg(k),k=1,3)
14165           do k=1,3
14166             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14167           enddo
14168 !          do k=1,3
14169 !            ghalf=0.5D0*ggg(k)
14170 !            gelc(k,i)=gelc(k,i)+ghalf
14171 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14172 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14173 !            gelc(k,j)=gelc(k,j)+ghalf
14174 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14175 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14176 !          enddo
14177 !grad          do k=i+1,j-1
14178 !grad            do l=1,3
14179 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14180 !grad            enddo
14181 !grad          enddo
14182           do k=1,3
14183             gelc(k,i)=gelc(k,i) &
14184                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14185                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14186                      *sss_ele_cut
14187             gelc(k,j)=gelc(k,j) &
14188                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14189                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14190                      *sss_ele_cut
14191             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14192             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14193           enddo
14194           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14195               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14196               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14197 !
14198 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14199 !   energy of a peptide unit is assumed in the form of a second-order
14200 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14201 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14202 !   are computed for EVERY pair of non-contiguous peptide groups.
14203 !
14204           if (j.lt.nres-1) then
14205             j1=j+1
14206             j2=j-1
14207           else
14208             j1=j-1
14209             j2=j-2
14210           endif
14211           kkk=0
14212           do k=1,2
14213             do l=1,2
14214               kkk=kkk+1
14215               muij(kkk)=mu(k,i)*mu(l,j)
14216             enddo
14217           enddo
14218 !d         write (iout,*) 'EELEC: i',i,' j',j
14219 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14220 !d          write(iout,*) 'muij',muij
14221           ury=scalar(uy(1,i),erij)
14222           urz=scalar(uz(1,i),erij)
14223           vry=scalar(uy(1,j),erij)
14224           vrz=scalar(uz(1,j),erij)
14225           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14226           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14227           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14228           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14229           fac=dsqrt(-ael6i)*r3ij
14230           a22=a22*fac
14231           a23=a23*fac
14232           a32=a32*fac
14233           a33=a33*fac
14234 !d          write (iout,'(4i5,4f10.5)')
14235 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14236 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14237 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14238 !d     &      uy(:,j),uz(:,j)
14239 !d          write (iout,'(4f10.5)')
14240 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14241 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14242 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14243 !d           write (iout,'(9f10.5/)')
14244 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14245 ! Derivatives of the elements of A in virtual-bond vectors
14246           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14247           do k=1,3
14248             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14249             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14250             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14251             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14252             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14253             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14254             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14255             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14256             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14257             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14258             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14259             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14260           enddo
14261 ! Compute radial contributions to the gradient
14262           facr=-3.0d0*rrmij
14263           a22der=a22*facr
14264           a23der=a23*facr
14265           a32der=a32*facr
14266           a33der=a33*facr
14267           agg(1,1)=a22der*xj
14268           agg(2,1)=a22der*yj
14269           agg(3,1)=a22der*zj
14270           agg(1,2)=a23der*xj
14271           agg(2,2)=a23der*yj
14272           agg(3,2)=a23der*zj
14273           agg(1,3)=a32der*xj
14274           agg(2,3)=a32der*yj
14275           agg(3,3)=a32der*zj
14276           agg(1,4)=a33der*xj
14277           agg(2,4)=a33der*yj
14278           agg(3,4)=a33der*zj
14279 ! Add the contributions coming from er
14280           fac3=-3.0d0*fac
14281           do k=1,3
14282             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14283             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14284             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14285             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14286           enddo
14287           do k=1,3
14288 ! Derivatives in DC(i)
14289 !grad            ghalf1=0.5d0*agg(k,1)
14290 !grad            ghalf2=0.5d0*agg(k,2)
14291 !grad            ghalf3=0.5d0*agg(k,3)
14292 !grad            ghalf4=0.5d0*agg(k,4)
14293             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14294             -3.0d0*uryg(k,2)*vry)!+ghalf1
14295             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14296             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14297             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14298             -3.0d0*urzg(k,2)*vry)!+ghalf3
14299             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14300             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14301 ! Derivatives in DC(i+1)
14302             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14303             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14304             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14305             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14306             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14307             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14308             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14309             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14310 ! Derivatives in DC(j)
14311             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14312             -3.0d0*vryg(k,2)*ury)!+ghalf1
14313             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14314             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14315             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14316             -3.0d0*vryg(k,2)*urz)!+ghalf3
14317             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14318             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14319 ! Derivatives in DC(j+1) or DC(nres-1)
14320             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14321             -3.0d0*vryg(k,3)*ury)
14322             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14323             -3.0d0*vrzg(k,3)*ury)
14324             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14325             -3.0d0*vryg(k,3)*urz)
14326             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14327             -3.0d0*vrzg(k,3)*urz)
14328 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14329 !grad              do l=1,4
14330 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14331 !grad              enddo
14332 !grad            endif
14333           enddo
14334           acipa(1,1)=a22
14335           acipa(1,2)=a23
14336           acipa(2,1)=a32
14337           acipa(2,2)=a33
14338           a22=-a22
14339           a23=-a23
14340           do l=1,2
14341             do k=1,3
14342               agg(k,l)=-agg(k,l)
14343               aggi(k,l)=-aggi(k,l)
14344               aggi1(k,l)=-aggi1(k,l)
14345               aggj(k,l)=-aggj(k,l)
14346               aggj1(k,l)=-aggj1(k,l)
14347             enddo
14348           enddo
14349           if (j.lt.nres-1) then
14350             a22=-a22
14351             a32=-a32
14352             do l=1,3,2
14353               do k=1,3
14354                 agg(k,l)=-agg(k,l)
14355                 aggi(k,l)=-aggi(k,l)
14356                 aggi1(k,l)=-aggi1(k,l)
14357                 aggj(k,l)=-aggj(k,l)
14358                 aggj1(k,l)=-aggj1(k,l)
14359               enddo
14360             enddo
14361           else
14362             a22=-a22
14363             a23=-a23
14364             a32=-a32
14365             a33=-a33
14366             do l=1,4
14367               do k=1,3
14368                 agg(k,l)=-agg(k,l)
14369                 aggi(k,l)=-aggi(k,l)
14370                 aggi1(k,l)=-aggi1(k,l)
14371                 aggj(k,l)=-aggj(k,l)
14372                 aggj1(k,l)=-aggj1(k,l)
14373               enddo
14374             enddo
14375           endif
14376           ENDIF ! WCORR
14377           IF (wel_loc.gt.0.0d0) THEN
14378 ! Contribution to the local-electrostatic energy coming from the i-j pair
14379           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14380            +a33*muij(4)
14381 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14382
14383           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14384                   'eelloc',i,j,eel_loc_ij
14385 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14386
14387           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14388 ! Partial derivatives in virtual-bond dihedral angles gamma
14389           if (i.gt.1) &
14390           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14391                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14392                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14393                  *sss_ele_cut
14394           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14395                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14396                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14397                  *sss_ele_cut
14398            xtemp(1)=xj
14399            xtemp(2)=yj
14400            xtemp(3)=zj
14401
14402 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14403           do l=1,3
14404             ggg(l)=(agg(l,1)*muij(1)+ &
14405                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14406             *sss_ele_cut &
14407              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14408
14409             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14410             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14411 !grad            ghalf=0.5d0*ggg(l)
14412 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14413 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14414           enddo
14415 !grad          do k=i+1,j2
14416 !grad            do l=1,3
14417 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14418 !grad            enddo
14419 !grad          enddo
14420 ! Remaining derivatives of eello
14421           do l=1,3
14422             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14423                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14424             *sss_ele_cut
14425
14426             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14427                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14428             *sss_ele_cut
14429
14430             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14431                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14432             *sss_ele_cut
14433
14434             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14435                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14436             *sss_ele_cut
14437
14438           enddo
14439           ENDIF
14440 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14441 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14442           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14443              .and. num_conti.le.maxconts) then
14444 !            write (iout,*) i,j," entered corr"
14445 !
14446 ! Calculate the contact function. The ith column of the array JCONT will
14447 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14448 ! greater than I). The arrays FACONT and GACONT will contain the values of
14449 ! the contact function and its derivative.
14450 !           r0ij=1.02D0*rpp(iteli,itelj)
14451 !           r0ij=1.11D0*rpp(iteli,itelj)
14452             r0ij=2.20D0*rpp(iteli,itelj)
14453 !           r0ij=1.55D0*rpp(iteli,itelj)
14454             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14455 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14456             if (fcont.gt.0.0D0) then
14457               num_conti=num_conti+1
14458               if (num_conti.gt.maxconts) then
14459 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14460                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14461                                ' will skip next contacts for this conf.',num_conti
14462               else
14463                 jcont_hb(num_conti,i)=j
14464 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14465 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14466                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14467                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14468 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14469 !  terms.
14470                 d_cont(num_conti,i)=rij
14471 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14472 !     --- Electrostatic-interaction matrix ---
14473                 a_chuj(1,1,num_conti,i)=a22
14474                 a_chuj(1,2,num_conti,i)=a23
14475                 a_chuj(2,1,num_conti,i)=a32
14476                 a_chuj(2,2,num_conti,i)=a33
14477 !     --- Gradient of rij
14478                 do kkk=1,3
14479                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14480                 enddo
14481                 kkll=0
14482                 do k=1,2
14483                   do l=1,2
14484                     kkll=kkll+1
14485                     do m=1,3
14486                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14487                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14488                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14489                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14490                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14491                     enddo
14492                   enddo
14493                 enddo
14494                 ENDIF
14495                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14496 ! Calculate contact energies
14497                 cosa4=4.0D0*cosa
14498                 wij=cosa-3.0D0*cosb*cosg
14499                 cosbg1=cosb+cosg
14500                 cosbg2=cosb-cosg
14501 !               fac3=dsqrt(-ael6i)/r0ij**3
14502                 fac3=dsqrt(-ael6i)*r3ij
14503 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14504                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14505                 if (ees0tmp.gt.0) then
14506                   ees0pij=dsqrt(ees0tmp)
14507                 else
14508                   ees0pij=0
14509                 endif
14510 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14511                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14512                 if (ees0tmp.gt.0) then
14513                   ees0mij=dsqrt(ees0tmp)
14514                 else
14515                   ees0mij=0
14516                 endif
14517 !               ees0mij=0.0D0
14518                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14519                      *sss_ele_cut
14520
14521                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14522                      *sss_ele_cut
14523
14524 ! Diagnostics. Comment out or remove after debugging!
14525 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14526 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14527 !               ees0m(num_conti,i)=0.0D0
14528 ! End diagnostics.
14529 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14530 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14531 ! Angular derivatives of the contact function
14532                 ees0pij1=fac3/ees0pij
14533                 ees0mij1=fac3/ees0mij
14534                 fac3p=-3.0D0*fac3*rrmij
14535                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14536                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14537 !               ees0mij1=0.0D0
14538                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14539                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14540                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14541                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14542                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14543                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14544                 ecosap=ecosa1+ecosa2
14545                 ecosbp=ecosb1+ecosb2
14546                 ecosgp=ecosg1+ecosg2
14547                 ecosam=ecosa1-ecosa2
14548                 ecosbm=ecosb1-ecosb2
14549                 ecosgm=ecosg1-ecosg2
14550 ! Diagnostics
14551 !               ecosap=ecosa1
14552 !               ecosbp=ecosb1
14553 !               ecosgp=ecosg1
14554 !               ecosam=0.0D0
14555 !               ecosbm=0.0D0
14556 !               ecosgm=0.0D0
14557 ! End diagnostics
14558                 facont_hb(num_conti,i)=fcont
14559                 fprimcont=fprimcont/rij
14560 !d              facont_hb(num_conti,i)=1.0D0
14561 ! Following line is for diagnostics.
14562 !d              fprimcont=0.0D0
14563                 do k=1,3
14564                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14565                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14566                 enddo
14567                 do k=1,3
14568                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14569                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14570                 enddo
14571 !                gggp(1)=gggp(1)+ees0pijp*xj
14572 !                gggp(2)=gggp(2)+ees0pijp*yj
14573 !                gggp(3)=gggp(3)+ees0pijp*zj
14574 !                gggm(1)=gggm(1)+ees0mijp*xj
14575 !                gggm(2)=gggm(2)+ees0mijp*yj
14576 !                gggm(3)=gggm(3)+ees0mijp*zj
14577                 gggp(1)=gggp(1)+ees0pijp*xj &
14578                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14579                 gggp(2)=gggp(2)+ees0pijp*yj &
14580                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14581                 gggp(3)=gggp(3)+ees0pijp*zj &
14582                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14583
14584                 gggm(1)=gggm(1)+ees0mijp*xj &
14585                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14586
14587                 gggm(2)=gggm(2)+ees0mijp*yj &
14588                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14589
14590                 gggm(3)=gggm(3)+ees0mijp*zj &
14591                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14592
14593 ! Derivatives due to the contact function
14594                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14595                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14596                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14597                 do k=1,3
14598 !
14599 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14600 !          following the change of gradient-summation algorithm.
14601 !
14602 !grad                  ghalfp=0.5D0*gggp(k)
14603 !grad                  ghalfm=0.5D0*gggm(k)
14604 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14605 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14606 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14607 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14608 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14609 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14610 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14611 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14612 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14613 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14614 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14615 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14616 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14617 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14618                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14619                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14620                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14621                      *sss_ele_cut
14622
14623                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14624                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14625                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14626                      *sss_ele_cut
14627
14628                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14629                      *sss_ele_cut
14630
14631                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14632                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14633                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14634                      *sss_ele_cut
14635
14636                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14637                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14638                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14639                      *sss_ele_cut
14640
14641                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14642                      *sss_ele_cut
14643
14644                 enddo
14645               ENDIF ! wcorr
14646               endif  ! num_conti.le.maxconts
14647             endif  ! fcont.gt.0
14648           endif    ! j.gt.i+1
14649           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14650             do k=1,4
14651               do l=1,3
14652                 ghalf=0.5d0*agg(l,k)
14653                 aggi(l,k)=aggi(l,k)+ghalf
14654                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14655                 aggj(l,k)=aggj(l,k)+ghalf
14656               enddo
14657             enddo
14658             if (j.eq.nres-1 .and. i.lt.j-2) then
14659               do k=1,4
14660                 do l=1,3
14661                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14662                 enddo
14663               enddo
14664             endif
14665           endif
14666  128      continue
14667 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14668       return
14669       end subroutine eelecij_scale
14670 !-----------------------------------------------------------------------------
14671       subroutine evdwpp_short(evdw1)
14672 !
14673 ! Compute Evdwpp
14674 !
14675 !      implicit real*8 (a-h,o-z)
14676 !      include 'DIMENSIONS'
14677 !      include 'COMMON.CONTROL'
14678 !      include 'COMMON.IOUNITS'
14679 !      include 'COMMON.GEO'
14680 !      include 'COMMON.VAR'
14681 !      include 'COMMON.LOCAL'
14682 !      include 'COMMON.CHAIN'
14683 !      include 'COMMON.DERIV'
14684 !      include 'COMMON.INTERACT'
14685 !      include 'COMMON.CONTACTS'
14686 !      include 'COMMON.TORSION'
14687 !      include 'COMMON.VECTORS'
14688 !      include 'COMMON.FFIELD'
14689       real(kind=8),dimension(3) :: ggg
14690 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14691 #ifdef MOMENT
14692       real(kind=8) :: scal_el=1.0d0
14693 #else
14694       real(kind=8) :: scal_el=0.5d0
14695 #endif
14696 !el local variables
14697       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14698       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14699       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14700                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14701                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14702       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14703                     dist_temp, dist_init,sss_grad
14704       integer xshift,yshift,zshift
14705
14706
14707       evdw1=0.0D0
14708 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14709 !     & " iatel_e_vdw",iatel_e_vdw
14710       call flush(iout)
14711       do i=iatel_s_vdw,iatel_e_vdw
14712         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14713         dxi=dc(1,i)
14714         dyi=dc(2,i)
14715         dzi=dc(3,i)
14716         dx_normi=dc_norm(1,i)
14717         dy_normi=dc_norm(2,i)
14718         dz_normi=dc_norm(3,i)
14719         xmedi=c(1,i)+0.5d0*dxi
14720         ymedi=c(2,i)+0.5d0*dyi
14721         zmedi=c(3,i)+0.5d0*dzi
14722           xmedi=dmod(xmedi,boxxsize)
14723           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14724           ymedi=dmod(ymedi,boxysize)
14725           if (ymedi.lt.0) ymedi=ymedi+boxysize
14726           zmedi=dmod(zmedi,boxzsize)
14727           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14728         num_conti=0
14729 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14730 !     &   ' ielend',ielend_vdw(i)
14731         call flush(iout)
14732         do j=ielstart_vdw(i),ielend_vdw(i)
14733           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14734 !el          ind=ind+1
14735           iteli=itel(i)
14736           itelj=itel(j)
14737           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14738           aaa=app(iteli,itelj)
14739           bbb=bpp(iteli,itelj)
14740           dxj=dc(1,j)
14741           dyj=dc(2,j)
14742           dzj=dc(3,j)
14743           dx_normj=dc_norm(1,j)
14744           dy_normj=dc_norm(2,j)
14745           dz_normj=dc_norm(3,j)
14746 !          xj=c(1,j)+0.5D0*dxj-xmedi
14747 !          yj=c(2,j)+0.5D0*dyj-ymedi
14748 !          zj=c(3,j)+0.5D0*dzj-zmedi
14749           xj=c(1,j)+0.5D0*dxj
14750           yj=c(2,j)+0.5D0*dyj
14751           zj=c(3,j)+0.5D0*dzj
14752           xj=mod(xj,boxxsize)
14753           if (xj.lt.0) xj=xj+boxxsize
14754           yj=mod(yj,boxysize)
14755           if (yj.lt.0) yj=yj+boxysize
14756           zj=mod(zj,boxzsize)
14757           if (zj.lt.0) zj=zj+boxzsize
14758       isubchap=0
14759       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14760       xj_safe=xj
14761       yj_safe=yj
14762       zj_safe=zj
14763       do xshift=-1,1
14764       do yshift=-1,1
14765       do zshift=-1,1
14766           xj=xj_safe+xshift*boxxsize
14767           yj=yj_safe+yshift*boxysize
14768           zj=zj_safe+zshift*boxzsize
14769           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14770           if(dist_temp.lt.dist_init) then
14771             dist_init=dist_temp
14772             xj_temp=xj
14773             yj_temp=yj
14774             zj_temp=zj
14775             isubchap=1
14776           endif
14777        enddo
14778        enddo
14779        enddo
14780        if (isubchap.eq.1) then
14781 !C          print *,i,j
14782           xj=xj_temp-xmedi
14783           yj=yj_temp-ymedi
14784           zj=zj_temp-zmedi
14785        else
14786           xj=xj_safe-xmedi
14787           yj=yj_safe-ymedi
14788           zj=zj_safe-zmedi
14789        endif
14790
14791           rij=xj*xj+yj*yj+zj*zj
14792           rrmij=1.0D0/rij
14793           rij=dsqrt(rij)
14794           sss=sscale(rij/rpp(iteli,itelj))
14795             sss_ele_cut=sscale_ele(rij)
14796             sss_ele_grad=sscagrad_ele(rij)
14797             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14798             if (sss_ele_cut.le.0.0) cycle
14799           if (sss.gt.0.0d0) then
14800             rmij=1.0D0/rij
14801             r3ij=rrmij*rmij
14802             r6ij=r3ij*r3ij
14803             ev1=aaa*r6ij*r6ij
14804 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14805             if (j.eq.i+2) ev1=scal_el*ev1
14806             ev2=bbb*r6ij
14807             evdwij=ev1+ev2
14808             if (energy_dec) then
14809               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14810             endif
14811             evdw1=evdw1+evdwij*sss*sss_ele_cut
14812 !
14813 ! Calculate contributions to the Cartesian gradient.
14814 !
14815             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14816 !            ggg(1)=facvdw*xj
14817 !            ggg(2)=facvdw*yj
14818 !            ggg(3)=facvdw*zj
14819           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14820           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14821           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14822           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14823           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14824           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14825
14826             do k=1,3
14827               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14828               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14829             enddo
14830           endif
14831         enddo ! j
14832       enddo   ! i
14833       return
14834       end subroutine evdwpp_short
14835 !-----------------------------------------------------------------------------
14836       subroutine escp_long(evdw2,evdw2_14)
14837 !
14838 ! This subroutine calculates the excluded-volume interaction energy between
14839 ! peptide-group centers and side chains and its gradient in virtual-bond and
14840 ! side-chain vectors.
14841 !
14842 !      implicit real*8 (a-h,o-z)
14843 !      include 'DIMENSIONS'
14844 !      include 'COMMON.GEO'
14845 !      include 'COMMON.VAR'
14846 !      include 'COMMON.LOCAL'
14847 !      include 'COMMON.CHAIN'
14848 !      include 'COMMON.DERIV'
14849 !      include 'COMMON.INTERACT'
14850 !      include 'COMMON.FFIELD'
14851 !      include 'COMMON.IOUNITS'
14852 !      include 'COMMON.CONTROL'
14853       real(kind=8),dimension(3) :: ggg
14854 !el local variables
14855       integer :: i,iint,j,k,iteli,itypj,subchap
14856       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14857       real(kind=8) :: evdw2,evdw2_14,evdwij
14858       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14859                     dist_temp, dist_init
14860
14861       evdw2=0.0D0
14862       evdw2_14=0.0d0
14863 !d    print '(a)','Enter ESCP'
14864 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14865       do i=iatscp_s,iatscp_e
14866         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14867         iteli=itel(i)
14868         xi=0.5D0*(c(1,i)+c(1,i+1))
14869         yi=0.5D0*(c(2,i)+c(2,i+1))
14870         zi=0.5D0*(c(3,i)+c(3,i+1))
14871           xi=mod(xi,boxxsize)
14872           if (xi.lt.0) xi=xi+boxxsize
14873           yi=mod(yi,boxysize)
14874           if (yi.lt.0) yi=yi+boxysize
14875           zi=mod(zi,boxzsize)
14876           if (zi.lt.0) zi=zi+boxzsize
14877
14878         do iint=1,nscp_gr(i)
14879
14880         do j=iscpstart(i,iint),iscpend(i,iint)
14881           itypj=itype(j,1)
14882           if (itypj.eq.ntyp1) cycle
14883 ! Uncomment following three lines for SC-p interactions
14884 !         xj=c(1,nres+j)-xi
14885 !         yj=c(2,nres+j)-yi
14886 !         zj=c(3,nres+j)-zi
14887 ! Uncomment following three lines for Ca-p interactions
14888           xj=c(1,j)
14889           yj=c(2,j)
14890           zj=c(3,j)
14891           xj=mod(xj,boxxsize)
14892           if (xj.lt.0) xj=xj+boxxsize
14893           yj=mod(yj,boxysize)
14894           if (yj.lt.0) yj=yj+boxysize
14895           zj=mod(zj,boxzsize)
14896           if (zj.lt.0) zj=zj+boxzsize
14897       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14898       xj_safe=xj
14899       yj_safe=yj
14900       zj_safe=zj
14901       subchap=0
14902       do xshift=-1,1
14903       do yshift=-1,1
14904       do zshift=-1,1
14905           xj=xj_safe+xshift*boxxsize
14906           yj=yj_safe+yshift*boxysize
14907           zj=zj_safe+zshift*boxzsize
14908           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14909           if(dist_temp.lt.dist_init) then
14910             dist_init=dist_temp
14911             xj_temp=xj
14912             yj_temp=yj
14913             zj_temp=zj
14914             subchap=1
14915           endif
14916        enddo
14917        enddo
14918        enddo
14919        if (subchap.eq.1) then
14920           xj=xj_temp-xi
14921           yj=yj_temp-yi
14922           zj=zj_temp-zi
14923        else
14924           xj=xj_safe-xi
14925           yj=yj_safe-yi
14926           zj=zj_safe-zi
14927        endif
14928           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14929
14930           rij=dsqrt(1.0d0/rrij)
14931             sss_ele_cut=sscale_ele(rij)
14932             sss_ele_grad=sscagrad_ele(rij)
14933 !            print *,sss_ele_cut,sss_ele_grad,&
14934 !            (rij),r_cut_ele,rlamb_ele
14935             if (sss_ele_cut.le.0.0) cycle
14936           sss=sscale((rij/rscp(itypj,iteli)))
14937           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14938           if (sss.lt.1.0d0) then
14939
14940             fac=rrij**expon2
14941             e1=fac*fac*aad(itypj,iteli)
14942             e2=fac*bad(itypj,iteli)
14943             if (iabs(j-i) .le. 2) then
14944               e1=scal14*e1
14945               e2=scal14*e2
14946               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
14947             endif
14948             evdwij=e1+e2
14949             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
14950             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14951                 'evdw2',i,j,sss,evdwij
14952 !
14953 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14954 !
14955             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
14956             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
14957             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14958             ggg(1)=xj*fac
14959             ggg(2)=yj*fac
14960             ggg(3)=zj*fac
14961 ! Uncomment following three lines for SC-p interactions
14962 !           do k=1,3
14963 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14964 !           enddo
14965 ! Uncomment following line for SC-p interactions
14966 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14967             do k=1,3
14968               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14969               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14970             enddo
14971           endif
14972         enddo
14973
14974         enddo ! iint
14975       enddo ! i
14976       do i=1,nct
14977         do j=1,3
14978           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14979           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14980           gradx_scp(j,i)=expon*gradx_scp(j,i)
14981         enddo
14982       enddo
14983 !******************************************************************************
14984 !
14985 !                              N O T E !!!
14986 !
14987 ! To save time the factor EXPON has been extracted from ALL components
14988 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14989 ! use!
14990 !
14991 !******************************************************************************
14992       return
14993       end subroutine escp_long
14994 !-----------------------------------------------------------------------------
14995       subroutine escp_short(evdw2,evdw2_14)
14996 !
14997 ! This subroutine calculates the excluded-volume interaction energy between
14998 ! peptide-group centers and side chains and its gradient in virtual-bond and
14999 ! side-chain vectors.
15000 !
15001 !      implicit real*8 (a-h,o-z)
15002 !      include 'DIMENSIONS'
15003 !      include 'COMMON.GEO'
15004 !      include 'COMMON.VAR'
15005 !      include 'COMMON.LOCAL'
15006 !      include 'COMMON.CHAIN'
15007 !      include 'COMMON.DERIV'
15008 !      include 'COMMON.INTERACT'
15009 !      include 'COMMON.FFIELD'
15010 !      include 'COMMON.IOUNITS'
15011 !      include 'COMMON.CONTROL'
15012       real(kind=8),dimension(3) :: ggg
15013 !el local variables
15014       integer :: i,iint,j,k,iteli,itypj,subchap
15015       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15016       real(kind=8) :: evdw2,evdw2_14,evdwij
15017       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15018                     dist_temp, dist_init
15019
15020       evdw2=0.0D0
15021       evdw2_14=0.0d0
15022 !d    print '(a)','Enter ESCP'
15023 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15024       do i=iatscp_s,iatscp_e
15025         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15026         iteli=itel(i)
15027         xi=0.5D0*(c(1,i)+c(1,i+1))
15028         yi=0.5D0*(c(2,i)+c(2,i+1))
15029         zi=0.5D0*(c(3,i)+c(3,i+1))
15030           xi=mod(xi,boxxsize)
15031           if (xi.lt.0) xi=xi+boxxsize
15032           yi=mod(yi,boxysize)
15033           if (yi.lt.0) yi=yi+boxysize
15034           zi=mod(zi,boxzsize)
15035           if (zi.lt.0) zi=zi+boxzsize
15036
15037         do iint=1,nscp_gr(i)
15038
15039         do j=iscpstart(i,iint),iscpend(i,iint)
15040           itypj=itype(j,1)
15041           if (itypj.eq.ntyp1) cycle
15042 ! Uncomment following three lines for SC-p interactions
15043 !         xj=c(1,nres+j)-xi
15044 !         yj=c(2,nres+j)-yi
15045 !         zj=c(3,nres+j)-zi
15046 ! Uncomment following three lines for Ca-p interactions
15047 !          xj=c(1,j)-xi
15048 !          yj=c(2,j)-yi
15049 !          zj=c(3,j)-zi
15050           xj=c(1,j)
15051           yj=c(2,j)
15052           zj=c(3,j)
15053           xj=mod(xj,boxxsize)
15054           if (xj.lt.0) xj=xj+boxxsize
15055           yj=mod(yj,boxysize)
15056           if (yj.lt.0) yj=yj+boxysize
15057           zj=mod(zj,boxzsize)
15058           if (zj.lt.0) zj=zj+boxzsize
15059       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15060       xj_safe=xj
15061       yj_safe=yj
15062       zj_safe=zj
15063       subchap=0
15064       do xshift=-1,1
15065       do yshift=-1,1
15066       do zshift=-1,1
15067           xj=xj_safe+xshift*boxxsize
15068           yj=yj_safe+yshift*boxysize
15069           zj=zj_safe+zshift*boxzsize
15070           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15071           if(dist_temp.lt.dist_init) then
15072             dist_init=dist_temp
15073             xj_temp=xj
15074             yj_temp=yj
15075             zj_temp=zj
15076             subchap=1
15077           endif
15078        enddo
15079        enddo
15080        enddo
15081        if (subchap.eq.1) then
15082           xj=xj_temp-xi
15083           yj=yj_temp-yi
15084           zj=zj_temp-zi
15085        else
15086           xj=xj_safe-xi
15087           yj=yj_safe-yi
15088           zj=zj_safe-zi
15089        endif
15090
15091           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15092           rij=dsqrt(1.0d0/rrij)
15093             sss_ele_cut=sscale_ele(rij)
15094             sss_ele_grad=sscagrad_ele(rij)
15095 !            print *,sss_ele_cut,sss_ele_grad,&
15096 !            (rij),r_cut_ele,rlamb_ele
15097             if (sss_ele_cut.le.0.0) cycle
15098           sss=sscale(rij/rscp(itypj,iteli))
15099           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15100           if (sss.gt.0.0d0) then
15101
15102             fac=rrij**expon2
15103             e1=fac*fac*aad(itypj,iteli)
15104             e2=fac*bad(itypj,iteli)
15105             if (iabs(j-i) .le. 2) then
15106               e1=scal14*e1
15107               e2=scal14*e2
15108               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15109             endif
15110             evdwij=e1+e2
15111             evdw2=evdw2+evdwij*sss*sss_ele_cut
15112             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15113                 'evdw2',i,j,sss,evdwij
15114 !
15115 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15116 !
15117             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15118             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15119             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15120
15121             ggg(1)=xj*fac
15122             ggg(2)=yj*fac
15123             ggg(3)=zj*fac
15124 ! Uncomment following three lines for SC-p interactions
15125 !           do k=1,3
15126 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15127 !           enddo
15128 ! Uncomment following line for SC-p interactions
15129 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15130             do k=1,3
15131               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15132               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15133             enddo
15134           endif
15135         enddo
15136
15137         enddo ! iint
15138       enddo ! i
15139       do i=1,nct
15140         do j=1,3
15141           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15142           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15143           gradx_scp(j,i)=expon*gradx_scp(j,i)
15144         enddo
15145       enddo
15146 !******************************************************************************
15147 !
15148 !                              N O T E !!!
15149 !
15150 ! To save time the factor EXPON has been extracted from ALL components
15151 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15152 ! use!
15153 !
15154 !******************************************************************************
15155       return
15156       end subroutine escp_short
15157 !-----------------------------------------------------------------------------
15158 ! energy_p_new-sep_barrier.F
15159 !-----------------------------------------------------------------------------
15160       subroutine sc_grad_scale(scalfac)
15161 !      implicit real*8 (a-h,o-z)
15162       use calc_data
15163 !      include 'DIMENSIONS'
15164 !      include 'COMMON.CHAIN'
15165 !      include 'COMMON.DERIV'
15166 !      include 'COMMON.CALC'
15167 !      include 'COMMON.IOUNITS'
15168       real(kind=8),dimension(3) :: dcosom1,dcosom2
15169       real(kind=8) :: scalfac
15170 !el local variables
15171 !      integer :: i,j,k,l
15172
15173       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15174       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15175       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15176            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15177 ! diagnostics only
15178 !      eom1=0.0d0
15179 !      eom2=0.0d0
15180 !      eom12=evdwij*eps1_om12
15181 ! end diagnostics
15182 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15183 !     &  " sigder",sigder
15184 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15185 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15186       do k=1,3
15187         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15188         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15189       enddo
15190       do k=1,3
15191         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15192          *sss_ele_cut
15193       enddo
15194 !      write (iout,*) "gg",(gg(k),k=1,3)
15195       do k=1,3
15196         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15197                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15198                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15199                  *sss_ele_cut
15200         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15201                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15202                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15203          *sss_ele_cut
15204 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15205 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15206 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15207 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15208       enddo
15209 !
15210 ! Calculate the components of the gradient in DC and X
15211 !
15212       do l=1,3
15213         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15214         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15215       enddo
15216       return
15217       end subroutine sc_grad_scale
15218 !-----------------------------------------------------------------------------
15219 ! energy_split-sep.F
15220 !-----------------------------------------------------------------------------
15221       subroutine etotal_long(energia)
15222 !
15223 ! Compute the long-range slow-varying contributions to the energy
15224 !
15225 !      implicit real*8 (a-h,o-z)
15226 !      include 'DIMENSIONS'
15227       use MD_data, only: totT,usampl,eq_time
15228 #ifndef ISNAN
15229       external proc_proc
15230 #ifdef WINPGI
15231 !MS$ATTRIBUTES C ::  proc_proc
15232 #endif
15233 #endif
15234 #ifdef MPI
15235       include "mpif.h"
15236       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15237 #endif
15238 !      include 'COMMON.SETUP'
15239 !      include 'COMMON.IOUNITS'
15240 !      include 'COMMON.FFIELD'
15241 !      include 'COMMON.DERIV'
15242 !      include 'COMMON.INTERACT'
15243 !      include 'COMMON.SBRIDGE'
15244 !      include 'COMMON.CHAIN'
15245 !      include 'COMMON.VAR'
15246 !      include 'COMMON.LOCAL'
15247 !      include 'COMMON.MD'
15248       real(kind=8),dimension(0:n_ene) :: energia
15249 !el local variables
15250       integer :: i,n_corr,n_corr1,ierror,ierr
15251       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15252                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15253                   ecorr,ecorr5,ecorr6,eturn6,time00
15254 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15255 !elwrite(iout,*)"in etotal long"
15256
15257       if (modecalc.eq.12.or.modecalc.eq.14) then
15258 #ifdef MPI
15259 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15260 #else
15261         call int_from_cart1(.false.)
15262 #endif
15263       endif
15264 !elwrite(iout,*)"in etotal long"
15265
15266 #ifdef MPI
15267 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15268 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15269       call flush(iout)
15270       if (nfgtasks.gt.1) then
15271         time00=MPI_Wtime()
15272 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15273         if (fg_rank.eq.0) then
15274           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15275 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15276 !          call flush(iout)
15277 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15278 ! FG slaves as WEIGHTS array.
15279           weights_(1)=wsc
15280           weights_(2)=wscp
15281           weights_(3)=welec
15282           weights_(4)=wcorr
15283           weights_(5)=wcorr5
15284           weights_(6)=wcorr6
15285           weights_(7)=wel_loc
15286           weights_(8)=wturn3
15287           weights_(9)=wturn4
15288           weights_(10)=wturn6
15289           weights_(11)=wang
15290           weights_(12)=wscloc
15291           weights_(13)=wtor
15292           weights_(14)=wtor_d
15293           weights_(15)=wstrain
15294           weights_(16)=wvdwpp
15295           weights_(17)=wbond
15296           weights_(18)=scal14
15297           weights_(21)=wsccor
15298 ! FG Master broadcasts the WEIGHTS_ array
15299           call MPI_Bcast(weights_(1),n_ene,&
15300               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15301         else
15302 ! FG slaves receive the WEIGHTS array
15303           call MPI_Bcast(weights(1),n_ene,&
15304               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15305           wsc=weights(1)
15306           wscp=weights(2)
15307           welec=weights(3)
15308           wcorr=weights(4)
15309           wcorr5=weights(5)
15310           wcorr6=weights(6)
15311           wel_loc=weights(7)
15312           wturn3=weights(8)
15313           wturn4=weights(9)
15314           wturn6=weights(10)
15315           wang=weights(11)
15316           wscloc=weights(12)
15317           wtor=weights(13)
15318           wtor_d=weights(14)
15319           wstrain=weights(15)
15320           wvdwpp=weights(16)
15321           wbond=weights(17)
15322           scal14=weights(18)
15323           wsccor=weights(21)
15324         endif
15325         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15326           king,FG_COMM,IERR)
15327          time_Bcast=time_Bcast+MPI_Wtime()-time00
15328          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15329 !        call chainbuild_cart
15330 !        call int_from_cart1(.false.)
15331       endif
15332 !      write (iout,*) 'Processor',myrank,
15333 !     &  ' calling etotal_short ipot=',ipot
15334 !      call flush(iout)
15335 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15336 #endif
15337 !d    print *,'nnt=',nnt,' nct=',nct
15338 !
15339 !elwrite(iout,*)"in etotal long"
15340 ! Compute the side-chain and electrostatic interaction energy
15341 !
15342       goto (101,102,103,104,105,106) ipot
15343 ! Lennard-Jones potential.
15344   101 call elj_long(evdw)
15345 !d    print '(a)','Exit ELJ'
15346       goto 107
15347 ! Lennard-Jones-Kihara potential (shifted).
15348   102 call eljk_long(evdw)
15349       goto 107
15350 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15351   103 call ebp_long(evdw)
15352       goto 107
15353 ! Gay-Berne potential (shifted LJ, angular dependence).
15354   104 call egb_long(evdw)
15355       goto 107
15356 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15357   105 call egbv_long(evdw)
15358       goto 107
15359 ! Soft-sphere potential
15360   106 call e_softsphere(evdw)
15361 !
15362 ! Calculate electrostatic (H-bonding) energy of the main chain.
15363 !
15364   107 continue
15365       call vec_and_deriv
15366       if (ipot.lt.6) then
15367 #ifdef SPLITELE
15368          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15369              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15370              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15371              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15372 #else
15373          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15374              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15375              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15376              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15377 #endif
15378            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15379          else
15380             ees=0
15381             evdw1=0
15382             eel_loc=0
15383             eello_turn3=0
15384             eello_turn4=0
15385          endif
15386       else
15387 !        write (iout,*) "Soft-spheer ELEC potential"
15388         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15389          eello_turn4)
15390       endif
15391 !
15392 ! Calculate excluded-volume interaction energy between peptide groups
15393 ! and side chains.
15394 !
15395       if (ipot.lt.6) then
15396        if(wscp.gt.0d0) then
15397         call escp_long(evdw2,evdw2_14)
15398        else
15399         evdw2=0
15400         evdw2_14=0
15401        endif
15402       else
15403         call escp_soft_sphere(evdw2,evdw2_14)
15404       endif
15405 !
15406 ! 12/1/95 Multi-body terms
15407 !
15408       n_corr=0
15409       n_corr1=0
15410       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15411           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15412          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15413 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15414 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15415       else
15416          ecorr=0.0d0
15417          ecorr5=0.0d0
15418          ecorr6=0.0d0
15419          eturn6=0.0d0
15420       endif
15421       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15422          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15423       endif
15424 !
15425 ! If performing constraint dynamics, call the constraint energy
15426 !  after the equilibration time
15427       if(usampl.and.totT.gt.eq_time) then
15428          call EconstrQ
15429          call Econstr_back
15430       else
15431          Uconst=0.0d0
15432          Uconst_back=0.0d0
15433       endif
15434 !
15435 ! Sum the energies
15436 !
15437       do i=1,n_ene
15438         energia(i)=0.0d0
15439       enddo
15440       energia(1)=evdw
15441 #ifdef SCP14
15442       energia(2)=evdw2-evdw2_14
15443       energia(18)=evdw2_14
15444 #else
15445       energia(2)=evdw2
15446       energia(18)=0.0d0
15447 #endif
15448 #ifdef SPLITELE
15449       energia(3)=ees
15450       energia(16)=evdw1
15451 #else
15452       energia(3)=ees+evdw1
15453       energia(16)=0.0d0
15454 #endif
15455       energia(4)=ecorr
15456       energia(5)=ecorr5
15457       energia(6)=ecorr6
15458       energia(7)=eel_loc
15459       energia(8)=eello_turn3
15460       energia(9)=eello_turn4
15461       energia(10)=eturn6
15462       energia(20)=Uconst+Uconst_back
15463       call sum_energy(energia,.true.)
15464 !      write (iout,*) "Exit ETOTAL_LONG"
15465       call flush(iout)
15466       return
15467       end subroutine etotal_long
15468 !-----------------------------------------------------------------------------
15469       subroutine etotal_short(energia)
15470 !
15471 ! Compute the short-range fast-varying contributions to the energy
15472 !
15473 !      implicit real*8 (a-h,o-z)
15474 !      include 'DIMENSIONS'
15475 #ifndef ISNAN
15476       external proc_proc
15477 #ifdef WINPGI
15478 !MS$ATTRIBUTES C ::  proc_proc
15479 #endif
15480 #endif
15481 #ifdef MPI
15482       include "mpif.h"
15483       integer :: ierror,ierr
15484       real(kind=8),dimension(n_ene) :: weights_
15485       real(kind=8) :: time00
15486 #endif
15487 !      include 'COMMON.SETUP'
15488 !      include 'COMMON.IOUNITS'
15489 !      include 'COMMON.FFIELD'
15490 !      include 'COMMON.DERIV'
15491 !      include 'COMMON.INTERACT'
15492 !      include 'COMMON.SBRIDGE'
15493 !      include 'COMMON.CHAIN'
15494 !      include 'COMMON.VAR'
15495 !      include 'COMMON.LOCAL'
15496       real(kind=8),dimension(0:n_ene) :: energia
15497 !el local variables
15498       integer :: i,nres6
15499       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15500       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15501       nres6=6*nres
15502
15503 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15504 !      call flush(iout)
15505       if (modecalc.eq.12.or.modecalc.eq.14) then
15506 #ifdef MPI
15507         if (fg_rank.eq.0) call int_from_cart1(.false.)
15508 #else
15509         call int_from_cart1(.false.)
15510 #endif
15511       endif
15512 #ifdef MPI
15513 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15514 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15515 !      call flush(iout)
15516       if (nfgtasks.gt.1) then
15517         time00=MPI_Wtime()
15518 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15519         if (fg_rank.eq.0) then
15520           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15521 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15522 !          call flush(iout)
15523 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15524 ! FG slaves as WEIGHTS array.
15525           weights_(1)=wsc
15526           weights_(2)=wscp
15527           weights_(3)=welec
15528           weights_(4)=wcorr
15529           weights_(5)=wcorr5
15530           weights_(6)=wcorr6
15531           weights_(7)=wel_loc
15532           weights_(8)=wturn3
15533           weights_(9)=wturn4
15534           weights_(10)=wturn6
15535           weights_(11)=wang
15536           weights_(12)=wscloc
15537           weights_(13)=wtor
15538           weights_(14)=wtor_d
15539           weights_(15)=wstrain
15540           weights_(16)=wvdwpp
15541           weights_(17)=wbond
15542           weights_(18)=scal14
15543           weights_(21)=wsccor
15544 ! FG Master broadcasts the WEIGHTS_ array
15545           call MPI_Bcast(weights_(1),n_ene,&
15546               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15547         else
15548 ! FG slaves receive the WEIGHTS array
15549           call MPI_Bcast(weights(1),n_ene,&
15550               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15551           wsc=weights(1)
15552           wscp=weights(2)
15553           welec=weights(3)
15554           wcorr=weights(4)
15555           wcorr5=weights(5)
15556           wcorr6=weights(6)
15557           wel_loc=weights(7)
15558           wturn3=weights(8)
15559           wturn4=weights(9)
15560           wturn6=weights(10)
15561           wang=weights(11)
15562           wscloc=weights(12)
15563           wtor=weights(13)
15564           wtor_d=weights(14)
15565           wstrain=weights(15)
15566           wvdwpp=weights(16)
15567           wbond=weights(17)
15568           scal14=weights(18)
15569           wsccor=weights(21)
15570         endif
15571 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15572         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15573           king,FG_COMM,IERR)
15574 !        write (iout,*) "Processor",myrank," BROADCAST c"
15575         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15576           king,FG_COMM,IERR)
15577 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15578         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15579           king,FG_COMM,IERR)
15580 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15581         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15582           king,FG_COMM,IERR)
15583 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15584         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15585           king,FG_COMM,IERR)
15586 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15587         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15588           king,FG_COMM,IERR)
15589 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15590         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15591           king,FG_COMM,IERR)
15592 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15593         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15594           king,FG_COMM,IERR)
15595 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15596         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15597           king,FG_COMM,IERR)
15598          time_Bcast=time_Bcast+MPI_Wtime()-time00
15599 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15600       endif
15601 !      write (iout,*) 'Processor',myrank,
15602 !     &  ' calling etotal_short ipot=',ipot
15603 !      call flush(iout)
15604 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15605 #endif
15606 !      call int_from_cart1(.false.)
15607 !
15608 ! Compute the side-chain and electrostatic interaction energy
15609 !
15610       goto (101,102,103,104,105,106) ipot
15611 ! Lennard-Jones potential.
15612   101 call elj_short(evdw)
15613 !d    print '(a)','Exit ELJ'
15614       goto 107
15615 ! Lennard-Jones-Kihara potential (shifted).
15616   102 call eljk_short(evdw)
15617       goto 107
15618 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15619   103 call ebp_short(evdw)
15620       goto 107
15621 ! Gay-Berne potential (shifted LJ, angular dependence).
15622   104 call egb_short(evdw)
15623       goto 107
15624 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15625   105 call egbv_short(evdw)
15626       goto 107
15627 ! Soft-sphere potential - already dealt with in the long-range part
15628   106 evdw=0.0d0
15629 !  106 call e_softsphere_short(evdw)
15630 !
15631 ! Calculate electrostatic (H-bonding) energy of the main chain.
15632 !
15633   107 continue
15634 !
15635 ! Calculate the short-range part of Evdwpp
15636 !
15637       call evdwpp_short(evdw1)
15638 !
15639 ! Calculate the short-range part of ESCp
15640 !
15641       if (ipot.lt.6) then
15642         call escp_short(evdw2,evdw2_14)
15643       endif
15644 !
15645 ! Calculate the bond-stretching energy
15646 !
15647       call ebond(estr)
15648 !
15649 ! Calculate the disulfide-bridge and other energy and the contributions
15650 ! from other distance constraints.
15651       call edis(ehpb)
15652 !
15653 ! Calculate the virtual-bond-angle energy.
15654 !
15655       call ebend(ebe,ethetacnstr)
15656 !
15657 ! Calculate the SC local energy.
15658 !
15659       call vec_and_deriv
15660       call esc(escloc)
15661 !
15662 ! Calculate the virtual-bond torsional energy.
15663 !
15664       call etor(etors,edihcnstr)
15665 !
15666 ! 6/23/01 Calculate double-torsional energy
15667 !
15668       call etor_d(etors_d)
15669 !
15670 ! 21/5/07 Calculate local sicdechain correlation energy
15671 !
15672       if (wsccor.gt.0.0d0) then
15673         call eback_sc_corr(esccor)
15674       else
15675         esccor=0.0d0
15676       endif
15677 !
15678 ! Put energy components into an array
15679 !
15680       do i=1,n_ene
15681         energia(i)=0.0d0
15682       enddo
15683       energia(1)=evdw
15684 #ifdef SCP14
15685       energia(2)=evdw2-evdw2_14
15686       energia(18)=evdw2_14
15687 #else
15688       energia(2)=evdw2
15689       energia(18)=0.0d0
15690 #endif
15691 #ifdef SPLITELE
15692       energia(16)=evdw1
15693 #else
15694       energia(3)=evdw1
15695 #endif
15696       energia(11)=ebe
15697       energia(12)=escloc
15698       energia(13)=etors
15699       energia(14)=etors_d
15700       energia(15)=ehpb
15701       energia(17)=estr
15702       energia(19)=edihcnstr
15703       energia(21)=esccor
15704 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15705       call flush(iout)
15706       call sum_energy(energia,.true.)
15707 !      write (iout,*) "Exit ETOTAL_SHORT"
15708       call flush(iout)
15709       return
15710       end subroutine etotal_short
15711 !-----------------------------------------------------------------------------
15712 ! gnmr1.f
15713 !-----------------------------------------------------------------------------
15714       real(kind=8) function gnmr1(y,ymin,ymax)
15715 !      implicit none
15716       real(kind=8) :: y,ymin,ymax
15717       real(kind=8) :: wykl=4.0d0
15718       if (y.lt.ymin) then
15719         gnmr1=(ymin-y)**wykl/wykl
15720       else if (y.gt.ymax) then
15721         gnmr1=(y-ymax)**wykl/wykl
15722       else
15723         gnmr1=0.0d0
15724       endif
15725       return
15726       end function gnmr1
15727 !-----------------------------------------------------------------------------
15728       real(kind=8) function gnmr1prim(y,ymin,ymax)
15729 !      implicit none
15730       real(kind=8) :: y,ymin,ymax
15731       real(kind=8) :: wykl=4.0d0
15732       if (y.lt.ymin) then
15733         gnmr1prim=-(ymin-y)**(wykl-1)
15734       else if (y.gt.ymax) then
15735         gnmr1prim=(y-ymax)**(wykl-1)
15736       else
15737         gnmr1prim=0.0d0
15738       endif
15739       return
15740       end function gnmr1prim
15741 !----------------------------------------------------------------------------
15742       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15743       real(kind=8) y,ymin,ymax,sigma
15744       real(kind=8) wykl /4.0d0/
15745       if (y.lt.ymin) then
15746         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15747       else if (y.gt.ymax) then
15748         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15749       else
15750         rlornmr1=0.0d0
15751       endif
15752       return
15753       end function rlornmr1
15754 !------------------------------------------------------------------------------
15755       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15756       real(kind=8) y,ymin,ymax,sigma
15757       real(kind=8) wykl /4.0d0/
15758       if (y.lt.ymin) then
15759         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15760         ((ymin-y)**wykl+sigma**wykl)**2
15761       else if (y.gt.ymax) then
15762         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15763         ((y-ymax)**wykl+sigma**wykl)**2
15764       else
15765         rlornmr1prim=0.0d0
15766       endif
15767       return
15768       end function rlornmr1prim
15769
15770       real(kind=8) function harmonic(y,ymax)
15771 !      implicit none
15772       real(kind=8) :: y,ymax
15773       real(kind=8) :: wykl=2.0d0
15774       harmonic=(y-ymax)**wykl
15775       return
15776       end function harmonic
15777 !-----------------------------------------------------------------------------
15778       real(kind=8) function harmonicprim(y,ymax)
15779       real(kind=8) :: y,ymin,ymax
15780       real(kind=8) :: wykl=2.0d0
15781       harmonicprim=(y-ymax)*wykl
15782       return
15783       end function harmonicprim
15784 !-----------------------------------------------------------------------------
15785 ! gradient_p.F
15786 !-----------------------------------------------------------------------------
15787       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15788
15789       use io_base, only:intout,briefout
15790 !      implicit real*8 (a-h,o-z)
15791 !      include 'DIMENSIONS'
15792 !      include 'COMMON.CHAIN'
15793 !      include 'COMMON.DERIV'
15794 !      include 'COMMON.VAR'
15795 !      include 'COMMON.INTERACT'
15796 !      include 'COMMON.FFIELD'
15797 !      include 'COMMON.MD'
15798 !      include 'COMMON.IOUNITS'
15799       real(kind=8),external :: ufparm
15800       integer :: uiparm(1)
15801       real(kind=8) :: urparm(1)
15802       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15803       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15804       integer :: n,nf,ind,ind1,i,k,j
15805 !
15806 ! This subroutine calculates total internal coordinate gradient.
15807 ! Depending on the number of function evaluations, either whole energy
15808 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15809 ! internal coordinates are reevaluated or only the cartesian-in-internal
15810 ! coordinate derivatives are evaluated. The subroutine was designed to work
15811 ! with SUMSL.
15812 !
15813 !
15814       icg=mod(nf,2)+1
15815
15816 !d      print *,'grad',nf,icg
15817       if (nf-nfl+1) 20,30,40
15818    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15819 !    write (iout,*) 'grad 20'
15820       if (nf.eq.0) return
15821       goto 40
15822    30 call var_to_geom(n,x)
15823       call chainbuild
15824 !    write (iout,*) 'grad 30'
15825 !
15826 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15827 !
15828    40 call cartder
15829 !     write (iout,*) 'grad 40'
15830 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15831 !
15832 ! Convert the Cartesian gradient into internal-coordinate gradient.
15833 !
15834       ind=0
15835       ind1=0
15836       do i=1,nres-2
15837         gthetai=0.0D0
15838         gphii=0.0D0
15839         do j=i+1,nres-1
15840           ind=ind+1
15841 !         ind=indmat(i,j)
15842 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
15843           do k=1,3
15844             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
15845           enddo
15846           do k=1,3
15847             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
15848           enddo
15849         enddo
15850         do j=i+1,nres-1
15851           ind1=ind1+1
15852 !         ind1=indmat(i,j)
15853 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
15854           do k=1,3
15855             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
15856             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
15857           enddo
15858         enddo
15859         if (i.gt.1) g(i-1)=gphii
15860         if (n.gt.nphi) g(nphi+i)=gthetai
15861       enddo
15862       if (n.le.nphi+ntheta) goto 10
15863       do i=2,nres-1
15864         if (itype(i,1).ne.10) then
15865           galphai=0.0D0
15866           gomegai=0.0D0
15867           do k=1,3
15868             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
15869           enddo
15870           do k=1,3
15871             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
15872           enddo
15873           g(ialph(i,1))=galphai
15874           g(ialph(i,1)+nside)=gomegai
15875         endif
15876       enddo
15877 !
15878 ! Add the components corresponding to local energy terms.
15879 !
15880    10 continue
15881       do i=1,nvar
15882 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
15883         g(i)=g(i)+gloc(i,icg)
15884       enddo
15885 ! Uncomment following three lines for diagnostics.
15886 !d    call intout
15887 !elwrite(iout,*) "in gradient after calling intout"
15888 !d    call briefout(0,0.0d0)
15889 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
15890       return
15891       end subroutine gradient
15892 !-----------------------------------------------------------------------------
15893       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
15894
15895       use comm_chu
15896 !      implicit real*8 (a-h,o-z)
15897 !      include 'DIMENSIONS'
15898 !      include 'COMMON.DERIV'
15899 !      include 'COMMON.IOUNITS'
15900 !      include 'COMMON.GEO'
15901       integer :: n,nf
15902 !el      integer :: jjj
15903 !el      common /chuju/ jjj
15904       real(kind=8) :: energia(0:n_ene)
15905       integer :: uiparm(1)
15906       real(kind=8) :: urparm(1)
15907       real(kind=8) :: f
15908       real(kind=8),external :: ufparm
15909       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
15910 !     if (jjj.gt.0) then
15911 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15912 !     endif
15913       nfl=nf
15914       icg=mod(nf,2)+1
15915 !d      print *,'func',nf,nfl,icg
15916       call var_to_geom(n,x)
15917       call zerograd
15918       call chainbuild
15919 !d    write (iout,*) 'ETOTAL called from FUNC'
15920       call etotal(energia)
15921       call sum_gradient
15922       f=energia(0)
15923 !     if (jjj.gt.0) then
15924 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15925 !       write (iout,*) 'f=',etot
15926 !       jjj=0
15927 !     endif
15928       return
15929       end subroutine func
15930 !-----------------------------------------------------------------------------
15931       subroutine cartgrad
15932 !      implicit real*8 (a-h,o-z)
15933 !      include 'DIMENSIONS'
15934       use energy_data
15935       use MD_data, only: totT,usampl,eq_time
15936 #ifdef MPI
15937       include 'mpif.h'
15938 #endif
15939 !      include 'COMMON.CHAIN'
15940 !      include 'COMMON.DERIV'
15941 !      include 'COMMON.VAR'
15942 !      include 'COMMON.INTERACT'
15943 !      include 'COMMON.FFIELD'
15944 !      include 'COMMON.MD'
15945 !      include 'COMMON.IOUNITS'
15946 !      include 'COMMON.TIME1'
15947 !
15948       integer :: i,j
15949
15950 ! This subrouting calculates total Cartesian coordinate gradient.
15951 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
15952 !
15953 !el#define DEBUG
15954 #ifdef TIMING
15955       time00=MPI_Wtime()
15956 #endif
15957       icg=1
15958       call sum_gradient
15959 #ifdef TIMING
15960 #endif
15961 !el      write (iout,*) "After sum_gradient"
15962 #ifdef DEBUG
15963 !el      write (iout,*) "After sum_gradient"
15964       do i=1,nres-1
15965         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
15966         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
15967       enddo
15968 #endif
15969 ! If performing constraint dynamics, add the gradients of the constraint energy
15970       if(usampl.and.totT.gt.eq_time) then
15971          do i=1,nct
15972            do j=1,3
15973              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
15974              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
15975            enddo
15976          enddo
15977          do i=1,nres-3
15978            gloc(i,icg)=gloc(i,icg)+dugamma(i)
15979          enddo
15980          do i=1,nres-2
15981            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
15982          enddo
15983       endif
15984 !elwrite (iout,*) "After sum_gradient"
15985 #ifdef TIMING
15986       time01=MPI_Wtime()
15987 #endif
15988       call intcartderiv
15989 !elwrite (iout,*) "After sum_gradient"
15990 #ifdef TIMING
15991       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
15992 #endif
15993 !     call checkintcartgrad
15994 !     write(iout,*) 'calling int_to_cart'
15995 #ifdef DEBUG
15996       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
15997 #endif
15998       do i=0,nct
15999         do j=1,3
16000           gcart(j,i)=gradc(j,i,icg)
16001           gxcart(j,i)=gradx(j,i,icg)
16002         enddo
16003 #ifdef DEBUG
16004         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16005           (gxcart(j,i),j=1,3),gloc(i,icg)
16006 #endif
16007       enddo
16008 #ifdef TIMING
16009       time01=MPI_Wtime()
16010 #endif
16011       call int_to_cart
16012 #ifdef TIMING
16013       time_inttocart=time_inttocart+MPI_Wtime()-time01
16014 #endif
16015 #ifdef DEBUG
16016       write (iout,*) "gcart and gxcart after int_to_cart"
16017       do i=0,nres-1
16018         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16019             (gxcart(j,i),j=1,3)
16020       enddo
16021 #endif
16022 #ifdef CARGRAD
16023 #ifdef DEBUG
16024       write (iout,*) "CARGRAD"
16025 #endif
16026       do i=nres,0,-1
16027         do j=1,3
16028           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16029 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16030         enddo
16031 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16032 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16033       enddo
16034 ! Correction: dummy residues
16035         if (nnt.gt.1) then
16036           do j=1,3
16037 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16038             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16039           enddo
16040         endif
16041         if (nct.lt.nres) then
16042           do j=1,3
16043 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16044             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16045           enddo
16046         endif
16047 #endif
16048 #ifdef TIMING
16049       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16050 #endif
16051 !el#undef DEBUG
16052       return
16053       end subroutine cartgrad
16054 !-----------------------------------------------------------------------------
16055       subroutine zerograd
16056 !      implicit real*8 (a-h,o-z)
16057 !      include 'DIMENSIONS'
16058 !      include 'COMMON.DERIV'
16059 !      include 'COMMON.CHAIN'
16060 !      include 'COMMON.VAR'
16061 !      include 'COMMON.MD'
16062 !      include 'COMMON.SCCOR'
16063 !
16064 !el local variables
16065       integer :: i,j,intertyp,k
16066 ! Initialize Cartesian-coordinate gradient
16067 !
16068 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16069 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16070
16071 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16072 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16073 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16074 !      allocate(gradcorr_long(3,nres))
16075 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16076 !      allocate(gcorr6_turn_long(3,nres))
16077 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16078
16079 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16080
16081 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16082 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16083
16084 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16085 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16086
16087 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16088 !      allocate(gscloc(3,nres)) !(3,maxres)
16089 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16090
16091
16092
16093 !      common /deriv_scloc/
16094 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16095 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16096 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
16097 !      common /mpgrad/
16098 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16099
16100
16101
16102 !          gradc(j,i,icg)=0.0d0
16103 !          gradx(j,i,icg)=0.0d0
16104
16105 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16106 !elwrite(iout,*) "icg",icg
16107       do i=-1,nres
16108         do j=1,3
16109           gvdwx(j,i)=0.0D0
16110           gradx_scp(j,i)=0.0D0
16111           gvdwc(j,i)=0.0D0
16112           gvdwc_scp(j,i)=0.0D0
16113           gvdwc_scpp(j,i)=0.0d0
16114           gelc(j,i)=0.0D0
16115           gelc_long(j,i)=0.0D0
16116           gradb(j,i)=0.0d0
16117           gradbx(j,i)=0.0d0
16118           gvdwpp(j,i)=0.0d0
16119           gel_loc(j,i)=0.0d0
16120           gel_loc_long(j,i)=0.0d0
16121           ghpbc(j,i)=0.0D0
16122           ghpbx(j,i)=0.0D0
16123           gcorr3_turn(j,i)=0.0d0
16124           gcorr4_turn(j,i)=0.0d0
16125           gradcorr(j,i)=0.0d0
16126           gradcorr_long(j,i)=0.0d0
16127           gradcorr5_long(j,i)=0.0d0
16128           gradcorr6_long(j,i)=0.0d0
16129           gcorr6_turn_long(j,i)=0.0d0
16130           gradcorr5(j,i)=0.0d0
16131           gradcorr6(j,i)=0.0d0
16132           gcorr6_turn(j,i)=0.0d0
16133           gsccorc(j,i)=0.0d0
16134           gsccorx(j,i)=0.0d0
16135           gradc(j,i,icg)=0.0d0
16136           gradx(j,i,icg)=0.0d0
16137           gscloc(j,i)=0.0d0
16138           gsclocx(j,i)=0.0d0
16139           gliptran(j,i)=0.0d0
16140           gliptranx(j,i)=0.0d0
16141           gliptranc(j,i)=0.0d0
16142           gshieldx(j,i)=0.0d0
16143           gshieldc(j,i)=0.0d0
16144           gshieldc_loc(j,i)=0.0d0
16145           gshieldx_ec(j,i)=0.0d0
16146           gshieldc_ec(j,i)=0.0d0
16147           gshieldc_loc_ec(j,i)=0.0d0
16148           gshieldx_t3(j,i)=0.0d0
16149           gshieldc_t3(j,i)=0.0d0
16150           gshieldc_loc_t3(j,i)=0.0d0
16151           gshieldx_t4(j,i)=0.0d0
16152           gshieldc_t4(j,i)=0.0d0
16153           gshieldc_loc_t4(j,i)=0.0d0
16154           gshieldx_ll(j,i)=0.0d0
16155           gshieldc_ll(j,i)=0.0d0
16156           gshieldc_loc_ll(j,i)=0.0d0
16157           gg_tube(j,i)=0.0d0
16158           gg_tube_sc(j,i)=0.0d0
16159           gradafm(j,i)=0.0d0
16160           gradb_nucl(j,i)=0.0d0
16161           gradbx_nucl(j,i)=0.0d0
16162           do intertyp=1,3
16163            gloc_sc(intertyp,i,icg)=0.0d0
16164           enddo
16165         enddo
16166       enddo
16167       do i=1,nres
16168        do j=1,maxcontsshi
16169        shield_list(j,i)=0
16170         do k=1,3
16171 !C           print *,i,j,k
16172            grad_shield_side(k,j,i)=0.0d0
16173            grad_shield_loc(k,j,i)=0.0d0
16174          enddo
16175        enddo
16176        ishield_list(i)=0
16177       enddo
16178
16179 !
16180 ! Initialize the gradient of local energy terms.
16181 !
16182 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
16183 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16184 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16185 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
16186 !      allocate(gel_loc_turn3(nres))
16187 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16188 !      allocate(gsccor_loc(nres))       !(maxres)
16189
16190       do i=1,4*nres
16191         gloc(i,icg)=0.0D0
16192       enddo
16193       do i=1,nres
16194         gel_loc_loc(i)=0.0d0
16195         gcorr_loc(i)=0.0d0
16196         g_corr5_loc(i)=0.0d0
16197         g_corr6_loc(i)=0.0d0
16198         gel_loc_turn3(i)=0.0d0
16199         gel_loc_turn4(i)=0.0d0
16200         gel_loc_turn6(i)=0.0d0
16201         gsccor_loc(i)=0.0d0
16202       enddo
16203 ! initialize gcart and gxcart
16204 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16205       do i=0,nres
16206         do j=1,3
16207           gcart(j,i)=0.0d0
16208           gxcart(j,i)=0.0d0
16209         enddo
16210       enddo
16211       return
16212       end subroutine zerograd
16213 !-----------------------------------------------------------------------------
16214       real(kind=8) function fdum()
16215       fdum=0.0D0
16216       return
16217       end function fdum
16218 !-----------------------------------------------------------------------------
16219 ! intcartderiv.F
16220 !-----------------------------------------------------------------------------
16221       subroutine intcartderiv
16222 !      implicit real*8 (a-h,o-z)
16223 !      include 'DIMENSIONS'
16224 #ifdef MPI
16225       include 'mpif.h'
16226 #endif
16227 !      include 'COMMON.SETUP'
16228 !      include 'COMMON.CHAIN'
16229 !      include 'COMMON.VAR'
16230 !      include 'COMMON.GEO'
16231 !      include 'COMMON.INTERACT'
16232 !      include 'COMMON.DERIV'
16233 !      include 'COMMON.IOUNITS'
16234 !      include 'COMMON.LOCAL'
16235 !      include 'COMMON.SCCOR'
16236       real(kind=8) :: pi4,pi34
16237       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16238       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16239                     dcosomega,dsinomega !(3,3,maxres)
16240       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16241
16242       integer :: i,j,k
16243       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16244                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16245                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16246                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16247       integer :: nres2
16248       nres2=2*nres
16249
16250 !el from module energy-------------
16251 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16252 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16253 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16254
16255 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16256 !el      allocate(dsintau(3,3,3,0:nres2))
16257 !el      allocate(dtauangle(3,3,3,0:nres2))
16258 !el      allocate(domicron(3,2,2,0:nres2))
16259 !el      allocate(dcosomicron(3,2,2,0:nres2))
16260
16261
16262
16263 #if defined(MPI) && defined(PARINTDER)
16264       if (nfgtasks.gt.1 .and. me.eq.king) &
16265         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16266 #endif
16267       pi4 = 0.5d0*pipol
16268       pi34 = 3*pi4
16269
16270 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
16271 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16272
16273 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16274       do i=1,nres
16275         do j=1,3
16276           dtheta(j,1,i)=0.0d0
16277           dtheta(j,2,i)=0.0d0
16278           dphi(j,1,i)=0.0d0
16279           dphi(j,2,i)=0.0d0
16280           dphi(j,3,i)=0.0d0
16281         enddo
16282       enddo
16283 ! Derivatives of theta's
16284 #if defined(MPI) && defined(PARINTDER)
16285 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16286       do i=max0(ithet_start-1,3),ithet_end
16287 #else
16288       do i=3,nres
16289 #endif
16290         cost=dcos(theta(i))
16291         sint=sqrt(1-cost*cost)
16292         do j=1,3
16293           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16294           vbld(i-1)
16295           if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16296           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16297           vbld(i)
16298           if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16299         enddo
16300       enddo
16301 #if defined(MPI) && defined(PARINTDER)
16302 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16303       do i=max0(ithet_start-1,3),ithet_end
16304 #else
16305       do i=3,nres
16306 #endif
16307       if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16308         cost1=dcos(omicron(1,i))
16309         sint1=sqrt(1-cost1*cost1)
16310         cost2=dcos(omicron(2,i))
16311         sint2=sqrt(1-cost2*cost2)
16312        do j=1,3
16313 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16314           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16315           cost1*dc_norm(j,i-2))/ &
16316           vbld(i-1)
16317           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16318           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16319           +cost1*(dc_norm(j,i-1+nres)))/ &
16320           vbld(i-1+nres)
16321           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16322 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16323 !C Looks messy but better than if in loop
16324           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16325           +cost2*dc_norm(j,i-1))/ &
16326           vbld(i)
16327           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16328           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16329            +cost2*(-dc_norm(j,i-1+nres)))/ &
16330           vbld(i-1+nres)
16331 !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16332           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16333         enddo
16334        endif
16335       enddo
16336 !elwrite(iout,*) "after vbld write"
16337 ! Derivatives of phi:
16338 ! If phi is 0 or 180 degrees, then the formulas
16339 ! have to be derived by power series expansion of the
16340 ! conventional formulas around 0 and 180.
16341 #ifdef PARINTDER
16342       do i=iphi1_start,iphi1_end
16343 #else
16344       do i=4,nres
16345 #endif
16346 !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16347 ! the conventional case
16348         sint=dsin(theta(i))
16349         sint1=dsin(theta(i-1))
16350         sing=dsin(phi(i))
16351         cost=dcos(theta(i))
16352         cost1=dcos(theta(i-1))
16353         cosg=dcos(phi(i))
16354         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16355         fac0=1.0d0/(sint1*sint)
16356         fac1=cost*fac0
16357         fac2=cost1*fac0
16358         fac3=cosg*cost1/(sint1*sint1)
16359         fac4=cosg*cost/(sint*sint)
16360 !    Obtaining the gamma derivatives from sine derivative
16361        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16362            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16363            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16364          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16365          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16366          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16367          do j=1,3
16368             ctgt=cost/sint
16369             ctgt1=cost1/sint1
16370             cosg_inv=1.0d0/cosg
16371             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16372             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16373               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16374             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16375             dsinphi(j,2,i)= &
16376               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16377               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16378             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16379             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16380               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16381 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16382             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16383             endif
16384 ! Bug fixed 3/24/05 (AL)
16385          enddo
16386 !   Obtaining the gamma derivatives from cosine derivative
16387         else
16388            do j=1,3
16389            if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16390            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16391            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16392            dc_norm(j,i-3))/vbld(i-2)
16393            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16394            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16395            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16396            dcostheta(j,1,i)
16397            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16398            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16399            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16400            dc_norm(j,i-1))/vbld(i)
16401            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16402            endif
16403          enddo
16404         endif
16405       enddo
16406 !alculate derivative of Tauangle
16407 #ifdef PARINTDER
16408       do i=itau_start,itau_end
16409 #else
16410       do i=3,nres
16411 !elwrite(iout,*) " vecpr",i,nres
16412 #endif
16413        if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16414 !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16415 !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16416 !c dtauangle(j,intertyp,dervityp,residue number)
16417 !c INTERTYP=1 SC...Ca...Ca..Ca
16418 ! the conventional case
16419         sint=dsin(theta(i))
16420         sint1=dsin(omicron(2,i-1))
16421         sing=dsin(tauangle(1,i))
16422         cost=dcos(theta(i))
16423         cost1=dcos(omicron(2,i-1))
16424         cosg=dcos(tauangle(1,i))
16425 !elwrite(iout,*) " vecpr5",i,nres
16426         do j=1,3
16427 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16428 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16429         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16430 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16431         enddo
16432         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16433         fac0=1.0d0/(sint1*sint)
16434         fac1=cost*fac0
16435         fac2=cost1*fac0
16436         fac3=cosg*cost1/(sint1*sint1)
16437         fac4=cosg*cost/(sint*sint)
16438 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16439 !    Obtaining the gamma derivatives from sine derivative
16440        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16441            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16442            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16443          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16444          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16445          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16446         do j=1,3
16447             ctgt=cost/sint
16448             ctgt1=cost1/sint1
16449             cosg_inv=1.0d0/cosg
16450             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16451        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16452        *vbld_inv(i-2+nres)
16453             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16454             dsintau(j,1,2,i)= &
16455               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16456               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16457 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16458             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16459 ! Bug fixed 3/24/05 (AL)
16460             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16461               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16462 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16463             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16464          enddo
16465 !   Obtaining the gamma derivatives from cosine derivative
16466         else
16467            do j=1,3
16468            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16469            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16470            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16471            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16472            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16473            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16474            dcostheta(j,1,i)
16475            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16476            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16477            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16478            dc_norm(j,i-1))/vbld(i)
16479            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16480 !         write (iout,*) "else",i
16481          enddo
16482         endif
16483 !        do k=1,3
16484 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16485 !        enddo
16486       enddo
16487 !C Second case Ca...Ca...Ca...SC
16488 #ifdef PARINTDER
16489       do i=itau_start,itau_end
16490 #else
16491       do i=4,nres
16492 #endif
16493        if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16494           (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16495 ! the conventional case
16496         sint=dsin(omicron(1,i))
16497         sint1=dsin(theta(i-1))
16498         sing=dsin(tauangle(2,i))
16499         cost=dcos(omicron(1,i))
16500         cost1=dcos(theta(i-1))
16501         cosg=dcos(tauangle(2,i))
16502 !        do j=1,3
16503 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16504 !        enddo
16505         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16506         fac0=1.0d0/(sint1*sint)
16507         fac1=cost*fac0
16508         fac2=cost1*fac0
16509         fac3=cosg*cost1/(sint1*sint1)
16510         fac4=cosg*cost/(sint*sint)
16511 !    Obtaining the gamma derivatives from sine derivative
16512        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16513            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16514            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16515          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16516          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16517          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16518         do j=1,3
16519             ctgt=cost/sint
16520             ctgt1=cost1/sint1
16521             cosg_inv=1.0d0/cosg
16522             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16523               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16524 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16525 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16526             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16527             dsintau(j,2,2,i)= &
16528               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16529               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16530 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16531 !     & sing*ctgt*domicron(j,1,2,i),
16532 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16533             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16534 ! Bug fixed 3/24/05 (AL)
16535             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16536              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16537 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16538             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16539          enddo
16540 !   Obtaining the gamma derivatives from cosine derivative
16541         else
16542            do j=1,3
16543            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16544            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16545            dc_norm(j,i-3))/vbld(i-2)
16546            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16547            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16548            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16549            dcosomicron(j,1,1,i)
16550            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16551            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16552            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16553            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16554            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16555 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16556          enddo
16557         endif
16558       enddo
16559
16560 !CC third case SC...Ca...Ca...SC
16561 #ifdef PARINTDER
16562
16563       do i=itau_start,itau_end
16564 #else
16565       do i=3,nres
16566 #endif
16567 ! the conventional case
16568       if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16569       (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16570         sint=dsin(omicron(1,i))
16571         sint1=dsin(omicron(2,i-1))
16572         sing=dsin(tauangle(3,i))
16573         cost=dcos(omicron(1,i))
16574         cost1=dcos(omicron(2,i-1))
16575         cosg=dcos(tauangle(3,i))
16576         do j=1,3
16577         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16578 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16579         enddo
16580         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16581         fac0=1.0d0/(sint1*sint)
16582         fac1=cost*fac0
16583         fac2=cost1*fac0
16584         fac3=cosg*cost1/(sint1*sint1)
16585         fac4=cosg*cost/(sint*sint)
16586 !    Obtaining the gamma derivatives from sine derivative
16587        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16588            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16589            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16590          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16591          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16592          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16593         do j=1,3
16594             ctgt=cost/sint
16595             ctgt1=cost1/sint1
16596             cosg_inv=1.0d0/cosg
16597             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16598               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16599               *vbld_inv(i-2+nres)
16600             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16601             dsintau(j,3,2,i)= &
16602               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16603               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16604             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16605 ! Bug fixed 3/24/05 (AL)
16606             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16607               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16608               *vbld_inv(i-1+nres)
16609 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16610             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16611          enddo
16612 !   Obtaining the gamma derivatives from cosine derivative
16613         else
16614            do j=1,3
16615            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16616            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16617            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16618            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16619            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16620            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16621            dcosomicron(j,1,1,i)
16622            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16623            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16624            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16625            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16626            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16627 !          write(iout,*) "else",i
16628          enddo
16629         endif
16630       enddo
16631
16632 #ifdef CRYST_SC
16633 !   Derivatives of side-chain angles alpha and omega
16634 #if defined(MPI) && defined(PARINTDER)
16635         do i=ibond_start,ibond_end
16636 #else
16637         do i=2,nres-1
16638 #endif
16639           if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16640              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16641              fac6=fac5/vbld(i)
16642              fac7=fac5*fac5
16643              fac8=fac5/vbld(i+1)
16644              fac9=fac5/vbld(i+nres)
16645              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16646              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16647              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16648              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16649              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16650              sina=sqrt(1-cosa*cosa)
16651              sino=dsin(omeg(i))
16652 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16653              do j=1,3
16654                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16655                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16656                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16657                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16658                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16659                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16660                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16661                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16662                 vbld(i+nres))
16663                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16664             enddo
16665 ! obtaining the derivatives of omega from sines
16666             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16667                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16668                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16669                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16670                dsin(theta(i+1)))
16671                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16672                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16673                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16674                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16675                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16676                coso_inv=1.0d0/dcos(omeg(i))
16677                do j=1,3
16678                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16679                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16680                  (sino*dc_norm(j,i-1))/vbld(i)
16681                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16682                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16683                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16684                  -sino*dc_norm(j,i)/vbld(i+1)
16685                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16686                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16687                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16688                  vbld(i+nres)
16689                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16690               enddo
16691            else
16692 !   obtaining the derivatives of omega from cosines
16693              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16694              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16695              fac12=fac10*sina
16696              fac13=fac12*fac12
16697              fac14=sina*sina
16698              do j=1,3
16699                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16700                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16701                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16702                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16703                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16704                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16705                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16706                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16707                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16708                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16709                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16710                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16711                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16712                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16713                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16714             enddo
16715           endif
16716          else
16717            do j=1,3
16718              do k=1,3
16719                dalpha(k,j,i)=0.0d0
16720                domega(k,j,i)=0.0d0
16721              enddo
16722            enddo
16723          endif
16724        enddo
16725 #endif
16726 #if defined(MPI) && defined(PARINTDER)
16727       if (nfgtasks.gt.1) then
16728 #ifdef DEBUG
16729 !d      write (iout,*) "Gather dtheta"
16730 !d      call flush(iout)
16731       write (iout,*) "dtheta before gather"
16732       do i=1,nres
16733         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16734       enddo
16735 #endif
16736       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16737         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16738         king,FG_COMM,IERROR)
16739 #ifdef DEBUG
16740 !d      write (iout,*) "Gather dphi"
16741 !d      call flush(iout)
16742       write (iout,*) "dphi before gather"
16743       do i=1,nres
16744         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16745       enddo
16746 #endif
16747       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16748         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16749         king,FG_COMM,IERROR)
16750 !d      write (iout,*) "Gather dalpha"
16751 !d      call flush(iout)
16752 #ifdef CRYST_SC
16753       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16754         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16755         king,FG_COMM,IERROR)
16756 !d      write (iout,*) "Gather domega"
16757 !d      call flush(iout)
16758       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16759         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16760         king,FG_COMM,IERROR)
16761 #endif
16762       endif
16763 #endif
16764 #ifdef DEBUG
16765       write (iout,*) "dtheta after gather"
16766       do i=1,nres
16767         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16768       enddo
16769       write (iout,*) "dphi after gather"
16770       do i=1,nres
16771         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16772       enddo
16773       write (iout,*) "dalpha after gather"
16774       do i=1,nres
16775         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16776       enddo
16777       write (iout,*) "domega after gather"
16778       do i=1,nres
16779         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16780       enddo
16781 #endif
16782       return
16783       end subroutine intcartderiv
16784 !-----------------------------------------------------------------------------
16785       subroutine checkintcartgrad
16786 !      implicit real*8 (a-h,o-z)
16787 !      include 'DIMENSIONS'
16788 #ifdef MPI
16789       include 'mpif.h'
16790 #endif
16791 !      include 'COMMON.CHAIN'
16792 !      include 'COMMON.VAR'
16793 !      include 'COMMON.GEO'
16794 !      include 'COMMON.INTERACT'
16795 !      include 'COMMON.DERIV'
16796 !      include 'COMMON.IOUNITS'
16797 !      include 'COMMON.SETUP'
16798       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16799       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16800       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16801       real(kind=8),dimension(3) :: dc_norm_s
16802       real(kind=8) :: aincr=1.0d-5
16803       integer :: i,j
16804       real(kind=8) :: dcji
16805       do i=1,nres
16806         phi_s(i)=phi(i)
16807         theta_s(i)=theta(i)
16808         alph_s(i)=alph(i)
16809         omeg_s(i)=omeg(i)
16810       enddo
16811 ! Check theta gradient
16812       write (iout,*) &
16813        "Analytical (upper) and numerical (lower) gradient of theta"
16814       write (iout,*)
16815       do i=3,nres
16816         do j=1,3
16817           dcji=dc(j,i-2)
16818           dc(j,i-2)=dcji+aincr
16819           call chainbuild_cart
16820           call int_from_cart1(.false.)
16821           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
16822           dc(j,i-2)=dcji
16823           dcji=dc(j,i-1)
16824           dc(j,i-1)=dc(j,i-1)+aincr
16825           call chainbuild_cart
16826           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
16827           dc(j,i-1)=dcji
16828         enddo
16829 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
16830 !el          (dtheta(j,2,i),j=1,3)
16831 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
16832 !el          (dthetanum(j,2,i),j=1,3)
16833 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
16834 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
16835 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
16836 !el        write (iout,*)
16837       enddo
16838 ! Check gamma gradient
16839       write (iout,*) &
16840        "Analytical (upper) and numerical (lower) gradient of gamma"
16841       do i=4,nres
16842         do j=1,3
16843           dcji=dc(j,i-3)
16844           dc(j,i-3)=dcji+aincr
16845           call chainbuild_cart
16846           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
16847           dc(j,i-3)=dcji
16848           dcji=dc(j,i-2)
16849           dc(j,i-2)=dcji+aincr
16850           call chainbuild_cart
16851           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
16852           dc(j,i-2)=dcji
16853           dcji=dc(j,i-1)
16854           dc(j,i-1)=dc(j,i-1)+aincr
16855           call chainbuild_cart
16856           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
16857           dc(j,i-1)=dcji
16858         enddo
16859 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
16860 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
16861 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
16862 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
16863 !el        write (iout,'(5x,3(3f10.5,5x))') &
16864 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
16865 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
16866 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
16867 !el        write (iout,*)
16868       enddo
16869 ! Check alpha gradient
16870       write (iout,*) &
16871        "Analytical (upper) and numerical (lower) gradient of alpha"
16872       do i=2,nres-1
16873        if(itype(i,1).ne.10) then
16874             do j=1,3
16875               dcji=dc(j,i-1)
16876               dc(j,i-1)=dcji+aincr
16877               call chainbuild_cart
16878               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
16879               /aincr
16880               dc(j,i-1)=dcji
16881               dcji=dc(j,i)
16882               dc(j,i)=dcji+aincr
16883               call chainbuild_cart
16884               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
16885               /aincr
16886               dc(j,i)=dcji
16887               dcji=dc(j,i+nres)
16888               dc(j,i+nres)=dc(j,i+nres)+aincr
16889               call chainbuild_cart
16890               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
16891               /aincr
16892              dc(j,i+nres)=dcji
16893             enddo
16894           endif
16895 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
16896 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
16897 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
16898 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
16899 !el        write (iout,'(5x,3(3f10.5,5x))') &
16900 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
16901 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
16902 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
16903 !el        write (iout,*)
16904       enddo
16905 !     Check omega gradient
16906       write (iout,*) &
16907        "Analytical (upper) and numerical (lower) gradient of omega"
16908       do i=2,nres-1
16909        if(itype(i,1).ne.10) then
16910             do j=1,3
16911               dcji=dc(j,i-1)
16912               dc(j,i-1)=dcji+aincr
16913               call chainbuild_cart
16914               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
16915               /aincr
16916               dc(j,i-1)=dcji
16917               dcji=dc(j,i)
16918               dc(j,i)=dcji+aincr
16919               call chainbuild_cart
16920               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
16921               /aincr
16922               dc(j,i)=dcji
16923               dcji=dc(j,i+nres)
16924               dc(j,i+nres)=dc(j,i+nres)+aincr
16925               call chainbuild_cart
16926               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
16927               /aincr
16928              dc(j,i+nres)=dcji
16929             enddo
16930           endif
16931 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
16932 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
16933 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
16934 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
16935 !el        write (iout,'(5x,3(3f10.5,5x))') &
16936 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
16937 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
16938 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
16939 !el        write (iout,*)
16940       enddo
16941       return
16942       end subroutine checkintcartgrad
16943 !-----------------------------------------------------------------------------
16944 ! q_measure.F
16945 !-----------------------------------------------------------------------------
16946       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
16947 !      implicit real*8 (a-h,o-z)
16948 !      include 'DIMENSIONS'
16949 !      include 'COMMON.IOUNITS'
16950 !      include 'COMMON.CHAIN'
16951 !      include 'COMMON.INTERACT'
16952 !      include 'COMMON.VAR'
16953       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
16954       integer :: kkk,nsep=3
16955       real(kind=8) :: qm        !dist,
16956       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
16957       logical :: lprn=.false.
16958       logical :: flag
16959 !      real(kind=8) :: sigm,x
16960
16961 !el      sigm(x)=0.25d0*x     ! local function
16962       qqmax=1.0d10
16963       do kkk=1,nperm
16964       qq = 0.0d0
16965       nl=0
16966        if(flag) then
16967         do il=seg1+nsep,seg2
16968           do jl=seg1,il-nsep
16969             nl=nl+1
16970             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
16971                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
16972                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16973             dij=dist(il,jl)
16974             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16975             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
16976               nl=nl+1
16977               d0ijCM=dsqrt( &
16978                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16979                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16980                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16981               dijCM=dist(il+nres,jl+nres)
16982               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16983             endif
16984             qq = qq+qqij+qqijCM
16985           enddo
16986         enddo
16987         qq = qq/nl
16988       else
16989       do il=seg1,seg2
16990         if((seg3-il).lt.3) then
16991              secseg=il+3
16992         else
16993              secseg=seg3
16994         endif
16995           do jl=secseg,seg4
16996             nl=nl+1
16997             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16998                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16999                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17000             dij=dist(il,jl)
17001             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17002             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17003               nl=nl+1
17004               d0ijCM=dsqrt( &
17005                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17006                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17007                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17008               dijCM=dist(il+nres,jl+nres)
17009               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17010             endif
17011             qq = qq+qqij+qqijCM
17012           enddo
17013         enddo
17014       qq = qq/nl
17015       endif
17016       if (qqmax.le.qq) qqmax=qq
17017       enddo
17018       qwolynes=1.0d0-qqmax
17019       return
17020       end function qwolynes
17021 !-----------------------------------------------------------------------------
17022       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17023 !      implicit real*8 (a-h,o-z)
17024 !      include 'DIMENSIONS'
17025 !      include 'COMMON.IOUNITS'
17026 !      include 'COMMON.CHAIN'
17027 !      include 'COMMON.INTERACT'
17028 !      include 'COMMON.VAR'
17029 !      include 'COMMON.MD'
17030       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17031       integer :: nsep=3, kkk
17032 !el      real(kind=8) :: dist
17033       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17034       logical :: lprn=.false.
17035       logical :: flag
17036       real(kind=8) :: sim,dd0,fac,ddqij
17037 !el      sigm(x)=0.25d0*x            ! local function
17038       do kkk=1,nperm
17039       do i=0,nres
17040         do j=1,3
17041           dqwol(j,i)=0.0d0
17042           dxqwol(j,i)=0.0d0
17043         enddo
17044       enddo
17045       nl=0
17046        if(flag) then
17047         do il=seg1+nsep,seg2
17048           do jl=seg1,il-nsep
17049             nl=nl+1
17050             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17051                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17052                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17053             dij=dist(il,jl)
17054             sim = 1.0d0/sigm(d0ij)
17055             sim = sim*sim
17056             dd0 = dij-d0ij
17057             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17058             do k=1,3
17059               ddqij = (c(k,il)-c(k,jl))*fac
17060               dqwol(k,il)=dqwol(k,il)+ddqij
17061               dqwol(k,jl)=dqwol(k,jl)-ddqij
17062             enddo
17063
17064             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17065               nl=nl+1
17066               d0ijCM=dsqrt( &
17067                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17068                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17069                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17070               dijCM=dist(il+nres,jl+nres)
17071               sim = 1.0d0/sigm(d0ijCM)
17072               sim = sim*sim
17073               dd0=dijCM-d0ijCM
17074               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17075               do k=1,3
17076                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17077                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17078                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17079               enddo
17080             endif
17081           enddo
17082         enddo
17083        else
17084         do il=seg1,seg2
17085         if((seg3-il).lt.3) then
17086              secseg=il+3
17087         else
17088              secseg=seg3
17089         endif
17090           do jl=secseg,seg4
17091             nl=nl+1
17092             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17093                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17094                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17095             dij=dist(il,jl)
17096             sim = 1.0d0/sigm(d0ij)
17097             sim = sim*sim
17098             dd0 = dij-d0ij
17099             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17100             do k=1,3
17101               ddqij = (c(k,il)-c(k,jl))*fac
17102               dqwol(k,il)=dqwol(k,il)+ddqij
17103               dqwol(k,jl)=dqwol(k,jl)-ddqij
17104             enddo
17105             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17106               nl=nl+1
17107               d0ijCM=dsqrt( &
17108                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17109                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17110                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17111               dijCM=dist(il+nres,jl+nres)
17112               sim = 1.0d0/sigm(d0ijCM)
17113               sim=sim*sim
17114               dd0 = dijCM-d0ijCM
17115               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17116               do k=1,3
17117                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17118                dxqwol(k,il)=dxqwol(k,il)+ddqij
17119                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17120               enddo
17121             endif
17122           enddo
17123         enddo
17124       endif
17125       enddo
17126        do i=0,nres
17127          do j=1,3
17128            dqwol(j,i)=dqwol(j,i)/nl
17129            dxqwol(j,i)=dxqwol(j,i)/nl
17130          enddo
17131        enddo
17132       return
17133       end subroutine qwolynes_prim
17134 !-----------------------------------------------------------------------------
17135       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17136 !      implicit real*8 (a-h,o-z)
17137 !      include 'DIMENSIONS'
17138 !      include 'COMMON.IOUNITS'
17139 !      include 'COMMON.CHAIN'
17140 !      include 'COMMON.INTERACT'
17141 !      include 'COMMON.VAR'
17142       integer :: seg1,seg2,seg3,seg4
17143       logical :: flag
17144       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17145       real(kind=8),dimension(3,0:2*nres) :: cdummy
17146       real(kind=8) :: q1,q2
17147       real(kind=8) :: delta=1.0d-10
17148       integer :: i,j
17149
17150       do i=0,nres
17151         do j=1,3
17152           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17153           cdummy(j,i)=c(j,i)
17154           c(j,i)=c(j,i)+delta
17155           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17156           qwolan(j,i)=(q2-q1)/delta
17157           c(j,i)=cdummy(j,i)
17158         enddo
17159       enddo
17160       do i=0,nres
17161         do j=1,3
17162           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17163           cdummy(j,i+nres)=c(j,i+nres)
17164           c(j,i+nres)=c(j,i+nres)+delta
17165           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17166           qwolxan(j,i)=(q2-q1)/delta
17167           c(j,i+nres)=cdummy(j,i+nres)
17168         enddo
17169       enddo
17170 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17171 !      do i=0,nct
17172 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17173 !      enddo
17174 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17175 !      do i=0,nct
17176 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17177 !      enddo
17178       return
17179       end subroutine qwol_num
17180 !-----------------------------------------------------------------------------
17181       subroutine EconstrQ
17182 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17183 !      implicit real*8 (a-h,o-z)
17184 !      include 'DIMENSIONS'
17185 !      include 'COMMON.CONTROL'
17186 !      include 'COMMON.VAR'
17187 !      include 'COMMON.MD'
17188       use MD_data
17189 !#ifndef LANG0
17190 !      include 'COMMON.LANGEVIN'
17191 !#else
17192 !      include 'COMMON.LANGEVIN.lang0'
17193 !#endif
17194 !      include 'COMMON.CHAIN'
17195 !      include 'COMMON.DERIV'
17196 !      include 'COMMON.GEO'
17197 !      include 'COMMON.LOCAL'
17198 !      include 'COMMON.INTERACT'
17199 !      include 'COMMON.IOUNITS'
17200 !      include 'COMMON.NAMES'
17201 !      include 'COMMON.TIME1'
17202       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17203       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17204                    duconst,duxconst
17205       integer :: kstart,kend,lstart,lend,idummy
17206       real(kind=8) :: delta=1.0d-7
17207       integer :: i,j,k,ii
17208       do i=0,nres
17209          do j=1,3
17210             duconst(j,i)=0.0d0
17211             dudconst(j,i)=0.0d0
17212             duxconst(j,i)=0.0d0
17213             dudxconst(j,i)=0.0d0
17214          enddo
17215       enddo
17216       Uconst=0.0d0
17217       do i=1,nfrag
17218          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17219            idummy,idummy)
17220          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17221 ! Calculating the derivatives of Constraint energy with respect to Q
17222          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17223            qinfrag(i,iset))
17224 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17225 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17226 !         hmnum=(hm2-hm1)/delta
17227 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17228 !     &   qinfrag(i,iset))
17229 !         write(iout,*) "harmonicnum frag", hmnum
17230 ! Calculating the derivatives of Q with respect to cartesian coordinates
17231          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17232           idummy,idummy)
17233 !         write(iout,*) "dqwol "
17234 !         do ii=1,nres
17235 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17236 !         enddo
17237 !         write(iout,*) "dxqwol "
17238 !         do ii=1,nres
17239 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17240 !         enddo
17241 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17242 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17243 !     &  ,idummy,idummy)
17244 !  The gradients of Uconst in Cs
17245          do ii=0,nres
17246             do j=1,3
17247                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17248                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17249             enddo
17250          enddo
17251       enddo
17252       do i=1,npair
17253          kstart=ifrag(1,ipair(1,i,iset),iset)
17254          kend=ifrag(2,ipair(1,i,iset),iset)
17255          lstart=ifrag(1,ipair(2,i,iset),iset)
17256          lend=ifrag(2,ipair(2,i,iset),iset)
17257          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17258          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17259 !  Calculating dU/dQ
17260          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17261 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17262 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17263 !         hmnum=(hm2-hm1)/delta
17264 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17265 !     &   qinpair(i,iset))
17266 !         write(iout,*) "harmonicnum pair ", hmnum
17267 ! Calculating dQ/dXi
17268          call qwolynes_prim(kstart,kend,.false.,&
17269           lstart,lend)
17270 !         write(iout,*) "dqwol "
17271 !         do ii=1,nres
17272 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17273 !         enddo
17274 !         write(iout,*) "dxqwol "
17275 !         do ii=1,nres
17276 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17277 !        enddo
17278 ! Calculating numerical gradients
17279 !        call qwol_num(kstart,kend,.false.
17280 !     &  ,lstart,lend)
17281 ! The gradients of Uconst in Cs
17282          do ii=0,nres
17283             do j=1,3
17284                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17285                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17286             enddo
17287          enddo
17288       enddo
17289 !      write(iout,*) "Uconst inside subroutine ", Uconst
17290 ! Transforming the gradients from Cs to dCs for the backbone
17291       do i=0,nres
17292          do j=i+1,nres
17293            do k=1,3
17294              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17295            enddo
17296          enddo
17297       enddo
17298 !  Transforming the gradients from Cs to dCs for the side chains
17299       do i=1,nres
17300          do j=1,3
17301            dudxconst(j,i)=duxconst(j,i)
17302          enddo
17303       enddo
17304 !      write(iout,*) "dU/ddc backbone "
17305 !       do ii=0,nres
17306 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17307 !      enddo
17308 !      write(iout,*) "dU/ddX side chain "
17309 !      do ii=1,nres
17310 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17311 !      enddo
17312 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17313 !      call dEconstrQ_num
17314       return
17315       end subroutine EconstrQ
17316 !-----------------------------------------------------------------------------
17317       subroutine dEconstrQ_num
17318 ! Calculating numerical dUconst/ddc and dUconst/ddx
17319 !      implicit real*8 (a-h,o-z)
17320 !      include 'DIMENSIONS'
17321 !      include 'COMMON.CONTROL'
17322 !      include 'COMMON.VAR'
17323 !      include 'COMMON.MD'
17324       use MD_data
17325 !#ifndef LANG0
17326 !      include 'COMMON.LANGEVIN'
17327 !#else
17328 !      include 'COMMON.LANGEVIN.lang0'
17329 !#endif
17330 !      include 'COMMON.CHAIN'
17331 !      include 'COMMON.DERIV'
17332 !      include 'COMMON.GEO'
17333 !      include 'COMMON.LOCAL'
17334 !      include 'COMMON.INTERACT'
17335 !      include 'COMMON.IOUNITS'
17336 !      include 'COMMON.NAMES'
17337 !      include 'COMMON.TIME1'
17338       real(kind=8) :: uzap1,uzap2
17339       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17340       integer :: kstart,kend,lstart,lend,idummy
17341       real(kind=8) :: delta=1.0d-7
17342 !el local variables
17343       integer :: i,ii,j
17344 !     real(kind=8) ::
17345 !     For the backbone
17346       do i=0,nres-1
17347          do j=1,3
17348             dUcartan(j,i)=0.0d0
17349             cdummy(j,i)=dc(j,i)
17350             dc(j,i)=dc(j,i)+delta
17351             call chainbuild_cart
17352             uzap2=0.0d0
17353             do ii=1,nfrag
17354              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17355                 idummy,idummy)
17356                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17357                 qinfrag(ii,iset))
17358             enddo
17359             do ii=1,npair
17360                kstart=ifrag(1,ipair(1,ii,iset),iset)
17361                kend=ifrag(2,ipair(1,ii,iset),iset)
17362                lstart=ifrag(1,ipair(2,ii,iset),iset)
17363                lend=ifrag(2,ipair(2,ii,iset),iset)
17364                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17365                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17366                  qinpair(ii,iset))
17367             enddo
17368             dc(j,i)=cdummy(j,i)
17369             call chainbuild_cart
17370             uzap1=0.0d0
17371              do ii=1,nfrag
17372              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17373                 idummy,idummy)
17374                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17375                 qinfrag(ii,iset))
17376             enddo
17377             do ii=1,npair
17378                kstart=ifrag(1,ipair(1,ii,iset),iset)
17379                kend=ifrag(2,ipair(1,ii,iset),iset)
17380                lstart=ifrag(1,ipair(2,ii,iset),iset)
17381                lend=ifrag(2,ipair(2,ii,iset),iset)
17382                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17383                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17384                 qinpair(ii,iset))
17385             enddo
17386             ducartan(j,i)=(uzap2-uzap1)/(delta)
17387          enddo
17388       enddo
17389 ! Calculating numerical gradients for dU/ddx
17390       do i=0,nres-1
17391          duxcartan(j,i)=0.0d0
17392          do j=1,3
17393             cdummy(j,i)=dc(j,i+nres)
17394             dc(j,i+nres)=dc(j,i+nres)+delta
17395             call chainbuild_cart
17396             uzap2=0.0d0
17397             do ii=1,nfrag
17398              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17399                 idummy,idummy)
17400                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17401                 qinfrag(ii,iset))
17402             enddo
17403             do ii=1,npair
17404                kstart=ifrag(1,ipair(1,ii,iset),iset)
17405                kend=ifrag(2,ipair(1,ii,iset),iset)
17406                lstart=ifrag(1,ipair(2,ii,iset),iset)
17407                lend=ifrag(2,ipair(2,ii,iset),iset)
17408                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17409                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17410                 qinpair(ii,iset))
17411             enddo
17412             dc(j,i+nres)=cdummy(j,i)
17413             call chainbuild_cart
17414             uzap1=0.0d0
17415              do ii=1,nfrag
17416                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17417                 ifrag(2,ii,iset),.true.,idummy,idummy)
17418                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17419                 qinfrag(ii,iset))
17420             enddo
17421             do ii=1,npair
17422                kstart=ifrag(1,ipair(1,ii,iset),iset)
17423                kend=ifrag(2,ipair(1,ii,iset),iset)
17424                lstart=ifrag(1,ipair(2,ii,iset),iset)
17425                lend=ifrag(2,ipair(2,ii,iset),iset)
17426                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17427                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17428                 qinpair(ii,iset))
17429             enddo
17430             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17431          enddo
17432       enddo
17433       write(iout,*) "Numerical dUconst/ddc backbone "
17434       do ii=0,nres
17435         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17436       enddo
17437 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17438 !      do ii=1,nres
17439 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17440 !      enddo
17441       return
17442       end subroutine dEconstrQ_num
17443 !-----------------------------------------------------------------------------
17444 ! ssMD.F
17445 !-----------------------------------------------------------------------------
17446       subroutine check_energies
17447
17448 !      use random, only: ran_number
17449
17450 !      implicit none
17451 !     Includes
17452 !      include 'DIMENSIONS'
17453 !      include 'COMMON.CHAIN'
17454 !      include 'COMMON.VAR'
17455 !      include 'COMMON.IOUNITS'
17456 !      include 'COMMON.SBRIDGE'
17457 !      include 'COMMON.LOCAL'
17458 !      include 'COMMON.GEO'
17459
17460 !     External functions
17461 !EL      double precision ran_number
17462 !EL      external ran_number
17463
17464 !     Local variables
17465       integer :: i,j,k,l,lmax,p,pmax
17466       real(kind=8) :: rmin,rmax
17467       real(kind=8) :: eij
17468
17469       real(kind=8) :: d
17470       real(kind=8) :: wi,rij,tj,pj
17471 !      return
17472
17473       i=5
17474       j=14
17475
17476       d=dsc(1)
17477       rmin=2.0D0
17478       rmax=12.0D0
17479
17480       lmax=10000
17481       pmax=1
17482
17483       do k=1,3
17484         c(k,i)=0.0D0
17485         c(k,j)=0.0D0
17486         c(k,nres+i)=0.0D0
17487         c(k,nres+j)=0.0D0
17488       enddo
17489
17490       do l=1,lmax
17491
17492 !t        wi=ran_number(0.0D0,pi)
17493 !        wi=ran_number(0.0D0,pi/6.0D0)
17494 !        wi=0.0D0
17495 !t        tj=ran_number(0.0D0,pi)
17496 !t        pj=ran_number(0.0D0,pi)
17497 !        pj=ran_number(0.0D0,pi/6.0D0)
17498 !        pj=0.0D0
17499
17500         do p=1,pmax
17501 !t           rij=ran_number(rmin,rmax)
17502
17503            c(1,j)=d*sin(pj)*cos(tj)
17504            c(2,j)=d*sin(pj)*sin(tj)
17505            c(3,j)=d*cos(pj)
17506
17507            c(3,nres+i)=-rij
17508
17509            c(1,i)=d*sin(wi)
17510            c(3,i)=-rij-d*cos(wi)
17511
17512            do k=1,3
17513               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17514               dc_norm(k,nres+i)=dc(k,nres+i)/d
17515               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17516               dc_norm(k,nres+j)=dc(k,nres+j)/d
17517            enddo
17518
17519            call dyn_ssbond_ene(i,j,eij)
17520         enddo
17521       enddo
17522       call exit(1)
17523       return
17524       end subroutine check_energies
17525 !-----------------------------------------------------------------------------
17526       subroutine dyn_ssbond_ene(resi,resj,eij)
17527 !      implicit none
17528 !      Includes
17529       use calc_data
17530       use comm_sschecks
17531 !      include 'DIMENSIONS'
17532 !      include 'COMMON.SBRIDGE'
17533 !      include 'COMMON.CHAIN'
17534 !      include 'COMMON.DERIV'
17535 !      include 'COMMON.LOCAL'
17536 !      include 'COMMON.INTERACT'
17537 !      include 'COMMON.VAR'
17538 !      include 'COMMON.IOUNITS'
17539 !      include 'COMMON.CALC'
17540 #ifndef CLUST
17541 #ifndef WHAM
17542        use MD_data
17543 !      include 'COMMON.MD'
17544 !      use MD, only: totT,t_bath
17545 #endif
17546 #endif
17547 !     External functions
17548 !EL      double precision h_base
17549 !EL      external h_base
17550
17551 !     Input arguments
17552       integer :: resi,resj
17553
17554 !     Output arguments
17555       real(kind=8) :: eij
17556
17557 !     Local variables
17558       logical :: havebond
17559       integer itypi,itypj
17560       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17561       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17562       real(kind=8),dimension(3) :: dcosom1,dcosom2
17563       real(kind=8) :: ed
17564       real(kind=8) :: pom1,pom2
17565       real(kind=8) :: ljA,ljB,ljXs
17566       real(kind=8),dimension(1:3) :: d_ljB
17567       real(kind=8) :: ssA,ssB,ssC,ssXs
17568       real(kind=8) :: ssxm,ljxm,ssm,ljm
17569       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17570       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17571       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17572 !-------FIRST METHOD
17573       real(kind=8) :: xm
17574       real(kind=8),dimension(1:3) :: d_xm
17575 !-------END FIRST METHOD
17576 !-------SECOND METHOD
17577 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17578 !-------END SECOND METHOD
17579
17580 !-------TESTING CODE
17581 !el      logical :: checkstop,transgrad
17582 !el      common /sschecks/ checkstop,transgrad
17583
17584       integer :: icheck,nicheck,jcheck,njcheck
17585       real(kind=8),dimension(-1:1) :: echeck
17586       real(kind=8) :: deps,ssx0,ljx0
17587 !-------END TESTING CODE
17588
17589       eij=0.0d0
17590       i=resi
17591       j=resj
17592
17593 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17594 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17595
17596       itypi=itype(i,1)
17597       dxi=dc_norm(1,nres+i)
17598       dyi=dc_norm(2,nres+i)
17599       dzi=dc_norm(3,nres+i)
17600       dsci_inv=vbld_inv(i+nres)
17601
17602       itypj=itype(j,1)
17603       xj=c(1,nres+j)-c(1,nres+i)
17604       yj=c(2,nres+j)-c(2,nres+i)
17605       zj=c(3,nres+j)-c(3,nres+i)
17606       dxj=dc_norm(1,nres+j)
17607       dyj=dc_norm(2,nres+j)
17608       dzj=dc_norm(3,nres+j)
17609       dscj_inv=vbld_inv(j+nres)
17610
17611       chi1=chi(itypi,itypj)
17612       chi2=chi(itypj,itypi)
17613       chi12=chi1*chi2
17614       chip1=chip(itypi)
17615       chip2=chip(itypj)
17616       chip12=chip1*chip2
17617       alf1=alp(itypi)
17618       alf2=alp(itypj)
17619       alf12=0.5D0*(alf1+alf2)
17620
17621       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17622       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17623 !     The following are set in sc_angular
17624 !      erij(1)=xj*rij
17625 !      erij(2)=yj*rij
17626 !      erij(3)=zj*rij
17627 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17628 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17629 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17630       call sc_angular
17631       rij=1.0D0/rij  ! Reset this so it makes sense
17632
17633       sig0ij=sigma(itypi,itypj)
17634       sig=sig0ij*dsqrt(1.0D0/sigsq)
17635
17636       ljXs=sig-sig0ij
17637       ljA=eps1*eps2rt**2*eps3rt**2
17638       ljB=ljA*bb_aq(itypi,itypj)
17639       ljA=ljA*aa_aq(itypi,itypj)
17640       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17641
17642       ssXs=d0cm
17643       deltat1=1.0d0-om1
17644       deltat2=1.0d0+om2
17645       deltat12=om2-om1+2.0d0
17646       cosphi=om12-om1*om2
17647       ssA=akcm
17648       ssB=akct*deltat12
17649       ssC=ss_depth &
17650            +akth*(deltat1*deltat1+deltat2*deltat2) &
17651            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17652       ssxm=ssXs-0.5D0*ssB/ssA
17653
17654 !-------TESTING CODE
17655 !$$$c     Some extra output
17656 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17657 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17658 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17659 !$$$      if (ssx0.gt.0.0d0) then
17660 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17661 !$$$      else
17662 !$$$        ssx0=ssxm
17663 !$$$      endif
17664 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17665 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17666 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17667 !$$$      return
17668 !-------END TESTING CODE
17669
17670 !-------TESTING CODE
17671 !     Stop and plot energy and derivative as a function of distance
17672       if (checkstop) then
17673         ssm=ssC-0.25D0*ssB*ssB/ssA
17674         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17675         if (ssm.lt.ljm .and. &
17676              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17677           nicheck=1000
17678           njcheck=1
17679           deps=0.5d-7
17680         else
17681           checkstop=.false.
17682         endif
17683       endif
17684       if (.not.checkstop) then
17685         nicheck=0
17686         njcheck=-1
17687       endif
17688
17689       do icheck=0,nicheck
17690       do jcheck=-1,njcheck
17691       if (checkstop) rij=(ssxm-1.0d0)+ &
17692              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17693 !-------END TESTING CODE
17694
17695       if (rij.gt.ljxm) then
17696         havebond=.false.
17697         ljd=rij-ljXs
17698         fac=(1.0D0/ljd)**expon
17699         e1=fac*fac*aa_aq(itypi,itypj)
17700         e2=fac*bb_aq(itypi,itypj)
17701         eij=eps1*eps2rt*eps3rt*(e1+e2)
17702         eps2der=eij*eps3rt
17703         eps3der=eij*eps2rt
17704         eij=eij*eps2rt*eps3rt
17705
17706         sigder=-sig/sigsq
17707         e1=e1*eps1*eps2rt**2*eps3rt**2
17708         ed=-expon*(e1+eij)/ljd
17709         sigder=ed*sigder
17710         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17711         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17712         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17713              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17714       else if (rij.lt.ssxm) then
17715         havebond=.true.
17716         ssd=rij-ssXs
17717         eij=ssA*ssd*ssd+ssB*ssd+ssC
17718
17719         ed=2*akcm*ssd+akct*deltat12
17720         pom1=akct*ssd
17721         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17722         eom1=-2*akth*deltat1-pom1-om2*pom2
17723         eom2= 2*akth*deltat2+pom1-om1*pom2
17724         eom12=pom2
17725       else
17726         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17727
17728         d_ssxm(1)=0.5D0*akct/ssA
17729         d_ssxm(2)=-d_ssxm(1)
17730         d_ssxm(3)=0.0D0
17731
17732         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17733         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17734         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17735         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17736
17737 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17738         xm=0.5d0*(ssxm+ljxm)
17739         do k=1,3
17740           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17741         enddo
17742         if (rij.lt.xm) then
17743           havebond=.true.
17744           ssm=ssC-0.25D0*ssB*ssB/ssA
17745           d_ssm(1)=0.5D0*akct*ssB/ssA
17746           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17747           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17748           d_ssm(3)=omega
17749           f1=(rij-xm)/(ssxm-xm)
17750           f2=(rij-ssxm)/(xm-ssxm)
17751           h1=h_base(f1,hd1)
17752           h2=h_base(f2,hd2)
17753           eij=ssm*h1+Ht*h2
17754           delta_inv=1.0d0/(xm-ssxm)
17755           deltasq_inv=delta_inv*delta_inv
17756           fac=ssm*hd1-Ht*hd2
17757           fac1=deltasq_inv*fac*(xm-rij)
17758           fac2=deltasq_inv*fac*(rij-ssxm)
17759           ed=delta_inv*(Ht*hd2-ssm*hd1)
17760           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17761           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17762           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17763         else
17764           havebond=.false.
17765           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17766           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17767           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17768           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17769                alf12/eps3rt)
17770           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17771           f1=(rij-ljxm)/(xm-ljxm)
17772           f2=(rij-xm)/(ljxm-xm)
17773           h1=h_base(f1,hd1)
17774           h2=h_base(f2,hd2)
17775           eij=Ht*h1+ljm*h2
17776           delta_inv=1.0d0/(ljxm-xm)
17777           deltasq_inv=delta_inv*delta_inv
17778           fac=Ht*hd1-ljm*hd2
17779           fac1=deltasq_inv*fac*(ljxm-rij)
17780           fac2=deltasq_inv*fac*(rij-xm)
17781           ed=delta_inv*(ljm*hd2-Ht*hd1)
17782           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17783           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17784           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17785         endif
17786 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17787
17788 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17789 !$$$        ssd=rij-ssXs
17790 !$$$        ljd=rij-ljXs
17791 !$$$        fac1=rij-ljxm
17792 !$$$        fac2=rij-ssxm
17793 !$$$
17794 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17795 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17796 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17797 !$$$
17798 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17799 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17800 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17801 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17802 !$$$        d_ssm(3)=omega
17803 !$$$
17804 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17805 !$$$        do k=1,3
17806 !$$$          d_ljm(k)=ljm*d_ljB(k)
17807 !$$$        enddo
17808 !$$$        ljm=ljm*ljB
17809 !$$$
17810 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17811 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17812 !$$$        d_ss(2)=akct*ssd
17813 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17814 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17815 !$$$        d_ss(3)=omega
17816 !$$$
17817 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17818 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17819 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
17820 !$$$        do k=1,3
17821 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
17822 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
17823 !$$$        enddo
17824 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
17825 !$$$
17826 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
17827 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
17828 !$$$        h1=h_base(f1,hd1)
17829 !$$$        h2=h_base(f2,hd2)
17830 !$$$        eij=ss*h1+ljf*h2
17831 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
17832 !$$$        deltasq_inv=delta_inv*delta_inv
17833 !$$$        fac=ljf*hd2-ss*hd1
17834 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
17835 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
17836 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
17837 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
17838 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
17839 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
17840 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
17841 !$$$
17842 !$$$        havebond=.false.
17843 !$$$        if (ed.gt.0.0d0) havebond=.true.
17844 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17845
17846       endif
17847
17848       if (havebond) then
17849 !#ifndef CLUST
17850 !#ifndef WHAM
17851 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
17852 !          write(iout,'(a15,f12.2,f8.1,2i5)')
17853 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
17854 !        endif
17855 !#endif
17856 !#endif
17857         dyn_ssbond_ij(i,j)=eij
17858       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
17859         dyn_ssbond_ij(i,j)=1.0d300
17860 !#ifndef CLUST
17861 !#ifndef WHAM
17862 !        write(iout,'(a15,f12.2,f8.1,2i5)')
17863 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
17864 !#endif
17865 !#endif
17866       endif
17867
17868 !-------TESTING CODE
17869 !el      if (checkstop) then
17870         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
17871              "CHECKSTOP",rij,eij,ed
17872         echeck(jcheck)=eij
17873 !el      endif
17874       enddo
17875       if (checkstop) then
17876         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
17877       endif
17878       enddo
17879       if (checkstop) then
17880         transgrad=.true.
17881         checkstop=.false.
17882       endif
17883 !-------END TESTING CODE
17884
17885       do k=1,3
17886         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
17887         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
17888       enddo
17889       do k=1,3
17890         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
17891       enddo
17892       do k=1,3
17893         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17894              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17895              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17896         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17897              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17898              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17899       enddo
17900 !grad      do k=i,j-1
17901 !grad        do l=1,3
17902 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
17903 !grad        enddo
17904 !grad      enddo
17905
17906       do l=1,3
17907         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17908         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17909       enddo
17910
17911       return
17912       end subroutine dyn_ssbond_ene
17913 !--------------------------------------------------------------------------
17914          subroutine triple_ssbond_ene(resi,resj,resk,eij)
17915 !      implicit none
17916 !      Includes
17917       use calc_data
17918       use comm_sschecks
17919 !      include 'DIMENSIONS'
17920 !      include 'COMMON.SBRIDGE'
17921 !      include 'COMMON.CHAIN'
17922 !      include 'COMMON.DERIV'
17923 !      include 'COMMON.LOCAL'
17924 !      include 'COMMON.INTERACT'
17925 !      include 'COMMON.VAR'
17926 !      include 'COMMON.IOUNITS'
17927 !      include 'COMMON.CALC'
17928 #ifndef CLUST
17929 #ifndef WHAM
17930        use MD_data
17931 !      include 'COMMON.MD'
17932 !      use MD, only: totT,t_bath
17933 #endif
17934 #endif
17935       double precision h_base
17936       external h_base
17937
17938 !c     Input arguments
17939       integer resi,resj,resk,m,itypi,itypj,itypk
17940
17941 !c     Output arguments
17942       double precision eij,eij1,eij2,eij3
17943
17944 !c     Local variables
17945       logical havebond
17946 !c      integer itypi,itypj,k,l
17947       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
17948       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
17949       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
17950       double precision sig0ij,ljd,sig,fac,e1,e2
17951       double precision dcosom1(3),dcosom2(3),ed
17952       double precision pom1,pom2
17953       double precision ljA,ljB,ljXs
17954       double precision d_ljB(1:3)
17955       double precision ssA,ssB,ssC,ssXs
17956       double precision ssxm,ljxm,ssm,ljm
17957       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
17958       eij=0.0
17959       if (dtriss.eq.0) return
17960       i=resi
17961       j=resj
17962       k=resk
17963 !C      write(iout,*) resi,resj,resk
17964       itypi=itype(i,1)
17965       dxi=dc_norm(1,nres+i)
17966       dyi=dc_norm(2,nres+i)
17967       dzi=dc_norm(3,nres+i)
17968       dsci_inv=vbld_inv(i+nres)
17969       xi=c(1,nres+i)
17970       yi=c(2,nres+i)
17971       zi=c(3,nres+i)
17972       itypj=itype(j,1)
17973       xj=c(1,nres+j)
17974       yj=c(2,nres+j)
17975       zj=c(3,nres+j)
17976
17977       dxj=dc_norm(1,nres+j)
17978       dyj=dc_norm(2,nres+j)
17979       dzj=dc_norm(3,nres+j)
17980       dscj_inv=vbld_inv(j+nres)
17981       itypk=itype(k,1)
17982       xk=c(1,nres+k)
17983       yk=c(2,nres+k)
17984       zk=c(3,nres+k)
17985
17986       dxk=dc_norm(1,nres+k)
17987       dyk=dc_norm(2,nres+k)
17988       dzk=dc_norm(3,nres+k)
17989       dscj_inv=vbld_inv(k+nres)
17990       xij=xj-xi
17991       xik=xk-xi
17992       xjk=xk-xj
17993       yij=yj-yi
17994       yik=yk-yi
17995       yjk=yk-yj
17996       zij=zj-zi
17997       zik=zk-zi
17998       zjk=zk-zj
17999       rrij=(xij*xij+yij*yij+zij*zij)
18000       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18001       rrik=(xik*xik+yik*yik+zik*zik)
18002       rik=dsqrt(rrik)
18003       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18004       rjk=dsqrt(rrjk)
18005 !C there are three combination of distances for each trisulfide bonds
18006 !C The first case the ith atom is the center
18007 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18008 !C distance y is second distance the a,b,c,d are parameters derived for
18009 !C this problem d parameter was set as a penalty currenlty set to 1.
18010       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18011       eij1=0.0d0
18012       else
18013       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18014       endif
18015 !C second case jth atom is center
18016       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18017       eij2=0.0d0
18018       else
18019       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18020       endif
18021 !C the third case kth atom is the center
18022       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18023       eij3=0.0d0
18024       else
18025       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18026       endif
18027 !C      eij2=0.0
18028 !C      eij3=0.0
18029 !C      eij1=0.0
18030       eij=eij1+eij2+eij3
18031 !C      write(iout,*)i,j,k,eij
18032 !C The energy penalty calculated now time for the gradient part
18033 !C derivative over rij
18034       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18035       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18036             gg(1)=xij*fac/rij
18037             gg(2)=yij*fac/rij
18038             gg(3)=zij*fac/rij
18039       do m=1,3
18040         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18041         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18042       enddo
18043
18044       do l=1,3
18045         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18046         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18047       enddo
18048 !C now derivative over rik
18049       fac=-eij1**2/dtriss* &
18050       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18051       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18052             gg(1)=xik*fac/rik
18053             gg(2)=yik*fac/rik
18054             gg(3)=zik*fac/rik
18055       do m=1,3
18056         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18057         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18058       enddo
18059       do l=1,3
18060         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18061         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18062       enddo
18063 !C now derivative over rjk
18064       fac=-eij2**2/dtriss* &
18065       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18066       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18067             gg(1)=xjk*fac/rjk
18068             gg(2)=yjk*fac/rjk
18069             gg(3)=zjk*fac/rjk
18070       do m=1,3
18071         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18072         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18073       enddo
18074       do l=1,3
18075         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18076         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18077       enddo
18078       return
18079       end subroutine triple_ssbond_ene
18080
18081
18082
18083 !-----------------------------------------------------------------------------
18084       real(kind=8) function h_base(x,deriv)
18085 !     A smooth function going 0->1 in range [0,1]
18086 !     It should NOT be called outside range [0,1], it will not work there.
18087       implicit none
18088
18089 !     Input arguments
18090       real(kind=8) :: x
18091
18092 !     Output arguments
18093       real(kind=8) :: deriv
18094
18095 !     Local variables
18096       real(kind=8) :: xsq
18097
18098
18099 !     Two parabolas put together.  First derivative zero at extrema
18100 !$$$      if (x.lt.0.5D0) then
18101 !$$$        h_base=2.0D0*x*x
18102 !$$$        deriv=4.0D0*x
18103 !$$$      else
18104 !$$$        deriv=1.0D0-x
18105 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18106 !$$$        deriv=4.0D0*deriv
18107 !$$$      endif
18108
18109 !     Third degree polynomial.  First derivative zero at extrema
18110       h_base=x*x*(3.0d0-2.0d0*x)
18111       deriv=6.0d0*x*(1.0d0-x)
18112
18113 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18114 !$$$      xsq=x*x
18115 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18116 !$$$      deriv=x-1.0d0
18117 !$$$      deriv=deriv*deriv
18118 !$$$      deriv=30.0d0*xsq*deriv
18119
18120       return
18121       end function h_base
18122 !-----------------------------------------------------------------------------
18123       subroutine dyn_set_nss
18124 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18125 !      implicit none
18126       use MD_data, only: totT,t_bath
18127 !     Includes
18128 !      include 'DIMENSIONS'
18129 #ifdef MPI
18130       include "mpif.h"
18131 #endif
18132 !      include 'COMMON.SBRIDGE'
18133 !      include 'COMMON.CHAIN'
18134 !      include 'COMMON.IOUNITS'
18135 !      include 'COMMON.SETUP'
18136 !      include 'COMMON.MD'
18137 !     Local variables
18138       real(kind=8) :: emin
18139       integer :: i,j,imin,ierr
18140       integer :: diff,allnss,newnss
18141       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18142                 newihpb,newjhpb
18143       logical :: found
18144       integer,dimension(0:nfgtasks) :: i_newnss
18145       integer,dimension(0:nfgtasks) :: displ
18146       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18147       integer :: g_newnss
18148
18149       allnss=0
18150       do i=1,nres-1
18151         do j=i+1,nres
18152           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18153             allnss=allnss+1
18154             allflag(allnss)=0
18155             allihpb(allnss)=i
18156             alljhpb(allnss)=j
18157           endif
18158         enddo
18159       enddo
18160
18161 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18162
18163  1    emin=1.0d300
18164       do i=1,allnss
18165         if (allflag(i).eq.0 .and. &
18166              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18167           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18168           imin=i
18169         endif
18170       enddo
18171       if (emin.lt.1.0d300) then
18172         allflag(imin)=1
18173         do i=1,allnss
18174           if (allflag(i).eq.0 .and. &
18175                (allihpb(i).eq.allihpb(imin) .or. &
18176                alljhpb(i).eq.allihpb(imin) .or. &
18177                allihpb(i).eq.alljhpb(imin) .or. &
18178                alljhpb(i).eq.alljhpb(imin))) then
18179             allflag(i)=-1
18180           endif
18181         enddo
18182         goto 1
18183       endif
18184
18185 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18186
18187       newnss=0
18188       do i=1,allnss
18189         if (allflag(i).eq.1) then
18190           newnss=newnss+1
18191           newihpb(newnss)=allihpb(i)
18192           newjhpb(newnss)=alljhpb(i)
18193         endif
18194       enddo
18195
18196 #ifdef MPI
18197       if (nfgtasks.gt.1)then
18198
18199         call MPI_Reduce(newnss,g_newnss,1,&
18200           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18201         call MPI_Gather(newnss,1,MPI_INTEGER,&
18202                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18203         displ(0)=0
18204         do i=1,nfgtasks-1,1
18205           displ(i)=i_newnss(i-1)+displ(i-1)
18206         enddo
18207         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18208                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18209                          king,FG_COMM,IERR)
18210         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18211                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18212                          king,FG_COMM,IERR)
18213         if(fg_rank.eq.0) then
18214 !         print *,'g_newnss',g_newnss
18215 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18216 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18217          newnss=g_newnss
18218          do i=1,newnss
18219           newihpb(i)=g_newihpb(i)
18220           newjhpb(i)=g_newjhpb(i)
18221          enddo
18222         endif
18223       endif
18224 #endif
18225
18226       diff=newnss-nss
18227
18228 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18229 !       print *,newnss,nss,maxdim
18230       do i=1,nss
18231         found=.false.
18232 !        print *,newnss
18233         do j=1,newnss
18234 !!          print *,j
18235           if (idssb(i).eq.newihpb(j) .and. &
18236                jdssb(i).eq.newjhpb(j)) found=.true.
18237         enddo
18238 #ifndef CLUST
18239 #ifndef WHAM
18240 !        write(iout,*) "found",found,i,j
18241         if (.not.found.and.fg_rank.eq.0) &
18242             write(iout,'(a15,f12.2,f8.1,2i5)') &
18243              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18244 #endif
18245 #endif
18246       enddo
18247
18248       do i=1,newnss
18249         found=.false.
18250         do j=1,nss
18251 !          print *,i,j
18252           if (newihpb(i).eq.idssb(j) .and. &
18253                newjhpb(i).eq.jdssb(j)) found=.true.
18254         enddo
18255 #ifndef CLUST
18256 #ifndef WHAM
18257 !        write(iout,*) "found",found,i,j
18258         if (.not.found.and.fg_rank.eq.0) &
18259             write(iout,'(a15,f12.2,f8.1,2i5)') &
18260              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18261 #endif
18262 #endif
18263       enddo
18264
18265       nss=newnss
18266       do i=1,nss
18267         idssb(i)=newihpb(i)
18268         jdssb(i)=newjhpb(i)
18269       enddo
18270
18271       return
18272       end subroutine dyn_set_nss
18273 ! Lipid transfer energy function
18274       subroutine Eliptransfer(eliptran)
18275 !C this is done by Adasko
18276 !C      print *,"wchodze"
18277 !C structure of box:
18278 !C      water
18279 !C--bordliptop-- buffore starts
18280 !C--bufliptop--- here true lipid starts
18281 !C      lipid
18282 !C--buflipbot--- lipid ends buffore starts
18283 !C--bordlipbot--buffore ends
18284       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18285       integer :: i
18286       eliptran=0.0
18287 !      print *, "I am in eliptran"
18288       do i=ilip_start,ilip_end
18289 !C       do i=1,1
18290         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18291          cycle
18292
18293         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18294         if (positi.le.0.0) positi=positi+boxzsize
18295 !C        print *,i
18296 !C first for peptide groups
18297 !c for each residue check if it is in lipid or lipid water border area
18298        if ((positi.gt.bordlipbot)  &
18299       .and.(positi.lt.bordliptop)) then
18300 !C the energy transfer exist
18301         if (positi.lt.buflipbot) then
18302 !C what fraction I am in
18303          fracinbuf=1.0d0-      &
18304              ((positi-bordlipbot)/lipbufthick)
18305 !C lipbufthick is thickenes of lipid buffore
18306          sslip=sscalelip(fracinbuf)
18307          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18308          eliptran=eliptran+sslip*pepliptran
18309          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18310          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18311 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18312
18313 !C        print *,"doing sccale for lower part"
18314 !C         print *,i,sslip,fracinbuf,ssgradlip
18315         elseif (positi.gt.bufliptop) then
18316          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18317          sslip=sscalelip(fracinbuf)
18318          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18319          eliptran=eliptran+sslip*pepliptran
18320          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18321          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18322 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18323 !C          print *, "doing sscalefor top part"
18324 !C         print *,i,sslip,fracinbuf,ssgradlip
18325         else
18326          eliptran=eliptran+pepliptran
18327 !C         print *,"I am in true lipid"
18328         endif
18329 !C       else
18330 !C       eliptran=elpitran+0.0 ! I am in water
18331        endif
18332        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18333        enddo
18334 ! here starts the side chain transfer
18335        do i=ilip_start,ilip_end
18336         if (itype(i,1).eq.ntyp1) cycle
18337         positi=(mod(c(3,i+nres),boxzsize))
18338         if (positi.le.0) positi=positi+boxzsize
18339 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18340 !c for each residue check if it is in lipid or lipid water border area
18341 !C       respos=mod(c(3,i+nres),boxzsize)
18342 !C       print *,positi,bordlipbot,buflipbot
18343        if ((positi.gt.bordlipbot) &
18344        .and.(positi.lt.bordliptop)) then
18345 !C the energy transfer exist
18346         if (positi.lt.buflipbot) then
18347          fracinbuf=1.0d0-   &
18348            ((positi-bordlipbot)/lipbufthick)
18349 !C lipbufthick is thickenes of lipid buffore
18350          sslip=sscalelip(fracinbuf)
18351          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18352          eliptran=eliptran+sslip*liptranene(itype(i,1))
18353          gliptranx(3,i)=gliptranx(3,i) &
18354       +ssgradlip*liptranene(itype(i,1))
18355          gliptranc(3,i-1)= gliptranc(3,i-1) &
18356       +ssgradlip*liptranene(itype(i,1))
18357 !C         print *,"doing sccale for lower part"
18358         elseif (positi.gt.bufliptop) then
18359          fracinbuf=1.0d0-  &
18360       ((bordliptop-positi)/lipbufthick)
18361          sslip=sscalelip(fracinbuf)
18362          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18363          eliptran=eliptran+sslip*liptranene(itype(i,1))
18364          gliptranx(3,i)=gliptranx(3,i)  &
18365        +ssgradlip*liptranene(itype(i,1))
18366          gliptranc(3,i-1)= gliptranc(3,i-1) &
18367       +ssgradlip*liptranene(itype(i,1))
18368 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18369         else
18370          eliptran=eliptran+liptranene(itype(i,1))
18371 !C         print *,"I am in true lipid"
18372         endif
18373         endif ! if in lipid or buffor
18374 !C       else
18375 !C       eliptran=elpitran+0.0 ! I am in water
18376         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18377        enddo
18378        return
18379        end  subroutine Eliptransfer
18380 !----------------------------------NANO FUNCTIONS
18381 !C-----------------------------------------------------------------------
18382 !C-----------------------------------------------------------
18383 !C This subroutine is to mimic the histone like structure but as well can be
18384 !C utilizet to nanostructures (infinit) small modification has to be used to
18385 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18386 !C gradient has to be modified at the ends
18387 !C The energy function is Kihara potential
18388 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18389 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18390 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18391 !C simple Kihara potential
18392       subroutine calctube(Etube)
18393       real(kind=8),dimension(3) :: vectube
18394       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18395        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18396        sc_aa_tube,sc_bb_tube
18397       integer :: i,j,iti
18398       Etube=0.0d0
18399       do i=itube_start,itube_end
18400         enetube(i)=0.0d0
18401         enetube(i+nres)=0.0d0
18402       enddo
18403 !C first we calculate the distance from tube center
18404 !C for UNRES
18405        do i=itube_start,itube_end
18406 !C lets ommit dummy atoms for now
18407        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18408 !C now calculate distance from center of tube and direction vectors
18409       xmin=boxxsize
18410       ymin=boxysize
18411 ! Find minimum distance in periodic box
18412         do j=-1,1
18413          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18414          vectube(1)=vectube(1)+boxxsize*j
18415          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18416          vectube(2)=vectube(2)+boxysize*j
18417          xminact=abs(vectube(1)-tubecenter(1))
18418          yminact=abs(vectube(2)-tubecenter(2))
18419            if (xmin.gt.xminact) then
18420             xmin=xminact
18421             xtemp=vectube(1)
18422            endif
18423            if (ymin.gt.yminact) then
18424              ymin=yminact
18425              ytemp=vectube(2)
18426             endif
18427          enddo
18428       vectube(1)=xtemp
18429       vectube(2)=ytemp
18430       vectube(1)=vectube(1)-tubecenter(1)
18431       vectube(2)=vectube(2)-tubecenter(2)
18432
18433 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18434 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18435
18436 !C as the tube is infinity we do not calculate the Z-vector use of Z
18437 !C as chosen axis
18438       vectube(3)=0.0d0
18439 !C now calculte the distance
18440        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18441 !C now normalize vector
18442       vectube(1)=vectube(1)/tub_r
18443       vectube(2)=vectube(2)/tub_r
18444 !C calculte rdiffrence between r and r0
18445       rdiff=tub_r-tubeR0
18446 !C and its 6 power
18447       rdiff6=rdiff**6.0d0
18448 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18449        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18450 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18451 !C       print *,rdiff,rdiff6,pep_aa_tube
18452 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18453 !C now we calculate gradient
18454        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18455             6.0d0*pep_bb_tube)/rdiff6/rdiff
18456 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18457 !C     &rdiff,fac
18458 !C now direction of gg_tube vector
18459         do j=1,3
18460         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18461         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18462         enddo
18463         enddo
18464 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18465 !C        print *,gg_tube(1,0),"TU"
18466
18467
18468        do i=itube_start,itube_end
18469 !C Lets not jump over memory as we use many times iti
18470          iti=itype(i,1)
18471 !C lets ommit dummy atoms for now
18472          if ((iti.eq.ntyp1)  &
18473 !C in UNRES uncomment the line below as GLY has no side-chain...
18474 !C      .or.(iti.eq.10)
18475         ) cycle
18476       xmin=boxxsize
18477       ymin=boxysize
18478         do j=-1,1
18479          vectube(1)=mod((c(1,i+nres)),boxxsize)
18480          vectube(1)=vectube(1)+boxxsize*j
18481          vectube(2)=mod((c(2,i+nres)),boxysize)
18482          vectube(2)=vectube(2)+boxysize*j
18483
18484          xminact=abs(vectube(1)-tubecenter(1))
18485          yminact=abs(vectube(2)-tubecenter(2))
18486            if (xmin.gt.xminact) then
18487             xmin=xminact
18488             xtemp=vectube(1)
18489            endif
18490            if (ymin.gt.yminact) then
18491              ymin=yminact
18492              ytemp=vectube(2)
18493             endif
18494          enddo
18495       vectube(1)=xtemp
18496       vectube(2)=ytemp
18497 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18498 !C     &     tubecenter(2)
18499       vectube(1)=vectube(1)-tubecenter(1)
18500       vectube(2)=vectube(2)-tubecenter(2)
18501
18502 !C as the tube is infinity we do not calculate the Z-vector use of Z
18503 !C as chosen axis
18504       vectube(3)=0.0d0
18505 !C now calculte the distance
18506        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18507 !C now normalize vector
18508       vectube(1)=vectube(1)/tub_r
18509       vectube(2)=vectube(2)/tub_r
18510
18511 !C calculte rdiffrence between r and r0
18512       rdiff=tub_r-tubeR0
18513 !C and its 6 power
18514       rdiff6=rdiff**6.0d0
18515 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18516        sc_aa_tube=sc_aa_tube_par(iti)
18517        sc_bb_tube=sc_bb_tube_par(iti)
18518        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18519        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18520              6.0d0*sc_bb_tube/rdiff6/rdiff
18521 !C now direction of gg_tube vector
18522          do j=1,3
18523           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18524           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18525          enddo
18526         enddo
18527         do i=itube_start,itube_end
18528           Etube=Etube+enetube(i)+enetube(i+nres)
18529         enddo
18530 !C        print *,"ETUBE", etube
18531         return
18532         end subroutine calctube
18533 !C TO DO 1) add to total energy
18534 !C       2) add to gradient summation
18535 !C       3) add reading parameters (AND of course oppening of PARAM file)
18536 !C       4) add reading the center of tube
18537 !C       5) add COMMONs
18538 !C       6) add to zerograd
18539 !C       7) allocate matrices
18540
18541
18542 !C-----------------------------------------------------------------------
18543 !C-----------------------------------------------------------
18544 !C This subroutine is to mimic the histone like structure but as well can be
18545 !C utilizet to nanostructures (infinit) small modification has to be used to
18546 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18547 !C gradient has to be modified at the ends
18548 !C The energy function is Kihara potential
18549 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18550 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18551 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18552 !C simple Kihara potential
18553       subroutine calctube2(Etube)
18554             real(kind=8),dimension(3) :: vectube
18555       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18556        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18557        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18558       integer:: i,j,iti
18559       Etube=0.0d0
18560       do i=itube_start,itube_end
18561         enetube(i)=0.0d0
18562         enetube(i+nres)=0.0d0
18563       enddo
18564 !C first we calculate the distance from tube center
18565 !C first sugare-phosphate group for NARES this would be peptide group
18566 !C for UNRES
18567        do i=itube_start,itube_end
18568 !C lets ommit dummy atoms for now
18569
18570        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18571 !C now calculate distance from center of tube and direction vectors
18572 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18573 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18574 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18575 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18576       xmin=boxxsize
18577       ymin=boxysize
18578         do j=-1,1
18579          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18580          vectube(1)=vectube(1)+boxxsize*j
18581          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18582          vectube(2)=vectube(2)+boxysize*j
18583
18584          xminact=abs(vectube(1)-tubecenter(1))
18585          yminact=abs(vectube(2)-tubecenter(2))
18586            if (xmin.gt.xminact) then
18587             xmin=xminact
18588             xtemp=vectube(1)
18589            endif
18590            if (ymin.gt.yminact) then
18591              ymin=yminact
18592              ytemp=vectube(2)
18593             endif
18594          enddo
18595       vectube(1)=xtemp
18596       vectube(2)=ytemp
18597       vectube(1)=vectube(1)-tubecenter(1)
18598       vectube(2)=vectube(2)-tubecenter(2)
18599
18600 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18601 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18602
18603 !C as the tube is infinity we do not calculate the Z-vector use of Z
18604 !C as chosen axis
18605       vectube(3)=0.0d0
18606 !C now calculte the distance
18607        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18608 !C now normalize vector
18609       vectube(1)=vectube(1)/tub_r
18610       vectube(2)=vectube(2)/tub_r
18611 !C calculte rdiffrence between r and r0
18612       rdiff=tub_r-tubeR0
18613 !C and its 6 power
18614       rdiff6=rdiff**6.0d0
18615 !C THIS FRAGMENT MAKES TUBE FINITE
18616         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18617         if (positi.le.0) positi=positi+boxzsize
18618 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18619 !c for each residue check if it is in lipid or lipid water border area
18620 !C       respos=mod(c(3,i+nres),boxzsize)
18621 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18622        if ((positi.gt.bordtubebot)  &
18623         .and.(positi.lt.bordtubetop)) then
18624 !C the energy transfer exist
18625         if (positi.lt.buftubebot) then
18626          fracinbuf=1.0d0-  &
18627            ((positi-bordtubebot)/tubebufthick)
18628 !C lipbufthick is thickenes of lipid buffore
18629          sstube=sscalelip(fracinbuf)
18630          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18631 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18632          enetube(i)=enetube(i)+sstube*tubetranenepep
18633 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18634 !C     &+ssgradtube*tubetranene(itype(i,1))
18635 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18636 !C     &+ssgradtube*tubetranene(itype(i,1))
18637 !C         print *,"doing sccale for lower part"
18638         elseif (positi.gt.buftubetop) then
18639          fracinbuf=1.0d0-  &
18640         ((bordtubetop-positi)/tubebufthick)
18641          sstube=sscalelip(fracinbuf)
18642          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18643          enetube(i)=enetube(i)+sstube*tubetranenepep
18644 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18645 !C     &+ssgradtube*tubetranene(itype(i,1))
18646 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18647 !C     &+ssgradtube*tubetranene(itype(i,1))
18648 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18649         else
18650          sstube=1.0d0
18651          ssgradtube=0.0d0
18652          enetube(i)=enetube(i)+sstube*tubetranenepep
18653 !C         print *,"I am in true lipid"
18654         endif
18655         else
18656 !C          sstube=0.0d0
18657 !C          ssgradtube=0.0d0
18658         cycle
18659         endif ! if in lipid or buffor
18660
18661 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18662        enetube(i)=enetube(i)+sstube* &
18663         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18664 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18665 !C       print *,rdiff,rdiff6,pep_aa_tube
18666 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18667 !C now we calculate gradient
18668        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18669              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18670 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18671 !C     &rdiff,fac
18672
18673 !C now direction of gg_tube vector
18674        do j=1,3
18675         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18676         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18677         enddo
18678          gg_tube(3,i)=gg_tube(3,i)  &
18679        +ssgradtube*enetube(i)/sstube/2.0d0
18680          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18681        +ssgradtube*enetube(i)/sstube/2.0d0
18682
18683         enddo
18684 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18685 !C        print *,gg_tube(1,0),"TU"
18686         do i=itube_start,itube_end
18687 !C Lets not jump over memory as we use many times iti
18688          iti=itype(i,1)
18689 !C lets ommit dummy atoms for now
18690          if ((iti.eq.ntyp1) &
18691 !!C in UNRES uncomment the line below as GLY has no side-chain...
18692            .or.(iti.eq.10) &
18693           ) cycle
18694           vectube(1)=c(1,i+nres)
18695           vectube(1)=mod(vectube(1),boxxsize)
18696           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18697           vectube(2)=c(2,i+nres)
18698           vectube(2)=mod(vectube(2),boxysize)
18699           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18700
18701       vectube(1)=vectube(1)-tubecenter(1)
18702       vectube(2)=vectube(2)-tubecenter(2)
18703 !C THIS FRAGMENT MAKES TUBE FINITE
18704         positi=(mod(c(3,i+nres),boxzsize))
18705         if (positi.le.0) positi=positi+boxzsize
18706 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18707 !c for each residue check if it is in lipid or lipid water border area
18708 !C       respos=mod(c(3,i+nres),boxzsize)
18709 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18710
18711        if ((positi.gt.bordtubebot)  &
18712         .and.(positi.lt.bordtubetop)) then
18713 !C the energy transfer exist
18714         if (positi.lt.buftubebot) then
18715          fracinbuf=1.0d0- &
18716             ((positi-bordtubebot)/tubebufthick)
18717 !C lipbufthick is thickenes of lipid buffore
18718          sstube=sscalelip(fracinbuf)
18719          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18720 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18721          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18722 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18723 !C     &+ssgradtube*tubetranene(itype(i,1))
18724 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18725 !C     &+ssgradtube*tubetranene(itype(i,1))
18726 !C         print *,"doing sccale for lower part"
18727         elseif (positi.gt.buftubetop) then
18728          fracinbuf=1.0d0- &
18729         ((bordtubetop-positi)/tubebufthick)
18730
18731          sstube=sscalelip(fracinbuf)
18732          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18733          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18734 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18735 !C     &+ssgradtube*tubetranene(itype(i,1))
18736 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18737 !C     &+ssgradtube*tubetranene(itype(i,1))
18738 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18739         else
18740          sstube=1.0d0
18741          ssgradtube=0.0d0
18742          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18743 !C         print *,"I am in true lipid"
18744         endif
18745         else
18746 !C          sstube=0.0d0
18747 !C          ssgradtube=0.0d0
18748         cycle
18749         endif ! if in lipid or buffor
18750 !CEND OF FINITE FRAGMENT
18751 !C as the tube is infinity we do not calculate the Z-vector use of Z
18752 !C as chosen axis
18753       vectube(3)=0.0d0
18754 !C now calculte the distance
18755        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18756 !C now normalize vector
18757       vectube(1)=vectube(1)/tub_r
18758       vectube(2)=vectube(2)/tub_r
18759 !C calculte rdiffrence between r and r0
18760       rdiff=tub_r-tubeR0
18761 !C and its 6 power
18762       rdiff6=rdiff**6.0d0
18763 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18764        sc_aa_tube=sc_aa_tube_par(iti)
18765        sc_bb_tube=sc_bb_tube_par(iti)
18766        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18767                        *sstube+enetube(i+nres)
18768 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18769 !C now we calculate gradient
18770        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18771             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18772 !C now direction of gg_tube vector
18773          do j=1,3
18774           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18775           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18776          enddo
18777          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18778        +ssgradtube*enetube(i+nres)/sstube
18779          gg_tube(3,i-1)= gg_tube(3,i-1) &
18780        +ssgradtube*enetube(i+nres)/sstube
18781
18782         enddo
18783         do i=itube_start,itube_end
18784           Etube=Etube+enetube(i)+enetube(i+nres)
18785         enddo
18786 !C        print *,"ETUBE", etube
18787         return
18788         end subroutine calctube2
18789 !=====================================================================================================================================
18790       subroutine calcnano(Etube)
18791       real(kind=8),dimension(3) :: vectube
18792
18793       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18794        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
18795        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
18796        integer:: i,j,iti,r
18797
18798       Etube=0.0d0
18799 !      print *,itube_start,itube_end,"poczatek"
18800       do i=itube_start,itube_end
18801         enetube(i)=0.0d0
18802         enetube(i+nres)=0.0d0
18803       enddo
18804 !C first we calculate the distance from tube center
18805 !C first sugare-phosphate group for NARES this would be peptide group
18806 !C for UNRES
18807        do i=itube_start,itube_end
18808 !C lets ommit dummy atoms for now
18809        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18810 !C now calculate distance from center of tube and direction vectors
18811       xmin=boxxsize
18812       ymin=boxysize
18813       zmin=boxzsize
18814
18815         do j=-1,1
18816          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18817          vectube(1)=vectube(1)+boxxsize*j
18818          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18819          vectube(2)=vectube(2)+boxysize*j
18820          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18821          vectube(3)=vectube(3)+boxzsize*j
18822
18823
18824          xminact=dabs(vectube(1)-tubecenter(1))
18825          yminact=dabs(vectube(2)-tubecenter(2))
18826          zminact=dabs(vectube(3)-tubecenter(3))
18827
18828            if (xmin.gt.xminact) then
18829             xmin=xminact
18830             xtemp=vectube(1)
18831            endif
18832            if (ymin.gt.yminact) then
18833              ymin=yminact
18834              ytemp=vectube(2)
18835             endif
18836            if (zmin.gt.zminact) then
18837              zmin=zminact
18838              ztemp=vectube(3)
18839             endif
18840          enddo
18841       vectube(1)=xtemp
18842       vectube(2)=ytemp
18843       vectube(3)=ztemp
18844
18845       vectube(1)=vectube(1)-tubecenter(1)
18846       vectube(2)=vectube(2)-tubecenter(2)
18847       vectube(3)=vectube(3)-tubecenter(3)
18848
18849 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18850 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18851 !C as the tube is infinity we do not calculate the Z-vector use of Z
18852 !C as chosen axis
18853 !C      vectube(3)=0.0d0
18854 !C now calculte the distance
18855        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18856 !C now normalize vector
18857       vectube(1)=vectube(1)/tub_r
18858       vectube(2)=vectube(2)/tub_r
18859       vectube(3)=vectube(3)/tub_r
18860 !C calculte rdiffrence between r and r0
18861       rdiff=tub_r-tubeR0
18862 !C and its 6 power
18863       rdiff6=rdiff**6.0d0
18864 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18865        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18866 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18867 !C       print *,rdiff,rdiff6,pep_aa_tube
18868 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18869 !C now we calculate gradient
18870        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
18871             6.0d0*pep_bb_tube)/rdiff6/rdiff
18872 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18873 !C     &rdiff,fac
18874          if (acavtubpep.eq.0.0d0) then
18875 !C go to 667
18876          enecavtube(i)=0.0
18877          faccav=0.0
18878          else
18879          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
18880          enecavtube(i)=  &
18881         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
18882         /denominator
18883          enecavtube(i)=0.0
18884          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
18885         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
18886         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
18887         /denominator**2.0d0
18888 !C         faccav=0.0
18889 !C         fac=fac+faccav
18890 !C 667     continue
18891          endif
18892           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
18893         do j=1,3
18894         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18895         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18896         enddo
18897         enddo
18898
18899        do i=itube_start,itube_end
18900         enecavtube(i)=0.0d0
18901 !C Lets not jump over memory as we use many times iti
18902          iti=itype(i,1)
18903 !C lets ommit dummy atoms for now
18904          if ((iti.eq.ntyp1) &
18905 !C in UNRES uncomment the line below as GLY has no side-chain...
18906 !C      .or.(iti.eq.10)
18907          ) cycle
18908       xmin=boxxsize
18909       ymin=boxysize
18910       zmin=boxzsize
18911         do j=-1,1
18912          vectube(1)=dmod((c(1,i+nres)),boxxsize)
18913          vectube(1)=vectube(1)+boxxsize*j
18914          vectube(2)=dmod((c(2,i+nres)),boxysize)
18915          vectube(2)=vectube(2)+boxysize*j
18916          vectube(3)=dmod((c(3,i+nres)),boxzsize)
18917          vectube(3)=vectube(3)+boxzsize*j
18918
18919
18920          xminact=dabs(vectube(1)-tubecenter(1))
18921          yminact=dabs(vectube(2)-tubecenter(2))
18922          zminact=dabs(vectube(3)-tubecenter(3))
18923
18924            if (xmin.gt.xminact) then
18925             xmin=xminact
18926             xtemp=vectube(1)
18927            endif
18928            if (ymin.gt.yminact) then
18929              ymin=yminact
18930              ytemp=vectube(2)
18931             endif
18932            if (zmin.gt.zminact) then
18933              zmin=zminact
18934              ztemp=vectube(3)
18935             endif
18936          enddo
18937       vectube(1)=xtemp
18938       vectube(2)=ytemp
18939       vectube(3)=ztemp
18940
18941 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18942 !C     &     tubecenter(2)
18943       vectube(1)=vectube(1)-tubecenter(1)
18944       vectube(2)=vectube(2)-tubecenter(2)
18945       vectube(3)=vectube(3)-tubecenter(3)
18946 !C now calculte the distance
18947        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18948 !C now normalize vector
18949       vectube(1)=vectube(1)/tub_r
18950       vectube(2)=vectube(2)/tub_r
18951       vectube(3)=vectube(3)/tub_r
18952
18953 !C calculte rdiffrence between r and r0
18954       rdiff=tub_r-tubeR0
18955 !C and its 6 power
18956       rdiff6=rdiff**6.0d0
18957        sc_aa_tube=sc_aa_tube_par(iti)
18958        sc_bb_tube=sc_bb_tube_par(iti)
18959        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18960 !C       enetube(i+nres)=0.0d0
18961 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18962 !C now we calculate gradient
18963        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
18964             6.0d0*sc_bb_tube/rdiff6/rdiff
18965 !C       fac=0.0
18966 !C now direction of gg_tube vector
18967 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
18968          if (acavtub(iti).eq.0.0d0) then
18969 !C go to 667
18970          enecavtube(i+nres)=0.0d0
18971          faccav=0.0d0
18972          else
18973          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
18974          enecavtube(i+nres)=   &
18975         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
18976         /denominator
18977 !C         enecavtube(i)=0.0
18978          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
18979         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
18980         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
18981         /denominator**2.0d0
18982 !C         faccav=0.0
18983          fac=fac+faccav
18984 !C 667     continue
18985          endif
18986 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
18987 !C     &   enecavtube(i),faccav
18988 !C         print *,"licz=",
18989 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
18990 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
18991          do j=1,3
18992           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18993           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18994          enddo
18995           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
18996         enddo
18997
18998
18999
19000         do i=itube_start,itube_end
19001           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19002          +enecavtube(i+nres)
19003         enddo
19004 !        do i=1,20
19005 !         print *,"begin", i,"a"
19006 !         do r=1,10000
19007 !          rdiff=r/100.0d0
19008 !          rdiff6=rdiff**6.0d0
19009 !          sc_aa_tube=sc_aa_tube_par(i)
19010 !          sc_bb_tube=sc_bb_tube_par(i)
19011 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19012 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19013 !          enecavtube(i)=   &
19014 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19015 !         /denominator
19016
19017 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19018 !         enddo
19019 !         print *,"end",i,"a"
19020 !        enddo
19021 !C        print *,"ETUBE", etube
19022         return
19023         end subroutine calcnano
19024
19025 !===============================================
19026 !--------------------------------------------------------------------------------
19027 !C first for shielding is setting of function of side-chains
19028
19029        subroutine set_shield_fac2
19030        real(kind=8) :: div77_81=0.974996043d0, &
19031         div4_81=0.2222222222d0
19032        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19033          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19034          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19035          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19036 !C the vector between center of side_chain and peptide group
19037        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19038          pept_group,costhet_grad,cosphi_grad_long, &
19039          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19040          sh_frac_dist_grad,pep_side
19041         integer i,j,k
19042 !C      write(2,*) "ivec",ivec_start,ivec_end
19043       do i=1,nres
19044         fac_shield(i)=0.0d0
19045         do j=1,3
19046         grad_shield(j,i)=0.0d0
19047         enddo
19048       enddo
19049       do i=ivec_start,ivec_end
19050 !C      do i=1,nres-1
19051 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19052       ishield_list(i)=0
19053       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19054 !Cif there two consequtive dummy atoms there is no peptide group between them
19055 !C the line below has to be changed for FGPROC>1
19056       VolumeTotal=0.0
19057       do k=1,nres
19058        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19059        dist_pep_side=0.0
19060        dist_side_calf=0.0
19061        do j=1,3
19062 !C first lets set vector conecting the ithe side-chain with kth side-chain
19063       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19064 !C      pep_side(j)=2.0d0
19065 !C and vector conecting the side-chain with its proper calfa
19066       side_calf(j)=c(j,k+nres)-c(j,k)
19067 !C      side_calf(j)=2.0d0
19068       pept_group(j)=c(j,i)-c(j,i+1)
19069 !C lets have their lenght
19070       dist_pep_side=pep_side(j)**2+dist_pep_side
19071       dist_side_calf=dist_side_calf+side_calf(j)**2
19072       dist_pept_group=dist_pept_group+pept_group(j)**2
19073       enddo
19074        dist_pep_side=sqrt(dist_pep_side)
19075        dist_pept_group=sqrt(dist_pept_group)
19076        dist_side_calf=sqrt(dist_side_calf)
19077       do j=1,3
19078         pep_side_norm(j)=pep_side(j)/dist_pep_side
19079         side_calf_norm(j)=dist_side_calf
19080       enddo
19081 !C now sscale fraction
19082        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19083 !C       print *,buff_shield,"buff"
19084 !C now sscale
19085         if (sh_frac_dist.le.0.0) cycle
19086 !C        print *,ishield_list(i),i
19087 !C If we reach here it means that this side chain reaches the shielding sphere
19088 !C Lets add him to the list for gradient
19089         ishield_list(i)=ishield_list(i)+1
19090 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19091 !C this list is essential otherwise problem would be O3
19092         shield_list(ishield_list(i),i)=k
19093 !C Lets have the sscale value
19094         if (sh_frac_dist.gt.1.0) then
19095          scale_fac_dist=1.0d0
19096          do j=1,3
19097          sh_frac_dist_grad(j)=0.0d0
19098          enddo
19099         else
19100          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19101                         *(2.0d0*sh_frac_dist-3.0d0)
19102          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19103                        /dist_pep_side/buff_shield*0.5d0
19104          do j=1,3
19105          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19106 !C         sh_frac_dist_grad(j)=0.0d0
19107 !C         scale_fac_dist=1.0d0
19108 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19109 !C     &                    sh_frac_dist_grad(j)
19110          enddo
19111         endif
19112 !C this is what is now we have the distance scaling now volume...
19113       short=short_r_sidechain(itype(k,1))
19114       long=long_r_sidechain(itype(k,1))
19115       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19116       sinthet=short/dist_pep_side*costhet
19117 !C now costhet_grad
19118 !C       costhet=0.6d0
19119 !C       sinthet=0.8
19120        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19121 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19122 !C     &             -short/dist_pep_side**2/costhet)
19123 !C       costhet_fac=0.0d0
19124        do j=1,3
19125          costhet_grad(j)=costhet_fac*pep_side(j)
19126        enddo
19127 !C remember for the final gradient multiply costhet_grad(j)
19128 !C for side_chain by factor -2 !
19129 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19130 !C pep_side0pept_group is vector multiplication
19131       pep_side0pept_group=0.0d0
19132       do j=1,3
19133       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19134       enddo
19135       cosalfa=(pep_side0pept_group/ &
19136       (dist_pep_side*dist_side_calf))
19137       fac_alfa_sin=1.0d0-cosalfa**2
19138       fac_alfa_sin=dsqrt(fac_alfa_sin)
19139       rkprim=fac_alfa_sin*(long-short)+short
19140 !C      rkprim=short
19141
19142 !C now costhet_grad
19143        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19144 !C       cosphi=0.6
19145        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19146        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19147            dist_pep_side**2)
19148 !C       sinphi=0.8
19149        do j=1,3
19150          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19151       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19152       *(long-short)/fac_alfa_sin*cosalfa/ &
19153       ((dist_pep_side*dist_side_calf))* &
19154       ((side_calf(j))-cosalfa* &
19155       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19156 !C       cosphi_grad_long(j)=0.0d0
19157         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19158       *(long-short)/fac_alfa_sin*cosalfa &
19159       /((dist_pep_side*dist_side_calf))* &
19160       (pep_side(j)- &
19161       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19162 !C       cosphi_grad_loc(j)=0.0d0
19163        enddo
19164 !C      print *,sinphi,sinthet
19165       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19166      &                    /VSolvSphere_div
19167 !C     &                    *wshield
19168 !C now the gradient...
19169       do j=1,3
19170       grad_shield(j,i)=grad_shield(j,i) &
19171 !C gradient po skalowaniu
19172                      +(sh_frac_dist_grad(j)*VofOverlap &
19173 !C  gradient po costhet
19174             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19175         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19176             sinphi/sinthet*costhet*costhet_grad(j) &
19177            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19178         )*wshield
19179 !C grad_shield_side is Cbeta sidechain gradient
19180       grad_shield_side(j,ishield_list(i),i)=&
19181              (sh_frac_dist_grad(j)*-2.0d0&
19182              *VofOverlap&
19183             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19184        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19185             sinphi/sinthet*costhet*costhet_grad(j)&
19186            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19187             )*wshield
19188
19189        grad_shield_loc(j,ishield_list(i),i)=   &
19190             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19191       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19192             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19193              ))&
19194              *wshield
19195       enddo
19196       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19197       enddo
19198       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19199
19200 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19201       enddo
19202       return
19203       end subroutine set_shield_fac2
19204 !----------------------------------------------------------------------------
19205 ! SOUBROUTINE FOR AFM
19206        subroutine AFMvel(Eafmforce)
19207        use MD_data, only:totTafm
19208       real(kind=8),dimension(3) :: diffafm
19209       real(kind=8) :: afmdist,Eafmforce
19210        integer :: i
19211 !C Only for check grad COMMENT if not used for checkgrad
19212 !C      totT=3.0d0
19213 !C--------------------------------------------------------
19214 !C      print *,"wchodze"
19215       afmdist=0.0d0
19216       Eafmforce=0.0d0
19217       do i=1,3
19218       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19219       afmdist=afmdist+diffafm(i)**2
19220       enddo
19221       afmdist=dsqrt(afmdist)
19222 !      totTafm=3.0
19223       Eafmforce=0.5d0*forceAFMconst &
19224       *(distafminit+totTafm*velAFMconst-afmdist)**2
19225 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19226       do i=1,3
19227       gradafm(i,afmend-1)=-forceAFMconst* &
19228        (distafminit+totTafm*velAFMconst-afmdist) &
19229        *diffafm(i)/afmdist
19230       gradafm(i,afmbeg-1)=forceAFMconst* &
19231       (distafminit+totTafm*velAFMconst-afmdist) &
19232       *diffafm(i)/afmdist
19233       enddo
19234 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19235       return
19236       end subroutine AFMvel
19237 !---------------------------------------------------------
19238        subroutine AFMforce(Eafmforce)
19239
19240       real(kind=8),dimension(3) :: diffafm
19241 !      real(kind=8) ::afmdist
19242       real(kind=8) :: afmdist,Eafmforce
19243       integer :: i
19244       afmdist=0.0d0
19245       Eafmforce=0.0d0
19246       do i=1,3
19247       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19248       afmdist=afmdist+diffafm(i)**2
19249       enddo
19250       afmdist=dsqrt(afmdist)
19251 !      print *,afmdist,distafminit
19252       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19253       do i=1,3
19254       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19255       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19256       enddo
19257 !C      print *,'AFM',Eafmforce
19258       return
19259       end subroutine AFMforce
19260
19261 !-----------------------------------------------------------------------------
19262 #ifdef WHAM
19263       subroutine read_ssHist
19264 !      implicit none
19265 !      Includes
19266 !      include 'DIMENSIONS'
19267 !      include "DIMENSIONS.FREE"
19268 !      include 'COMMON.FREE'
19269 !     Local variables
19270       integer :: i,j
19271       character(len=80) :: controlcard
19272
19273       do i=1,dyn_nssHist
19274         call card_concat(controlcard,.true.)
19275         read(controlcard,*) &
19276              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19277       enddo
19278
19279       return
19280       end subroutine read_ssHist
19281 #endif
19282 !-----------------------------------------------------------------------------
19283       integer function indmat(i,j)
19284 !el
19285 ! get the position of the jth ijth fragment of the chain coordinate system
19286 ! in the fromto array.
19287         integer :: i,j
19288
19289         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19290       return
19291       end function indmat
19292 !-----------------------------------------------------------------------------
19293       real(kind=8) function sigm(x)
19294 !el
19295        real(kind=8) :: x
19296         sigm=0.25d0*x
19297       return
19298       end function sigm
19299 !-----------------------------------------------------------------------------
19300 !-----------------------------------------------------------------------------
19301       subroutine alloc_ener_arrays
19302 !EL Allocation of arrays used by module energy
19303       use MD_data, only: mset
19304 !el local variables
19305       integer :: i,j
19306
19307       if(nres.lt.100) then
19308         maxconts=nres
19309       elseif(nres.lt.200) then
19310         maxconts=0.8*nres       ! Max. number of contacts per residue
19311       else
19312         maxconts=0.6*nres ! (maxconts=maxres/4)
19313       endif
19314       maxcont=12*nres   ! Max. number of SC contacts
19315       maxvar=6*nres     ! Max. number of variables
19316 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19317       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19318 !----------------------
19319 ! arrays in subroutine init_int_table
19320 !el#ifdef MPI
19321 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19322 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19323 !el#endif
19324       allocate(nint_gr(nres))
19325       allocate(nscp_gr(nres))
19326       allocate(ielstart(nres))
19327       allocate(ielend(nres))
19328 !(maxres)
19329       allocate(istart(nres,maxint_gr))
19330       allocate(iend(nres,maxint_gr))
19331 !(maxres,maxint_gr)
19332       allocate(iscpstart(nres,maxint_gr))
19333       allocate(iscpend(nres,maxint_gr))
19334 !(maxres,maxint_gr)
19335       allocate(ielstart_vdw(nres))
19336       allocate(ielend_vdw(nres))
19337 !(maxres)
19338
19339       allocate(lentyp(0:nfgtasks-1))
19340 !(0:maxprocs-1)
19341 !----------------------
19342 ! commom.contacts
19343 !      common /contacts/
19344       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19345       allocate(icont(2,maxcont))
19346 !(2,maxcont)
19347 !      common /contacts1/
19348       allocate(num_cont(0:nres+4))
19349 !(maxres)
19350       allocate(jcont(maxconts,nres))
19351 !(maxconts,maxres)
19352       allocate(facont(maxconts,nres))
19353 !(maxconts,maxres)
19354       allocate(gacont(3,maxconts,nres))
19355 !(3,maxconts,maxres)
19356 !      common /contacts_hb/
19357       allocate(gacontp_hb1(3,maxconts,nres))
19358       allocate(gacontp_hb2(3,maxconts,nres))
19359       allocate(gacontp_hb3(3,maxconts,nres))
19360       allocate(gacontm_hb1(3,maxconts,nres))
19361       allocate(gacontm_hb2(3,maxconts,nres))
19362       allocate(gacontm_hb3(3,maxconts,nres))
19363       allocate(gacont_hbr(3,maxconts,nres))
19364       allocate(grij_hb_cont(3,maxconts,nres))
19365 !(3,maxconts,maxres)
19366       allocate(facont_hb(maxconts,nres))
19367
19368       allocate(ees0p(maxconts,nres))
19369       allocate(ees0m(maxconts,nres))
19370       allocate(d_cont(maxconts,nres))
19371       allocate(ees0plist(maxconts,nres))
19372
19373 !(maxconts,maxres)
19374       allocate(num_cont_hb(nres))
19375 !(maxres)
19376       allocate(jcont_hb(maxconts,nres))
19377 !(maxconts,maxres)
19378 !      common /rotat/
19379       allocate(Ug(2,2,nres))
19380       allocate(Ugder(2,2,nres))
19381       allocate(Ug2(2,2,nres))
19382       allocate(Ug2der(2,2,nres))
19383 !(2,2,maxres)
19384       allocate(obrot(2,nres))
19385       allocate(obrot2(2,nres))
19386       allocate(obrot_der(2,nres))
19387       allocate(obrot2_der(2,nres))
19388 !(2,maxres)
19389 !      common /precomp1/
19390       allocate(mu(2,nres))
19391       allocate(muder(2,nres))
19392       allocate(Ub2(2,nres))
19393       Ub2(1,:)=0.0d0
19394       Ub2(2,:)=0.0d0
19395       allocate(Ub2der(2,nres))
19396       allocate(Ctobr(2,nres))
19397       allocate(Ctobrder(2,nres))
19398       allocate(Dtobr2(2,nres))
19399       allocate(Dtobr2der(2,nres))
19400 !(2,maxres)
19401       allocate(EUg(2,2,nres))
19402       allocate(EUgder(2,2,nres))
19403       allocate(CUg(2,2,nres))
19404       allocate(CUgder(2,2,nres))
19405       allocate(DUg(2,2,nres))
19406       allocate(Dugder(2,2,nres))
19407       allocate(DtUg2(2,2,nres))
19408       allocate(DtUg2der(2,2,nres))
19409 !(2,2,maxres)
19410 !      common /precomp2/
19411       allocate(Ug2Db1t(2,nres))
19412       allocate(Ug2Db1tder(2,nres))
19413       allocate(CUgb2(2,nres))
19414       allocate(CUgb2der(2,nres))
19415 !(2,maxres)
19416       allocate(EUgC(2,2,nres))
19417       allocate(EUgCder(2,2,nres))
19418       allocate(EUgD(2,2,nres))
19419       allocate(EUgDder(2,2,nres))
19420       allocate(DtUg2EUg(2,2,nres))
19421       allocate(Ug2DtEUg(2,2,nres))
19422 !(2,2,maxres)
19423       allocate(Ug2DtEUgder(2,2,2,nres))
19424       allocate(DtUg2EUgder(2,2,2,nres))
19425 !(2,2,2,maxres)
19426 !      common /rotat_old/
19427       allocate(costab(nres))
19428       allocate(sintab(nres))
19429       allocate(costab2(nres))
19430       allocate(sintab2(nres))
19431 !(maxres)
19432 !      common /dipmat/
19433       allocate(a_chuj(2,2,maxconts,nres))
19434 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19435       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19436 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19437 !      common /contdistrib/
19438       allocate(ncont_sent(nres))
19439       allocate(ncont_recv(nres))
19440
19441       allocate(iat_sent(nres))
19442 !(maxres)
19443       allocate(iint_sent(4,nres,nres))
19444       allocate(iint_sent_local(4,nres,nres))
19445 !(4,maxres,maxres)
19446       allocate(iturn3_sent(4,0:nres+4))
19447       allocate(iturn4_sent(4,0:nres+4))
19448       allocate(iturn3_sent_local(4,nres))
19449       allocate(iturn4_sent_local(4,nres))
19450 !(4,maxres)
19451       allocate(itask_cont_from(0:nfgtasks-1))
19452       allocate(itask_cont_to(0:nfgtasks-1))
19453 !(0:max_fg_procs-1)
19454
19455
19456
19457 !----------------------
19458 ! commom.deriv;
19459 !      common /derivat/
19460       allocate(dcdv(6,maxdim))
19461       allocate(dxdv(6,maxdim))
19462 !(6,maxdim)
19463       allocate(dxds(6,nres))
19464 !(6,maxres)
19465       allocate(gradx(3,-1:nres,0:2))
19466       allocate(gradc(3,-1:nres,0:2))
19467 !(3,maxres,2)
19468       allocate(gvdwx(3,-1:nres))
19469       allocate(gvdwc(3,-1:nres))
19470       allocate(gelc(3,-1:nres))
19471       allocate(gelc_long(3,-1:nres))
19472       allocate(gvdwpp(3,-1:nres))
19473       allocate(gvdwc_scpp(3,-1:nres))
19474       allocate(gradx_scp(3,-1:nres))
19475       allocate(gvdwc_scp(3,-1:nres))
19476       allocate(ghpbx(3,-1:nres))
19477       allocate(ghpbc(3,-1:nres))
19478       allocate(gradcorr(3,-1:nres))
19479       allocate(gradcorr_long(3,-1:nres))
19480       allocate(gradcorr5_long(3,-1:nres))
19481       allocate(gradcorr6_long(3,-1:nres))
19482       allocate(gcorr6_turn_long(3,-1:nres))
19483       allocate(gradxorr(3,-1:nres))
19484       allocate(gradcorr5(3,-1:nres))
19485       allocate(gradcorr6(3,-1:nres))
19486       allocate(gliptran(3,-1:nres))
19487       allocate(gliptranc(3,-1:nres))
19488       allocate(gliptranx(3,-1:nres))
19489       allocate(gshieldx(3,-1:nres))
19490       allocate(gshieldc(3,-1:nres))
19491       allocate(gshieldc_loc(3,-1:nres))
19492       allocate(gshieldx_ec(3,-1:nres))
19493       allocate(gshieldc_ec(3,-1:nres))
19494       allocate(gshieldc_loc_ec(3,-1:nres))
19495       allocate(gshieldx_t3(3,-1:nres))
19496       allocate(gshieldc_t3(3,-1:nres))
19497       allocate(gshieldc_loc_t3(3,-1:nres))
19498       allocate(gshieldx_t4(3,-1:nres))
19499       allocate(gshieldc_t4(3,-1:nres))
19500       allocate(gshieldc_loc_t4(3,-1:nres))
19501       allocate(gshieldx_ll(3,-1:nres))
19502       allocate(gshieldc_ll(3,-1:nres))
19503       allocate(gshieldc_loc_ll(3,-1:nres))
19504       allocate(grad_shield(3,-1:nres))
19505       allocate(gg_tube_sc(3,-1:nres))
19506       allocate(gg_tube(3,-1:nres))
19507       allocate(gradafm(3,-1:nres))
19508       allocate(gradb_nucl(3,-1:nres))
19509       allocate(gradbx_nucl(3,-1:nres))
19510 !(3,maxres)
19511       allocate(grad_shield_side(3,50,nres))
19512       allocate(grad_shield_loc(3,50,nres))
19513 ! grad for shielding surroing
19514       allocate(gloc(0:maxvar,0:2))
19515       allocate(gloc_x(0:maxvar,2))
19516 !(maxvar,2)
19517       allocate(gel_loc(3,-1:nres))
19518       allocate(gel_loc_long(3,-1:nres))
19519       allocate(gcorr3_turn(3,-1:nres))
19520       allocate(gcorr4_turn(3,-1:nres))
19521       allocate(gcorr6_turn(3,-1:nres))
19522       allocate(gradb(3,-1:nres))
19523       allocate(gradbx(3,-1:nres))
19524 !(3,maxres)
19525       allocate(gel_loc_loc(maxvar))
19526       allocate(gel_loc_turn3(maxvar))
19527       allocate(gel_loc_turn4(maxvar))
19528       allocate(gel_loc_turn6(maxvar))
19529       allocate(gcorr_loc(maxvar))
19530       allocate(g_corr5_loc(maxvar))
19531       allocate(g_corr6_loc(maxvar))
19532 !(maxvar)
19533       allocate(gsccorc(3,-1:nres))
19534       allocate(gsccorx(3,-1:nres))
19535 !(3,maxres)
19536       allocate(gsccor_loc(-1:nres))
19537 !(maxres)
19538       allocate(dtheta(3,2,-1:nres))
19539 !(3,2,maxres)
19540       allocate(gscloc(3,-1:nres))
19541       allocate(gsclocx(3,-1:nres))
19542 !(3,maxres)
19543       allocate(dphi(3,3,-1:nres))
19544       allocate(dalpha(3,3,-1:nres))
19545       allocate(domega(3,3,-1:nres))
19546 !(3,3,maxres)
19547 !      common /deriv_scloc/
19548       allocate(dXX_C1tab(3,nres))
19549       allocate(dYY_C1tab(3,nres))
19550       allocate(dZZ_C1tab(3,nres))
19551       allocate(dXX_Ctab(3,nres))
19552       allocate(dYY_Ctab(3,nres))
19553       allocate(dZZ_Ctab(3,nres))
19554       allocate(dXX_XYZtab(3,nres))
19555       allocate(dYY_XYZtab(3,nres))
19556       allocate(dZZ_XYZtab(3,nres))
19557 !(3,maxres)
19558 !      common /mpgrad/
19559       allocate(jgrad_start(nres))
19560       allocate(jgrad_end(nres))
19561 !(maxres)
19562 !----------------------
19563
19564 !      common /indices/
19565       allocate(ibond_displ(0:nfgtasks-1))
19566       allocate(ibond_count(0:nfgtasks-1))
19567       allocate(ithet_displ(0:nfgtasks-1))
19568       allocate(ithet_count(0:nfgtasks-1))
19569       allocate(iphi_displ(0:nfgtasks-1))
19570       allocate(iphi_count(0:nfgtasks-1))
19571       allocate(iphi1_displ(0:nfgtasks-1))
19572       allocate(iphi1_count(0:nfgtasks-1))
19573       allocate(ivec_displ(0:nfgtasks-1))
19574       allocate(ivec_count(0:nfgtasks-1))
19575       allocate(iset_displ(0:nfgtasks-1))
19576       allocate(iset_count(0:nfgtasks-1))
19577       allocate(iint_count(0:nfgtasks-1))
19578       allocate(iint_displ(0:nfgtasks-1))
19579 !(0:max_fg_procs-1)
19580 !----------------------
19581 ! common.MD
19582 !      common /mdgrad/
19583       allocate(gcart(3,-1:nres))
19584       allocate(gxcart(3,-1:nres))
19585 !(3,0:MAXRES)
19586       allocate(gradcag(3,-1:nres))
19587       allocate(gradxag(3,-1:nres))
19588 !(3,MAXRES)
19589 !      common /back_constr/
19590 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19591       allocate(dutheta(nres))
19592       allocate(dugamma(nres))
19593 !(maxres)
19594       allocate(duscdiff(3,nres))
19595       allocate(duscdiffx(3,nres))
19596 !(3,maxres)
19597 !el i io:read_fragments
19598 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19599 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19600 !      common /qmeas/
19601 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19602 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19603       allocate(mset(0:nprocs))  !(maxprocs/20)
19604       mset(:)=0
19605 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19606 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19607       allocate(dUdconst(3,0:nres))
19608       allocate(dUdxconst(3,0:nres))
19609       allocate(dqwol(3,0:nres))
19610       allocate(dxqwol(3,0:nres))
19611 !(3,0:MAXRES)
19612 !----------------------
19613 ! common.sbridge
19614 !      common /sbridge/ in io_common: read_bridge
19615 !el    allocate((:),allocatable :: iss  !(maxss)
19616 !      common /links/  in io_common: read_bridge
19617 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19618 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19619 !      common /dyn_ssbond/
19620 ! and side-chain vectors in theta or phi.
19621       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19622 !(maxres,maxres)
19623 !      do i=1,nres
19624 !        do j=i+1,nres
19625       dyn_ssbond_ij(:,:)=1.0d300
19626 !        enddo
19627 !      enddo
19628
19629 !      if (nss.gt.0) then
19630         allocate(idssb(maxdim),jdssb(maxdim))
19631 !        allocate(newihpb(nss),newjhpb(nss))
19632 !(maxdim)
19633 !      endif
19634       allocate(ishield_list(nres))
19635       allocate(shield_list(50,nres))
19636       allocate(dyn_ss_mask(nres))
19637       allocate(fac_shield(nres))
19638       allocate(enetube(nres*2))
19639       allocate(enecavtube(nres*2))
19640
19641 !(maxres)
19642       dyn_ss_mask(:)=.false.
19643 !----------------------
19644 ! common.sccor
19645 ! Parameters of the SCCOR term
19646 !      common/sccor/
19647 !el in io_conf: parmread
19648 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19649 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19650 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19651 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19652 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19653 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19654 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19655 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19656 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
19657 !----------------
19658       allocate(gloc_sc(3,0:2*nres,0:10))
19659 !(3,0:maxres2,10)maxres2=2*maxres
19660       allocate(dcostau(3,3,3,2*nres))
19661       allocate(dsintau(3,3,3,2*nres))
19662       allocate(dtauangle(3,3,3,2*nres))
19663       allocate(dcosomicron(3,3,3,2*nres))
19664       allocate(domicron(3,3,3,2*nres))
19665 !(3,3,3,maxres2)maxres2=2*maxres
19666 !----------------------
19667 ! common.var
19668 !      common /restr/
19669       allocate(varall(maxvar))
19670 !(maxvar)(maxvar=6*maxres)
19671       allocate(mask_theta(nres))
19672       allocate(mask_phi(nres))
19673       allocate(mask_side(nres))
19674 !(maxres)
19675 !----------------------
19676 ! common.vectors
19677 !      common /vectors/
19678       allocate(uy(3,nres))
19679       allocate(uz(3,nres))
19680 !(3,maxres)
19681       allocate(uygrad(3,3,2,nres))
19682       allocate(uzgrad(3,3,2,nres))
19683 !(3,3,2,maxres)
19684
19685       return
19686       end subroutine alloc_ener_arrays
19687 !-----------------------------------------------------------------
19688       subroutine ebond_nucl(estr_nucl)
19689 !c
19690 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
19691 !c
19692
19693       real(kind=8),dimension(3) :: u,ud
19694       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
19695       real(kind=8) :: estr_nucl,diff
19696       integer :: iti,i,j,k,nbi
19697       estr_nucl=0.0d0
19698 !C      print *,"I enter ebond"
19699       if (energy_dec) &
19700       write (iout,*) "ibondp_start,ibondp_end",&
19701        ibondp_nucl_start,ibondp_nucl_end
19702       do i=ibondp_nucl_start,ibondp_nucl_end
19703         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
19704          itype(i,2).eq.ntyp1_molec(2)) cycle
19705 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
19706 !          do j=1,3
19707 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
19708 !     &      *dc(j,i-1)/vbld(i)
19709 !          enddo
19710 !          if (energy_dec) write(iout,*)
19711 !     &       "estr1",i,vbld(i),distchainmax,
19712 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
19713
19714           diff = vbld(i)-vbldp0_nucl
19715           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
19716           vbldp0_nucl,diff,AKP_nucl*diff*diff
19717           estr_nucl=estr_nucl+diff*diff
19718           print *,estr_nucl
19719           do j=1,3
19720             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
19721           enddo
19722 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
19723       enddo
19724       estr_nucl=0.5d0*AKP_nucl*estr_nucl
19725       print *,"partial sum", estr_nucl,AKP_nucl
19726
19727       if (energy_dec) &
19728       write (iout,*) "ibondp_start,ibondp_end",&
19729        ibond_nucl_start,ibond_nucl_end
19730
19731       do i=ibond_nucl_start,ibond_nucl_end
19732 !C        print *, "I am stuck",i
19733         iti=itype(i,2)
19734         if (iti.eq.ntyp1_molec(2)) cycle
19735           nbi=nbondterm_nucl(iti)
19736 !C        print *,iti,nbi
19737           if (nbi.eq.1) then
19738             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
19739
19740             if (energy_dec) &
19741            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
19742            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
19743             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
19744             print *,estr_nucl
19745             do j=1,3
19746               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
19747             enddo
19748           else
19749             do j=1,nbi
19750               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
19751               ud(j)=aksc_nucl(j,iti)*diff
19752               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
19753             enddo
19754             uprod=u(1)
19755             do j=2,nbi
19756               uprod=uprod*u(j)
19757             enddo
19758             usum=0.0d0
19759             usumsqder=0.0d0
19760             do j=1,nbi
19761               uprod1=1.0d0
19762               uprod2=1.0d0
19763               do k=1,nbi
19764                 if (k.ne.j) then
19765                   uprod1=uprod1*u(k)
19766                   uprod2=uprod2*u(k)*u(k)
19767                 endif
19768               enddo
19769               usum=usum+uprod1
19770               usumsqder=usumsqder+ud(j)*uprod2
19771             enddo
19772             estr_nucl=estr_nucl+uprod/usum
19773             do j=1,3
19774              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
19775             enddo
19776         endif
19777       enddo
19778 !C      print *,"I am about to leave ebond"
19779       return
19780       end subroutine ebond_nucl
19781
19782 !-----------------------------------------------------------------------------
19783       subroutine ebend_nucl(etheta_nucl)
19784       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
19785       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
19786       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
19787       logical :: lprn=.true., lprn1=.false.
19788 !el local variables
19789       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
19790       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
19791       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
19792 ! local variables for constrains
19793       real(kind=8) :: difi,thetiii
19794        integer itheta
19795       etheta_nucl=0.0D0
19796       print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
19797       do i=ithet_nucl_start,ithet_nucl_end
19798         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
19799         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
19800         (itype(i,2).eq.ntyp1_molec(2))) cycle
19801         dethetai=0.0d0
19802         dephii=0.0d0
19803         dephii1=0.0d0
19804         theti2=0.5d0*theta(i)
19805         ityp2=ithetyp_nucl(itype(i-1,2))
19806         do k=1,nntheterm_nucl
19807           coskt(k)=dcos(k*theti2)
19808           sinkt(k)=dsin(k*theti2)
19809         enddo
19810         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
19811 #ifdef OSF
19812           phii=phi(i)
19813           if (phii.ne.phii) phii=150.0
19814 #else
19815           phii=phi(i)
19816 #endif
19817           ityp1=ithetyp_nucl(itype(i-2,2))
19818           do k=1,nsingle_nucl
19819             cosph1(k)=dcos(k*phii)
19820             sinph1(k)=dsin(k*phii)
19821           enddo
19822         else
19823           phii=0.0d0
19824           ityp1=nthetyp_nucl+1
19825           do k=1,nsingle_nucl
19826             cosph1(k)=0.0d0
19827             sinph1(k)=0.0d0
19828           enddo
19829         endif
19830
19831         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
19832 #ifdef OSF
19833           phii1=phi(i+1)
19834           if (phii1.ne.phii1) phii1=150.0
19835           phii1=pinorm(phii1)
19836 #else
19837           phii1=phi(i+1)
19838 #endif
19839           ityp3=ithetyp_nucl(itype(i,2))
19840           do k=1,nsingle_nucl
19841             cosph2(k)=dcos(k*phii1)
19842             sinph2(k)=dsin(k*phii1)
19843           enddo
19844         else
19845           phii1=0.0d0
19846           ityp3=nthetyp_nucl+1
19847           do k=1,nsingle_nucl
19848             cosph2(k)=0.0d0
19849             sinph2(k)=0.0d0
19850           enddo
19851         endif
19852         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
19853         do k=1,ndouble_nucl
19854           do l=1,k-1
19855             ccl=cosph1(l)*cosph2(k-l)
19856             ssl=sinph1(l)*sinph2(k-l)
19857             scl=sinph1(l)*cosph2(k-l)
19858             csl=cosph1(l)*sinph2(k-l)
19859             cosph1ph2(l,k)=ccl-ssl
19860             cosph1ph2(k,l)=ccl+ssl
19861             sinph1ph2(l,k)=scl+csl
19862             sinph1ph2(k,l)=scl-csl
19863           enddo
19864         enddo
19865         if (lprn) then
19866         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
19867          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
19868         write (iout,*) "coskt and sinkt",nntheterm_nucl
19869         do k=1,nntheterm_nucl
19870           write (iout,*) k,coskt(k),sinkt(k)
19871         enddo
19872         endif
19873         do k=1,ntheterm_nucl
19874           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
19875           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
19876            *coskt(k)
19877           if (lprn)&
19878          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
19879           " ethetai",ethetai
19880         enddo
19881         if (lprn) then
19882         write (iout,*) "cosph and sinph"
19883         do k=1,nsingle_nucl
19884           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
19885         enddo
19886         write (iout,*) "cosph1ph2 and sinph2ph2"
19887         do k=2,ndouble_nucl
19888           do l=1,k-1
19889             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
19890               sinph1ph2(l,k),sinph1ph2(k,l)
19891           enddo
19892         enddo
19893         write(iout,*) "ethetai",ethetai
19894         endif
19895         do m=1,ntheterm2_nucl
19896           do k=1,nsingle_nucl
19897             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
19898               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
19899               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
19900               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
19901             ethetai=ethetai+sinkt(m)*aux
19902             dethetai=dethetai+0.5d0*m*aux*coskt(m)
19903             dephii=dephii+k*sinkt(m)*(&
19904                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
19905                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
19906             dephii1=dephii1+k*sinkt(m)*(&
19907                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
19908                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
19909             if (lprn) &
19910            write (iout,*) "m",m," k",k," bbthet",&
19911               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
19912               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
19913               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
19914               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
19915           enddo
19916         enddo
19917         if (lprn) &
19918         write(iout,*) "ethetai",ethetai
19919         do m=1,ntheterm3_nucl
19920           do k=2,ndouble_nucl
19921             do l=1,k-1
19922               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
19923                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
19924                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
19925                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
19926               ethetai=ethetai+sinkt(m)*aux
19927               dethetai=dethetai+0.5d0*m*coskt(m)*aux
19928               dephii=dephii+l*sinkt(m)*(&
19929                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
19930                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
19931                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
19932                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
19933               dephii1=dephii1+(k-l)*sinkt(m)*( &
19934                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
19935                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
19936                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
19937                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
19938               if (lprn) then
19939               write (iout,*) "m",m," k",k," l",l," ffthet", &
19940                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
19941                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
19942                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
19943                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
19944               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
19945                  cosph1ph2(k,l)*sinkt(m),&
19946                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
19947               endif
19948             enddo
19949           enddo
19950         enddo
19951 10      continue
19952         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
19953         i,theta(i)*rad2deg,phii*rad2deg, &
19954         phii1*rad2deg,ethetai
19955         etheta_nucl=etheta_nucl+ethetai
19956         print *,i,"partial sum",etheta_nucl
19957         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
19958         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
19959         gloc(nphi+i-2,icg)=wang_nucl*dethetai
19960       enddo
19961       return
19962       end subroutine ebend_nucl
19963
19964 !-----------------------------------------------------------------------------
19965 !-----------------------------------------------------------------------------
19966       end module energy