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 !-----------------------------------------------------------------------------
  33 ! commom.calc common/calc/
  34 !-----------------------------------------------------------------------------
  35 ! commom.contacts
  36 !      common /contacts/
  37 ! Change 12/1/95 - common block CONTACTS1 included.
  38 !      common /contacts1/
  39       integer,dimension(:),allocatable :: num_cont      !(maxres)
  40       integer,dimension(:,:),allocatable :: jcont       !(maxconts,maxres)
  41       real(kind=8),dimension(:,:),allocatable :: facont !(maxconts,maxres)
  42       real(kind=8),dimension(:,:,:),allocatable :: gacont       !(3,maxconts,maxres)
  43 !
  44 ! 12/26/95 - H-bonding contacts
  45 !      common /contacts_hb/
  46       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  47        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont  !(3,maxconts,maxres)
  48       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  49         ees0m,d_cont    !(maxconts,maxres)
  50       integer,dimension(:),allocatable :: num_cont_hb   !(maxres)
  51       integer,dimension(:,:),allocatable :: jcont_hb    !(maxconts,maxres)
  52 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  53 !         interactions
  54 ! 7/25/08 commented out; not needed when cumulants used
  55 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  56 !  common /dipint/
  57       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  58          dipderg        !(4,maxconts,maxres)
  59       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  60 ! 10/30/99 Added other pre-computed vectors and matrices needed
  61 !          to calculate three - six-order el-loc correlation terms
  62 ! common /rotat/
  63       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der  !(2,2,maxres)
  64       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  65        obrot2_der       !(2,maxres)
  66 !
  67 ! This common block contains vectors and matrices dependent on a single
  68 ! amino-acid residue.
  69 !      common /precomp1/
  70       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  71        Ctobr,Ctobrder,Dtobr2,Dtobr2der  !(2,maxres)
  72       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  73        CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres)
  74 ! This common block contains vectors and matrices dependent on two
  75 ! consecutive amino-acid residues.
  76 !      common /precomp2/
  77       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  78        CUgb2,CUgb2der   !(2,maxres)
  79       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  80        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg   !(2,2,maxres)
  81       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  82        DtUg2EUgder      !(2,2,2,maxres)
  83 !      common /rotat_old/
  84       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  85        costab2,sintab2  !(maxres)
  86 ! This common block contains dipole-interaction matrices and their
  87 ! Cartesian derivatives.
  88 !      common /dipmat/
  89       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj     !(2,2,maxconts,maxres)
  90       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der     !(2,2,3,5,maxconts,maxres)
  91 !      common /diploc/
  92       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  93        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
  94       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
  95        ADtEA1derg,AEAb2derg
  96       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
  97        AECAderx,ADtEAderx,ADtEA1derx
  98       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
  99       real(kind=8),dimension(3,2) :: g_contij
 100       real(kind=8) :: ekont
 101 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 102 !   RE: Parallelization of 4th and higher order loc-el correlations
 103 !      common /contdistrib/
 104       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 105 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 106 !-----------------------------------------------------------------------------
 107 ! commom.deriv;
 108 !      common /derivat/
 109 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 110 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 111 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 112       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 113         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 114         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 115         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6 !(3,maxres)
 116 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 117       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 118         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 119       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 120         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 121         g_corr6_loc     !(maxvar)
 122       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 123       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 124 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 125       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 126 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 127 !      integer :: nfl,icg
 128 !      common /deriv_loc/
 129       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 130 !      common /deriv_scloc/
 131       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 132        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 133        dZZ_XYZtab       !(3,maxres)
 134 !-----------------------------------------------------------------------------
 135 ! common.maxgrad
 136 !      common /maxgrad/
 137       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 138        gradb_max,ghpbc_max,&
 139        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 140        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 141        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 142        gsccorx_max,gsclocx_max
 143 !-----------------------------------------------------------------------------
 144 ! common.MD
 145 !      common /back_constr/
 146       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 147       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 148 !      common /qmeas/
 149       real(kind=8) :: Ucdfrag,Ucdpair
 150       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 151        dqwol,dxqwol     !(3,0:MAXRES)
 152 !-----------------------------------------------------------------------------
 153 ! common.sbridge
 154 !      common /dyn_ssbond/
 155       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 156 !-----------------------------------------------------------------------------
 157 ! common.sccor
 158 ! Parameters of the SCCOR term
 159 !      common/sccor/
 160       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 161        dcosomicron,domicron     !(3,3,3,maxres2)
 162 !-----------------------------------------------------------------------------
 163 ! common.vectors
 164 !      common /vectors/
 165       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 166       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 167 !-----------------------------------------------------------------------------
 168 ! common /przechowalnia/
 169       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 170       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 171 !-----------------------------------------------------------------------------
 172 !-----------------------------------------------------------------------------
 173 !
 174 !
 175 !-----------------------------------------------------------------------------
 176       contains
 177 !-----------------------------------------------------------------------------
 178 ! energy_p_new_barrier.F
 179 !-----------------------------------------------------------------------------
 180       subroutine etotal(energia)
 181 !      implicit real*8 (a-h,o-z)
 182 !      include 'DIMENSIONS'
 183       use MD_data
 184 #ifndef ISNAN
 185       external proc_proc
 186 #ifdef WINPGI
 187 !MS$ATTRIBUTES C ::  proc_proc
 188 #endif
 189 #endif
 190 #ifdef MPI
 191       include "mpif.h"
 192 #endif
 193 !      include 'COMMON.SETUP'
 194 !      include 'COMMON.IOUNITS'
 195       real(kind=8),dimension(0:n_ene) :: energia
 196 !      include 'COMMON.LOCAL'
 197 !      include 'COMMON.FFIELD'
 198 !      include 'COMMON.DERIV'
 199 !      include 'COMMON.INTERACT'
 200 !      include 'COMMON.SBRIDGE'
 201 !      include 'COMMON.CHAIN'
 202 !      include 'COMMON.VAR'
 203 !      include 'COMMON.MD'
 204 !      include 'COMMON.CONTROL'
 205 !      include 'COMMON.TIME1'
 206       real(kind=8) :: time00
 207 !el local variables
 208       integer :: n_corr,n_corr1,ierror
 209       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 210       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 211       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe
 212       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 213
 214 #ifdef MPI
 215       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 216 ! shielding effect varibles for MPI
 217 !      real(kind=8)   fac_shieldbuf(maxres),
 218 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 219 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 220 !     & grad_shieldbuf(3,-1:maxres)
 221 !       integer ishield_listbuf(maxres),
 222 !     &shield_listbuf(maxcontsshi,maxres)
 223
 224 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 225 !     & " nfgtasks",nfgtasks
 226       if (nfgtasks.gt.1) then
 227         time00=MPI_Wtime()
 228 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 229         if (fg_rank.eq.0) then
 230           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 231 !          print *,"Processor",myrank," BROADCAST iorder"
 232 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 233 ! FG slaves as WEIGHTS array.
 234           weights_(1)=wsc
 235           weights_(2)=wscp
 236           weights_(3)=welec
 237           weights_(4)=wcorr
 238           weights_(5)=wcorr5
 239           weights_(6)=wcorr6
 240           weights_(7)=wel_loc
 241           weights_(8)=wturn3
 242           weights_(9)=wturn4
 243           weights_(10)=wturn6
 244           weights_(11)=wang
 245           weights_(12)=wscloc
 246           weights_(13)=wtor
 247           weights_(14)=wtor_d
 248           weights_(15)=wstrain
 249           weights_(16)=wvdwpp
 250           weights_(17)=wbond
 251           weights_(18)=scal14
 252           weights_(21)=wsccor
 253 ! FG Master broadcasts the WEIGHTS_ array
 254           call MPI_Bcast(weights_(1),n_ene,&
 255              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 256         else
 257 ! FG slaves receive the WEIGHTS array
 258           call MPI_Bcast(weights(1),n_ene,&
 259               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 260           wsc=weights(1)
 261           wscp=weights(2)
 262           welec=weights(3)
 263           wcorr=weights(4)
 264           wcorr5=weights(5)
 265           wcorr6=weights(6)
 266           wel_loc=weights(7)
 267           wturn3=weights(8)
 268           wturn4=weights(9)
 269           wturn6=weights(10)
 270           wang=weights(11)
 271           wscloc=weights(12)
 272           wtor=weights(13)
 273           wtor_d=weights(14)
 274           wstrain=weights(15)
 275           wvdwpp=weights(16)
 276           wbond=weights(17)
 277           scal14=weights(18)
 278           wsccor=weights(21)
 279         endif
 280         time_Bcast=time_Bcast+MPI_Wtime()-time00
 281         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 282 !        call chainbuild_cart
 283       endif
 284 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 285 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 286 #else
 287 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 288 !        call int_from_cart1(.false.)
 289 !      endif
 290 #endif
 291 #ifdef TIMING
 292       time00=MPI_Wtime()
 293 #endif
 294 !
 295 ! Compute the side-chain and electrostatic interaction energy
 296 !
 297 !      goto (101,102,103,104,105,106) ipot
 298       select case(ipot)
 299 ! Lennard-Jones potential.
 300 !  101 call elj(evdw)
 301        case (1)
 302          call elj(evdw)
 303 !d    print '(a)','Exit ELJcall el'
 304 !      goto 107
 305 ! Lennard-Jones-Kihara potential (shifted).
 306 !  102 call eljk(evdw)
 307        case (2)
 308          call eljk(evdw)
 309 !      goto 107
 310 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 311 !  103 call ebp(evdw)
 312        case (3)
 313          call ebp(evdw)
 314 !      goto 107
 315 ! Gay-Berne potential (shifted LJ, angular dependence).
 316 !  104 call egb(evdw)
 317        case (4)
 318          call egb(evdw)
 319 !      goto 107
 320 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 321 !  105 call egbv(evdw)
 322        case (5)
 323          call egbv(evdw)
 324 !      goto 107
 325 ! Soft-sphere potential
 326 !  106 call e_softsphere(evdw)
 327        case (6)
 328          call e_softsphere(evdw)
 329 !
 330 ! Calculate electrostatic (H-bonding) energy of the main chain.
 331 !
 332 !  107 continue
 333        case default
 334          write(iout,*)"Wrong ipot"
 335 !         return
 336 !   50 continue
 337       end select
 338 !      continue
 339
 340 !mc
 341 !mc Sep-06: egb takes care of dynamic ss bonds too
 342 !mc
 343 !      if (dyn_ss) call dyn_set_nss
 344 !      print *,"Processor",myrank," computed USCSC"
 345 #ifdef TIMING
 346       time01=MPI_Wtime()
 347 #endif
 348       call vec_and_deriv
 349 #ifdef TIMING
 350       time_vec=time_vec+MPI_Wtime()-time01
 351 #endif
 352 !      print *,"Processor",myrank," left VEC_AND_DERIV"
 353       if (ipot.lt.6) then
 354 #ifdef SPLITELE
 355          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 356              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 357              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 358              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 359 #else
 360          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 361              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 362              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 363              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 364 #endif
 365             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 366 !        write (iout,*) "ELEC calc"
 367          else
 368             ees=0.0d0
 369             evdw1=0.0d0
 370             eel_loc=0.0d0
 371             eello_turn3=0.0d0
 372             eello_turn4=0.0d0
 373          endif
 374       else
 375 !        write (iout,*) "Soft-spheer ELEC potential"
 376         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 377          eello_turn4)
 378       endif
 379 !      print *,"Processor",myrank," computed UELEC"
 380 !
 381 ! Calculate excluded-volume interaction energy between peptide groups
 382 ! and side chains.
 383 !
 384 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 385
 386       if (ipot.lt.6) then
 387        if(wscp.gt.0d0) then
 388         call escp(evdw2,evdw2_14)
 389        else
 390         evdw2=0
 391         evdw2_14=0
 392        endif
 393       else
 394 !        write (iout,*) "Soft-sphere SCP potential"
 395         call escp_soft_sphere(evdw2,evdw2_14)
 396       endif
 397 !elwrite(iout,*) "in etotal before ebond",ipot
 398
 399 !
 400 ! Calculate the bond-stretching energy
 401 !
 402       call ebond(estr)
 403 !elwrite(iout,*) "in etotal afer ebond",ipot
 404
 405 !
 406 ! Calculate the disulfide-bridge and other energy and the contributions
 407 ! from other distance constraints.
 408 !      print *,'Calling EHPB'
 409       call edis(ehpb)
 410 !elwrite(iout,*) "in etotal afer edis",ipot
 411 !      print *,'EHPB exitted succesfully.'
 412 !
 413 ! Calculate the virtual-bond-angle energy.
 414 !
 415       if (wang.gt.0d0) then
 416         call ebend(ebe)
 417       else
 418         ebe=0
 419       endif
 420 !      print *,"Processor",myrank," computed UB"
 421 !
 422 ! Calculate the SC local energy.
 423 !
 424       call esc(escloc)
 425 !elwrite(iout,*) "in etotal afer esc",ipot
 426 !      print *,"Processor",myrank," computed USC"
 427 !
 428 ! Calculate the virtual-bond torsional energy.
 429 !
 430 !d    print *,'nterm=',nterm
 431       if (wtor.gt.0) then
 432        call etor(etors,edihcnstr)
 433       else
 434        etors=0
 435        edihcnstr=0
 436       endif
 437 !      print *,"Processor",myrank," computed Utor"
 438 !
 439 ! 6/23/01 Calculate double-torsional energy
 440 !
 441 !elwrite(iout,*) "in etotal",ipot
 442       if (wtor_d.gt.0) then
 443        call etor_d(etors_d)
 444       else
 445        etors_d=0
 446       endif
 447 !      print *,"Processor",myrank," computed Utord"
 448 !
 449 ! 21/5/07 Calculate local sicdechain correlation energy
 450 !
 451       if (wsccor.gt.0.0d0) then
 452         call eback_sc_corr(esccor)
 453       else
 454         esccor=0.0d0
 455       endif
 456 !      print *,"Processor",myrank," computed Usccorr"
 457 !
 458 ! 12/1/95 Multi-body terms
 459 !
 460       n_corr=0
 461       n_corr1=0
 462       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 463           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 464          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 465 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 466 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 467       else
 468          ecorr=0.0d0
 469          ecorr5=0.0d0
 470          ecorr6=0.0d0
 471          eturn6=0.0d0
 472       endif
 473 !elwrite(iout,*) "in etotal",ipot
 474       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 475          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 476 !d         write (iout,*) "multibody_hb ecorr",ecorr
 477       endif
 478 !elwrite(iout,*) "afeter  multibody hb"
 479
 480 !      print *,"Processor",myrank," computed Ucorr"
 481 !
 482 ! If performing constraint dynamics, call the constraint energy
 483 !  after the equilibration time
 484       if(usampl.and.totT.gt.eq_time) then
 485 !elwrite(iout,*) "afeter  multibody hb"
 486          call EconstrQ
 487 !elwrite(iout,*) "afeter  multibody hb"
 488          call Econstr_back
 489 !elwrite(iout,*) "afeter  multibody hb"
 490       else
 491          Uconst=0.0d0
 492          Uconst_back=0.0d0
 493       endif
 494 !elwrite(iout,*) "after Econstr"
 495
 496 #ifdef TIMING
 497       time_enecalc=time_enecalc+MPI_Wtime()-time00
 498 #endif
 499 !      print *,"Processor",myrank," computed Uconstr"
 500 #ifdef TIMING
 501       time00=MPI_Wtime()
 502 #endif
 503 !
 504 ! Sum the energies
 505 !
 506       energia(1)=evdw
 507 #ifdef SCP14
 508       energia(2)=evdw2-evdw2_14
 509       energia(18)=evdw2_14
 510 #else
 511       energia(2)=evdw2
 512       energia(18)=0.0d0
 513 #endif
 514 #ifdef SPLITELE
 515       energia(3)=ees
 516       energia(16)=evdw1
 517 #else
 518       energia(3)=ees+evdw1
 519       energia(16)=0.0d0
 520 #endif
 521       energia(4)=ecorr
 522       energia(5)=ecorr5
 523       energia(6)=ecorr6
 524       energia(7)=eel_loc
 525       energia(8)=eello_turn3
 526       energia(9)=eello_turn4
 527       energia(10)=eturn6
 528       energia(11)=ebe
 529       energia(12)=escloc
 530       energia(13)=etors
 531       energia(14)=etors_d
 532       energia(15)=ehpb
 533       energia(19)=edihcnstr
 534       energia(17)=estr
 535       energia(20)=Uconst+Uconst_back
 536       energia(21)=esccor
 537 !    Here are the energies showed per procesor if the are more processors
 538 !    per molecule then we sum it up in sum_energy subroutine
 539 !      print *," Processor",myrank," calls SUM_ENERGY"
 540       call sum_energy(energia,.true.)
 541       if (dyn_ss) call dyn_set_nss
 542 !      print *," Processor",myrank," left SUM_ENERGY"
 543 #ifdef TIMING
 544       time_sumene=time_sumene+MPI_Wtime()-time00
 545 #endif
 546 !el        call enerprint(energia)
 547 !elwrite(iout,*)"finish etotal"
 548       return
 549       end subroutine etotal
 550 !-----------------------------------------------------------------------------
 551       subroutine sum_energy(energia,reduce)
 552 !      implicit real*8 (a-h,o-z)
 553 !      include 'DIMENSIONS'
 554 #ifndef ISNAN
 555       external proc_proc
 556 #ifdef WINPGI
 557 !MS$ATTRIBUTES C ::  proc_proc
 558 #endif
 559 #endif
 560 #ifdef MPI
 561       include "mpif.h"
 562 #endif
 563 !      include 'COMMON.SETUP'
 564 !      include 'COMMON.IOUNITS'
 565       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 566 !      include 'COMMON.FFIELD'
 567 !      include 'COMMON.DERIV'
 568 !      include 'COMMON.INTERACT'
 569 !      include 'COMMON.SBRIDGE'
 570 !      include 'COMMON.CHAIN'
 571 !      include 'COMMON.VAR'
 572 !      include 'COMMON.CONTROL'
 573 !      include 'COMMON.TIME1'
 574       logical :: reduce
 575       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 576       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 577       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot
 578       integer :: i
 579 #ifdef MPI
 580       integer :: ierr
 581       real(kind=8) :: time00
 582       if (nfgtasks.gt.1 .and. reduce) then
 583
 584 #ifdef DEBUG
 585         write (iout,*) "energies before REDUCE"
 586         call enerprint(energia)
 587         call flush(iout)
 588 #endif
 589         do i=0,n_ene
 590           enebuff(i)=energia(i)
 591         enddo
 592         time00=MPI_Wtime()
 593         call MPI_Barrier(FG_COMM,IERR)
 594         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 595         time00=MPI_Wtime()
 596         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 597           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 598 #ifdef DEBUG
 599         write (iout,*) "energies after REDUCE"
 600         call enerprint(energia)
 601         call flush(iout)
 602 #endif
 603         time_Reduce=time_Reduce+MPI_Wtime()-time00
 604       endif
 605       if (fg_rank.eq.0) then
 606 #endif
 607       evdw=energia(1)
 608 #ifdef SCP14
 609       evdw2=energia(2)+energia(18)
 610       evdw2_14=energia(18)
 611 #else
 612       evdw2=energia(2)
 613 #endif
 614 #ifdef SPLITELE
 615       ees=energia(3)
 616       evdw1=energia(16)
 617 #else
 618       ees=energia(3)
 619       evdw1=0.0d0
 620 #endif
 621       ecorr=energia(4)
 622       ecorr5=energia(5)
 623       ecorr6=energia(6)
 624       eel_loc=energia(7)
 625       eello_turn3=energia(8)
 626       eello_turn4=energia(9)
 627       eturn6=energia(10)
 628       ebe=energia(11)
 629       escloc=energia(12)
 630       etors=energia(13)
 631       etors_d=energia(14)
 632       ehpb=energia(15)
 633       edihcnstr=energia(19)
 634       estr=energia(17)
 635       Uconst=energia(20)
 636       esccor=energia(21)
 637 #ifdef SPLITELE
 638       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 639        +wang*ebe+wtor*etors+wscloc*escloc &
 640        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 641        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 642        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 643        +wbond*estr+Uconst+wsccor*esccor
 644 #else
 645       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 646        +wang*ebe+wtor*etors+wscloc*escloc &
 647        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 648        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 649        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 650        +wbond*estr+Uconst+wsccor*esccor
 651 #endif
 652       energia(0)=etot
 653 ! detecting NaNQ
 654 #ifdef ISNAN
 655 #ifdef AIX
 656       if (isnan(etot).ne.0) energia(0)=1.0d+99
 657 #else
 658       if (isnan(etot)) energia(0)=1.0d+99
 659 #endif
 660 #else
 661       i=0
 662 #ifdef WINPGI
 663       idumm=proc_proc(etot,i)
 664 #else
 665       call proc_proc(etot,i)
 666 #endif
 667       if(i.eq.1)energia(0)=1.0d+99
 668 #endif
 669 #ifdef MPI
 670       endif
 671 #endif
 672 !      call enerprint(energia)
 673       call flush(iout)
 674       return
 675       end subroutine sum_energy
 676 !-----------------------------------------------------------------------------
 677       subroutine rescale_weights(t_bath)
 678 !      implicit real*8 (a-h,o-z)
 679 #ifdef MPI
 680       include 'mpif.h'
 681 #endif
 682 !      include 'DIMENSIONS'
 683 !      include 'COMMON.IOUNITS'
 684 !      include 'COMMON.FFIELD'
 685 !      include 'COMMON.SBRIDGE'
 686       real(kind=8) :: kfac=2.4d0
 687       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 688 !el local variables
 689       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 690       real(kind=8) :: T0=3.0d2
 691       integer :: ierror
 692 !      facT=temp0/t_bath
 693 !      facT=2*temp0/(t_bath+temp0)
 694       if (rescale_mode.eq.0) then
 695         facT(1)=1.0d0
 696         facT(2)=1.0d0
 697         facT(3)=1.0d0
 698         facT(4)=1.0d0
 699         facT(5)=1.0d0
 700         facT(6)=1.0d0
 701       else if (rescale_mode.eq.1) then
 702         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 703         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 704         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 705         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 706         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 707 #ifdef WHAM_RUN
 708 !#if defined(WHAM_RUN) || defined(CLUSTER)
 709 #if defined(FUNCTH)
 710 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 711         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 712 #elif defined(FUNCT)
 713         facT(6)=t_bath/T0
 714 #else
 715         facT(6)=1.0d0
 716 #endif
 717 #endif
 718       else if (rescale_mode.eq.2) then
 719         x=t_bath/temp0
 720         x2=x*x
 721         x3=x2*x
 722         x4=x3*x
 723         x5=x4*x
 724         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 725         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 726         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 727         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 728         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 729 #ifdef WHAM_RUN
 730 !#if defined(WHAM_RUN) || defined(CLUSTER)
 731 #if defined(FUNCTH)
 732         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 733 #elif defined(FUNCT)
 734         facT(6)=t_bath/T0
 735 #else
 736         facT(6)=1.0d0
 737 #endif
 738 #endif
 739       else
 740         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 741         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 742 #ifdef MPI
 743        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 744 #endif
 745        stop 555
 746       endif
 747       welec=weights(3)*fact(1)
 748       wcorr=weights(4)*fact(3)
 749       wcorr5=weights(5)*fact(4)
 750       wcorr6=weights(6)*fact(5)
 751       wel_loc=weights(7)*fact(2)
 752       wturn3=weights(8)*fact(2)
 753       wturn4=weights(9)*fact(3)
 754       wturn6=weights(10)*fact(5)
 755       wtor=weights(13)*fact(1)
 756       wtor_d=weights(14)*fact(2)
 757       wsccor=weights(21)*fact(1)
 758
 759       return
 760       end subroutine rescale_weights
 761 !-----------------------------------------------------------------------------
 762       subroutine enerprint(energia)
 763 !      implicit real*8 (a-h,o-z)
 764 !      include 'DIMENSIONS'
 765 !      include 'COMMON.IOUNITS'
 766 !      include 'COMMON.FFIELD'
 767 !      include 'COMMON.SBRIDGE'
 768 !      include 'COMMON.MD'
 769       real(kind=8) :: energia(0:n_ene)
 770 !el local variables
 771       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 772       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 773       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor
 774
 775       etot=energia(0)
 776       evdw=energia(1)
 777       evdw2=energia(2)
 778 #ifdef SCP14
 779       evdw2=energia(2)+energia(18)
 780 #else
 781       evdw2=energia(2)
 782 #endif
 783       ees=energia(3)
 784 #ifdef SPLITELE
 785       evdw1=energia(16)
 786 #endif
 787       ecorr=energia(4)
 788       ecorr5=energia(5)
 789       ecorr6=energia(6)
 790       eel_loc=energia(7)
 791       eello_turn3=energia(8)
 792       eello_turn4=energia(9)
 793       eello_turn6=energia(10)
 794       ebe=energia(11)
 795       escloc=energia(12)
 796       etors=energia(13)
 797       etors_d=energia(14)
 798       ehpb=energia(15)
 799       edihcnstr=energia(19)
 800       estr=energia(17)
 801       Uconst=energia(20)
 802       esccor=energia(21)
 803 #ifdef SPLITELE
 804       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 805         estr,wbond,ebe,wang,&
 806         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 807         ecorr,wcorr,&
 808         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 809         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 810         edihcnstr,ebr*nss,&
 811         Uconst,etot
 812    10 format (/'Virtual-chain energies:'// &
 813        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 814        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 815        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 816        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 817        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 818        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 819        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 820        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 821        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 822        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 823        ' (SS bridges & dist. cnstr.)'/ &
 824        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 825        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 826        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 827        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 828        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 829        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 830        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 831        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 832        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 833        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 834        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 835        'ETOT=  ',1pE16.6,' (total)')
 836 #else
 837       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 838         estr,wbond,ebe,wang,&
 839         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 840         ecorr,wcorr,&
 841         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 842         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 843         ebr*nss,Uconst,etot
 844    10 format (/'Virtual-chain energies:'// &
 845        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 846        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 847        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 848        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 849        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 850        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 851        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 852        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 853        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 854        ' (SS bridges & dist. cnstr.)'/ &
 855        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 856        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 857        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 858        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 859        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 860        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 861        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 862        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 863        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 864        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 865        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 866        'ETOT=  ',1pE16.6,' (total)')
 867 #endif
 868       return
 869       end subroutine enerprint
 870 !-----------------------------------------------------------------------------
 871       subroutine elj(evdw)
 872 !
 873 ! This subroutine calculates the interaction energy of nonbonded side chains
 874 ! assuming the LJ potential of interaction.
 875 !
 876 !      implicit real*8 (a-h,o-z)
 877 !      include 'DIMENSIONS'
 878       real(kind=8),parameter :: accur=1.0d-10
 879 !      include 'COMMON.GEO'
 880 !      include 'COMMON.VAR'
 881 !      include 'COMMON.LOCAL'
 882 !      include 'COMMON.CHAIN'
 883 !      include 'COMMON.DERIV'
 884 !      include 'COMMON.INTERACT'
 885 !      include 'COMMON.TORSION'
 886 !      include 'COMMON.SBRIDGE'
 887 !      include 'COMMON.NAMES'
 888 !      include 'COMMON.IOUNITS'
 889 !      include 'COMMON.CONTACTS'
 890       real(kind=8),dimension(3) :: gg
 891       integer :: num_conti
 892 !el local variables
 893       integer :: i,itypi,iint,j,itypi1,itypj,k
 894       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 895       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 896       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 897
 898 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 899       evdw=0.0D0
 900 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 901 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 902 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 903 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 904
 905       do i=iatsc_s,iatsc_e
 906         itypi=iabs(itype(i))
 907         if (itypi.eq.ntyp1) cycle
 908         itypi1=iabs(itype(i+1))
 909         xi=c(1,nres+i)
 910         yi=c(2,nres+i)
 911         zi=c(3,nres+i)
 912 ! Change 12/1/95
 913         num_conti=0
 914 !
 915 ! Calculate SC interaction energy.
 916 !
 917         do iint=1,nint_gr(i)
 918 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 919 !d   &                  'iend=',iend(i,iint)
 920           do j=istart(i,iint),iend(i,iint)
 921             itypj=iabs(itype(j))
 922             if (itypj.eq.ntyp1) cycle
 923             xj=c(1,nres+j)-xi
 924             yj=c(2,nres+j)-yi
 925             zj=c(3,nres+j)-zi
 926 ! Change 12/1/95 to calculate four-body interactions
 927             rij=xj*xj+yj*yj+zj*zj
 928             rrij=1.0D0/rij
 929 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 930             eps0ij=eps(itypi,itypj)
 931             fac=rrij**expon2
 932             e1=fac*fac*aa(itypi,itypj)
 933             e2=fac*bb(itypi,itypj)
 934             evdwij=e1+e2
 935 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 936 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 937 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 938 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 939 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 940 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 941             evdw=evdw+evdwij
 942 !
 943 ! Calculate the components of the gradient in DC and X
 944 !
 945             fac=-rrij*(e1+evdwij)
 946             gg(1)=xj*fac
 947             gg(2)=yj*fac
 948             gg(3)=zj*fac
 949             do k=1,3
 950               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 951               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 952               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 953               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 954             enddo
 955 !grad            do k=i,j-1
 956 !grad              do l=1,3
 957 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 958 !grad              enddo
 959 !grad            enddo
 960 !
 961 ! 12/1/95, revised on 5/20/97
 962 !
 963 ! Calculate the contact function. The ith column of the array JCONT will
 964 ! contain the numbers of atoms that make contacts with the atom I (of numbers
 965 ! greater than I). The arrays FACONT and GACONT will contain the values of
 966 ! the contact function and its derivative.
 967 !
 968 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
 969 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 970 ! Uncomment next line, if the correlation interactions are contact function only
 971             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 972               rij=dsqrt(rij)
 973               sigij=sigma(itypi,itypj)
 974               r0ij=rs0(itypi,itypj)
 975 !
 976 ! Check whether the SC's are not too far to make a contact.
 977 !
 978               rcut=1.5d0*r0ij
 979               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 980 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 981 !
 982               if (fcont.gt.0.0D0) then
 983 ! If the SC-SC distance if close to sigma, apply spline.
 984 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 985 !Adam &             fcont1,fprimcont1)
 986 !Adam           fcont1=1.0d0-fcont1
 987 !Adam           if (fcont1.gt.0.0d0) then
 988 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 989 !Adam             fcont=fcont*fcont1
 990 !Adam           endif
 991 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
 992 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
 993 !ga             do k=1,3
 994 !ga               gg(k)=gg(k)*eps0ij
 995 !ga             enddo
 996 !ga             eps0ij=-evdwij*eps0ij
 997 ! Uncomment for AL's type of SC correlation interactions.
 998 !adam           eps0ij=-evdwij
 999                 num_conti=num_conti+1
1000                 jcont(num_conti,i)=j
1001                 facont(num_conti,i)=fcont*eps0ij
1002                 fprimcont=eps0ij*fprimcont/rij
1003                 fcont=expon*fcont
1004 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1005 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1006 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1007 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1008                 gacont(1,num_conti,i)=-fprimcont*xj
1009                 gacont(2,num_conti,i)=-fprimcont*yj
1010                 gacont(3,num_conti,i)=-fprimcont*zj
1011 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1012 !d              write (iout,'(2i3,3f10.5)')
1013 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1014               endif
1015             endif
1016           enddo      ! j
1017         enddo        ! iint
1018 ! Change 12/1/95
1019         num_cont(i)=num_conti
1020       enddo          ! i
1021       do i=1,nct
1022         do j=1,3
1023           gvdwc(j,i)=expon*gvdwc(j,i)
1024           gvdwx(j,i)=expon*gvdwx(j,i)
1025         enddo
1026       enddo
1027 !******************************************************************************
1028 !
1029 !                              N O T E !!!
1030 !
1031 ! To save time, the factor of EXPON has been extracted from ALL components
1032 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1033 ! use!
1034 !
1035 !******************************************************************************
1036       return
1037       end subroutine elj
1038 !-----------------------------------------------------------------------------
1039       subroutine eljk(evdw)
1040 !
1041 ! This subroutine calculates the interaction energy of nonbonded side chains
1042 ! assuming the LJK potential of interaction.
1043 !
1044 !      implicit real*8 (a-h,o-z)
1045 !      include 'DIMENSIONS'
1046 !      include 'COMMON.GEO'
1047 !      include 'COMMON.VAR'
1048 !      include 'COMMON.LOCAL'
1049 !      include 'COMMON.CHAIN'
1050 !      include 'COMMON.DERIV'
1051 !      include 'COMMON.INTERACT'
1052 !      include 'COMMON.IOUNITS'
1053 !      include 'COMMON.NAMES'
1054       real(kind=8),dimension(3) :: gg
1055       logical :: scheck
1056 !el local variables
1057       integer :: i,iint,j,itypi,itypi1,k,itypj
1058       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1059       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1060
1061 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 !
1071 ! Calculate SC interaction energy.
1072 !
1073         do iint=1,nint_gr(i)
1074           do j=istart(i,iint),iend(i,iint)
1075             itypj=iabs(itype(j))
1076             if (itypj.eq.ntyp1) cycle
1077             xj=c(1,nres+j)-xi
1078             yj=c(2,nres+j)-yi
1079             zj=c(3,nres+j)-zi
1080             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1081             fac_augm=rrij**expon
1082             e_augm=augm(itypi,itypj)*fac_augm
1083             r_inv_ij=dsqrt(rrij)
1084             rij=1.0D0/r_inv_ij
1085             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1086             fac=r_shift_inv**expon
1087             e1=fac*fac*aa(itypi,itypj)
1088             e2=fac*bb(itypi,itypj)
1089             evdwij=e_augm+e1+e2
1090 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1091 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1092 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1093 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1094 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1095 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1096 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1097             evdw=evdw+evdwij
1098 !
1099 ! Calculate the components of the gradient in DC and X
1100 !
1101             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1102             gg(1)=xj*fac
1103             gg(2)=yj*fac
1104             gg(3)=zj*fac
1105             do k=1,3
1106               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1107               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1108               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1109               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1110             enddo
1111 !grad            do k=i,j-1
1112 !grad              do l=1,3
1113 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1114 !grad              enddo
1115 !grad            enddo
1116           enddo      ! j
1117         enddo        ! iint
1118       enddo          ! i
1119       do i=1,nct
1120         do j=1,3
1121           gvdwc(j,i)=expon*gvdwc(j,i)
1122           gvdwx(j,i)=expon*gvdwx(j,i)
1123         enddo
1124       enddo
1125       return
1126       end subroutine eljk
1127 !-----------------------------------------------------------------------------
1128       subroutine ebp(evdw)
1129 !
1130 ! This subroutine calculates the interaction energy of nonbonded side chains
1131 ! assuming the Berne-Pechukas potential of interaction.
1132 !
1133       use comm_srutu
1134       use calc_data
1135 !      implicit real*8 (a-h,o-z)
1136 !      include 'DIMENSIONS'
1137 !      include 'COMMON.GEO'
1138 !      include 'COMMON.VAR'
1139 !      include 'COMMON.LOCAL'
1140 !      include 'COMMON.CHAIN'
1141 !      include 'COMMON.DERIV'
1142 !      include 'COMMON.NAMES'
1143 !      include 'COMMON.INTERACT'
1144 !      include 'COMMON.IOUNITS'
1145 !      include 'COMMON.CALC'
1146       use comm_srutu
1147 !el      integer :: icall
1148 !el      common /srutu/ icall
1149 !     double precision rrsave(maxdim)
1150       logical :: lprn
1151 !el local variables
1152       integer :: iint,itypi,itypi1,itypj
1153       real(kind=8) :: rrij,xi,yi,zi
1154       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1155
1156 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1157       evdw=0.0D0
1158 !     if (icall.eq.0) then
1159 !       lprn=.true.
1160 !     else
1161         lprn=.false.
1162 !     endif
1163 !el      ind=0
1164       do i=iatsc_s,iatsc_e
1165         itypi=iabs(itype(i))
1166         if (itypi.eq.ntyp1) cycle
1167         itypi1=iabs(itype(i+1))
1168         xi=c(1,nres+i)
1169         yi=c(2,nres+i)
1170         zi=c(3,nres+i)
1171         dxi=dc_norm(1,nres+i)
1172         dyi=dc_norm(2,nres+i)
1173         dzi=dc_norm(3,nres+i)
1174 !        dsci_inv=dsc_inv(itypi)
1175         dsci_inv=vbld_inv(i+nres)
1176 !
1177 ! Calculate SC interaction energy.
1178 !
1179         do iint=1,nint_gr(i)
1180           do j=istart(i,iint),iend(i,iint)
1181 !el            ind=ind+1
1182             itypj=iabs(itype(j))
1183             if (itypj.eq.ntyp1) cycle
1184 !            dscj_inv=dsc_inv(itypj)
1185             dscj_inv=vbld_inv(j+nres)
1186             chi1=chi(itypi,itypj)
1187             chi2=chi(itypj,itypi)
1188             chi12=chi1*chi2
1189             chip1=chip(itypi)
1190             chip2=chip(itypj)
1191             chip12=chip1*chip2
1192             alf1=alp(itypi)
1193             alf2=alp(itypj)
1194             alf12=0.5D0*(alf1+alf2)
1195 ! For diagnostics only!!!
1196 !           chi1=0.0D0
1197 !           chi2=0.0D0
1198 !           chi12=0.0D0
1199 !           chip1=0.0D0
1200 !           chip2=0.0D0
1201 !           chip12=0.0D0
1202 !           alf1=0.0D0
1203 !           alf2=0.0D0
1204 !           alf12=0.0D0
1205             xj=c(1,nres+j)-xi
1206             yj=c(2,nres+j)-yi
1207             zj=c(3,nres+j)-zi
1208             dxj=dc_norm(1,nres+j)
1209             dyj=dc_norm(2,nres+j)
1210             dzj=dc_norm(3,nres+j)
1211             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1212 !d          if (icall.eq.0) then
1213 !d            rrsave(ind)=rrij
1214 !d          else
1215 !d            rrij=rrsave(ind)
1216 !d          endif
1217             rij=dsqrt(rrij)
1218 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1219             call sc_angular
1220 ! Calculate whole angle-dependent part of epsilon and contributions
1221 ! to its derivatives
1222             fac=(rrij*sigsq)**expon2
1223             e1=fac*fac*aa(itypi,itypj)
1224             e2=fac*bb(itypi,itypj)
1225             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1226             eps2der=evdwij*eps3rt
1227             eps3der=evdwij*eps2rt
1228             evdwij=evdwij*eps2rt*eps3rt
1229             evdw=evdw+evdwij
1230             if (lprn) then
1231             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1232             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1233 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1234 !d     &        restyp(itypi),i,restyp(itypj),j,
1235 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1236 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1237 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1238 !d     &        evdwij
1239             endif
1240 ! Calculate gradient components.
1241             e1=e1*eps1*eps2rt**2*eps3rt**2
1242             fac=-expon*(e1+evdwij)
1243             sigder=fac/sigsq
1244             fac=rrij*fac
1245 ! Calculate radial part of the gradient
1246             gg(1)=xj*fac
1247             gg(2)=yj*fac
1248             gg(3)=zj*fac
1249 ! Calculate the angular part of the gradient and sum add the contributions
1250 ! to the appropriate components of the Cartesian gradient.
1251             call sc_grad
1252           enddo      ! j
1253         enddo        ! iint
1254       enddo          ! i
1255 !     stop
1256       return
1257       end subroutine ebp
1258 !-----------------------------------------------------------------------------
1259       subroutine egb(evdw)
1260 !
1261 ! This subroutine calculates the interaction energy of nonbonded side chains
1262 ! assuming the Gay-Berne potential of interaction.
1263 !
1264       use calc_data
1265 !      implicit real*8 (a-h,o-z)
1266 !      include 'DIMENSIONS'
1267 !      include 'COMMON.GEO'
1268 !      include 'COMMON.VAR'
1269 !      include 'COMMON.LOCAL'
1270 !      include 'COMMON.CHAIN'
1271 !      include 'COMMON.DERIV'
1272 !      include 'COMMON.NAMES'
1273 !      include 'COMMON.INTERACT'
1274 !      include 'COMMON.IOUNITS'
1275 !      include 'COMMON.CALC'
1276 !      include 'COMMON.CONTROL'
1277 !      include 'COMMON.SBRIDGE'
1278       logical :: lprn
1279 !el local variables
1280       integer :: iint,itypi,itypi1,itypj,subchap
1281       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1282       real(kind=8) :: evdw,sig0ij
1283       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1284                     dist_temp, dist_init
1285       integer :: ii
1286 !cccc      energy_dec=.false.
1287 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1288       evdw=0.0D0
1289       lprn=.false.
1290 !     if (icall.eq.0) lprn=.false.
1291 !el      ind=0
1292       do i=iatsc_s,iatsc_e
1293         itypi=iabs(itype(i))
1294         if (itypi.eq.ntyp1) cycle
1295         itypi1=iabs(itype(i+1))
1296         xi=c(1,nres+i)
1297         yi=c(2,nres+i)
1298         zi=c(3,nres+i)
1299           xi=dmod(xi,boxxsize)
1300           if (xi.lt.0) xi=xi+boxxsize
1301           yi=dmod(yi,boxysize)
1302           if (yi.lt.0) yi=yi+boxysize
1303           zi=dmod(zi,boxzsize)
1304           if (zi.lt.0) zi=zi+boxzsize
1305
1306         dxi=dc_norm(1,nres+i)
1307         dyi=dc_norm(2,nres+i)
1308         dzi=dc_norm(3,nres+i)
1309 !        dsci_inv=dsc_inv(itypi)
1310         dsci_inv=vbld_inv(i+nres)
1311 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1312 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1313 !
1314 ! Calculate SC interaction energy.
1315 !
1316         do iint=1,nint_gr(i)
1317           do j=istart(i,iint),iend(i,iint)
1318             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1319               call dyn_ssbond_ene(i,j,evdwij)
1320               evdw=evdw+evdwij
1321               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1322                               'evdw',i,j,evdwij,' ss'
1323 !              if (energy_dec) write (iout,*) &
1324 !                              'evdw',i,j,evdwij,' ss'
1325             ELSE
1326 !el            ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 !            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1332 !              1.0d0/vbld(j+nres) !d
1333 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1334             sig0ij=sigma(itypi,itypj)
1335             chi1=chi(itypi,itypj)
1336             chi2=chi(itypj,itypi)
1337             chi12=chi1*chi2
1338             chip1=chip(itypi)
1339             chip2=chip(itypj)
1340             chip12=chip1*chip2
1341             alf1=alp(itypi)
1342             alf2=alp(itypj)
1343             alf12=0.5D0*(alf1+alf2)
1344 ! For diagnostics only!!!
1345 !           chi1=0.0D0
1346 !           chi2=0.0D0
1347 !           chi12=0.0D0
1348 !           chip1=0.0D0
1349 !           chip2=0.0D0
1350 !           chip12=0.0D0
1351 !           alf1=0.0D0
1352 !           alf2=0.0D0
1353 !           alf12=0.0D0
1354            xj=c(1,nres+j)
1355            yj=c(2,nres+j)
1356            zj=c(3,nres+j)
1357           xj=dmod(xj,boxxsize)
1358           if (xj.lt.0) xj=xj+boxxsize
1359           yj=dmod(yj,boxysize)
1360           if (yj.lt.0) yj=yj+boxysize
1361           zj=dmod(zj,boxzsize)
1362           if (zj.lt.0) zj=zj+boxzsize
1363       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1364       xj_safe=xj
1365       yj_safe=yj
1366       zj_safe=zj
1367       subchap=0
1368       do xshift=-1,1
1369       do yshift=-1,1
1370       do zshift=-1,1
1371           xj=xj_safe+xshift*boxxsize
1372           yj=yj_safe+yshift*boxysize
1373           zj=zj_safe+zshift*boxzsize
1374           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1375           if(dist_temp.lt.dist_init) then
1376             dist_init=dist_temp
1377             xj_temp=xj
1378             yj_temp=yj
1379             zj_temp=zj
1380             subchap=1
1381           endif
1382        enddo
1383        enddo
1384        enddo
1385        if (subchap.eq.1) then
1386           xj=xj_temp-xi
1387           yj=yj_temp-yi
1388           zj=zj_temp-zi
1389        else
1390           xj=xj_safe-xi
1391           yj=yj_safe-yi
1392           zj=zj_safe-zi
1393        endif
1394             dxj=dc_norm(1,nres+j)
1395             dyj=dc_norm(2,nres+j)
1396             dzj=dc_norm(3,nres+j)
1397 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1398 !            write (iout,*) "j",j," dc_norm",& !d
1399 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1400 !          write(iout,*)"rrij ",rrij
1401 !          write(iout,*)"xj yj zj ", xj, yj, zj
1402 !          write(iout,*)"xi yi zi ", xi, yi, zi
1403 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1404             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1405             rij=dsqrt(rrij)
1406             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1407             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1408 !            print *,sss_ele_cut,sss_ele_grad,&
1409 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1410             if (sss_ele_cut.le.0.0) cycle
1411 ! Calculate angle-dependent terms of energy and contributions to their
1412 ! derivatives.
1413             call sc_angular
1414             sigsq=1.0D0/sigsq
1415             sig=sig0ij*dsqrt(sigsq)
1416             rij_shift=1.0D0/rij-sig+sig0ij
1417 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1418 !            "sig0ij",sig0ij
1419 ! for diagnostics; uncomment
1420 !            rij_shift=1.2*sig0ij
1421 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1422             if (rij_shift.le.0.0D0) then
1423               evdw=1.0D20
1424 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1425 !d     &        restyp(itypi),i,restyp(itypj),j,
1426 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1427               return
1428             endif
1429             sigder=-sig*sigsq
1430 !---------------------------------------------------------------
1431             rij_shift=1.0D0/rij_shift
1432             fac=rij_shift**expon
1433             e1=fac*fac*aa(itypi,itypj)
1434             e2=fac*bb(itypi,itypj)
1435             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1436             eps2der=evdwij*eps3rt
1437             eps3der=evdwij*eps2rt
1438 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1439 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1440 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1441             evdwij=evdwij*eps2rt*eps3rt
1442             evdw=evdw+evdwij*sss_ele_cut
1443             if (lprn) then
1444             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1445             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1446             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1447               restyp(itypi),i,restyp(itypj),j, &
1448               epsi,sigm,chi1,chi2,chip1,chip2, &
1449               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1450               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1451               evdwij
1452             endif
1453
1454             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
1455                              'evdw',i,j,evdwij !,"egb"
1456 !            if (energy_dec) write (iout,*) &
1457 !                             'evdw',i,j,evdwij
1458
1459 ! Calculate gradient components.
1460             e1=e1*eps1*eps2rt**2*eps3rt**2
1461             fac=-expon*(e1+evdwij)*rij_shift
1462             sigder=fac*sigder
1463             fac=rij*fac
1464 !            print *,'before fac',fac,rij,evdwij
1465             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1466             /sigma(itypi,itypj)*rij
1467 !            print *,'grad part scale',fac,   &
1468 !             evdwij*sss_ele_grad/sss_ele_cut &
1469 !            /sigma(itypi,itypj)*rij
1470 !            fac=0.0d0
1471 ! Calculate the radial part of the gradient
1472             gg(1)=xj*fac
1473             gg(2)=yj*fac
1474             gg(3)=zj*fac
1475 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1476 ! Calculate angular part of the gradient.
1477             call sc_grad
1478             ENDIF    ! dyn_ss
1479           enddo      ! j
1480         enddo        ! iint
1481       enddo          ! i
1482 !      write (iout,*) "Number of loop steps in EGB:",ind
1483 !ccc      energy_dec=.false.
1484       return
1485       end subroutine egb
1486 !-----------------------------------------------------------------------------
1487       subroutine egbv(evdw)
1488 !
1489 ! This subroutine calculates the interaction energy of nonbonded side chains
1490 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1491 !
1492       use comm_srutu
1493       use calc_data
1494 !      implicit real*8 (a-h,o-z)
1495 !      include 'DIMENSIONS'
1496 !      include 'COMMON.GEO'
1497 !      include 'COMMON.VAR'
1498 !      include 'COMMON.LOCAL'
1499 !      include 'COMMON.CHAIN'
1500 !      include 'COMMON.DERIV'
1501 !      include 'COMMON.NAMES'
1502 !      include 'COMMON.INTERACT'
1503 !      include 'COMMON.IOUNITS'
1504 !      include 'COMMON.CALC'
1505       use comm_srutu
1506 !el      integer :: icall
1507 !el      common /srutu/ icall
1508       logical :: lprn
1509 !el local variables
1510       integer :: iint,itypi,itypi1,itypj
1511       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1512       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1513
1514 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1515       evdw=0.0D0
1516       lprn=.false.
1517 !     if (icall.eq.0) lprn=.true.
1518 !el      ind=0
1519       do i=iatsc_s,iatsc_e
1520         itypi=iabs(itype(i))
1521         if (itypi.eq.ntyp1) cycle
1522         itypi1=iabs(itype(i+1))
1523         xi=c(1,nres+i)
1524         yi=c(2,nres+i)
1525         zi=c(3,nres+i)
1526         dxi=dc_norm(1,nres+i)
1527         dyi=dc_norm(2,nres+i)
1528         dzi=dc_norm(3,nres+i)
1529 !        dsci_inv=dsc_inv(itypi)
1530         dsci_inv=vbld_inv(i+nres)
1531 !
1532 ! Calculate SC interaction energy.
1533 !
1534         do iint=1,nint_gr(i)
1535           do j=istart(i,iint),iend(i,iint)
1536 !el            ind=ind+1
1537             itypj=iabs(itype(j))
1538             if (itypj.eq.ntyp1) cycle
1539 !            dscj_inv=dsc_inv(itypj)
1540             dscj_inv=vbld_inv(j+nres)
1541             sig0ij=sigma(itypi,itypj)
1542             r0ij=r0(itypi,itypj)
1543             chi1=chi(itypi,itypj)
1544             chi2=chi(itypj,itypi)
1545             chi12=chi1*chi2
1546             chip1=chip(itypi)
1547             chip2=chip(itypj)
1548             chip12=chip1*chip2
1549             alf1=alp(itypi)
1550             alf2=alp(itypj)
1551             alf12=0.5D0*(alf1+alf2)
1552 ! For diagnostics only!!!
1553 !           chi1=0.0D0
1554 !           chi2=0.0D0
1555 !           chi12=0.0D0
1556 !           chip1=0.0D0
1557 !           chip2=0.0D0
1558 !           chip12=0.0D0
1559 !           alf1=0.0D0
1560 !           alf2=0.0D0
1561 !           alf12=0.0D0
1562             xj=c(1,nres+j)-xi
1563             yj=c(2,nres+j)-yi
1564             zj=c(3,nres+j)-zi
1565             dxj=dc_norm(1,nres+j)
1566             dyj=dc_norm(2,nres+j)
1567             dzj=dc_norm(3,nres+j)
1568             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1569             rij=dsqrt(rrij)
1570 ! Calculate angle-dependent terms of energy and contributions to their
1571 ! derivatives.
1572             call sc_angular
1573             sigsq=1.0D0/sigsq
1574             sig=sig0ij*dsqrt(sigsq)
1575             rij_shift=1.0D0/rij-sig+r0ij
1576 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1577             if (rij_shift.le.0.0D0) then
1578               evdw=1.0D20
1579               return
1580             endif
1581             sigder=-sig*sigsq
1582 !---------------------------------------------------------------
1583             rij_shift=1.0D0/rij_shift
1584             fac=rij_shift**expon
1585             e1=fac*fac*aa(itypi,itypj)
1586             e2=fac*bb(itypi,itypj)
1587             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1588             eps2der=evdwij*eps3rt
1589             eps3der=evdwij*eps2rt
1590             fac_augm=rrij**expon
1591             e_augm=augm(itypi,itypj)*fac_augm
1592             evdwij=evdwij*eps2rt*eps3rt
1593             evdw=evdw+evdwij+e_augm
1594             if (lprn) then
1595             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1596             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1597             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1598               restyp(itypi),i,restyp(itypj),j,&
1599               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1600               chi1,chi2,chip1,chip2,&
1601               eps1,eps2rt**2,eps3rt**2,&
1602               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1603               evdwij+e_augm
1604             endif
1605 ! Calculate gradient components.
1606             e1=e1*eps1*eps2rt**2*eps3rt**2
1607             fac=-expon*(e1+evdwij)*rij_shift
1608             sigder=fac*sigder
1609             fac=rij*fac-2*expon*rrij*e_augm
1610 ! Calculate the radial part of the gradient
1611             gg(1)=xj*fac
1612             gg(2)=yj*fac
1613             gg(3)=zj*fac
1614 ! Calculate angular part of the gradient.
1615             call sc_grad
1616           enddo      ! j
1617         enddo        ! iint
1618       enddo          ! i
1619       end subroutine egbv
1620 !-----------------------------------------------------------------------------
1621 !el      subroutine sc_angular in module geometry
1622 !-----------------------------------------------------------------------------
1623       subroutine e_softsphere(evdw)
1624 !
1625 ! This subroutine calculates the interaction energy of nonbonded side chains
1626 ! assuming the LJ potential of interaction.
1627 !
1628 !      implicit real*8 (a-h,o-z)
1629 !      include 'DIMENSIONS'
1630       real(kind=8),parameter :: accur=1.0d-10
1631 !      include 'COMMON.GEO'
1632 !      include 'COMMON.VAR'
1633 !      include 'COMMON.LOCAL'
1634 !      include 'COMMON.CHAIN'
1635 !      include 'COMMON.DERIV'
1636 !      include 'COMMON.INTERACT'
1637 !      include 'COMMON.TORSION'
1638 !      include 'COMMON.SBRIDGE'
1639 !      include 'COMMON.NAMES'
1640 !      include 'COMMON.IOUNITS'
1641 !      include 'COMMON.CONTACTS'
1642       real(kind=8),dimension(3) :: gg
1643 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1644 !el local variables
1645       integer :: i,iint,j,itypi,itypi1,itypj,k
1646       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1647       real(kind=8) :: fac
1648
1649       evdw=0.0D0
1650       do i=iatsc_s,iatsc_e
1651         itypi=iabs(itype(i))
1652         if (itypi.eq.ntyp1) cycle
1653         itypi1=iabs(itype(i+1))
1654         xi=c(1,nres+i)
1655         yi=c(2,nres+i)
1656         zi=c(3,nres+i)
1657 !
1658 ! Calculate SC interaction energy.
1659 !
1660         do iint=1,nint_gr(i)
1661 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1662 !d   &                  'iend=',iend(i,iint)
1663           do j=istart(i,iint),iend(i,iint)
1664             itypj=iabs(itype(j))
1665             if (itypj.eq.ntyp1) cycle
1666             xj=c(1,nres+j)-xi
1667             yj=c(2,nres+j)-yi
1668             zj=c(3,nres+j)-zi
1669             rij=xj*xj+yj*yj+zj*zj
1670 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1671             r0ij=r0(itypi,itypj)
1672             r0ijsq=r0ij*r0ij
1673 !            print *,i,j,r0ij,dsqrt(rij)
1674             if (rij.lt.r0ijsq) then
1675               evdwij=0.25d0*(rij-r0ijsq)**2
1676               fac=rij-r0ijsq
1677             else
1678               evdwij=0.0d0
1679               fac=0.0d0
1680             endif
1681             evdw=evdw+evdwij
1682 !
1683 ! Calculate the components of the gradient in DC and X
1684 !
1685             gg(1)=xj*fac
1686             gg(2)=yj*fac
1687             gg(3)=zj*fac
1688             do k=1,3
1689               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1690               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1691               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1692               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1693             enddo
1694 !grad            do k=i,j-1
1695 !grad              do l=1,3
1696 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1697 !grad              enddo
1698 !grad            enddo
1699           enddo ! j
1700         enddo ! iint
1701       enddo ! i
1702       return
1703       end subroutine e_softsphere
1704 !-----------------------------------------------------------------------------
1705       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1706 !
1707 ! Soft-sphere potential of p-p interaction
1708 !
1709 !      implicit real*8 (a-h,o-z)
1710 !      include 'DIMENSIONS'
1711 !      include 'COMMON.CONTROL'
1712 !      include 'COMMON.IOUNITS'
1713 !      include 'COMMON.GEO'
1714 !      include 'COMMON.VAR'
1715 !      include 'COMMON.LOCAL'
1716 !      include 'COMMON.CHAIN'
1717 !      include 'COMMON.DERIV'
1718 !      include 'COMMON.INTERACT'
1719 !      include 'COMMON.CONTACTS'
1720 !      include 'COMMON.TORSION'
1721 !      include 'COMMON.VECTORS'
1722 !      include 'COMMON.FFIELD'
1723       real(kind=8),dimension(3) :: ggg
1724 !d      write(iout,*) 'In EELEC_soft_sphere'
1725 !el local variables
1726       integer :: i,j,k,num_conti,iteli,itelj
1727       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1728       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1729       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1730
1731       ees=0.0D0
1732       evdw1=0.0D0
1733       eel_loc=0.0d0
1734       eello_turn3=0.0d0
1735       eello_turn4=0.0d0
1736 !el      ind=0
1737       do i=iatel_s,iatel_e
1738         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1739         dxi=dc(1,i)
1740         dyi=dc(2,i)
1741         dzi=dc(3,i)
1742         xmedi=c(1,i)+0.5d0*dxi
1743         ymedi=c(2,i)+0.5d0*dyi
1744         zmedi=c(3,i)+0.5d0*dzi
1745         num_conti=0
1746 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1747         do j=ielstart(i),ielend(i)
1748           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1749 !el          ind=ind+1
1750           iteli=itel(i)
1751           itelj=itel(j)
1752           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1753           r0ij=rpp(iteli,itelj)
1754           r0ijsq=r0ij*r0ij
1755           dxj=dc(1,j)
1756           dyj=dc(2,j)
1757           dzj=dc(3,j)
1758           xj=c(1,j)+0.5D0*dxj-xmedi
1759           yj=c(2,j)+0.5D0*dyj-ymedi
1760           zj=c(3,j)+0.5D0*dzj-zmedi
1761           rij=xj*xj+yj*yj+zj*zj
1762           if (rij.lt.r0ijsq) then
1763             evdw1ij=0.25d0*(rij-r0ijsq)**2
1764             fac=rij-r0ijsq
1765           else
1766             evdw1ij=0.0d0
1767             fac=0.0d0
1768           endif
1769           evdw1=evdw1+evdw1ij
1770 !
1771 ! Calculate contributions to the Cartesian gradient.
1772 !
1773           ggg(1)=fac*xj
1774           ggg(2)=fac*yj
1775           ggg(3)=fac*zj
1776           do k=1,3
1777             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1778             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1779           enddo
1780 !
1781 ! Loop over residues i+1 thru j-1.
1782 !
1783 !grad          do k=i+1,j-1
1784 !grad            do l=1,3
1785 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1786 !grad            enddo
1787 !grad          enddo
1788         enddo ! j
1789       enddo   ! i
1790 !grad      do i=nnt,nct-1
1791 !grad        do k=1,3
1792 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1793 !grad        enddo
1794 !grad        do j=i+1,nct-1
1795 !grad          do k=1,3
1796 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1797 !grad          enddo
1798 !grad        enddo
1799 !grad      enddo
1800       return
1801       end subroutine eelec_soft_sphere
1802 !-----------------------------------------------------------------------------
1803       subroutine vec_and_deriv
1804 !      implicit real*8 (a-h,o-z)
1805 !      include 'DIMENSIONS'
1806 #ifdef MPI
1807       include 'mpif.h'
1808 #endif
1809 !      include 'COMMON.IOUNITS'
1810 !      include 'COMMON.GEO'
1811 !      include 'COMMON.VAR'
1812 !      include 'COMMON.LOCAL'
1813 !      include 'COMMON.CHAIN'
1814 !      include 'COMMON.VECTORS'
1815 !      include 'COMMON.SETUP'
1816 !      include 'COMMON.TIME1'
1817       real(kind=8),dimension(3,3,2) :: uyder,uzder
1818       real(kind=8),dimension(2) :: vbld_inv_temp
1819 ! Compute the local reference systems. For reference system (i), the
1820 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1821 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1822 !el local variables
1823       integer :: i,j,k,l
1824       real(kind=8) :: facy,fac,costh
1825
1826 #ifdef PARVEC
1827       do i=ivec_start,ivec_end
1828 #else
1829       do i=1,nres-1
1830 #endif
1831           if (i.eq.nres-1) then
1832 ! Case of the last full residue
1833 ! Compute the Z-axis
1834             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1835             costh=dcos(pi-theta(nres))
1836             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1837             do k=1,3
1838               uz(k,i)=fac*uz(k,i)
1839             enddo
1840 ! Compute the derivatives of uz
1841             uzder(1,1,1)= 0.0d0
1842             uzder(2,1,1)=-dc_norm(3,i-1)
1843             uzder(3,1,1)= dc_norm(2,i-1)
1844             uzder(1,2,1)= dc_norm(3,i-1)
1845             uzder(2,2,1)= 0.0d0
1846             uzder(3,2,1)=-dc_norm(1,i-1)
1847             uzder(1,3,1)=-dc_norm(2,i-1)
1848             uzder(2,3,1)= dc_norm(1,i-1)
1849             uzder(3,3,1)= 0.0d0
1850             uzder(1,1,2)= 0.0d0
1851             uzder(2,1,2)= dc_norm(3,i)
1852             uzder(3,1,2)=-dc_norm(2,i)
1853             uzder(1,2,2)=-dc_norm(3,i)
1854             uzder(2,2,2)= 0.0d0
1855             uzder(3,2,2)= dc_norm(1,i)
1856             uzder(1,3,2)= dc_norm(2,i)
1857             uzder(2,3,2)=-dc_norm(1,i)
1858             uzder(3,3,2)= 0.0d0
1859 ! Compute the Y-axis
1860             facy=fac
1861             do k=1,3
1862               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1863             enddo
1864 ! Compute the derivatives of uy
1865             do j=1,3
1866               do k=1,3
1867                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
1868                               -dc_norm(k,i)*dc_norm(j,i-1)
1869                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1870               enddo
1871               uyder(j,j,1)=uyder(j,j,1)-costh
1872               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1873             enddo
1874             do j=1,2
1875               do k=1,3
1876                 do l=1,3
1877                   uygrad(l,k,j,i)=uyder(l,k,j)
1878                   uzgrad(l,k,j,i)=uzder(l,k,j)
1879                 enddo
1880               enddo
1881             enddo
1882             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1883             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1884             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1885             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1886           else
1887 ! Other residues
1888 ! Compute the Z-axis
1889             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1890             costh=dcos(pi-theta(i+2))
1891             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1892             do k=1,3
1893               uz(k,i)=fac*uz(k,i)
1894             enddo
1895 ! Compute the derivatives of uz
1896             uzder(1,1,1)= 0.0d0
1897             uzder(2,1,1)=-dc_norm(3,i+1)
1898             uzder(3,1,1)= dc_norm(2,i+1)
1899             uzder(1,2,1)= dc_norm(3,i+1)
1900             uzder(2,2,1)= 0.0d0
1901             uzder(3,2,1)=-dc_norm(1,i+1)
1902             uzder(1,3,1)=-dc_norm(2,i+1)
1903             uzder(2,3,1)= dc_norm(1,i+1)
1904             uzder(3,3,1)= 0.0d0
1905             uzder(1,1,2)= 0.0d0
1906             uzder(2,1,2)= dc_norm(3,i)
1907             uzder(3,1,2)=-dc_norm(2,i)
1908             uzder(1,2,2)=-dc_norm(3,i)
1909             uzder(2,2,2)= 0.0d0
1910             uzder(3,2,2)= dc_norm(1,i)
1911             uzder(1,3,2)= dc_norm(2,i)
1912             uzder(2,3,2)=-dc_norm(1,i)
1913             uzder(3,3,2)= 0.0d0
1914 ! Compute the Y-axis
1915             facy=fac
1916             do k=1,3
1917               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1918             enddo
1919 ! Compute the derivatives of uy
1920             do j=1,3
1921               do k=1,3
1922                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
1923                               -dc_norm(k,i)*dc_norm(j,i+1)
1924                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1925               enddo
1926               uyder(j,j,1)=uyder(j,j,1)-costh
1927               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1928             enddo
1929             do j=1,2
1930               do k=1,3
1931                 do l=1,3
1932                   uygrad(l,k,j,i)=uyder(l,k,j)
1933                   uzgrad(l,k,j,i)=uzder(l,k,j)
1934                 enddo
1935               enddo
1936             enddo
1937             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1938             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1939             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1940             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1941           endif
1942       enddo
1943       do i=1,nres-1
1944         vbld_inv_temp(1)=vbld_inv(i+1)
1945         if (i.lt.nres-1) then
1946           vbld_inv_temp(2)=vbld_inv(i+2)
1947           else
1948           vbld_inv_temp(2)=vbld_inv(i)
1949           endif
1950         do j=1,2
1951           do k=1,3
1952             do l=1,3
1953               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1954               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1955             enddo
1956           enddo
1957         enddo
1958       enddo
1959 #if defined(PARVEC) && defined(MPI)
1960       if (nfgtasks1.gt.1) then
1961         time00=MPI_Wtime()
1962 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
1963 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
1964 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
1965         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
1966          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1967          FG_COMM1,IERR)
1968         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
1969          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1970          FG_COMM1,IERR)
1971         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
1972          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
1973          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1974         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
1975          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
1976          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1977         time_gather=time_gather+MPI_Wtime()-time00
1978       endif
1979 !      if (fg_rank.eq.0) then
1980 !        write (iout,*) "Arrays UY and UZ"
1981 !        do i=1,nres-1
1982 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1983 !     &     (uz(k,i),k=1,3)
1984 !        enddo
1985 !      endif
1986 #endif
1987       return
1988       end subroutine vec_and_deriv
1989 !-----------------------------------------------------------------------------
1990       subroutine check_vecgrad
1991 !      implicit real*8 (a-h,o-z)
1992 !      include 'DIMENSIONS'
1993 !      include 'COMMON.IOUNITS'
1994 !      include 'COMMON.GEO'
1995 !      include 'COMMON.VAR'
1996 !      include 'COMMON.LOCAL'
1997 !      include 'COMMON.CHAIN'
1998 !      include 'COMMON.VECTORS'
1999       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2000       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2001       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2002       real(kind=8),dimension(3) :: erij
2003       real(kind=8) :: delta=1.0d-7
2004 !el local variables
2005       integer :: i,j,k,l
2006
2007       call vec_and_deriv
2008 !d      do i=1,nres
2009 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2010 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2011 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2012 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2013 !d     &     (dc_norm(if90,i),if90=1,3)
2014 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2015 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2016 !d          write(iout,'(a)')
2017 !d      enddo
2018       do i=1,nres
2019         do j=1,2
2020           do k=1,3
2021             do l=1,3
2022               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2023               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2024             enddo
2025           enddo
2026         enddo
2027       enddo
2028       call vec_and_deriv
2029       do i=1,nres
2030         do j=1,3
2031           uyt(j,i)=uy(j,i)
2032           uzt(j,i)=uz(j,i)
2033         enddo
2034       enddo
2035       do i=1,nres
2036 !d        write (iout,*) 'i=',i
2037         do k=1,3
2038           erij(k)=dc_norm(k,i)
2039         enddo
2040         do j=1,3
2041           do k=1,3
2042             dc_norm(k,i)=erij(k)
2043           enddo
2044           dc_norm(j,i)=dc_norm(j,i)+delta
2045 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2046 !          do k=1,3
2047 !            dc_norm(k,i)=dc_norm(k,i)/fac
2048 !          enddo
2049 !          write (iout,*) (dc_norm(k,i),k=1,3)
2050 !          write (iout,*) (erij(k),k=1,3)
2051           call vec_and_deriv
2052           do k=1,3
2053             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2054             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2055             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2056             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2057           enddo
2058 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2059 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2060 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2061         enddo
2062         do k=1,3
2063           dc_norm(k,i)=erij(k)
2064         enddo
2065 !d        do k=1,3
2066 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2067 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2068 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2069 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2070 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2071 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2072 !d          write (iout,'(a)')
2073 !d        enddo
2074       enddo
2075       return
2076       end subroutine check_vecgrad
2077 !-----------------------------------------------------------------------------
2078       subroutine set_matrices
2079 !      implicit real*8 (a-h,o-z)
2080 !      include 'DIMENSIONS'
2081 #ifdef MPI
2082       include "mpif.h"
2083 !      include "COMMON.SETUP"
2084       integer :: IERR
2085       integer :: status(MPI_STATUS_SIZE)
2086 #endif
2087 !      include 'COMMON.IOUNITS'
2088 !      include 'COMMON.GEO'
2089 !      include 'COMMON.VAR'
2090 !      include 'COMMON.LOCAL'
2091 !      include 'COMMON.CHAIN'
2092 !      include 'COMMON.DERIV'
2093 !      include 'COMMON.INTERACT'
2094 !      include 'COMMON.CONTACTS'
2095 !      include 'COMMON.TORSION'
2096 !      include 'COMMON.VECTORS'
2097 !      include 'COMMON.FFIELD'
2098       real(kind=8) :: auxvec(2),auxmat(2,2)
2099       integer :: i,iti1,iti,k,l
2100       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2101
2102 !
2103 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2104 ! to calculate the el-loc multibody terms of various order.
2105 !
2106 !AL el      mu=0.0d0
2107 #ifdef PARMAT
2108       do i=ivec_start+2,ivec_end+2
2109 #else
2110       do i=3,nres+1
2111 #endif
2112         if (i .lt. nres+1) then
2113           sin1=dsin(phi(i))
2114           cos1=dcos(phi(i))
2115           sintab(i-2)=sin1
2116           costab(i-2)=cos1
2117           obrot(1,i-2)=cos1
2118           obrot(2,i-2)=sin1
2119           sin2=dsin(2*phi(i))
2120           cos2=dcos(2*phi(i))
2121           sintab2(i-2)=sin2
2122           costab2(i-2)=cos2
2123           obrot2(1,i-2)=cos2
2124           obrot2(2,i-2)=sin2
2125           Ug(1,1,i-2)=-cos1
2126           Ug(1,2,i-2)=-sin1
2127           Ug(2,1,i-2)=-sin1
2128           Ug(2,2,i-2)= cos1
2129           Ug2(1,1,i-2)=-cos2
2130           Ug2(1,2,i-2)=-sin2
2131           Ug2(2,1,i-2)=-sin2
2132           Ug2(2,2,i-2)= cos2
2133         else
2134           costab(i-2)=1.0d0
2135           sintab(i-2)=0.0d0
2136           obrot(1,i-2)=1.0d0
2137           obrot(2,i-2)=0.0d0
2138           obrot2(1,i-2)=0.0d0
2139           obrot2(2,i-2)=0.0d0
2140           Ug(1,1,i-2)=1.0d0
2141           Ug(1,2,i-2)=0.0d0
2142           Ug(2,1,i-2)=0.0d0
2143           Ug(2,2,i-2)=1.0d0
2144           Ug2(1,1,i-2)=0.0d0
2145           Ug2(1,2,i-2)=0.0d0
2146           Ug2(2,1,i-2)=0.0d0
2147           Ug2(2,2,i-2)=0.0d0
2148         endif
2149         if (i .gt. 3 .and. i .lt. nres+1) then
2150           obrot_der(1,i-2)=-sin1
2151           obrot_der(2,i-2)= cos1
2152           Ugder(1,1,i-2)= sin1
2153           Ugder(1,2,i-2)=-cos1
2154           Ugder(2,1,i-2)=-cos1
2155           Ugder(2,2,i-2)=-sin1
2156           dwacos2=cos2+cos2
2157           dwasin2=sin2+sin2
2158           obrot2_der(1,i-2)=-dwasin2
2159           obrot2_der(2,i-2)= dwacos2
2160           Ug2der(1,1,i-2)= dwasin2
2161           Ug2der(1,2,i-2)=-dwacos2
2162           Ug2der(2,1,i-2)=-dwacos2
2163           Ug2der(2,2,i-2)=-dwasin2
2164         else
2165           obrot_der(1,i-2)=0.0d0
2166           obrot_der(2,i-2)=0.0d0
2167           Ugder(1,1,i-2)=0.0d0
2168           Ugder(1,2,i-2)=0.0d0
2169           Ugder(2,1,i-2)=0.0d0
2170           Ugder(2,2,i-2)=0.0d0
2171           obrot2_der(1,i-2)=0.0d0
2172           obrot2_der(2,i-2)=0.0d0
2173           Ug2der(1,1,i-2)=0.0d0
2174           Ug2der(1,2,i-2)=0.0d0
2175           Ug2der(2,1,i-2)=0.0d0
2176           Ug2der(2,2,i-2)=0.0d0
2177         endif
2178 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2179         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2180           iti = itortyp(itype(i-2))
2181         else
2182           iti=ntortyp+1
2183         endif
2184 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2185         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2186           iti1 = itortyp(itype(i-1))
2187         else
2188           iti1=ntortyp+1
2189         endif
2190 !d        write (iout,*) '*******i',i,' iti1',iti
2191 !d        write (iout,*) 'b1',b1(:,iti)
2192 !d        write (iout,*) 'b2',b2(:,iti)
2193 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2194 !        if (i .gt. iatel_s+2) then
2195         if (i .gt. nnt+2) then
2196           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2197           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2198           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2199           then
2200           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2201           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2202           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2203           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2204           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2205           endif
2206         else
2207           do k=1,2
2208             Ub2(k,i-2)=0.0d0
2209             Ctobr(k,i-2)=0.0d0
2210             Dtobr2(k,i-2)=0.0d0
2211             do l=1,2
2212               EUg(l,k,i-2)=0.0d0
2213               CUg(l,k,i-2)=0.0d0
2214               DUg(l,k,i-2)=0.0d0
2215               DtUg2(l,k,i-2)=0.0d0
2216             enddo
2217           enddo
2218         endif
2219         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2220         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2221         do k=1,2
2222           muder(k,i-2)=Ub2der(k,i-2)
2223         enddo
2224 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2225         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2226           if (itype(i-1).le.ntyp) then
2227             iti1 = itortyp(itype(i-1))
2228           else
2229             iti1=ntortyp+1
2230           endif
2231         else
2232           iti1=ntortyp+1
2233         endif
2234         do k=1,2
2235           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2236         enddo
2237 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2238 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2239 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2240 !d        write (iout,*) 'mu1',mu1(:,i-2)
2241 !d        write (iout,*) 'mu2',mu2(:,i-2)
2242         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2243         then
2244         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2245         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2246         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2247         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2248         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2249 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2250         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2251         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2252         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2253         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2254         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2255         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2256         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2257         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2258         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2259         endif
2260       enddo
2261 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2262 ! The order of matrices is from left to right.
2263       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2264       then
2265 !      do i=max0(ivec_start,2),ivec_end
2266       do i=2,nres-1
2267         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2268         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2269         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2270         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2271         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2272         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2273         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2274         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2275       enddo
2276       endif
2277 #if defined(MPI) && defined(PARMAT)
2278 #ifdef DEBUG
2279 !      if (fg_rank.eq.0) then
2280         write (iout,*) "Arrays UG and UGDER before GATHER"
2281         do i=1,nres-1
2282           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2283            ((ug(l,k,i),l=1,2),k=1,2),&
2284            ((ugder(l,k,i),l=1,2),k=1,2)
2285         enddo
2286         write (iout,*) "Arrays UG2 and UG2DER"
2287         do i=1,nres-1
2288           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2289            ((ug2(l,k,i),l=1,2),k=1,2),&
2290            ((ug2der(l,k,i),l=1,2),k=1,2)
2291         enddo
2292         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2293         do i=1,nres-1
2294           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2295            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2296            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2297         enddo
2298         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2299         do i=1,nres-1
2300           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2301            costab(i),sintab(i),costab2(i),sintab2(i)
2302         enddo
2303         write (iout,*) "Array MUDER"
2304         do i=1,nres-1
2305           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2306         enddo
2307 !      endif
2308 #endif
2309       if (nfgtasks.gt.1) then
2310         time00=MPI_Wtime()
2311 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2312 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2313 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2314 #ifdef MATGATHER
2315         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2316          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2317          FG_COMM1,IERR)
2318         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2319          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2320          FG_COMM1,IERR)
2321         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2322          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2323          FG_COMM1,IERR)
2324         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2325          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2326          FG_COMM1,IERR)
2327         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2328          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2329          FG_COMM1,IERR)
2330         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2331          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2332          FG_COMM1,IERR)
2333         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2334          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2335          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2336         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2337          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2338          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2339         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2340          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2341          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2342         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2343          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2344          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2345         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2346         then
2347         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2348          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2349          FG_COMM1,IERR)
2350         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2351          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2352          FG_COMM1,IERR)
2353         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2354          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2355          FG_COMM1,IERR)
2356        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2357          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2358          FG_COMM1,IERR)
2359         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2360          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2361          FG_COMM1,IERR)
2362         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2363          ivec_count(fg_rank1),&
2364          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2365          FG_COMM1,IERR)
2366         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2367          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2368          FG_COMM1,IERR)
2369         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2370          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2371          FG_COMM1,IERR)
2372         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2373          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2374          FG_COMM1,IERR)
2375         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2376          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2377          FG_COMM1,IERR)
2378         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2379          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2380          FG_COMM1,IERR)
2381         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2382          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2383          FG_COMM1,IERR)
2384         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2385          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2386          FG_COMM1,IERR)
2387         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2388          ivec_count(fg_rank1),&
2389          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2390          FG_COMM1,IERR)
2391         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2392          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2393          FG_COMM1,IERR)
2394        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2395          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2396          FG_COMM1,IERR)
2397         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2398          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2399          FG_COMM1,IERR)
2400        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2401          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2402          FG_COMM1,IERR)
2403         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2404          ivec_count(fg_rank1),&
2405          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2406          FG_COMM1,IERR)
2407         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2408          ivec_count(fg_rank1),&
2409          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2410          FG_COMM1,IERR)
2411         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2412          ivec_count(fg_rank1),&
2413          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2414          MPI_MAT2,FG_COMM1,IERR)
2415         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2416          ivec_count(fg_rank1),&
2417          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2418          MPI_MAT2,FG_COMM1,IERR)
2419         endif
2420 #else
2421 ! Passes matrix info through the ring
2422       isend=fg_rank1
2423       irecv=fg_rank1-1
2424       if (irecv.lt.0) irecv=nfgtasks1-1
2425       iprev=irecv
2426       inext=fg_rank1+1
2427       if (inext.ge.nfgtasks1) inext=0
2428       do i=1,nfgtasks1-1
2429 !        write (iout,*) "isend",isend," irecv",irecv
2430 !        call flush(iout)
2431         lensend=lentyp(isend)
2432         lenrecv=lentyp(irecv)
2433 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2434 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2435 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2436 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2437 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2438 !        write (iout,*) "Gather ROTAT1"
2439 !        call flush(iout)
2440 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2441 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2442 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2443 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2444 !        write (iout,*) "Gather ROTAT2"
2445 !        call flush(iout)
2446         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2447          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2448          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2449          iprev,4400+irecv,FG_COMM,status,IERR)
2450 !        write (iout,*) "Gather ROTAT_OLD"
2451 !        call flush(iout)
2452         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2453          MPI_PRECOMP11(lensend),inext,5500+isend,&
2454          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2455          iprev,5500+irecv,FG_COMM,status,IERR)
2456 !        write (iout,*) "Gather PRECOMP11"
2457 !        call flush(iout)
2458         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2459          MPI_PRECOMP12(lensend),inext,6600+isend,&
2460          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2461          iprev,6600+irecv,FG_COMM,status,IERR)
2462 !        write (iout,*) "Gather PRECOMP12"
2463 !        call flush(iout)
2464         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2465         then
2466         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2467          MPI_ROTAT2(lensend),inext,7700+isend,&
2468          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2469          iprev,7700+irecv,FG_COMM,status,IERR)
2470 !        write (iout,*) "Gather PRECOMP21"
2471 !        call flush(iout)
2472         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2473          MPI_PRECOMP22(lensend),inext,8800+isend,&
2474          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2475          iprev,8800+irecv,FG_COMM,status,IERR)
2476 !        write (iout,*) "Gather PRECOMP22"
2477 !        call flush(iout)
2478         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2479          MPI_PRECOMP23(lensend),inext,9900+isend,&
2480          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2481          MPI_PRECOMP23(lenrecv),&
2482          iprev,9900+irecv,FG_COMM,status,IERR)
2483 !        write (iout,*) "Gather PRECOMP23"
2484 !        call flush(iout)
2485         endif
2486         isend=irecv
2487         irecv=irecv-1
2488         if (irecv.lt.0) irecv=nfgtasks1-1
2489       enddo
2490 #endif
2491         time_gather=time_gather+MPI_Wtime()-time00
2492       endif
2493 #ifdef DEBUG
2494 !      if (fg_rank.eq.0) then
2495         write (iout,*) "Arrays UG and UGDER"
2496         do i=1,nres-1
2497           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2498            ((ug(l,k,i),l=1,2),k=1,2),&
2499            ((ugder(l,k,i),l=1,2),k=1,2)
2500         enddo
2501         write (iout,*) "Arrays UG2 and UG2DER"
2502         do i=1,nres-1
2503           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2504            ((ug2(l,k,i),l=1,2),k=1,2),&
2505            ((ug2der(l,k,i),l=1,2),k=1,2)
2506         enddo
2507         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2508         do i=1,nres-1
2509           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2510            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2511            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2512         enddo
2513         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2514         do i=1,nres-1
2515           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2516            costab(i),sintab(i),costab2(i),sintab2(i)
2517         enddo
2518         write (iout,*) "Array MUDER"
2519         do i=1,nres-1
2520           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2521         enddo
2522 !      endif
2523 #endif
2524 #endif
2525 !d      do i=1,nres
2526 !d        iti = itortyp(itype(i))
2527 !d        write (iout,*) i
2528 !d        do j=1,2
2529 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2530 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2531 !d        enddo
2532 !d      enddo
2533       return
2534       end subroutine set_matrices
2535 !-----------------------------------------------------------------------------
2536       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2537 !
2538 ! This subroutine calculates the average interaction energy and its gradient
2539 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2540 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2541 ! The potential depends both on the distance of peptide-group centers and on
2542 ! the orientation of the CA-CA virtual bonds.
2543 !
2544       use comm_locel
2545 !      implicit real*8 (a-h,o-z)
2546 #ifdef MPI
2547       include 'mpif.h'
2548 #endif
2549 !      include 'DIMENSIONS'
2550 !      include 'COMMON.CONTROL'
2551 !      include 'COMMON.SETUP'
2552 !      include 'COMMON.IOUNITS'
2553 !      include 'COMMON.GEO'
2554 !      include 'COMMON.VAR'
2555 !      include 'COMMON.LOCAL'
2556 !      include 'COMMON.CHAIN'
2557 !      include 'COMMON.DERIV'
2558 !      include 'COMMON.INTERACT'
2559 !      include 'COMMON.CONTACTS'
2560 !      include 'COMMON.TORSION'
2561 !      include 'COMMON.VECTORS'
2562 !      include 'COMMON.FFIELD'
2563 !      include 'COMMON.TIME1'
2564       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2565       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2566       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2567 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2568       real(kind=8),dimension(4) :: muij
2569 !el      integer :: num_conti,j1,j2
2570 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2571 !el        dz_normi,xmedi,ymedi,zmedi
2572
2573 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2574 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2575 !el          num_conti,j1,j2
2576
2577 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2578 #ifdef MOMENT
2579       real(kind=8) :: scal_el=1.0d0
2580 #else
2581       real(kind=8) :: scal_el=0.5d0
2582 #endif
2583 ! 12/13/98
2584 ! 13-go grudnia roku pamietnego...
2585       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2586                                              0.0d0,1.0d0,0.0d0,&
2587                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2588 !el local variables
2589       integer :: i,k,j
2590       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2591       real(kind=8) :: fac,t_eelecij
2592
2593
2594 !d      write(iout,*) 'In EELEC'
2595 !d      do i=1,nloctyp
2596 !d        write(iout,*) 'Type',i
2597 !d        write(iout,*) 'B1',B1(:,i)
2598 !d        write(iout,*) 'B2',B2(:,i)
2599 !d        write(iout,*) 'CC',CC(:,:,i)
2600 !d        write(iout,*) 'DD',DD(:,:,i)
2601 !d        write(iout,*) 'EE',EE(:,:,i)
2602 !d      enddo
2603 !d      call check_vecgrad
2604 !d      stop
2605 !      ees=0.0d0  !AS
2606 !      evdw1=0.0d0
2607 !      eel_loc=0.0d0
2608 !      eello_turn3=0.0d0
2609 !      eello_turn4=0.0d0
2610       t_eelecij=0.0d0
2611       ees=0.0D0
2612       evdw1=0.0D0
2613       eel_loc=0.0d0
2614       eello_turn3=0.0d0
2615       eello_turn4=0.0d0
2616 !
2617
2618       if (icheckgrad.eq.1) then
2619 !el
2620 !        do i=0,2*nres+2
2621 !          dc_norm(1,i)=0.0d0
2622 !          dc_norm(2,i)=0.0d0
2623 !          dc_norm(3,i)=0.0d0
2624 !        enddo
2625         do i=1,nres-1
2626           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2627           do k=1,3
2628             dc_norm(k,i)=dc(k,i)*fac
2629           enddo
2630 !          write (iout,*) 'i',i,' fac',fac
2631         enddo
2632       endif
2633       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2634           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2635           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2636 !        call vec_and_deriv
2637 #ifdef TIMING
2638         time01=MPI_Wtime()
2639 #endif
2640         call set_matrices
2641 #ifdef TIMING
2642         time_mat=time_mat+MPI_Wtime()-time01
2643 #endif
2644       endif
2645 !d      do i=1,nres-1
2646 !d        write (iout,*) 'i=',i
2647 !d        do k=1,3
2648 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2649 !d        enddo
2650 !d        do k=1,3
2651 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2652 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2653 !d        enddo
2654 !d      enddo
2655       t_eelecij=0.0d0
2656       ees=0.0D0
2657       evdw1=0.0D0
2658       eel_loc=0.0d0
2659       eello_turn3=0.0d0
2660       eello_turn4=0.0d0
2661 !el      ind=0
2662       do i=1,nres
2663         num_cont_hb(i)=0
2664       enddo
2665 !d      print '(a)','Enter EELEC'
2666 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2667 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2668 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2669       do i=1,nres
2670         gel_loc_loc(i)=0.0d0
2671         gcorr_loc(i)=0.0d0
2672       enddo
2673 !
2674 !
2675 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2676 !
2677 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2678 !
2679
2680
2681
2682       do i=iturn3_start,iturn3_end
2683         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2684         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2685         dxi=dc(1,i)
2686         dyi=dc(2,i)
2687         dzi=dc(3,i)
2688         dx_normi=dc_norm(1,i)
2689         dy_normi=dc_norm(2,i)
2690         dz_normi=dc_norm(3,i)
2691         xmedi=c(1,i)+0.5d0*dxi
2692         ymedi=c(2,i)+0.5d0*dyi
2693         zmedi=c(3,i)+0.5d0*dzi
2694           xmedi=dmod(xmedi,boxxsize)
2695           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2696           ymedi=dmod(ymedi,boxysize)
2697           if (ymedi.lt.0) ymedi=ymedi+boxysize
2698           zmedi=dmod(zmedi,boxzsize)
2699           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2700         num_conti=0
2701         call eelecij(i,i+2,ees,evdw1,eel_loc)
2702         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2703         num_cont_hb(i)=num_conti
2704       enddo
2705       do i=iturn4_start,iturn4_end
2706         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2707           .or. itype(i+3).eq.ntyp1 &
2708           .or. itype(i+4).eq.ntyp1) cycle
2709         dxi=dc(1,i)
2710         dyi=dc(2,i)
2711         dzi=dc(3,i)
2712         dx_normi=dc_norm(1,i)
2713         dy_normi=dc_norm(2,i)
2714         dz_normi=dc_norm(3,i)
2715         xmedi=c(1,i)+0.5d0*dxi
2716         ymedi=c(2,i)+0.5d0*dyi
2717         zmedi=c(3,i)+0.5d0*dzi
2718           xmedi=dmod(xmedi,boxxsize)
2719           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2720           ymedi=dmod(ymedi,boxysize)
2721           if (ymedi.lt.0) ymedi=ymedi+boxysize
2722           zmedi=dmod(zmedi,boxzsize)
2723           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2724         num_conti=num_cont_hb(i)
2725         call eelecij(i,i+3,ees,evdw1,eel_loc)
2726         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2727          call eturn4(i,eello_turn4)
2728         num_cont_hb(i)=num_conti
2729       enddo   ! i
2730 !
2731 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2732 !
2733       do i=iatel_s,iatel_e
2734         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2735         dxi=dc(1,i)
2736         dyi=dc(2,i)
2737         dzi=dc(3,i)
2738         dx_normi=dc_norm(1,i)
2739         dy_normi=dc_norm(2,i)
2740         dz_normi=dc_norm(3,i)
2741         xmedi=c(1,i)+0.5d0*dxi
2742         ymedi=c(2,i)+0.5d0*dyi
2743         zmedi=c(3,i)+0.5d0*dzi
2744           xmedi=dmod(xmedi,boxxsize)
2745           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2746           ymedi=dmod(ymedi,boxysize)
2747           if (ymedi.lt.0) ymedi=ymedi+boxysize
2748           zmedi=dmod(zmedi,boxzsize)
2749           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2750
2751 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2752         num_conti=num_cont_hb(i)
2753         do j=ielstart(i),ielend(i)
2754 !          write (iout,*) i,j,itype(i),itype(j)
2755           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2756           call eelecij(i,j,ees,evdw1,eel_loc)
2757         enddo ! j
2758         num_cont_hb(i)=num_conti
2759       enddo   ! i
2760 !      write (iout,*) "Number of loop steps in EELEC:",ind
2761 !d      do i=1,nres
2762 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2763 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2764 !d      enddo
2765 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2766 !cc      eel_loc=eel_loc+eello_turn3
2767 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2768       return
2769       end subroutine eelec
2770 !-----------------------------------------------------------------------------
2771       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2772
2773       use comm_locel
2774 !      implicit real*8 (a-h,o-z)
2775 !      include 'DIMENSIONS'
2776 #ifdef MPI
2777       include "mpif.h"
2778 #endif
2779 !      include 'COMMON.CONTROL'
2780 !      include 'COMMON.IOUNITS'
2781 !      include 'COMMON.GEO'
2782 !      include 'COMMON.VAR'
2783 !      include 'COMMON.LOCAL'
2784 !      include 'COMMON.CHAIN'
2785 !      include 'COMMON.DERIV'
2786 !      include 'COMMON.INTERACT'
2787 !      include 'COMMON.CONTACTS'
2788 !      include 'COMMON.TORSION'
2789 !      include 'COMMON.VECTORS'
2790 !      include 'COMMON.FFIELD'
2791 !      include 'COMMON.TIME1'
2792       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2793       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2794       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2795 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2796       real(kind=8),dimension(4) :: muij
2797       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
2798                     dist_temp, dist_init
2799       integer xshift,yshift,zshift
2800 !el      integer :: num_conti,j1,j2
2801 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2802 !el        dz_normi,xmedi,ymedi,zmedi
2803
2804 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2805 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2806 !el          num_conti,j1,j2
2807
2808 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2809 #ifdef MOMENT
2810       real(kind=8) :: scal_el=1.0d0
2811 #else
2812       real(kind=8) :: scal_el=0.5d0
2813 #endif
2814 ! 12/13/98
2815 ! 13-go grudnia roku pamietnego...
2816       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2817                                              0.0d0,1.0d0,0.0d0,&
2818                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2819 !      integer :: maxconts=nres/4
2820 !el local variables
2821       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
2822       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
2823       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
2824       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
2825                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
2826                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
2827                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
2828                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
2829                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
2830                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
2831                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
2832 !      maxconts=nres/4
2833 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
2834 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
2835
2836 !          time00=MPI_Wtime()
2837 !d      write (iout,*) "eelecij",i,j
2838 !          ind=ind+1
2839           iteli=itel(i)
2840           itelj=itel(j)
2841           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2842           aaa=app(iteli,itelj)
2843           bbb=bpp(iteli,itelj)
2844           ael6i=ael6(iteli,itelj)
2845           ael3i=ael3(iteli,itelj)
2846           dxj=dc(1,j)
2847           dyj=dc(2,j)
2848           dzj=dc(3,j)
2849           dx_normj=dc_norm(1,j)
2850           dy_normj=dc_norm(2,j)
2851           dz_normj=dc_norm(3,j)
2852 !          xj=c(1,j)+0.5D0*dxj-xmedi
2853 !          yj=c(2,j)+0.5D0*dyj-ymedi
2854 !          zj=c(3,j)+0.5D0*dzj-zmedi
2855           xj=c(1,j)+0.5D0*dxj
2856           yj=c(2,j)+0.5D0*dyj
2857           zj=c(3,j)+0.5D0*dzj
2858           xj=mod(xj,boxxsize)
2859           if (xj.lt.0) xj=xj+boxxsize
2860           yj=mod(yj,boxysize)
2861           if (yj.lt.0) yj=yj+boxysize
2862           zj=mod(zj,boxzsize)
2863           if (zj.lt.0) zj=zj+boxzsize
2864       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2865       xj_safe=xj
2866       yj_safe=yj
2867       zj_safe=zj
2868       do xshift=-1,1
2869       do yshift=-1,1
2870       do zshift=-1,1
2871           xj=xj_safe+xshift*boxxsize
2872           yj=yj_safe+yshift*boxysize
2873           zj=zj_safe+zshift*boxzsize
2874           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2875           if(dist_temp.lt.dist_init) then
2876             dist_init=dist_temp
2877             xj_temp=xj
2878             yj_temp=yj
2879             zj_temp=zj
2880             isubchap=1
2881           endif
2882        enddo
2883        enddo
2884        enddo
2885        if (isubchap.eq.1) then
2886 !C          print *,i,j
2887           xj=xj_temp-xmedi
2888           yj=yj_temp-ymedi
2889           zj=zj_temp-zmedi
2890        else
2891           xj=xj_safe-xmedi
2892           yj=yj_safe-ymedi
2893           zj=zj_safe-zmedi
2894        endif
2895
2896           rij=xj*xj+yj*yj+zj*zj
2897           rrmij=1.0D0/rij
2898           rij=dsqrt(rij)
2899             sss_ele_cut=sscale_ele(rij)
2900             sss_ele_grad=sscagrad_ele(rij)
2901 !            print *,sss_ele_cut,sss_ele_grad,&
2902 !            (rij),r_cut_ele,rlamb_ele
2903             if (sss_ele_cut.le.0.0) go to 128
2904
2905           rmij=1.0D0/rij
2906           r3ij=rrmij*rmij
2907           r6ij=r3ij*r3ij
2908           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2909           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2910           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2911           fac=cosa-3.0D0*cosb*cosg
2912           ev1=aaa*r6ij*r6ij
2913 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2914           if (j.eq.i+2) ev1=scal_el*ev1
2915           ev2=bbb*r6ij
2916           fac3=ael6i*r6ij
2917           fac4=ael3i*r3ij
2918           evdwij=ev1+ev2
2919           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2920           el2=fac4*fac
2921           eesij=el1+el2
2922 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
2923           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2924           ees=ees+eesij*sss_ele_cut
2925           evdw1=evdw1+evdwij*sss_ele_cut
2926 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2927 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2928 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2929 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
2930
2931           if (energy_dec) then
2932 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
2933 !                  'evdw1',i,j,evdwij,&
2934 !                  iteli,itelj,aaa,evdw1
2935               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2936               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2937           endif
2938 !
2939 ! Calculate contributions to the Cartesian gradient.
2940 !
2941 #ifdef SPLITELE
2942           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut
2943           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
2944           fac1=fac
2945           erij(1)=xj*rmij
2946           erij(2)=yj*rmij
2947           erij(3)=zj*rmij
2948 !
2949 ! Radial derivatives. First process both termini of the fragment (i,j)
2950 !
2951           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
2952           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
2953           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
2954
2955 !          do k=1,3
2956 !            ghalf=0.5D0*ggg(k)
2957 !            gelc(k,i)=gelc(k,i)+ghalf
2958 !            gelc(k,j)=gelc(k,j)+ghalf
2959 !          enddo
2960 ! 9/28/08 AL Gradient compotents will be summed only at the end
2961           do k=1,3
2962             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2963             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2964           enddo
2965 !
2966 ! Loop over residues i+1 thru j-1.
2967 !
2968 !grad          do k=i+1,j-1
2969 !grad            do l=1,3
2970 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2971 !grad            enddo
2972 !grad          enddo
2973           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj
2974           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj
2975           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj
2976 !          do k=1,3
2977 !            ghalf=0.5D0*ggg(k)
2978 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2979 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2980 !          enddo
2981 ! 9/28/08 AL Gradient compotents will be summed only at the end
2982           do k=1,3
2983             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2984             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2985           enddo
2986 !
2987 ! Loop over residues i+1 thru j-1.
2988 !
2989 !grad          do k=i+1,j-1
2990 !grad            do l=1,3
2991 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2992 !grad            enddo
2993 !grad          enddo
2994 #else
2995           facvdw=(ev1+evdwij)*sss_ele_cut
2996           facel=(el1+eesij)*sss_ele_cut
2997           fac1=fac
2998           fac=-3*rrmij*(facvdw+facvdw+facel)
2999           erij(1)=xj*rmij
3000           erij(2)=yj*rmij
3001           erij(3)=zj*rmij
3002 !
3003 ! Radial derivatives. First process both termini of the fragment (i,j)
3004 !
3005           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3006           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3007           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3008 !          do k=1,3
3009 !            ghalf=0.5D0*ggg(k)
3010 !            gelc(k,i)=gelc(k,i)+ghalf
3011 !            gelc(k,j)=gelc(k,j)+ghalf
3012 !          enddo
3013 ! 9/28/08 AL Gradient compotents will be summed only at the end
3014           do k=1,3
3015             gelc_long(k,j)=gelc(k,j)+ggg(k)
3016             gelc_long(k,i)=gelc(k,i)-ggg(k)
3017           enddo
3018 !
3019 ! Loop over residues i+1 thru j-1.
3020 !
3021 !grad          do k=i+1,j-1
3022 !grad            do l=1,3
3023 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3024 !grad            enddo
3025 !grad          enddo
3026 ! 9/28/08 AL Gradient compotents will be summed only at the end
3027           ggg(1)=facvdw*xj
3028           ggg(2)=facvdw*yj
3029           ggg(3)=facvdw*zj
3030           do k=1,3
3031             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3032             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3033           enddo
3034 #endif
3035 !
3036 ! Angular part
3037 !
3038           ecosa=2.0D0*fac3*fac1+fac4
3039           fac4=-3.0D0*fac4
3040           fac3=-6.0D0*fac3
3041           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3042           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3043           do k=1,3
3044             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3045             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3046           enddo
3047 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3048 !d   &          (dcosg(k),k=1,3)
3049           do k=1,3
3050             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut
3051           enddo
3052 !          do k=1,3
3053 !            ghalf=0.5D0*ggg(k)
3054 !            gelc(k,i)=gelc(k,i)+ghalf
3055 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3056 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3057 !            gelc(k,j)=gelc(k,j)+ghalf
3058 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3059 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3060 !          enddo
3061 !grad          do k=i+1,j-1
3062 !grad            do l=1,3
3063 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3064 !grad            enddo
3065 !grad          enddo
3066           do k=1,3
3067             gelc(k,i)=gelc(k,i) &
3068                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3069                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3070                      *sss_ele_cut
3071             gelc(k,j)=gelc(k,j) &
3072                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3073                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3074                      *sss_ele_cut
3075             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3076             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3077           enddo
3078  128      continue
3079           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3080               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3081               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3082 !
3083 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3084 !   energy of a peptide unit is assumed in the form of a second-order
3085 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3086 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3087 !   are computed for EVERY pair of non-contiguous peptide groups.
3088 !
3089           if (j.lt.nres-1) then
3090             j1=j+1
3091             j2=j-1
3092           else
3093             j1=j-1
3094             j2=j-2
3095           endif
3096           kkk=0
3097           do k=1,2
3098             do l=1,2
3099               kkk=kkk+1
3100               muij(kkk)=mu(k,i)*mu(l,j)
3101             enddo
3102           enddo
3103 !d         write (iout,*) 'EELEC: i',i,' j',j
3104 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3105 !d          write(iout,*) 'muij',muij
3106           ury=scalar(uy(1,i),erij)
3107           urz=scalar(uz(1,i),erij)
3108           vry=scalar(uy(1,j),erij)
3109           vrz=scalar(uz(1,j),erij)
3110           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3111           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3112           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3113           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3114           fac=dsqrt(-ael6i)*r3ij
3115           a22=a22*fac
3116           a23=a23*fac
3117           a32=a32*fac
3118           a33=a33*fac
3119 !d          write (iout,'(4i5,4f10.5)')
3120 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3121 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3122 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3123 !d     &      uy(:,j),uz(:,j)
3124 !d          write (iout,'(4f10.5)')
3125 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3126 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3127 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3128 !d           write (iout,'(9f10.5/)')
3129 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3130 ! Derivatives of the elements of A in virtual-bond vectors
3131           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3132           do k=1,3
3133             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3134             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3135             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3136             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3137             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3138             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3139             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3140             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3141             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3142             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3143             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3144             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3145           enddo
3146 ! Compute radial contributions to the gradient
3147           facr=-3.0d0*rrmij
3148           a22der=a22*facr
3149           a23der=a23*facr
3150           a32der=a32*facr
3151           a33der=a33*facr
3152           agg(1,1)=a22der*xj
3153           agg(2,1)=a22der*yj
3154           agg(3,1)=a22der*zj
3155           agg(1,2)=a23der*xj
3156           agg(2,2)=a23der*yj
3157           agg(3,2)=a23der*zj
3158           agg(1,3)=a32der*xj
3159           agg(2,3)=a32der*yj
3160           agg(3,3)=a32der*zj
3161           agg(1,4)=a33der*xj
3162           agg(2,4)=a33der*yj
3163           agg(3,4)=a33der*zj
3164 ! Add the contributions coming from er
3165           fac3=-3.0d0*fac
3166           do k=1,3
3167             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3168             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3169             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3170             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3171           enddo
3172           do k=1,3
3173 ! Derivatives in DC(i)
3174 !grad            ghalf1=0.5d0*agg(k,1)
3175 !grad            ghalf2=0.5d0*agg(k,2)
3176 !grad            ghalf3=0.5d0*agg(k,3)
3177 !grad            ghalf4=0.5d0*agg(k,4)
3178             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3179             -3.0d0*uryg(k,2)*vry)!+ghalf1
3180             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3181             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3182             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3183             -3.0d0*urzg(k,2)*vry)!+ghalf3
3184             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3185             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3186 ! Derivatives in DC(i+1)
3187             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3188             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3189             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3190             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3191             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3192             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3193             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3194             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3195 ! Derivatives in DC(j)
3196             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3197             -3.0d0*vryg(k,2)*ury)!+ghalf1
3198             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3199             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3200             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3201             -3.0d0*vryg(k,2)*urz)!+ghalf3
3202             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3203             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3204 ! Derivatives in DC(j+1) or DC(nres-1)
3205             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3206             -3.0d0*vryg(k,3)*ury)
3207             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3208             -3.0d0*vrzg(k,3)*ury)
3209             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3210             -3.0d0*vryg(k,3)*urz)
3211             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3212             -3.0d0*vrzg(k,3)*urz)
3213 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3214 !grad              do l=1,4
3215 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3216 !grad              enddo
3217 !grad            endif
3218           enddo
3219           acipa(1,1)=a22
3220           acipa(1,2)=a23
3221           acipa(2,1)=a32
3222           acipa(2,2)=a33
3223           a22=-a22
3224           a23=-a23
3225           do l=1,2
3226             do k=1,3
3227               agg(k,l)=-agg(k,l)
3228               aggi(k,l)=-aggi(k,l)
3229               aggi1(k,l)=-aggi1(k,l)
3230               aggj(k,l)=-aggj(k,l)
3231               aggj1(k,l)=-aggj1(k,l)
3232             enddo
3233           enddo
3234           if (j.lt.nres-1) then
3235             a22=-a22
3236             a32=-a32
3237             do l=1,3,2
3238               do k=1,3
3239                 agg(k,l)=-agg(k,l)
3240                 aggi(k,l)=-aggi(k,l)
3241                 aggi1(k,l)=-aggi1(k,l)
3242                 aggj(k,l)=-aggj(k,l)
3243                 aggj1(k,l)=-aggj1(k,l)
3244               enddo
3245             enddo
3246           else
3247             a22=-a22
3248             a23=-a23
3249             a32=-a32
3250             a33=-a33
3251             do l=1,4
3252               do k=1,3
3253                 agg(k,l)=-agg(k,l)
3254                 aggi(k,l)=-aggi(k,l)
3255                 aggi1(k,l)=-aggi1(k,l)
3256                 aggj(k,l)=-aggj(k,l)
3257                 aggj1(k,l)=-aggj1(k,l)
3258               enddo
3259             enddo
3260           endif
3261           ENDIF ! WCORR
3262           IF (wel_loc.gt.0.0d0) THEN
3263 ! Contribution to the local-electrostatic energy coming from the i-j pair
3264           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3265            +a33*muij(4)
3266 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3267
3268           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3269                   'eelloc',i,j,eel_loc_ij
3270 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3271 !          if (energy_dec) write (iout,*) "muij",muij
3272 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3273
3274           eel_loc=eel_loc+eel_loc_ij
3275 ! Partial derivatives in virtual-bond dihedral angles gamma
3276           if (i.gt.1) &
3277           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3278                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3279                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3280           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3281                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3282                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3283 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3284           do l=1,3
3285             ggg(l)=agg(l,1)*muij(1)+ &
3286                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3287             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3288             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3289 !grad            ghalf=0.5d0*ggg(l)
3290 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3291 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3292           enddo
3293 !grad          do k=i+1,j2
3294 !grad            do l=1,3
3295 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3296 !grad            enddo
3297 !grad          enddo
3298 ! Remaining derivatives of eello
3299           do l=1,3
3300             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
3301                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3302             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
3303                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3304             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
3305                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3306             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
3307                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3308           enddo
3309           ENDIF
3310 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3311 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3312           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3313              .and. num_conti.le.maxconts) then
3314 !            write (iout,*) i,j," entered corr"
3315 !
3316 ! Calculate the contact function. The ith column of the array JCONT will
3317 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3318 ! greater than I). The arrays FACONT and GACONT will contain the values of
3319 ! the contact function and its derivative.
3320 !           r0ij=1.02D0*rpp(iteli,itelj)
3321 !           r0ij=1.11D0*rpp(iteli,itelj)
3322             r0ij=2.20D0*rpp(iteli,itelj)
3323 !           r0ij=1.55D0*rpp(iteli,itelj)
3324             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3325 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3326             if (fcont.gt.0.0D0) then
3327               num_conti=num_conti+1
3328               if (num_conti.gt.maxconts) then
3329 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3330 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3331                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3332                                ' will skip next contacts for this conf.', num_conti
3333               else
3334                 jcont_hb(num_conti,i)=j
3335 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3336 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3337                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3338                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3339 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3340 !  terms.
3341                 d_cont(num_conti,i)=rij
3342 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3343 !     --- Electrostatic-interaction matrix ---
3344                 a_chuj(1,1,num_conti,i)=a22
3345                 a_chuj(1,2,num_conti,i)=a23
3346                 a_chuj(2,1,num_conti,i)=a32
3347                 a_chuj(2,2,num_conti,i)=a33
3348 !     --- Gradient of rij
3349                 do kkk=1,3
3350                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3351                 enddo
3352                 kkll=0
3353                 do k=1,2
3354                   do l=1,2
3355                     kkll=kkll+1
3356                     do m=1,3
3357                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3358                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3359                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3360                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3361                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3362                     enddo
3363                   enddo
3364                 enddo
3365                 ENDIF
3366                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3367 ! Calculate contact energies
3368                 cosa4=4.0D0*cosa
3369                 wij=cosa-3.0D0*cosb*cosg
3370                 cosbg1=cosb+cosg
3371                 cosbg2=cosb-cosg
3372 !               fac3=dsqrt(-ael6i)/r0ij**3
3373                 fac3=dsqrt(-ael6i)*r3ij
3374 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3375                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3376                 if (ees0tmp.gt.0) then
3377                   ees0pij=dsqrt(ees0tmp)
3378                 else
3379                   ees0pij=0
3380                 endif
3381 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3382                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3383                 if (ees0tmp.gt.0) then
3384                   ees0mij=dsqrt(ees0tmp)
3385                 else
3386                   ees0mij=0
3387                 endif
3388 !               ees0mij=0.0D0
3389                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3390                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3391 ! Diagnostics. Comment out or remove after debugging!
3392 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3393 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3394 !               ees0m(num_conti,i)=0.0D0
3395 ! End diagnostics.
3396 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3397 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3398 ! Angular derivatives of the contact function
3399                 ees0pij1=fac3/ees0pij
3400                 ees0mij1=fac3/ees0mij
3401                 fac3p=-3.0D0*fac3*rrmij
3402                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3403                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3404 !               ees0mij1=0.0D0
3405                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3406                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3407                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3408                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3409                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3410                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3411                 ecosap=ecosa1+ecosa2
3412                 ecosbp=ecosb1+ecosb2
3413                 ecosgp=ecosg1+ecosg2
3414                 ecosam=ecosa1-ecosa2
3415                 ecosbm=ecosb1-ecosb2
3416                 ecosgm=ecosg1-ecosg2
3417 ! Diagnostics
3418 !               ecosap=ecosa1
3419 !               ecosbp=ecosb1
3420 !               ecosgp=ecosg1
3421 !               ecosam=0.0D0
3422 !               ecosbm=0.0D0
3423 !               ecosgm=0.0D0
3424 ! End diagnostics
3425                 facont_hb(num_conti,i)=fcont
3426                 fprimcont=fprimcont/rij
3427 !d              facont_hb(num_conti,i)=1.0D0
3428 ! Following line is for diagnostics.
3429 !d              fprimcont=0.0D0
3430                 do k=1,3
3431                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3432                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3433                 enddo
3434                 do k=1,3
3435                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3436                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3437                 enddo
3438                 gggp(1)=gggp(1)+ees0pijp*xj
3439                 gggp(2)=gggp(2)+ees0pijp*yj
3440                 gggp(3)=gggp(3)+ees0pijp*zj
3441                 gggm(1)=gggm(1)+ees0mijp*xj
3442                 gggm(2)=gggm(2)+ees0mijp*yj
3443                 gggm(3)=gggm(3)+ees0mijp*zj
3444 ! Derivatives due to the contact function
3445                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3446                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3447                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3448                 do k=1,3
3449 !
3450 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3451 !          following the change of gradient-summation algorithm.
3452 !
3453 !grad                  ghalfp=0.5D0*gggp(k)
3454 !grad                  ghalfm=0.5D0*gggm(k)
3455                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3456                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3457                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3458                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3459                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3460                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3461                   gacontp_hb3(k,num_conti,i)=gggp(k)
3462                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3463                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3464                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3465                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3466                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3467                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3468                   gacontm_hb3(k,num_conti,i)=gggm(k)
3469                 enddo
3470 ! Diagnostics. Comment out or remove after debugging!
3471 !diag           do k=1,3
3472 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3473 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3474 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3475 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3476 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3477 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3478 !diag           enddo
3479               ENDIF ! wcorr
3480               endif  ! num_conti.le.maxconts
3481             endif  ! fcont.gt.0
3482           endif    ! j.gt.i+1
3483           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3484             do k=1,4
3485               do l=1,3
3486                 ghalf=0.5d0*agg(l,k)
3487                 aggi(l,k)=aggi(l,k)+ghalf
3488                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3489                 aggj(l,k)=aggj(l,k)+ghalf
3490               enddo
3491             enddo
3492             if (j.eq.nres-1 .and. i.lt.j-2) then
3493               do k=1,4
3494                 do l=1,3
3495                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3496                 enddo
3497               enddo
3498             endif
3499           endif
3500 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3501       return
3502       end subroutine eelecij
3503 !-----------------------------------------------------------------------------
3504       subroutine eturn3(i,eello_turn3)
3505 ! Third- and fourth-order contributions from turns
3506
3507       use comm_locel
3508 !      implicit real*8 (a-h,o-z)
3509 !      include 'DIMENSIONS'
3510 !      include 'COMMON.IOUNITS'
3511 !      include 'COMMON.GEO'
3512 !      include 'COMMON.VAR'
3513 !      include 'COMMON.LOCAL'
3514 !      include 'COMMON.CHAIN'
3515 !      include 'COMMON.DERIV'
3516 !      include 'COMMON.INTERACT'
3517 !      include 'COMMON.CONTACTS'
3518 !      include 'COMMON.TORSION'
3519 !      include 'COMMON.VECTORS'
3520 !      include 'COMMON.FFIELD'
3521 !      include 'COMMON.CONTROL'
3522       real(kind=8),dimension(3) :: ggg
3523       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3524         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3525       real(kind=8),dimension(2) :: auxvec,auxvec1
3526 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3527       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3528 !el      integer :: num_conti,j1,j2
3529 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3530 !el        dz_normi,xmedi,ymedi,zmedi
3531
3532 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3533 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3534 !el         num_conti,j1,j2
3535 !el local variables
3536       integer :: i,j,l
3537       real(kind=8) :: eello_turn3
3538
3539       j=i+2
3540 !      write (iout,*) "eturn3",i,j,j1,j2
3541       a_temp(1,1)=a22
3542       a_temp(1,2)=a23
3543       a_temp(2,1)=a32
3544       a_temp(2,2)=a33
3545 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3546 !
3547 !               Third-order contributions
3548 !
3549 !                 (i+2)o----(i+3)
3550 !                      | |
3551 !                      | |
3552 !                 (i+1)o----i
3553 !
3554 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3555 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3556         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3557         call transpose2(auxmat(1,1),auxmat1(1,1))
3558         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3559         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3560         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3561                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3562 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3563 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3564 !d     &    ' eello_turn3_num',4*eello_turn3_num
3565 ! Derivatives in gamma(i)
3566         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3567         call transpose2(auxmat2(1,1),auxmat3(1,1))
3568         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3569         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3570 ! Derivatives in gamma(i+1)
3571         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3572         call transpose2(auxmat2(1,1),auxmat3(1,1))
3573         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3574         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3575           +0.5d0*(pizda(1,1)+pizda(2,2))
3576 ! Cartesian derivatives
3577         do l=1,3
3578 !            ghalf1=0.5d0*agg(l,1)
3579 !            ghalf2=0.5d0*agg(l,2)
3580 !            ghalf3=0.5d0*agg(l,3)
3581 !            ghalf4=0.5d0*agg(l,4)
3582           a_temp(1,1)=aggi(l,1)!+ghalf1
3583           a_temp(1,2)=aggi(l,2)!+ghalf2
3584           a_temp(2,1)=aggi(l,3)!+ghalf3
3585           a_temp(2,2)=aggi(l,4)!+ghalf4
3586           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3587           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3588             +0.5d0*(pizda(1,1)+pizda(2,2))
3589           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3590           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3591           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3592           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3593           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3594           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3595             +0.5d0*(pizda(1,1)+pizda(2,2))
3596           a_temp(1,1)=aggj(l,1)!+ghalf1
3597           a_temp(1,2)=aggj(l,2)!+ghalf2
3598           a_temp(2,1)=aggj(l,3)!+ghalf3
3599           a_temp(2,2)=aggj(l,4)!+ghalf4
3600           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3601           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3602             +0.5d0*(pizda(1,1)+pizda(2,2))
3603           a_temp(1,1)=aggj1(l,1)
3604           a_temp(1,2)=aggj1(l,2)
3605           a_temp(2,1)=aggj1(l,3)
3606           a_temp(2,2)=aggj1(l,4)
3607           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3608           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3609             +0.5d0*(pizda(1,1)+pizda(2,2))
3610         enddo
3611       return
3612       end subroutine eturn3
3613 !-----------------------------------------------------------------------------
3614       subroutine eturn4(i,eello_turn4)
3615 ! Third- and fourth-order contributions from turns
3616
3617       use comm_locel
3618 !      implicit real*8 (a-h,o-z)
3619 !      include 'DIMENSIONS'
3620 !      include 'COMMON.IOUNITS'
3621 !      include 'COMMON.GEO'
3622 !      include 'COMMON.VAR'
3623 !      include 'COMMON.LOCAL'
3624 !      include 'COMMON.CHAIN'
3625 !      include 'COMMON.DERIV'
3626 !      include 'COMMON.INTERACT'
3627 !      include 'COMMON.CONTACTS'
3628 !      include 'COMMON.TORSION'
3629 !      include 'COMMON.VECTORS'
3630 !      include 'COMMON.FFIELD'
3631 !      include 'COMMON.CONTROL'
3632       real(kind=8),dimension(3) :: ggg
3633       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3634         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3635       real(kind=8),dimension(2) :: auxvec,auxvec1
3636 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3637       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3638 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3639 !el        dz_normi,xmedi,ymedi,zmedi
3640 !el      integer :: num_conti,j1,j2
3641 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3642 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3643 !el          num_conti,j1,j2
3644 !el local variables
3645       integer :: i,j,iti1,iti2,iti3,l
3646       real(kind=8) :: eello_turn4,s1,s2,s3
3647
3648       j=i+3
3649 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3650 !
3651 !               Fourth-order contributions
3652 !
3653 !                 (i+3)o----(i+4)
3654 !                     /  |
3655 !               (i+2)o   |
3656 !                     \  |
3657 !                 (i+1)o----i
3658 !
3659 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3660 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3661 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3662         a_temp(1,1)=a22
3663         a_temp(1,2)=a23
3664         a_temp(2,1)=a32
3665         a_temp(2,2)=a33
3666         iti1=itortyp(itype(i+1))
3667         iti2=itortyp(itype(i+2))
3668         iti3=itortyp(itype(i+3))
3669 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3670         call transpose2(EUg(1,1,i+1),e1t(1,1))
3671         call transpose2(Eug(1,1,i+2),e2t(1,1))
3672         call transpose2(Eug(1,1,i+3),e3t(1,1))
3673         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3674         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3675         s1=scalar2(b1(1,iti2),auxvec(1))
3676         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3677         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3678         s2=scalar2(b1(1,iti1),auxvec(1))
3679         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3680         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3681         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3682         eello_turn4=eello_turn4-(s1+s2+s3)
3683         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3684            'eturn4',i,j,-(s1+s2+s3)
3685 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3686 !d     &    ' eello_turn4_num',8*eello_turn4_num
3687 ! Derivatives in gamma(i)
3688         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3689         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3690         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3691         s1=scalar2(b1(1,iti2),auxvec(1))
3692         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3693         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3694         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3695 ! Derivatives in gamma(i+1)
3696         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3697         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3698         s2=scalar2(b1(1,iti1),auxvec(1))
3699         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3700         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3701         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3702         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3703 ! Derivatives in gamma(i+2)
3704         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3705         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3706         s1=scalar2(b1(1,iti2),auxvec(1))
3707         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3708         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3709         s2=scalar2(b1(1,iti1),auxvec(1))
3710         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3711         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3712         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3713         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3714 ! Cartesian derivatives
3715 ! Derivatives of this turn contributions in DC(i+2)
3716         if (j.lt.nres-1) then
3717           do l=1,3
3718             a_temp(1,1)=agg(l,1)
3719             a_temp(1,2)=agg(l,2)
3720             a_temp(2,1)=agg(l,3)
3721             a_temp(2,2)=agg(l,4)
3722             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3723             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3724             s1=scalar2(b1(1,iti2),auxvec(1))
3725             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3726             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3727             s2=scalar2(b1(1,iti1),auxvec(1))
3728             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3729             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3730             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3731             ggg(l)=-(s1+s2+s3)
3732             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3733           enddo
3734         endif
3735 ! Remaining derivatives of this turn contribution
3736         do l=1,3
3737           a_temp(1,1)=aggi(l,1)
3738           a_temp(1,2)=aggi(l,2)
3739           a_temp(2,1)=aggi(l,3)
3740           a_temp(2,2)=aggi(l,4)
3741           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3742           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3743           s1=scalar2(b1(1,iti2),auxvec(1))
3744           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3745           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3746           s2=scalar2(b1(1,iti1),auxvec(1))
3747           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3748           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3749           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3750           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3751           a_temp(1,1)=aggi1(l,1)
3752           a_temp(1,2)=aggi1(l,2)
3753           a_temp(2,1)=aggi1(l,3)
3754           a_temp(2,2)=aggi1(l,4)
3755           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3756           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3757           s1=scalar2(b1(1,iti2),auxvec(1))
3758           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3759           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3760           s2=scalar2(b1(1,iti1),auxvec(1))
3761           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3762           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3763           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3764           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3765           a_temp(1,1)=aggj(l,1)
3766           a_temp(1,2)=aggj(l,2)
3767           a_temp(2,1)=aggj(l,3)
3768           a_temp(2,2)=aggj(l,4)
3769           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3770           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3771           s1=scalar2(b1(1,iti2),auxvec(1))
3772           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3773           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3774           s2=scalar2(b1(1,iti1),auxvec(1))
3775           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3776           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3777           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3778           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3779           a_temp(1,1)=aggj1(l,1)
3780           a_temp(1,2)=aggj1(l,2)
3781           a_temp(2,1)=aggj1(l,3)
3782           a_temp(2,2)=aggj1(l,4)
3783           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3784           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3785           s1=scalar2(b1(1,iti2),auxvec(1))
3786           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3787           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3788           s2=scalar2(b1(1,iti1),auxvec(1))
3789           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3790           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3791           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3792 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3793           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3794         enddo
3795       return
3796       end subroutine eturn4
3797 !-----------------------------------------------------------------------------
3798       subroutine unormderiv(u,ugrad,unorm,ungrad)
3799 ! This subroutine computes the derivatives of a normalized vector u, given
3800 ! the derivatives computed without normalization conditions, ugrad. Returns
3801 ! ungrad.
3802 !      implicit none
3803       real(kind=8),dimension(3) :: u,vec
3804       real(kind=8),dimension(3,3) ::ugrad,ungrad
3805       real(kind=8) :: unorm     !,scalar
3806       integer :: i,j
3807 !      write (2,*) 'ugrad',ugrad
3808 !      write (2,*) 'u',u
3809       do i=1,3
3810         vec(i)=scalar(ugrad(1,i),u(1))
3811       enddo
3812 !      write (2,*) 'vec',vec
3813       do i=1,3
3814         do j=1,3
3815           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3816         enddo
3817       enddo
3818 !      write (2,*) 'ungrad',ungrad
3819       return
3820       end subroutine unormderiv
3821 !-----------------------------------------------------------------------------
3822       subroutine escp_soft_sphere(evdw2,evdw2_14)
3823 !
3824 ! This subroutine calculates the excluded-volume interaction energy between
3825 ! peptide-group centers and side chains and its gradient in virtual-bond and
3826 ! side-chain vectors.
3827 !
3828 !      implicit real*8 (a-h,o-z)
3829 !      include 'DIMENSIONS'
3830 !      include 'COMMON.GEO'
3831 !      include 'COMMON.VAR'
3832 !      include 'COMMON.LOCAL'
3833 !      include 'COMMON.CHAIN'
3834 !      include 'COMMON.DERIV'
3835 !      include 'COMMON.INTERACT'
3836 !      include 'COMMON.FFIELD'
3837 !      include 'COMMON.IOUNITS'
3838 !      include 'COMMON.CONTROL'
3839       real(kind=8),dimension(3) :: ggg
3840 !el local variables
3841       integer :: i,iint,j,k,iteli,itypj
3842       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3843                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3844
3845       evdw2=0.0D0
3846       evdw2_14=0.0d0
3847       r0_scp=4.5d0
3848 !d    print '(a)','Enter ESCP'
3849 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3850       do i=iatscp_s,iatscp_e
3851         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3852         iteli=itel(i)
3853         xi=0.5D0*(c(1,i)+c(1,i+1))
3854         yi=0.5D0*(c(2,i)+c(2,i+1))
3855         zi=0.5D0*(c(3,i)+c(3,i+1))
3856
3857         do iint=1,nscp_gr(i)
3858
3859         do j=iscpstart(i,iint),iscpend(i,iint)
3860           if (itype(j).eq.ntyp1) cycle
3861           itypj=iabs(itype(j))
3862 ! Uncomment following three lines for SC-p interactions
3863 !         xj=c(1,nres+j)-xi
3864 !         yj=c(2,nres+j)-yi
3865 !         zj=c(3,nres+j)-zi
3866 ! Uncomment following three lines for Ca-p interactions
3867           xj=c(1,j)-xi
3868           yj=c(2,j)-yi
3869           zj=c(3,j)-zi
3870           rij=xj*xj+yj*yj+zj*zj
3871           r0ij=r0_scp
3872           r0ijsq=r0ij*r0ij
3873           if (rij.lt.r0ijsq) then
3874             evdwij=0.25d0*(rij-r0ijsq)**2
3875             fac=rij-r0ijsq
3876           else
3877             evdwij=0.0d0
3878             fac=0.0d0
3879           endif
3880           evdw2=evdw2+evdwij
3881 !
3882 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3883 !
3884           ggg(1)=xj*fac
3885           ggg(2)=yj*fac
3886           ggg(3)=zj*fac
3887 !grad          if (j.lt.i) then
3888 !d          write (iout,*) 'j<i'
3889 ! Uncomment following three lines for SC-p interactions
3890 !           do k=1,3
3891 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3892 !           enddo
3893 !grad          else
3894 !d          write (iout,*) 'j>i'
3895 !grad            do k=1,3
3896 !grad              ggg(k)=-ggg(k)
3897 ! Uncomment following line for SC-p interactions
3898 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3899 !grad            enddo
3900 !grad          endif
3901 !grad          do k=1,3
3902 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3903 !grad          enddo
3904 !grad          kstart=min0(i+1,j)
3905 !grad          kend=max0(i-1,j-1)
3906 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3907 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3908 !grad          do k=kstart,kend
3909 !grad            do l=1,3
3910 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3911 !grad            enddo
3912 !grad          enddo
3913           do k=1,3
3914             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3915             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3916           enddo
3917         enddo
3918
3919         enddo ! iint
3920       enddo ! i
3921       return
3922       end subroutine escp_soft_sphere
3923 !-----------------------------------------------------------------------------
3924       subroutine escp(evdw2,evdw2_14)
3925 !
3926 ! This subroutine calculates the excluded-volume interaction energy between
3927 ! peptide-group centers and side chains and its gradient in virtual-bond and
3928 ! side-chain vectors.
3929 !
3930 !      implicit real*8 (a-h,o-z)
3931 !      include 'DIMENSIONS'
3932 !      include 'COMMON.GEO'
3933 !      include 'COMMON.VAR'
3934 !      include 'COMMON.LOCAL'
3935 !      include 'COMMON.CHAIN'
3936 !      include 'COMMON.DERIV'
3937 !      include 'COMMON.INTERACT'
3938 !      include 'COMMON.FFIELD'
3939 !      include 'COMMON.IOUNITS'
3940 !      include 'COMMON.CONTROL'
3941       real(kind=8),dimension(3) :: ggg
3942 !el local variables
3943       integer :: i,iint,j,k,iteli,itypj
3944       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
3945                    e1,e2,evdwij
3946
3947       evdw2=0.0D0
3948       evdw2_14=0.0d0
3949 !d    print '(a)','Enter ESCP'
3950 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3951       do i=iatscp_s,iatscp_e
3952         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3953         iteli=itel(i)
3954         xi=0.5D0*(c(1,i)+c(1,i+1))
3955         yi=0.5D0*(c(2,i)+c(2,i+1))
3956         zi=0.5D0*(c(3,i)+c(3,i+1))
3957
3958         do iint=1,nscp_gr(i)
3959
3960         do j=iscpstart(i,iint),iscpend(i,iint)
3961           itypj=iabs(itype(j))
3962           if (itypj.eq.ntyp1) cycle
3963 ! Uncomment following three lines for SC-p interactions
3964 !         xj=c(1,nres+j)-xi
3965 !         yj=c(2,nres+j)-yi
3966 !         zj=c(3,nres+j)-zi
3967 ! Uncomment following three lines for Ca-p interactions
3968           xj=c(1,j)-xi
3969           yj=c(2,j)-yi
3970           zj=c(3,j)-zi
3971           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3972           fac=rrij**expon2
3973           e1=fac*fac*aad(itypj,iteli)
3974           e2=fac*bad(itypj,iteli)
3975           if (iabs(j-i) .le. 2) then
3976             e1=scal14*e1
3977             e2=scal14*e2
3978             evdw2_14=evdw2_14+e1+e2
3979           endif
3980           evdwij=e1+e2
3981           evdw2=evdw2+evdwij
3982 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
3983 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
3984           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3985              'evdw2',i,j,evdwij
3986 !
3987 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3988 !
3989           fac=-(evdwij+e1)*rrij
3990           ggg(1)=xj*fac
3991           ggg(2)=yj*fac
3992           ggg(3)=zj*fac
3993 !grad          if (j.lt.i) then
3994 !d          write (iout,*) 'j<i'
3995 ! Uncomment following three lines for SC-p interactions
3996 !           do k=1,3
3997 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3998 !           enddo
3999 !grad          else
4000 !d          write (iout,*) 'j>i'
4001 !grad            do k=1,3
4002 !grad              ggg(k)=-ggg(k)
4003 ! Uncomment following line for SC-p interactions
4004 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4005 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4006 !grad            enddo
4007 !grad          endif
4008 !grad          do k=1,3
4009 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4010 !grad          enddo
4011 !grad          kstart=min0(i+1,j)
4012 !grad          kend=max0(i-1,j-1)
4013 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4014 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4015 !grad          do k=kstart,kend
4016 !grad            do l=1,3
4017 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4018 !grad            enddo
4019 !grad          enddo
4020           do k=1,3
4021             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4022             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4023           enddo
4024         enddo
4025
4026         enddo ! iint
4027       enddo ! i
4028       do i=1,nct
4029         do j=1,3
4030           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4031           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4032           gradx_scp(j,i)=expon*gradx_scp(j,i)
4033         enddo
4034       enddo
4035 !******************************************************************************
4036 !
4037 !                              N O T E !!!
4038 !
4039 ! To save time the factor EXPON has been extracted from ALL components
4040 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4041 ! use!
4042 !
4043 !******************************************************************************
4044       return
4045       end subroutine escp
4046 !-----------------------------------------------------------------------------
4047       subroutine edis(ehpb)
4048 !
4049 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4050 !
4051 !      implicit real*8 (a-h,o-z)
4052 !      include 'DIMENSIONS'
4053 !      include 'COMMON.SBRIDGE'
4054 !      include 'COMMON.CHAIN'
4055 !      include 'COMMON.DERIV'
4056 !      include 'COMMON.VAR'
4057 !      include 'COMMON.INTERACT'
4058 !      include 'COMMON.IOUNITS'
4059       real(kind=8),dimension(3) :: ggg
4060 !el local variables
4061       integer :: i,j,ii,jj,iii,jjj,k
4062       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4063
4064       ehpb=0.0D0
4065 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4066 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4067       if (link_end.eq.0) return
4068       do i=link_start,link_end
4069 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4070 ! CA-CA distance used in regularization of structure.
4071         ii=ihpb(i)
4072         jj=jhpb(i)
4073 ! iii and jjj point to the residues for which the distance is assigned.
4074         if (ii.gt.nres) then
4075           iii=ii-nres
4076           jjj=jj-nres
4077         else
4078           iii=ii
4079           jjj=jj
4080         endif
4081 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4082 !     &    dhpb(i),dhpb1(i),forcon(i)
4083 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4084 !    distance and angle dependent SS bond potential.
4085 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4086 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4087         if (.not.dyn_ss .and. i.le.nss) then
4088 ! 15/02/13 CC dynamic SSbond - additional check
4089          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4090         iabs(itype(jjj)).eq.1) then
4091           call ssbond_ene(iii,jjj,eij)
4092           ehpb=ehpb+2*eij
4093 !d          write (iout,*) "eij",eij
4094          endif
4095         else
4096 ! Calculate the distance between the two points and its difference from the
4097 ! target distance.
4098         dd=dist(ii,jj)
4099         rdis=dd-dhpb(i)
4100 ! Get the force constant corresponding to this distance.
4101         waga=forcon(i)
4102 ! Calculate the contribution to energy.
4103         ehpb=ehpb+waga*rdis*rdis
4104 !
4105 ! Evaluate gradient.
4106 !
4107         fac=waga*rdis/dd
4108 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4109 !d   &   ' waga=',waga,' fac=',fac
4110         do j=1,3
4111           ggg(j)=fac*(c(j,jj)-c(j,ii))
4112         enddo
4113 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4114 ! If this is a SC-SC distance, we need to calculate the contributions to the
4115 ! Cartesian gradient in the SC vectors (ghpbx).
4116         if (iii.lt.ii) then
4117           do j=1,3
4118             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4119             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4120           enddo
4121         endif
4122 !grad        do j=iii,jjj-1
4123 !grad          do k=1,3
4124 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4125 !grad          enddo
4126 !grad        enddo
4127         do k=1,3
4128           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4129           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4130         enddo
4131         endif
4132       enddo
4133       ehpb=0.5D0*ehpb
4134       return
4135       end subroutine edis
4136 !-----------------------------------------------------------------------------
4137       subroutine ssbond_ene(i,j,eij)
4138 !
4139 ! Calculate the distance and angle dependent SS-bond potential energy
4140 ! using a free-energy function derived based on RHF/6-31G** ab initio
4141 ! calculations of diethyl disulfide.
4142 !
4143 ! A. Liwo and U. Kozlowska, 11/24/03
4144 !
4145 !      implicit real*8 (a-h,o-z)
4146 !      include 'DIMENSIONS'
4147 !      include 'COMMON.SBRIDGE'
4148 !      include 'COMMON.CHAIN'
4149 !      include 'COMMON.DERIV'
4150 !      include 'COMMON.LOCAL'
4151 !      include 'COMMON.INTERACT'
4152 !      include 'COMMON.VAR'
4153 !      include 'COMMON.IOUNITS'
4154       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4155 !el local variables
4156       integer :: i,j,itypi,itypj,k
4157       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4158                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4159                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4160                    cosphi,ggk
4161
4162       itypi=iabs(itype(i))
4163       xi=c(1,nres+i)
4164       yi=c(2,nres+i)
4165       zi=c(3,nres+i)
4166       dxi=dc_norm(1,nres+i)
4167       dyi=dc_norm(2,nres+i)
4168       dzi=dc_norm(3,nres+i)
4169 !      dsci_inv=dsc_inv(itypi)
4170       dsci_inv=vbld_inv(nres+i)
4171       itypj=iabs(itype(j))
4172 !      dscj_inv=dsc_inv(itypj)
4173       dscj_inv=vbld_inv(nres+j)
4174       xj=c(1,nres+j)-xi
4175       yj=c(2,nres+j)-yi
4176       zj=c(3,nres+j)-zi
4177       dxj=dc_norm(1,nres+j)
4178       dyj=dc_norm(2,nres+j)
4179       dzj=dc_norm(3,nres+j)
4180       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4181       rij=dsqrt(rrij)
4182       erij(1)=xj*rij
4183       erij(2)=yj*rij
4184       erij(3)=zj*rij
4185       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4186       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4187       om12=dxi*dxj+dyi*dyj+dzi*dzj
4188       do k=1,3
4189         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4190         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4191       enddo
4192       rij=1.0d0/rij
4193       deltad=rij-d0cm
4194       deltat1=1.0d0-om1
4195       deltat2=1.0d0+om2
4196       deltat12=om2-om1+2.0d0
4197       cosphi=om12-om1*om2
4198       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4199         +akct*deltad*deltat12 &
4200         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4201 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4202 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4203 !     &  " deltat12",deltat12," eij",eij
4204       ed=2*akcm*deltad+akct*deltat12
4205       pom1=akct*deltad
4206       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4207       eom1=-2*akth*deltat1-pom1-om2*pom2
4208       eom2= 2*akth*deltat2+pom1-om1*pom2
4209       eom12=pom2
4210       do k=1,3
4211         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4212         ghpbx(k,i)=ghpbx(k,i)-ggk &
4213                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4214                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4215         ghpbx(k,j)=ghpbx(k,j)+ggk &
4216                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4217                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4218         ghpbc(k,i)=ghpbc(k,i)-ggk
4219         ghpbc(k,j)=ghpbc(k,j)+ggk
4220       enddo
4221 !
4222 ! Calculate the components of the gradient in DC and X
4223 !
4224 !grad      do k=i,j-1
4225 !grad        do l=1,3
4226 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4227 !grad        enddo
4228 !grad      enddo
4229       return
4230       end subroutine ssbond_ene
4231 !-----------------------------------------------------------------------------
4232       subroutine ebond(estr)
4233 !
4234 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4235 !
4236 !      implicit real*8 (a-h,o-z)
4237 !      include 'DIMENSIONS'
4238 !      include 'COMMON.LOCAL'
4239 !      include 'COMMON.GEO'
4240 !      include 'COMMON.INTERACT'
4241 !      include 'COMMON.DERIV'
4242 !      include 'COMMON.VAR'
4243 !      include 'COMMON.CHAIN'
4244 !      include 'COMMON.IOUNITS'
4245 !      include 'COMMON.NAMES'
4246 !      include 'COMMON.FFIELD'
4247 !      include 'COMMON.CONTROL'
4248 !      include 'COMMON.SETUP'
4249       real(kind=8),dimension(3) :: u,ud
4250 !el local variables
4251       integer :: i,j,iti,nbi,k
4252       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4253                    uprod1,uprod2
4254
4255       estr=0.0d0
4256       estr1=0.0d0
4257 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4258 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4259
4260       do i=ibondp_start,ibondp_end
4261         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4262         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4263 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4264 !C          do j=1,3
4265 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4266 !C            *dc(j,i-1)/vbld(i)
4267 !C          enddo
4268 !C          if (energy_dec) write(iout,*) &
4269 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4270         diff = vbld(i)-vbldpDUM
4271         else
4272         diff = vbld(i)-vbldp0
4273         endif
4274         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4275            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4276         estr=estr+diff*diff
4277         do j=1,3
4278           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4279         enddo
4280 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4281 !        endif
4282       enddo
4283       estr=0.5d0*AKP*estr+estr1
4284 !
4285 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4286 !
4287       do i=ibond_start,ibond_end
4288         iti=iabs(itype(i))
4289         if (iti.ne.10 .and. iti.ne.ntyp1) then
4290           nbi=nbondterm(iti)
4291           if (nbi.eq.1) then
4292             diff=vbld(i+nres)-vbldsc0(1,iti)
4293             if (energy_dec) write (iout,*) &
4294             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4295             AKSC(1,iti),AKSC(1,iti)*diff*diff
4296             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4297             do j=1,3
4298               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4299             enddo
4300           else
4301             do j=1,nbi
4302               diff=vbld(i+nres)-vbldsc0(j,iti)
4303               ud(j)=aksc(j,iti)*diff
4304               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4305             enddo
4306             uprod=u(1)
4307             do j=2,nbi
4308               uprod=uprod*u(j)
4309             enddo
4310             usum=0.0d0
4311             usumsqder=0.0d0
4312             do j=1,nbi
4313               uprod1=1.0d0
4314               uprod2=1.0d0
4315               do k=1,nbi
4316                 if (k.ne.j) then
4317                   uprod1=uprod1*u(k)
4318                   uprod2=uprod2*u(k)*u(k)
4319                 endif
4320               enddo
4321               usum=usum+uprod1
4322               usumsqder=usumsqder+ud(j)*uprod2
4323             enddo
4324             estr=estr+uprod/usum
4325             do j=1,3
4326              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4327             enddo
4328           endif
4329         endif
4330       enddo
4331       return
4332       end subroutine ebond
4333 #ifdef CRYST_THETA
4334 !-----------------------------------------------------------------------------
4335       subroutine ebend(etheta)
4336 !
4337 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4338 ! angles gamma and its derivatives in consecutive thetas and gammas.
4339 !
4340       use comm_calcthet
4341 !      implicit real*8 (a-h,o-z)
4342 !      include 'DIMENSIONS'
4343 !      include 'COMMON.LOCAL'
4344 !      include 'COMMON.GEO'
4345 !      include 'COMMON.INTERACT'
4346 !      include 'COMMON.DERIV'
4347 !      include 'COMMON.VAR'
4348 !      include 'COMMON.CHAIN'
4349 !      include 'COMMON.IOUNITS'
4350 !      include 'COMMON.NAMES'
4351 !      include 'COMMON.FFIELD'
4352 !      include 'COMMON.CONTROL'
4353 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4354 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4355 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4356 !el      integer :: it
4357 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4358 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4359 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4360 !el local variables
4361       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4362        ichir21,ichir22
4363       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4364        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4365        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4366       real(kind=8),dimension(2) :: y,z
4367
4368       delta=0.02d0*pi
4369 !      time11=dexp(-2*time)
4370 !      time12=1.0d0
4371       etheta=0.0D0
4372 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4373       do i=ithet_start,ithet_end
4374         if (itype(i-1).eq.ntyp1) cycle
4375 ! Zero the energy function and its derivative at 0 or pi.
4376         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4377         it=itype(i-1)
4378         ichir1=isign(1,itype(i-2))
4379         ichir2=isign(1,itype(i))
4380          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4381          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4382          if (itype(i-1).eq.10) then
4383           itype1=isign(10,itype(i-2))
4384           ichir11=isign(1,itype(i-2))
4385           ichir12=isign(1,itype(i-2))
4386           itype2=isign(10,itype(i))
4387           ichir21=isign(1,itype(i))
4388           ichir22=isign(1,itype(i))
4389          endif
4390
4391         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4392 #ifdef OSF
4393           phii=phi(i)
4394           if (phii.ne.phii) phii=150.0
4395 #else
4396           phii=phi(i)
4397 #endif
4398           y(1)=dcos(phii)
4399           y(2)=dsin(phii)
4400         else
4401           y(1)=0.0D0
4402           y(2)=0.0D0
4403         endif
4404         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4405 #ifdef OSF
4406           phii1=phi(i+1)
4407           if (phii1.ne.phii1) phii1=150.0
4408           phii1=pinorm(phii1)
4409           z(1)=cos(phii1)
4410 #else
4411           phii1=phi(i+1)
4412           z(1)=dcos(phii1)
4413 #endif
4414           z(2)=dsin(phii1)
4415         else
4416           z(1)=0.0D0
4417           z(2)=0.0D0
4418         endif
4419 ! Calculate the "mean" value of theta from the part of the distribution
4420 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4421 ! In following comments this theta will be referred to as t_c.
4422         thet_pred_mean=0.0d0
4423         do k=1,2
4424             athetk=athet(k,it,ichir1,ichir2)
4425             bthetk=bthet(k,it,ichir1,ichir2)
4426           if (it.eq.10) then
4427              athetk=athet(k,itype1,ichir11,ichir12)
4428              bthetk=bthet(k,itype2,ichir21,ichir22)
4429           endif
4430          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4431         enddo
4432         dthett=thet_pred_mean*ssd
4433         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4434 ! Derivatives of the "mean" values in gamma1 and gamma2.
4435         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4436                +athet(2,it,ichir1,ichir2)*y(1))*ss
4437         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4438                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4439          if (it.eq.10) then
4440         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4441              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4442         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4443                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4444          endif
4445         if (theta(i).gt.pi-delta) then
4446           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4447                E_tc0)
4448           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4449           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4450           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4451               E_theta)
4452           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4453               E_tc)
4454         else if (theta(i).lt.delta) then
4455           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4456           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4457           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4458               E_theta)
4459           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4460           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4461               E_tc)
4462         else
4463           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4464               E_theta,E_tc)
4465         endif
4466         etheta=etheta+ethetai
4467         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4468             'ebend',i,ethetai
4469         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4470         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4471         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4472       enddo
4473 ! Ufff.... We've done all this!!!
4474       return
4475       end subroutine ebend
4476 !-----------------------------------------------------------------------------
4477       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4478
4479       use comm_calcthet
4480 !      implicit real*8 (a-h,o-z)
4481 !      include 'DIMENSIONS'
4482 !      include 'COMMON.LOCAL'
4483 !      include 'COMMON.IOUNITS'
4484 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4485 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4486 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4487       integer :: i,j,k
4488       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4489 !el      integer :: it
4490 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4491 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4492 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4493 !el local variables
4494       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4495        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4496
4497 ! Calculate the contributions to both Gaussian lobes.
4498 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4499 ! The "polynomial part" of the "standard deviation" of this part of
4500 ! the distribution.
4501         sig=polthet(3,it)
4502         do j=2,0,-1
4503           sig=sig*thet_pred_mean+polthet(j,it)
4504         enddo
4505 ! Derivative of the "interior part" of the "standard deviation of the"
4506 ! gamma-dependent Gaussian lobe in t_c.
4507         sigtc=3*polthet(3,it)
4508         do j=2,1,-1
4509           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4510         enddo
4511         sigtc=sig*sigtc
4512 ! Set the parameters of both Gaussian lobes of the distribution.
4513 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4514         fac=sig*sig+sigc0(it)
4515         sigcsq=fac+fac
4516         sigc=1.0D0/sigcsq
4517 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4518         sigsqtc=-4.0D0*sigcsq*sigtc
4519 !       print *,i,sig,sigtc,sigsqtc
4520 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4521         sigtc=-sigtc/(fac*fac)
4522 ! Following variable is sigma(t_c)**(-2)
4523         sigcsq=sigcsq*sigcsq
4524         sig0i=sig0(it)
4525         sig0inv=1.0D0/sig0i**2
4526         delthec=thetai-thet_pred_mean
4527         delthe0=thetai-theta0i
4528         term1=-0.5D0*sigcsq*delthec*delthec
4529         term2=-0.5D0*sig0inv*delthe0*delthe0
4530 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4531 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4532 ! to the energy (this being the log of the distribution) at the end of energy
4533 ! term evaluation for this virtual-bond angle.
4534         if (term1.gt.term2) then
4535           termm=term1
4536           term2=dexp(term2-termm)
4537           term1=1.0d0
4538         else
4539           termm=term2
4540           term1=dexp(term1-termm)
4541           term2=1.0d0
4542         endif
4543 ! The ratio between the gamma-independent and gamma-dependent lobes of
4544 ! the distribution is a Gaussian function of thet_pred_mean too.
4545         diffak=gthet(2,it)-thet_pred_mean
4546         ratak=diffak/gthet(3,it)**2
4547         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4548 ! Let's differentiate it in thet_pred_mean NOW.
4549         aktc=ak*ratak
4550 ! Now put together the distribution terms to make complete distribution.
4551         termexp=term1+ak*term2
4552         termpre=sigc+ak*sig0i
4553 ! Contribution of the bending energy from this theta is just the -log of
4554 ! the sum of the contributions from the two lobes and the pre-exponential
4555 ! factor. Simple enough, isn't it?
4556         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4557 ! NOW the derivatives!!!
4558 ! 6/6/97 Take into account the deformation.
4559         E_theta=(delthec*sigcsq*term1 &
4560              +ak*delthe0*sig0inv*term2)/termexp
4561         E_tc=((sigtc+aktc*sig0i)/termpre &
4562             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4563              aktc*term2)/termexp)
4564       return
4565       end subroutine theteng
4566 #else
4567 !-----------------------------------------------------------------------------
4568       subroutine ebend(etheta)
4569 !
4570 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4571 ! angles gamma and its derivatives in consecutive thetas and gammas.
4572 ! ab initio-derived potentials from
4573 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4574 !
4575 !      implicit real*8 (a-h,o-z)
4576 !      include 'DIMENSIONS'
4577 !      include 'COMMON.LOCAL'
4578 !      include 'COMMON.GEO'
4579 !      include 'COMMON.INTERACT'
4580 !      include 'COMMON.DERIV'
4581 !      include 'COMMON.VAR'
4582 !      include 'COMMON.CHAIN'
4583 !      include 'COMMON.IOUNITS'
4584 !      include 'COMMON.NAMES'
4585 !      include 'COMMON.FFIELD'
4586 !      include 'COMMON.CONTROL'
4587       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4588       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4589       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4590       logical :: lprn=.false., lprn1=.false.
4591 !el local variables
4592       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4593       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4594       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4595
4596       etheta=0.0D0
4597       do i=ithet_start,ithet_end
4598         if (itype(i-1).eq.ntyp1) cycle
4599         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
4600         if (iabs(itype(i+1)).eq.20) iblock=2
4601         if (iabs(itype(i+1)).ne.20) iblock=1
4602         dethetai=0.0d0
4603         dephii=0.0d0
4604         dephii1=0.0d0
4605         theti2=0.5d0*theta(i)
4606         ityp2=ithetyp((itype(i-1)))
4607         do k=1,nntheterm
4608           coskt(k)=dcos(k*theti2)
4609           sinkt(k)=dsin(k*theti2)
4610         enddo
4611         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4612 #ifdef OSF
4613           phii=phi(i)
4614           if (phii.ne.phii) phii=150.0
4615 #else
4616           phii=phi(i)
4617 #endif
4618           ityp1=ithetyp((itype(i-2)))
4619 ! propagation of chirality for glycine type
4620           do k=1,nsingle
4621             cosph1(k)=dcos(k*phii)
4622             sinph1(k)=dsin(k*phii)
4623           enddo
4624         else
4625           phii=0.0d0
4626           ityp1=ithetyp(itype(i-2))
4627           do k=1,nsingle
4628             cosph1(k)=0.0d0
4629             sinph1(k)=0.0d0
4630           enddo
4631         endif
4632         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4633 #ifdef OSF
4634           phii1=phi(i+1)
4635           if (phii1.ne.phii1) phii1=150.0
4636           phii1=pinorm(phii1)
4637 #else
4638           phii1=phi(i+1)
4639 #endif
4640           ityp3=ithetyp((itype(i)))
4641           do k=1,nsingle
4642             cosph2(k)=dcos(k*phii1)
4643             sinph2(k)=dsin(k*phii1)
4644           enddo
4645         else
4646           phii1=0.0d0
4647           ityp3=ithetyp(itype(i))
4648           do k=1,nsingle
4649             cosph2(k)=0.0d0
4650             sinph2(k)=0.0d0
4651           enddo
4652         endif
4653         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4654         do k=1,ndouble
4655           do l=1,k-1
4656             ccl=cosph1(l)*cosph2(k-l)
4657             ssl=sinph1(l)*sinph2(k-l)
4658             scl=sinph1(l)*cosph2(k-l)
4659             csl=cosph1(l)*sinph2(k-l)
4660             cosph1ph2(l,k)=ccl-ssl
4661             cosph1ph2(k,l)=ccl+ssl
4662             sinph1ph2(l,k)=scl+csl
4663             sinph1ph2(k,l)=scl-csl
4664           enddo
4665         enddo
4666         if (lprn) then
4667         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4668           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4669         write (iout,*) "coskt and sinkt"
4670         do k=1,nntheterm
4671           write (iout,*) k,coskt(k),sinkt(k)
4672         enddo
4673         endif
4674         do k=1,ntheterm
4675           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4676           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4677             *coskt(k)
4678           if (lprn) &
4679           write (iout,*) "k",k,&
4680            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4681            " ethetai",ethetai
4682         enddo
4683         if (lprn) then
4684         write (iout,*) "cosph and sinph"
4685         do k=1,nsingle
4686           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4687         enddo
4688         write (iout,*) "cosph1ph2 and sinph2ph2"
4689         do k=2,ndouble
4690           do l=1,k-1
4691             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4692                sinph1ph2(l,k),sinph1ph2(k,l)
4693           enddo
4694         enddo
4695         write(iout,*) "ethetai",ethetai
4696         endif
4697         do m=1,ntheterm2
4698           do k=1,nsingle
4699             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4700                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4701                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4702                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4703             ethetai=ethetai+sinkt(m)*aux
4704             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4705             dephii=dephii+k*sinkt(m)* &
4706                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4707                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4708             dephii1=dephii1+k*sinkt(m)* &
4709                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4710                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4711             if (lprn) &
4712             write (iout,*) "m",m," k",k," bbthet", &
4713                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4714                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4715                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4716                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4717           enddo
4718         enddo
4719         if (lprn) &
4720         write(iout,*) "ethetai",ethetai
4721         do m=1,ntheterm3
4722           do k=2,ndouble
4723             do l=1,k-1
4724               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4725                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4726                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4727                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4728               ethetai=ethetai+sinkt(m)*aux
4729               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4730               dephii=dephii+l*sinkt(m)* &
4731                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4732                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4733                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4734                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4735               dephii1=dephii1+(k-l)*sinkt(m)* &
4736                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4737                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4738                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4739                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4740               if (lprn) then
4741               write (iout,*) "m",m," k",k," l",l," ffthet",&
4742                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4743                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4744                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4745                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4746                   " ethetai",ethetai
4747               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4748                   cosph1ph2(k,l)*sinkt(m),&
4749                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4750               endif
4751             enddo
4752           enddo
4753         enddo
4754 10      continue
4755 !        lprn1=.true.
4756         if (lprn1) &
4757           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4758          i,theta(i)*rad2deg,phii*rad2deg,&
4759          phii1*rad2deg,ethetai
4760 !        lprn1=.false.
4761         etheta=etheta+ethetai
4762         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4763                                     'ebend',i,ethetai
4764         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4765         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4766         gloc(nphi+i-2,icg)=wang*dethetai
4767       enddo
4768       return
4769       end subroutine ebend
4770 #endif
4771 #ifdef CRYST_SC
4772 !-----------------------------------------------------------------------------
4773       subroutine esc(escloc)
4774 ! Calculate the local energy of a side chain and its derivatives in the
4775 ! corresponding virtual-bond valence angles THETA and the spherical angles
4776 ! ALPHA and OMEGA.
4777 !
4778       use comm_sccalc
4779 !      implicit real*8 (a-h,o-z)
4780 !      include 'DIMENSIONS'
4781 !      include 'COMMON.GEO'
4782 !      include 'COMMON.LOCAL'
4783 !      include 'COMMON.VAR'
4784 !      include 'COMMON.INTERACT'
4785 !      include 'COMMON.DERIV'
4786 !      include 'COMMON.CHAIN'
4787 !      include 'COMMON.IOUNITS'
4788 !      include 'COMMON.NAMES'
4789 !      include 'COMMON.FFIELD'
4790 !      include 'COMMON.CONTROL'
4791       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4792          ddersc0,ddummy,xtemp,temp
4793 !el      real(kind=8) :: time11,time12,time112,theti
4794       real(kind=8) :: escloc,delta
4795 !el      integer :: it,nlobit
4796 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4797 !el local variables
4798       integer :: i,k
4799       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4800        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4801       delta=0.02d0*pi
4802       escloc=0.0D0
4803 !     write (iout,'(a)') 'ESC'
4804       do i=loc_start,loc_end
4805         it=itype(i)
4806         if (it.eq.ntyp1) cycle
4807         if (it.eq.10) goto 1
4808         nlobit=nlob(iabs(it))
4809 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4810 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4811         theti=theta(i+1)-pipol
4812         x(1)=dtan(theti)
4813         x(2)=alph(i)
4814         x(3)=omeg(i)
4815
4816         if (x(2).gt.pi-delta) then
4817           xtemp(1)=x(1)
4818           xtemp(2)=pi-delta
4819           xtemp(3)=x(3)
4820           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4821           xtemp(2)=pi
4822           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4823           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4824               escloci,dersc(2))
4825           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4826               ddersc0(1),dersc(1))
4827           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4828               ddersc0(3),dersc(3))
4829           xtemp(2)=pi-delta
4830           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4831           xtemp(2)=pi
4832           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4833           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4834                   dersc0(2),esclocbi,dersc02)
4835           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4836                   dersc12,dersc01)
4837           call splinthet(x(2),0.5d0*delta,ss,ssd)
4838           dersc0(1)=dersc01
4839           dersc0(2)=dersc02
4840           dersc0(3)=0.0d0
4841           do k=1,3
4842             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4843           enddo
4844           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4845 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4846 !    &             esclocbi,ss,ssd
4847           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4848 !         escloci=esclocbi
4849 !         write (iout,*) escloci
4850         else if (x(2).lt.delta) then
4851           xtemp(1)=x(1)
4852           xtemp(2)=delta
4853           xtemp(3)=x(3)
4854           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4855           xtemp(2)=0.0d0
4856           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4857           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4858               escloci,dersc(2))
4859           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4860               ddersc0(1),dersc(1))
4861           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4862               ddersc0(3),dersc(3))
4863           xtemp(2)=delta
4864           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4865           xtemp(2)=0.0d0
4866           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4867           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4868                   dersc0(2),esclocbi,dersc02)
4869           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4870                   dersc12,dersc01)
4871           dersc0(1)=dersc01
4872           dersc0(2)=dersc02
4873           dersc0(3)=0.0d0
4874           call splinthet(x(2),0.5d0*delta,ss,ssd)
4875           do k=1,3
4876             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4877           enddo
4878           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4879 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4880 !    &             esclocbi,ss,ssd
4881           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4882 !         write (iout,*) escloci
4883         else
4884           call enesc(x,escloci,dersc,ddummy,.false.)
4885         endif
4886
4887         escloc=escloc+escloci
4888         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4889            'escloc',i,escloci
4890 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4891
4892         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
4893          wscloc*dersc(1)
4894         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4895         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4896     1   continue
4897       enddo
4898       return
4899       end subroutine esc
4900 !-----------------------------------------------------------------------------
4901       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4902
4903       use comm_sccalc
4904 !      implicit real*8 (a-h,o-z)
4905 !      include 'DIMENSIONS'
4906 !      include 'COMMON.GEO'
4907 !      include 'COMMON.LOCAL'
4908 !      include 'COMMON.IOUNITS'
4909 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4910       real(kind=8),dimension(3) :: x,z,dersc,ddersc
4911       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
4912       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
4913       real(kind=8) :: escloci
4914       logical :: mixed
4915 !el local variables
4916       integer :: j,iii,l,k !el,it,nlobit
4917       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
4918 !el       time11,time12,time112
4919 !       write (iout,*) 'it=',it,' nlobit=',nlobit
4920         escloc_i=0.0D0
4921         do j=1,3
4922           dersc(j)=0.0D0
4923           if (mixed) ddersc(j)=0.0d0
4924         enddo
4925         x3=x(3)
4926
4927 ! Because of periodicity of the dependence of the SC energy in omega we have
4928 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4929 ! To avoid underflows, first compute & store the exponents.
4930
4931         do iii=-1,1
4932
4933           x(3)=x3+iii*dwapi
4934
4935           do j=1,nlobit
4936             do k=1,3
4937               z(k)=x(k)-censc(k,j,it)
4938             enddo
4939             do k=1,3
4940               Axk=0.0D0
4941               do l=1,3
4942                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4943               enddo
4944               Ax(k,j,iii)=Axk
4945             enddo
4946             expfac=0.0D0
4947             do k=1,3
4948               expfac=expfac+Ax(k,j,iii)*z(k)
4949             enddo
4950             contr(j,iii)=expfac
4951           enddo ! j
4952
4953         enddo ! iii
4954
4955         x(3)=x3
4956 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4957 ! subsequent NaNs and INFs in energy calculation.
4958 ! Find the largest exponent
4959         emin=contr(1,-1)
4960         do iii=-1,1
4961           do j=1,nlobit
4962             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4963           enddo
4964         enddo
4965         emin=0.5D0*emin
4966 !d      print *,'it=',it,' emin=',emin
4967
4968 ! Compute the contribution to SC energy and derivatives
4969         do iii=-1,1
4970
4971           do j=1,nlobit
4972 #ifdef OSF
4973             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4974             if(adexp.ne.adexp) adexp=1.0
4975             expfac=dexp(adexp)
4976 #else
4977             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4978 #endif
4979 !d          print *,'j=',j,' expfac=',expfac
4980             escloc_i=escloc_i+expfac
4981             do k=1,3
4982               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4983             enddo
4984             if (mixed) then
4985               do k=1,3,2
4986                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
4987                   +gaussc(k,2,j,it))*expfac
4988               enddo
4989             endif
4990           enddo
4991
4992         enddo ! iii
4993
4994         dersc(1)=dersc(1)/cos(theti)**2
4995         ddersc(1)=ddersc(1)/cos(theti)**2
4996         ddersc(3)=ddersc(3)
4997
4998         escloci=-(dlog(escloc_i)-emin)
4999         do j=1,3
5000           dersc(j)=dersc(j)/escloc_i
5001         enddo
5002         if (mixed) then
5003           do j=1,3,2
5004             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5005           enddo
5006         endif
5007       return
5008       end subroutine enesc
5009 !-----------------------------------------------------------------------------
5010       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5011
5012       use comm_sccalc
5013 !      implicit real*8 (a-h,o-z)
5014 !      include 'DIMENSIONS'
5015 !      include 'COMMON.GEO'
5016 !      include 'COMMON.LOCAL'
5017 !      include 'COMMON.IOUNITS'
5018 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5019       real(kind=8),dimension(3) :: x,z,dersc
5020       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5021       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5022       real(kind=8) :: escloci,dersc12,emin
5023       logical :: mixed
5024 !el local varables
5025       integer :: j,k,l !el,it,nlobit
5026       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5027
5028       escloc_i=0.0D0
5029
5030       do j=1,3
5031         dersc(j)=0.0D0
5032       enddo
5033
5034       do j=1,nlobit
5035         do k=1,2
5036           z(k)=x(k)-censc(k,j,it)
5037         enddo
5038         z(3)=dwapi
5039         do k=1,3
5040           Axk=0.0D0
5041           do l=1,3
5042             Axk=Axk+gaussc(l,k,j,it)*z(l)
5043           enddo
5044           Ax(k,j)=Axk
5045         enddo
5046         expfac=0.0D0
5047         do k=1,3
5048           expfac=expfac+Ax(k,j)*z(k)
5049         enddo
5050         contr(j)=expfac
5051       enddo ! j
5052
5053 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5054 ! subsequent NaNs and INFs in energy calculation.
5055 ! Find the largest exponent
5056       emin=contr(1)
5057       do j=1,nlobit
5058         if (emin.gt.contr(j)) emin=contr(j)
5059       enddo
5060       emin=0.5D0*emin
5061
5062 ! Compute the contribution to SC energy and derivatives
5063
5064       dersc12=0.0d0
5065       do j=1,nlobit
5066         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5067         escloc_i=escloc_i+expfac
5068         do k=1,2
5069           dersc(k)=dersc(k)+Ax(k,j)*expfac
5070         enddo
5071         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5072                   +gaussc(1,2,j,it))*expfac
5073         dersc(3)=0.0d0
5074       enddo
5075
5076       dersc(1)=dersc(1)/cos(theti)**2
5077       dersc12=dersc12/cos(theti)**2
5078       escloci=-(dlog(escloc_i)-emin)
5079       do j=1,2
5080         dersc(j)=dersc(j)/escloc_i
5081       enddo
5082       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5083       return
5084       end subroutine enesc_bound
5085 #else
5086 !-----------------------------------------------------------------------------
5087       subroutine esc(escloc)
5088 ! Calculate the local energy of a side chain and its derivatives in the
5089 ! corresponding virtual-bond valence angles THETA and the spherical angles
5090 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5091 ! added by Urszula Kozlowska. 07/11/2007
5092 !
5093       use comm_sccalc
5094 !      implicit real*8 (a-h,o-z)
5095 !      include 'DIMENSIONS'
5096 !      include 'COMMON.GEO'
5097 !      include 'COMMON.LOCAL'
5098 !      include 'COMMON.VAR'
5099 !      include 'COMMON.SCROT'
5100 !      include 'COMMON.INTERACT'
5101 !      include 'COMMON.DERIV'
5102 !      include 'COMMON.CHAIN'
5103 !      include 'COMMON.IOUNITS'
5104 !      include 'COMMON.NAMES'
5105 !      include 'COMMON.FFIELD'
5106 !      include 'COMMON.CONTROL'
5107 !      include 'COMMON.VECTORS'
5108       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5109       real(kind=8),dimension(65) :: x
5110       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5111          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5112       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5113       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5114          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5115 !el local variables
5116       integer :: i,j,k !el,it,nlobit
5117       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5118 !el      real(kind=8) :: time11,time12,time112,theti
5119 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5120       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5121                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5122                    sumene1x,sumene2x,sumene3x,sumene4x,&
5123                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5124                    cosfac2xx,sinfac2yy
5125 #ifdef DEBUG
5126       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5127                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5128                    de_dt_num
5129 #endif
5130 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5131
5132       delta=0.02d0*pi
5133       escloc=0.0D0
5134       do i=loc_start,loc_end
5135         if (itype(i).eq.ntyp1) cycle
5136         costtab(i+1) =dcos(theta(i+1))
5137         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5138         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5139         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5140         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5141         cosfac=dsqrt(cosfac2)
5142         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5143         sinfac=dsqrt(sinfac2)
5144         it=iabs(itype(i))
5145         if (it.eq.10) goto 1
5146 !
5147 !  Compute the axes of tghe local cartesian coordinates system; store in
5148 !   x_prime, y_prime and z_prime
5149 !
5150         do j=1,3
5151           x_prime(j) = 0.00
5152           y_prime(j) = 0.00
5153           z_prime(j) = 0.00
5154         enddo
5155 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5156 !     &   dc_norm(3,i+nres)
5157         do j = 1,3
5158           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5159           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5160         enddo
5161         do j = 1,3
5162           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5163         enddo
5164 !       write (2,*) "i",i
5165 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5166 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5167 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5168 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5169 !      & " xy",scalar(x_prime(1),y_prime(1)),
5170 !      & " xz",scalar(x_prime(1),z_prime(1)),
5171 !      & " yy",scalar(y_prime(1),y_prime(1)),
5172 !      & " yz",scalar(y_prime(1),z_prime(1)),
5173 !      & " zz",scalar(z_prime(1),z_prime(1))
5174 !
5175 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5176 ! to local coordinate system. Store in xx, yy, zz.
5177 !
5178         xx=0.0d0
5179         yy=0.0d0
5180         zz=0.0d0
5181         do j = 1,3
5182           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5183           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5184           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5185         enddo
5186
5187         xxtab(i)=xx
5188         yytab(i)=yy
5189         zztab(i)=zz
5190 !
5191 ! Compute the energy of the ith side cbain
5192 !
5193 !        write (2,*) "xx",xx," yy",yy," zz",zz
5194         it=iabs(itype(i))
5195         do j = 1,65
5196           x(j) = sc_parmin(j,it)
5197         enddo
5198 #ifdef CHECK_COORD
5199 !c diagnostics - remove later
5200         xx1 = dcos(alph(2))
5201         yy1 = dsin(alph(2))*dcos(omeg(2))
5202         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5203         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5204           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5205           xx1,yy1,zz1
5206 !,"  --- ", xx_w,yy_w,zz_w
5207 ! end diagnostics
5208 #endif
5209         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5210          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5211          + x(10)*yy*zz
5212         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5213          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5214          + x(20)*yy*zz
5215         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5216          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5217          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5218          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5219          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5220          +x(40)*xx*yy*zz
5221         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5222          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5223          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5224          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5225          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5226          +x(60)*xx*yy*zz
5227         dsc_i   = 0.743d0+x(61)
5228         dp2_i   = 1.9d0+x(62)
5229         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5230                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5231         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5232                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5233         s1=(1+x(63))/(0.1d0 + dscp1)
5234         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5235         s2=(1+x(65))/(0.1d0 + dscp2)
5236         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5237         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5238       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5239 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5240 !     &   sumene4,
5241 !     &   dscp1,dscp2,sumene
5242 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5243         escloc = escloc + sumene
5244 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5245 !     & ,zz,xx,yy
5246 !#define DEBUG
5247 #ifdef DEBUG
5248 !
5249 ! This section to check the numerical derivatives of the energy of ith side
5250 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5251 ! #define DEBUG in the code to turn it on.
5252 !
5253         write (2,*) "sumene               =",sumene
5254         aincr=1.0d-7
5255         xxsave=xx
5256         xx=xx+aincr
5257         write (2,*) xx,yy,zz
5258         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5259         de_dxx_num=(sumenep-sumene)/aincr
5260         xx=xxsave
5261         write (2,*) "xx+ sumene from enesc=",sumenep
5262         yysave=yy
5263         yy=yy+aincr
5264         write (2,*) xx,yy,zz
5265         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5266         de_dyy_num=(sumenep-sumene)/aincr
5267         yy=yysave
5268         write (2,*) "yy+ sumene from enesc=",sumenep
5269         zzsave=zz
5270         zz=zz+aincr
5271         write (2,*) xx,yy,zz
5272         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5273         de_dzz_num=(sumenep-sumene)/aincr
5274         zz=zzsave
5275         write (2,*) "zz+ sumene from enesc=",sumenep
5276         costsave=cost2tab(i+1)
5277         sintsave=sint2tab(i+1)
5278         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5279         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5280         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5281         de_dt_num=(sumenep-sumene)/aincr
5282         write (2,*) " t+ sumene from enesc=",sumenep
5283         cost2tab(i+1)=costsave
5284         sint2tab(i+1)=sintsave
5285 ! End of diagnostics section.
5286 #endif
5287 !
5288 ! Compute the gradient of esc
5289 !
5290 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5291         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5292         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5293         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5294         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5295         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5296         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5297         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5298         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5299         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5300            *(pom_s1/dscp1+pom_s16*dscp1**4)
5301         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5302            *(pom_s2/dscp2+pom_s26*dscp2**4)
5303         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5304         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5305         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5306         +x(40)*yy*zz
5307         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5308         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5309         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5310         +x(60)*yy*zz
5311         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5312               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5313               +(pom1+pom2)*pom_dx
5314 #ifdef DEBUG
5315         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5316 #endif
5317 !
5318         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5319         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5320         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5321         +x(40)*xx*zz
5322         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5323         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5324         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5325         +x(59)*zz**2 +x(60)*xx*zz
5326         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5327               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5328               +(pom1-pom2)*pom_dy
5329 #ifdef DEBUG
5330         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5331 #endif
5332 !
5333         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5334         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5335         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5336         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5337         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5338         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5339         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5340         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5341 #ifdef DEBUG
5342         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5343 #endif
5344 !
5345         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5346         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5347         +pom1*pom_dt1+pom2*pom_dt2
5348 #ifdef DEBUG
5349         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5350 #endif
5351 !
5352 !
5353        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5354        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5355        cosfac2xx=cosfac2*xx
5356        sinfac2yy=sinfac2*yy
5357        do k = 1,3
5358          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5359             vbld_inv(i+1)
5360          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5361             vbld_inv(i)
5362          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5363          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5364 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5365 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5366 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5367 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5368          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5369          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5370          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5371          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5372          dZZ_Ci1(k)=0.0d0
5373          dZZ_Ci(k)=0.0d0
5374          do j=1,3
5375            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5376            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5377            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5378            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5379          enddo
5380
5381          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5382          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5383          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5384          (z_prime(k)-zz*dC_norm(k,i+nres))
5385 !
5386          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5387          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5388        enddo
5389
5390        do k=1,3
5391          dXX_Ctab(k,i)=dXX_Ci(k)
5392          dXX_C1tab(k,i)=dXX_Ci1(k)
5393          dYY_Ctab(k,i)=dYY_Ci(k)
5394          dYY_C1tab(k,i)=dYY_Ci1(k)
5395          dZZ_Ctab(k,i)=dZZ_Ci(k)
5396          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5397          dXX_XYZtab(k,i)=dXX_XYZ(k)
5398          dYY_XYZtab(k,i)=dYY_XYZ(k)
5399          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5400        enddo
5401
5402        do k = 1,3
5403 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5404 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5405 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5406 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5407 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5408 !     &    dt_dci(k)
5409 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5410 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5411          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5412           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5413          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5414           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5415          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5416           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5417        enddo
5418 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5419 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5420
5421 ! to check gradient call subroutine check_grad
5422
5423     1 continue
5424       enddo
5425       return
5426       end subroutine esc
5427 !-----------------------------------------------------------------------------
5428       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5429 !      implicit none
5430       real(kind=8),dimension(65) :: x
5431       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5432         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5433
5434       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5435         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5436         + x(10)*yy*zz
5437       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5438         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5439         + x(20)*yy*zz
5440       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5441         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5442         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5443         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5444         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5445         +x(40)*xx*yy*zz
5446       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5447         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5448         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5449         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5450         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5451         +x(60)*xx*yy*zz
5452       dsc_i   = 0.743d0+x(61)
5453       dp2_i   = 1.9d0+x(62)
5454       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5455                 *(xx*cost2+yy*sint2))
5456       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5457                 *(xx*cost2-yy*sint2))
5458       s1=(1+x(63))/(0.1d0 + dscp1)
5459       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5460       s2=(1+x(65))/(0.1d0 + dscp2)
5461       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5462       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5463        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5464       enesc=sumene
5465       return
5466       end function enesc
5467 #endif
5468 !-----------------------------------------------------------------------------
5469       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5470 !
5471 ! This procedure calculates two-body contact function g(rij) and its derivative:
5472 !
5473 !           eps0ij                                     !       x < -1
5474 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5475 !            0                                         !       x > 1
5476 !
5477 ! where x=(rij-r0ij)/delta
5478 !
5479 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5480 !
5481 !      implicit none
5482       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5483       real(kind=8) :: x,x2,x4,delta
5484 !     delta=0.02D0*r0ij
5485 !      delta=0.2D0*r0ij
5486       x=(rij-r0ij)/delta
5487       if (x.lt.-1.0D0) then
5488         fcont=eps0ij
5489         fprimcont=0.0D0
5490       else if (x.le.1.0D0) then
5491         x2=x*x
5492         x4=x2*x2
5493         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5494         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5495       else
5496         fcont=0.0D0
5497         fprimcont=0.0D0
5498       endif
5499       return
5500       end subroutine gcont
5501 !-----------------------------------------------------------------------------
5502       subroutine splinthet(theti,delta,ss,ssder)
5503 !      implicit real*8 (a-h,o-z)
5504 !      include 'DIMENSIONS'
5505 !      include 'COMMON.VAR'
5506 !      include 'COMMON.GEO'
5507       real(kind=8) :: theti,delta,ss,ssder
5508       real(kind=8) :: thetup,thetlow
5509       thetup=pi-delta
5510       thetlow=delta
5511       if (theti.gt.pipol) then
5512         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5513       else
5514         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5515         ssder=-ssder
5516       endif
5517       return
5518       end subroutine splinthet
5519 !-----------------------------------------------------------------------------
5520       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5521 !      implicit none
5522       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5523       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5524       a1=fprim0*delta/(f1-f0)
5525       a2=3.0d0-2.0d0*a1
5526       a3=a1-2.0d0
5527       ksi=(x-x0)/delta
5528       ksi2=ksi*ksi
5529       ksi3=ksi2*ksi
5530       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5531       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5532       return
5533       end subroutine spline1
5534 !-----------------------------------------------------------------------------
5535       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5536 !      implicit none
5537       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5538       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5539       ksi=(x-x0)/delta
5540       ksi2=ksi*ksi
5541       ksi3=ksi2*ksi
5542       a1=fprim0x*delta
5543       a2=3*(f1x-f0x)-2*fprim0x*delta
5544       a3=fprim0x*delta-2*(f1x-f0x)
5545       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5546       return
5547       end subroutine spline2
5548 !-----------------------------------------------------------------------------
5549 #ifdef CRYST_TOR
5550 !-----------------------------------------------------------------------------
5551       subroutine etor(etors,edihcnstr)
5552 !      implicit real*8 (a-h,o-z)
5553 !      include 'DIMENSIONS'
5554 !      include 'COMMON.VAR'
5555 !      include 'COMMON.GEO'
5556 !      include 'COMMON.LOCAL'
5557 !      include 'COMMON.TORSION'
5558 !      include 'COMMON.INTERACT'
5559 !      include 'COMMON.DERIV'
5560 !      include 'COMMON.CHAIN'
5561 !      include 'COMMON.NAMES'
5562 !      include 'COMMON.IOUNITS'
5563 !      include 'COMMON.FFIELD'
5564 !      include 'COMMON.TORCNSTR'
5565 !      include 'COMMON.CONTROL'
5566       real(kind=8) :: etors,edihcnstr
5567       logical :: lprn
5568 !el local variables
5569       integer :: i,j,
5570       real(kind=8) :: phii,fac,etors_ii
5571
5572 ! Set lprn=.true. for debugging
5573       lprn=.false.
5574 !      lprn=.true.
5575       etors=0.0D0
5576       do i=iphi_start,iphi_end
5577       etors_ii=0.0D0
5578         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5579             .or. itype(i).eq.ntyp1) cycle
5580         itori=itortyp(itype(i-2))
5581         itori1=itortyp(itype(i-1))
5582         phii=phi(i)
5583         gloci=0.0D0
5584 ! Proline-Proline pair is a special case...
5585         if (itori.eq.3 .and. itori1.eq.3) then
5586           if (phii.gt.-dwapi3) then
5587             cosphi=dcos(3*phii)
5588             fac=1.0D0/(1.0D0-cosphi)
5589             etorsi=v1(1,3,3)*fac
5590             etorsi=etorsi+etorsi
5591             etors=etors+etorsi-v1(1,3,3)
5592             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5593             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5594           endif
5595           do j=1,3
5596             v1ij=v1(j+1,itori,itori1)
5597             v2ij=v2(j+1,itori,itori1)
5598             cosphi=dcos(j*phii)
5599             sinphi=dsin(j*phii)
5600             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5601             if (energy_dec) etors_ii=etors_ii+ &
5602                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5603             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5604           enddo
5605         else
5606           do j=1,nterm_old
5607             v1ij=v1(j,itori,itori1)
5608             v2ij=v2(j,itori,itori1)
5609             cosphi=dcos(j*phii)
5610             sinphi=dsin(j*phii)
5611             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5612             if (energy_dec) etors_ii=etors_ii+ &
5613                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5614             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5615           enddo
5616         endif
5617         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5618              'etor',i,etors_ii
5619         if (lprn) &
5620         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5621         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5622         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5623         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5624 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5625       enddo
5626 ! 6/20/98 - dihedral angle constraints
5627       edihcnstr=0.0d0
5628       do i=1,ndih_constr
5629         itori=idih_constr(i)
5630         phii=phi(itori)
5631         difi=phii-phi0(i)
5632         if (difi.gt.drange(i)) then
5633           difi=difi-drange(i)
5634           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5635           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5636         else if (difi.lt.-drange(i)) then
5637           difi=difi+drange(i)
5638           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5639           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5640         endif
5641 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5642 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5643       enddo
5644 !      write (iout,*) 'edihcnstr',edihcnstr
5645       return
5646       end subroutine etor
5647 !-----------------------------------------------------------------------------
5648       subroutine etor_d(etors_d)
5649       real(kind=8) :: etors_d
5650       etors_d=0.0d0
5651       return
5652       end subroutine etor_d
5653 #else
5654 !-----------------------------------------------------------------------------
5655       subroutine etor(etors,edihcnstr)
5656 !      implicit real*8 (a-h,o-z)
5657 !      include 'DIMENSIONS'
5658 !      include 'COMMON.VAR'
5659 !      include 'COMMON.GEO'
5660 !      include 'COMMON.LOCAL'
5661 !      include 'COMMON.TORSION'
5662 !      include 'COMMON.INTERACT'
5663 !      include 'COMMON.DERIV'
5664 !      include 'COMMON.CHAIN'
5665 !      include 'COMMON.NAMES'
5666 !      include 'COMMON.IOUNITS'
5667 !      include 'COMMON.FFIELD'
5668 !      include 'COMMON.TORCNSTR'
5669 !      include 'COMMON.CONTROL'
5670       real(kind=8) :: etors,edihcnstr
5671       logical :: lprn
5672 !el local variables
5673       integer :: i,j,iblock,itori,itori1
5674       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5675                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5676 ! Set lprn=.true. for debugging
5677       lprn=.false.
5678 !     lprn=.true.
5679       etors=0.0D0
5680       do i=iphi_start,iphi_end
5681         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5682              .or. itype(i-3).eq.ntyp1 &
5683              .or. itype(i).eq.ntyp1) cycle
5684         etors_ii=0.0D0
5685          if (iabs(itype(i)).eq.20) then
5686          iblock=2
5687          else
5688          iblock=1
5689          endif
5690         itori=itortyp(itype(i-2))
5691         itori1=itortyp(itype(i-1))
5692         phii=phi(i)
5693         gloci=0.0D0
5694 ! Regular cosine and sine terms
5695         do j=1,nterm(itori,itori1,iblock)
5696           v1ij=v1(j,itori,itori1,iblock)
5697           v2ij=v2(j,itori,itori1,iblock)
5698           cosphi=dcos(j*phii)
5699           sinphi=dsin(j*phii)
5700           etors=etors+v1ij*cosphi+v2ij*sinphi
5701           if (energy_dec) etors_ii=etors_ii+ &
5702                      v1ij*cosphi+v2ij*sinphi
5703           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5704         enddo
5705 ! Lorentz terms
5706 !                         v1
5707 !  E = SUM ----------------------------------- - v1
5708 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5709 !
5710         cosphi=dcos(0.5d0*phii)
5711         sinphi=dsin(0.5d0*phii)
5712         do j=1,nlor(itori,itori1,iblock)
5713           vl1ij=vlor1(j,itori,itori1)
5714           vl2ij=vlor2(j,itori,itori1)
5715           vl3ij=vlor3(j,itori,itori1)
5716           pom=vl2ij*cosphi+vl3ij*sinphi
5717           pom1=1.0d0/(pom*pom+1.0d0)
5718           etors=etors+vl1ij*pom1
5719           if (energy_dec) etors_ii=etors_ii+ &
5720                      vl1ij*pom1
5721           pom=-pom*pom1*pom1
5722           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5723         enddo
5724 ! Subtract the constant term
5725         etors=etors-v0(itori,itori1,iblock)
5726           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5727                'etor',i,etors_ii-v0(itori,itori1,iblock)
5728         if (lprn) &
5729         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5730         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5731         (v1(j,itori,itori1,iblock),j=1,6),&
5732         (v2(j,itori,itori1,iblock),j=1,6)
5733         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5734 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5735       enddo
5736 ! 6/20/98 - dihedral angle constraints
5737       edihcnstr=0.0d0
5738 !      do i=1,ndih_constr
5739       do i=idihconstr_start,idihconstr_end
5740         itori=idih_constr(i)
5741         phii=phi(itori)
5742         difi=pinorm(phii-phi0(i))
5743         if (difi.gt.drange(i)) then
5744           difi=difi-drange(i)
5745           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5746           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5747         else if (difi.lt.-drange(i)) then
5748           difi=difi+drange(i)
5749           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5750           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5751         else
5752           difi=0.0
5753         endif
5754 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5755 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5756 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5757       enddo
5758 !d       write (iout,*) 'edihcnstr',edihcnstr
5759       return
5760       end subroutine etor
5761 !-----------------------------------------------------------------------------
5762       subroutine etor_d(etors_d)
5763 ! 6/23/01 Compute double torsional energy
5764 !      implicit real*8 (a-h,o-z)
5765 !      include 'DIMENSIONS'
5766 !      include 'COMMON.VAR'
5767 !      include 'COMMON.GEO'
5768 !      include 'COMMON.LOCAL'
5769 !      include 'COMMON.TORSION'
5770 !      include 'COMMON.INTERACT'
5771 !      include 'COMMON.DERIV'
5772 !      include 'COMMON.CHAIN'
5773 !      include 'COMMON.NAMES'
5774 !      include 'COMMON.IOUNITS'
5775 !      include 'COMMON.FFIELD'
5776 !      include 'COMMON.TORCNSTR'
5777       real(kind=8) :: etors_d,etors_d_ii
5778       logical :: lprn
5779 !el local variables
5780       integer :: i,j,k,l,itori,itori1,itori2,iblock
5781       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5782                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5783                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5784                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5785 ! Set lprn=.true. for debugging
5786       lprn=.false.
5787 !     lprn=.true.
5788       etors_d=0.0D0
5789 !      write(iout,*) "a tu??"
5790       do i=iphid_start,iphid_end
5791         etors_d_ii=0.0D0
5792         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5793             .or. itype(i-3).eq.ntyp1 &
5794             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5795         itori=itortyp(itype(i-2))
5796         itori1=itortyp(itype(i-1))
5797         itori2=itortyp(itype(i))
5798         phii=phi(i)
5799         phii1=phi(i+1)
5800         gloci1=0.0D0
5801         gloci2=0.0D0
5802         iblock=1
5803         if (iabs(itype(i+1)).eq.20) iblock=2
5804
5805 ! Regular cosine and sine terms
5806         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5807           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5808           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5809           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5810           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5811           cosphi1=dcos(j*phii)
5812           sinphi1=dsin(j*phii)
5813           cosphi2=dcos(j*phii1)
5814           sinphi2=dsin(j*phii1)
5815           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5816            v2cij*cosphi2+v2sij*sinphi2
5817           if (energy_dec) etors_d_ii=etors_d_ii+ &
5818            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5819           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5820           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5821         enddo
5822         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5823           do l=1,k-1
5824             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5825             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5826             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5827             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5828             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5829             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5830             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5831             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5832             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5833               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5834             if (energy_dec) etors_d_ii=etors_d_ii+ &
5835               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5836               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5837             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5838               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5839             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5840               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5841           enddo
5842         enddo
5843         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5844                             'etor_d',i,etors_d_ii
5845         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5846         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5847       enddo
5848       return
5849       end subroutine etor_d
5850 #endif
5851 !-----------------------------------------------------------------------------
5852       subroutine eback_sc_corr(esccor)
5853 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5854 !        conformational states; temporarily implemented as differences
5855 !        between UNRES torsional potentials (dependent on three types of
5856 !        residues) and the torsional potentials dependent on all 20 types
5857 !        of residues computed from AM1  energy surfaces of terminally-blocked
5858 !        amino-acid residues.
5859 !      implicit real*8 (a-h,o-z)
5860 !      include 'DIMENSIONS'
5861 !      include 'COMMON.VAR'
5862 !      include 'COMMON.GEO'
5863 !      include 'COMMON.LOCAL'
5864 !      include 'COMMON.TORSION'
5865 !      include 'COMMON.SCCOR'
5866 !      include 'COMMON.INTERACT'
5867 !      include 'COMMON.DERIV'
5868 !      include 'COMMON.CHAIN'
5869 !      include 'COMMON.NAMES'
5870 !      include 'COMMON.IOUNITS'
5871 !      include 'COMMON.FFIELD'
5872 !      include 'COMMON.CONTROL'
5873       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5874                    cosphi,sinphi
5875       logical :: lprn
5876       integer :: i,interty,j,isccori,isccori1,intertyp
5877 ! Set lprn=.true. for debugging
5878       lprn=.false.
5879 !      lprn=.true.
5880 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5881       esccor=0.0D0
5882       do i=itau_start,itau_end
5883         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5884         esccor_ii=0.0D0
5885         isccori=isccortyp(itype(i-2))
5886         isccori1=isccortyp(itype(i-1))
5887
5888 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5889         phii=phi(i)
5890         do intertyp=1,3 !intertyp
5891          esccor_ii=0.0D0
5892 !c Added 09 May 2012 (Adasko)
5893 !c  Intertyp means interaction type of backbone mainchain correlation:
5894 !   1 = SC...Ca...Ca...Ca
5895 !   2 = Ca...Ca...Ca...SC
5896 !   3 = SC...Ca...Ca...SCi
5897         gloci=0.0D0
5898         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5899             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5900             (itype(i-1).eq.ntyp1))) &
5901           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5902            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5903            .or.(itype(i).eq.ntyp1))) &
5904           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5905             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5906             (itype(i-3).eq.ntyp1)))) cycle
5907         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5908         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5909        cycle
5910        do j=1,nterm_sccor(isccori,isccori1)
5911           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5912           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5913           cosphi=dcos(j*tauangle(intertyp,i))
5914           sinphi=dsin(j*tauangle(intertyp,i))
5915           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5916           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5917           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5918         enddo
5919         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
5920                                 'esccor',i,intertyp,esccor_ii
5921 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5922         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5923         if (lprn) &
5924         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5925         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5926         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5927         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5928         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5929        enddo !intertyp
5930       enddo
5931
5932       return
5933       end subroutine eback_sc_corr
5934 !-----------------------------------------------------------------------------
5935       subroutine multibody(ecorr)
5936 ! This subroutine calculates multi-body contributions to energy following
5937 ! the idea of Skolnick et al. If side chains I and J make a contact and
5938 ! at the same time side chains I+1 and J+1 make a contact, an extra
5939 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5940 !      implicit real*8 (a-h,o-z)
5941 !      include 'DIMENSIONS'
5942 !      include 'COMMON.IOUNITS'
5943 !      include 'COMMON.DERIV'
5944 !      include 'COMMON.INTERACT'
5945 !      include 'COMMON.CONTACTS'
5946       real(kind=8),dimension(3) :: gx,gx1
5947       logical :: lprn
5948       real(kind=8) :: ecorr
5949       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5950 ! Set lprn=.true. for debugging
5951       lprn=.false.
5952
5953       if (lprn) then
5954         write (iout,'(a)') 'Contact function values:'
5955         do i=nnt,nct-2
5956           write (iout,'(i2,20(1x,i2,f10.5))') &
5957               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5958         enddo
5959       endif
5960       ecorr=0.0D0
5961
5962 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
5963 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
5964       do i=nnt,nct
5965         do j=1,3
5966           gradcorr(j,i)=0.0D0
5967           gradxorr(j,i)=0.0D0
5968         enddo
5969       enddo
5970       do i=nnt,nct-2
5971
5972         DO ISHIFT = 3,4
5973
5974         i1=i+ishift
5975         num_conti=num_cont(i)
5976         num_conti1=num_cont(i1)
5977         do jj=1,num_conti
5978           j=jcont(jj,i)
5979           do kk=1,num_conti1
5980             j1=jcont(kk,i1)
5981             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5982 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5983 !d   &                   ' ishift=',ishift
5984 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5985 ! The system gains extra energy.
5986               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5987             endif   ! j1==j+-ishift
5988           enddo     ! kk
5989         enddo       ! jj
5990
5991         ENDDO ! ISHIFT
5992
5993       enddo         ! i
5994       return
5995       end subroutine multibody
5996 !-----------------------------------------------------------------------------
5997       real(kind=8) function esccorr(i,j,k,l,jj,kk)
5998 !      implicit real*8 (a-h,o-z)
5999 !      include 'DIMENSIONS'
6000 !      include 'COMMON.IOUNITS'
6001 !      include 'COMMON.DERIV'
6002 !      include 'COMMON.INTERACT'
6003 !      include 'COMMON.CONTACTS'
6004       real(kind=8),dimension(3) :: gx,gx1
6005       logical :: lprn
6006       integer :: i,j,k,l,jj,kk,m,ll
6007       real(kind=8) :: eij,ekl
6008       lprn=.false.
6009       eij=facont(jj,i)
6010       ekl=facont(kk,k)
6011 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6012 ! Calculate the multi-body contribution to energy.
6013 ! Calculate multi-body contributions to the gradient.
6014 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6015 !d   & k,l,(gacont(m,kk,k),m=1,3)
6016       do m=1,3
6017         gx(m) =ekl*gacont(m,jj,i)
6018         gx1(m)=eij*gacont(m,kk,k)
6019         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6020         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6021         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6022         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6023       enddo
6024       do m=i,j-1
6025         do ll=1,3
6026           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6027         enddo
6028       enddo
6029       do m=k,l-1
6030         do ll=1,3
6031           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6032         enddo
6033       enddo
6034       esccorr=-eij*ekl
6035       return
6036       end function esccorr
6037 !-----------------------------------------------------------------------------
6038       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6039 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6040 !      implicit real*8 (a-h,o-z)
6041 !      include 'DIMENSIONS'
6042 !      include 'COMMON.IOUNITS'
6043 #ifdef MPI
6044       include "mpif.h"
6045 !      integer :: maxconts !max_cont=maxconts  =nres/4
6046       integer,parameter :: max_dim=26
6047       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6048       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6049 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6050 !el      common /przechowalnia/ zapas
6051       integer :: status(MPI_STATUS_SIZE)
6052       integer,dimension((nres/4)*2) :: req !maxconts*2
6053       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6054 #endif
6055 !      include 'COMMON.SETUP'
6056 !      include 'COMMON.FFIELD'
6057 !      include 'COMMON.DERIV'
6058 !      include 'COMMON.INTERACT'
6059 !      include 'COMMON.CONTACTS'
6060 !      include 'COMMON.CONTROL'
6061 !      include 'COMMON.LOCAL'
6062       real(kind=8),dimension(3) :: gx,gx1
6063       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6064       logical :: lprn,ldone
6065 !el local variables
6066       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6067               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6068
6069 ! Set lprn=.true. for debugging
6070       lprn=.false.
6071 #ifdef MPI
6072 !      maxconts=nres/4
6073       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6074       n_corr=0
6075       n_corr1=0
6076       if (nfgtasks.le.1) goto 30
6077       if (lprn) then
6078         write (iout,'(a)') 'Contact function values before RECEIVE:'
6079         do i=nnt,nct-2
6080           write (iout,'(2i3,50(1x,i2,f5.2))') &
6081           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6082           j=1,num_cont_hb(i))
6083         enddo
6084       endif
6085       call flush(iout)
6086       do i=1,ntask_cont_from
6087         ncont_recv(i)=0
6088       enddo
6089       do i=1,ntask_cont_to
6090         ncont_sent(i)=0
6091       enddo
6092 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6093 !     & ntask_cont_to
6094 ! Make the list of contacts to send to send to other procesors
6095 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6096 !      call flush(iout)
6097       do i=iturn3_start,iturn3_end
6098 !        write (iout,*) "make contact list turn3",i," num_cont",
6099 !     &    num_cont_hb(i)
6100         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6101       enddo
6102       do i=iturn4_start,iturn4_end
6103 !        write (iout,*) "make contact list turn4",i," num_cont",
6104 !     &   num_cont_hb(i)
6105         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6106       enddo
6107       do ii=1,nat_sent
6108         i=iat_sent(ii)
6109 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6110 !     &    num_cont_hb(i)
6111         do j=1,num_cont_hb(i)
6112         do k=1,4
6113           jjc=jcont_hb(j,i)
6114           iproc=iint_sent_local(k,jjc,ii)
6115 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6116           if (iproc.gt.0) then
6117             ncont_sent(iproc)=ncont_sent(iproc)+1
6118             nn=ncont_sent(iproc)
6119             zapas(1,nn,iproc)=i
6120             zapas(2,nn,iproc)=jjc
6121             zapas(3,nn,iproc)=facont_hb(j,i)
6122             zapas(4,nn,iproc)=ees0p(j,i)
6123             zapas(5,nn,iproc)=ees0m(j,i)
6124             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6125             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6126             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6127             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6128             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6129             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6130             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6131             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6132             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6133             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6134             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6135             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6136             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6137             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6138             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6139             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6140             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6141             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6142             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6143             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6144             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6145           endif
6146         enddo
6147         enddo
6148       enddo
6149       if (lprn) then
6150       write (iout,*) &
6151         "Numbers of contacts to be sent to other processors",&
6152         (ncont_sent(i),i=1,ntask_cont_to)
6153       write (iout,*) "Contacts sent"
6154       do ii=1,ntask_cont_to
6155         nn=ncont_sent(ii)
6156         iproc=itask_cont_to(ii)
6157         write (iout,*) nn," contacts to processor",iproc,&
6158          " of CONT_TO_COMM group"
6159         do i=1,nn
6160           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6161         enddo
6162       enddo
6163       call flush(iout)
6164       endif
6165       CorrelType=477
6166       CorrelID=fg_rank+1
6167       CorrelType1=478
6168       CorrelID1=nfgtasks+fg_rank+1
6169       ireq=0
6170 ! Receive the numbers of needed contacts from other processors
6171       do ii=1,ntask_cont_from
6172         iproc=itask_cont_from(ii)
6173         ireq=ireq+1
6174         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6175           FG_COMM,req(ireq),IERR)
6176       enddo
6177 !      write (iout,*) "IRECV ended"
6178 !      call flush(iout)
6179 ! Send the number of contacts needed by other processors
6180       do ii=1,ntask_cont_to
6181         iproc=itask_cont_to(ii)
6182         ireq=ireq+1
6183         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6184           FG_COMM,req(ireq),IERR)
6185       enddo
6186 !      write (iout,*) "ISEND ended"
6187 !      write (iout,*) "number of requests (nn)",ireq
6188       call flush(iout)
6189       if (ireq.gt.0) &
6190         call MPI_Waitall(ireq,req,status_array,ierr)
6191 !      write (iout,*)
6192 !     &  "Numbers of contacts to be received from other processors",
6193 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6194 !      call flush(iout)
6195 ! Receive contacts
6196       ireq=0
6197       do ii=1,ntask_cont_from
6198         iproc=itask_cont_from(ii)
6199         nn=ncont_recv(ii)
6200 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6201 !     &   " of CONT_TO_COMM group"
6202         call flush(iout)
6203         if (nn.gt.0) then
6204           ireq=ireq+1
6205           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6206           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6207 !          write (iout,*) "ireq,req",ireq,req(ireq)
6208         endif
6209       enddo
6210 ! Send the contacts to processors that need them
6211       do ii=1,ntask_cont_to
6212         iproc=itask_cont_to(ii)
6213         nn=ncont_sent(ii)
6214 !        write (iout,*) nn," contacts to processor",iproc,
6215 !     &   " of CONT_TO_COMM group"
6216         if (nn.gt.0) then
6217           ireq=ireq+1
6218           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6219             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6220 !          write (iout,*) "ireq,req",ireq,req(ireq)
6221 !          do i=1,nn
6222 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6223 !          enddo
6224         endif
6225       enddo
6226 !      write (iout,*) "number of requests (contacts)",ireq
6227 !      write (iout,*) "req",(req(i),i=1,4)
6228 !      call flush(iout)
6229       if (ireq.gt.0) &
6230        call MPI_Waitall(ireq,req,status_array,ierr)
6231       do iii=1,ntask_cont_from
6232         iproc=itask_cont_from(iii)
6233         nn=ncont_recv(iii)
6234         if (lprn) then
6235         write (iout,*) "Received",nn," contacts from processor",iproc,&
6236          " of CONT_FROM_COMM group"
6237         call flush(iout)
6238         do i=1,nn
6239           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6240         enddo
6241         call flush(iout)
6242         endif
6243         do i=1,nn
6244           ii=zapas_recv(1,i,iii)
6245 ! Flag the received contacts to prevent double-counting
6246           jj=-zapas_recv(2,i,iii)
6247 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6248 !          call flush(iout)
6249           nnn=num_cont_hb(ii)+1
6250           num_cont_hb(ii)=nnn
6251           jcont_hb(nnn,ii)=jj
6252           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6253           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6254           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6255           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6256           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6257           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6258           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6259           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6260           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6261           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6262           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6263           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6264           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6265           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6266           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6267           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6268           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6269           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6270           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6271           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6272           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6273           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6274           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6275           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6276         enddo
6277       enddo
6278       call flush(iout)
6279       if (lprn) then
6280         write (iout,'(a)') 'Contact function values after receive:'
6281         do i=nnt,nct-2
6282           write (iout,'(2i3,50(1x,i3,f5.2))') &
6283           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6284           j=1,num_cont_hb(i))
6285         enddo
6286         call flush(iout)
6287       endif
6288    30 continue
6289 #endif
6290       if (lprn) then
6291         write (iout,'(a)') 'Contact function values:'
6292         do i=nnt,nct-2
6293           write (iout,'(2i3,50(1x,i3,f5.2))') &
6294           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6295           j=1,num_cont_hb(i))
6296         enddo
6297       endif
6298       ecorr=0.0D0
6299
6300 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6301 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6302 ! Remove the loop below after debugging !!!
6303       do i=nnt,nct
6304         do j=1,3
6305           gradcorr(j,i)=0.0D0
6306           gradxorr(j,i)=0.0D0
6307         enddo
6308       enddo
6309 ! Calculate the local-electrostatic correlation terms
6310       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6311         i1=i+1
6312         num_conti=num_cont_hb(i)
6313         num_conti1=num_cont_hb(i+1)
6314         do jj=1,num_conti
6315           j=jcont_hb(jj,i)
6316           jp=iabs(j)
6317           do kk=1,num_conti1
6318             j1=jcont_hb(kk,i1)
6319             jp1=iabs(j1)
6320 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6321 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6322             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6323                 .or. j.lt.0 .and. j1.gt.0) .and. &
6324                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6325 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6326 ! The system gains extra energy.
6327               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6328               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6329                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6330               n_corr=n_corr+1
6331             else if (j1.eq.j) then
6332 ! Contacts I-J and I-(J+1) occur simultaneously.
6333 ! The system loses extra energy.
6334 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6335             endif
6336           enddo ! kk
6337           do kk=1,num_conti
6338             j1=jcont_hb(kk,i)
6339 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6340 !    &         ' jj=',jj,' kk=',kk
6341             if (j1.eq.j+1) then
6342 ! Contacts I-J and (I+1)-J occur simultaneously.
6343 ! The system loses extra energy.
6344 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6345             endif ! j1==j+1
6346           enddo ! kk
6347         enddo ! jj
6348       enddo ! i
6349       return
6350       end subroutine multibody_hb
6351 !-----------------------------------------------------------------------------
6352       subroutine add_hb_contact(ii,jj,itask)
6353 !      implicit real*8 (a-h,o-z)
6354 !      include "DIMENSIONS"
6355 !      include "COMMON.IOUNITS"
6356 !      include "COMMON.CONTACTS"
6357 !      integer,parameter :: maxconts=nres/4
6358       integer,parameter :: max_dim=26
6359       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6360 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6361 !      common /przechowalnia/ zapas
6362       integer :: i,j,ii,jj,iproc,nn,jjc
6363       integer,dimension(4) :: itask
6364 !      write (iout,*) "itask",itask
6365       do i=1,2
6366         iproc=itask(i)
6367         if (iproc.gt.0) then
6368           do j=1,num_cont_hb(ii)
6369             jjc=jcont_hb(j,ii)
6370 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6371             if (jjc.eq.jj) then
6372               ncont_sent(iproc)=ncont_sent(iproc)+1
6373               nn=ncont_sent(iproc)
6374               zapas(1,nn,iproc)=ii
6375               zapas(2,nn,iproc)=jjc
6376               zapas(3,nn,iproc)=facont_hb(j,ii)
6377               zapas(4,nn,iproc)=ees0p(j,ii)
6378               zapas(5,nn,iproc)=ees0m(j,ii)
6379               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6380               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6381               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6382               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6383               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6384               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6385               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6386               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6387               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6388               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6389               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6390               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6391               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6392               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6393               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6394               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6395               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6396               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6397               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6398               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6399               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6400               exit
6401             endif
6402           enddo
6403         endif
6404       enddo
6405       return
6406       end subroutine add_hb_contact
6407 !-----------------------------------------------------------------------------
6408       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6409 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6410 !      implicit real*8 (a-h,o-z)
6411 !      include 'DIMENSIONS'
6412 !      include 'COMMON.IOUNITS'
6413       integer,parameter :: max_dim=70
6414 #ifdef MPI
6415       include "mpif.h"
6416 !      integer :: maxconts !max_cont=maxconts=nres/4
6417       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6418       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6419 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6420 !      common /przechowalnia/ zapas
6421       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6422         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6423         ierr,iii,nnn
6424 #endif
6425 !      include 'COMMON.SETUP'
6426 !      include 'COMMON.FFIELD'
6427 !      include 'COMMON.DERIV'
6428 !      include 'COMMON.LOCAL'
6429 !      include 'COMMON.INTERACT'
6430 !      include 'COMMON.CONTACTS'
6431 !      include 'COMMON.CHAIN'
6432 !      include 'COMMON.CONTROL'
6433       real(kind=8),dimension(3) :: gx,gx1
6434       integer,dimension(nres) :: num_cont_hb_old
6435       logical :: lprn,ldone
6436 !EL      double precision eello4,eello5,eelo6,eello_turn6
6437 !EL      external eello4,eello5,eello6,eello_turn6
6438 !el local variables
6439       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6440               j1,jp1,i1,num_conti1
6441       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6442       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6443
6444 ! Set lprn=.true. for debugging
6445       lprn=.false.
6446       eturn6=0.0d0
6447 #ifdef MPI
6448 !      maxconts=nres/4
6449       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6450       do i=1,nres
6451         num_cont_hb_old(i)=num_cont_hb(i)
6452       enddo
6453       n_corr=0
6454       n_corr1=0
6455       if (nfgtasks.le.1) goto 30
6456       if (lprn) then
6457         write (iout,'(a)') 'Contact function values before RECEIVE:'
6458         do i=nnt,nct-2
6459           write (iout,'(2i3,50(1x,i2,f5.2))') &
6460           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6461           j=1,num_cont_hb(i))
6462         enddo
6463       endif
6464       call flush(iout)
6465       do i=1,ntask_cont_from
6466         ncont_recv(i)=0
6467       enddo
6468       do i=1,ntask_cont_to
6469         ncont_sent(i)=0
6470       enddo
6471 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6472 !     & ntask_cont_to
6473 ! Make the list of contacts to send to send to other procesors
6474       do i=iturn3_start,iturn3_end
6475 !        write (iout,*) "make contact list turn3",i," num_cont",
6476 !     &    num_cont_hb(i)
6477         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6478       enddo
6479       do i=iturn4_start,iturn4_end
6480 !        write (iout,*) "make contact list turn4",i," num_cont",
6481 !     &   num_cont_hb(i)
6482         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6483       enddo
6484       do ii=1,nat_sent
6485         i=iat_sent(ii)
6486 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6487 !     &    num_cont_hb(i)
6488         do j=1,num_cont_hb(i)
6489         do k=1,4
6490           jjc=jcont_hb(j,i)
6491           iproc=iint_sent_local(k,jjc,ii)
6492 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6493           if (iproc.ne.0) then
6494             ncont_sent(iproc)=ncont_sent(iproc)+1
6495             nn=ncont_sent(iproc)
6496             zapas(1,nn,iproc)=i
6497             zapas(2,nn,iproc)=jjc
6498             zapas(3,nn,iproc)=d_cont(j,i)
6499             ind=3
6500             do kk=1,3
6501               ind=ind+1
6502               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6503             enddo
6504             do kk=1,2
6505               do ll=1,2
6506                 ind=ind+1
6507                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6508               enddo
6509             enddo
6510             do jj=1,5
6511               do kk=1,3
6512                 do ll=1,2
6513                   do mm=1,2
6514                     ind=ind+1
6515                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6516                   enddo
6517                 enddo
6518               enddo
6519             enddo
6520           endif
6521         enddo
6522         enddo
6523       enddo
6524       if (lprn) then
6525       write (iout,*) &
6526         "Numbers of contacts to be sent to other processors",&
6527         (ncont_sent(i),i=1,ntask_cont_to)
6528       write (iout,*) "Contacts sent"
6529       do ii=1,ntask_cont_to
6530         nn=ncont_sent(ii)
6531         iproc=itask_cont_to(ii)
6532         write (iout,*) nn," contacts to processor",iproc,&
6533          " of CONT_TO_COMM group"
6534         do i=1,nn
6535           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6536         enddo
6537       enddo
6538       call flush(iout)
6539       endif
6540       CorrelType=477
6541       CorrelID=fg_rank+1
6542       CorrelType1=478
6543       CorrelID1=nfgtasks+fg_rank+1
6544       ireq=0
6545 ! Receive the numbers of needed contacts from other processors
6546       do ii=1,ntask_cont_from
6547         iproc=itask_cont_from(ii)
6548         ireq=ireq+1
6549         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6550           FG_COMM,req(ireq),IERR)
6551       enddo
6552 !      write (iout,*) "IRECV ended"
6553 !      call flush(iout)
6554 ! Send the number of contacts needed by other processors
6555       do ii=1,ntask_cont_to
6556         iproc=itask_cont_to(ii)
6557         ireq=ireq+1
6558         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6559           FG_COMM,req(ireq),IERR)
6560       enddo
6561 !      write (iout,*) "ISEND ended"
6562 !      write (iout,*) "number of requests (nn)",ireq
6563       call flush(iout)
6564       if (ireq.gt.0) &
6565         call MPI_Waitall(ireq,req,status_array,ierr)
6566 !      write (iout,*)
6567 !     &  "Numbers of contacts to be received from other processors",
6568 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6569 !      call flush(iout)
6570 ! Receive contacts
6571       ireq=0
6572       do ii=1,ntask_cont_from
6573         iproc=itask_cont_from(ii)
6574         nn=ncont_recv(ii)
6575 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6576 !     &   " of CONT_TO_COMM group"
6577         call flush(iout)
6578         if (nn.gt.0) then
6579           ireq=ireq+1
6580           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6581           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6582 !          write (iout,*) "ireq,req",ireq,req(ireq)
6583         endif
6584       enddo
6585 ! Send the contacts to processors that need them
6586       do ii=1,ntask_cont_to
6587         iproc=itask_cont_to(ii)
6588         nn=ncont_sent(ii)
6589 !        write (iout,*) nn," contacts to processor",iproc,
6590 !     &   " of CONT_TO_COMM group"
6591         if (nn.gt.0) then
6592           ireq=ireq+1
6593           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6594             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6595 !          write (iout,*) "ireq,req",ireq,req(ireq)
6596 !          do i=1,nn
6597 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6598 !          enddo
6599         endif
6600       enddo
6601 !      write (iout,*) "number of requests (contacts)",ireq
6602 !      write (iout,*) "req",(req(i),i=1,4)
6603 !      call flush(iout)
6604       if (ireq.gt.0) &
6605        call MPI_Waitall(ireq,req,status_array,ierr)
6606       do iii=1,ntask_cont_from
6607         iproc=itask_cont_from(iii)
6608         nn=ncont_recv(iii)
6609         if (lprn) then
6610         write (iout,*) "Received",nn," contacts from processor",iproc,&
6611          " of CONT_FROM_COMM group"
6612         call flush(iout)
6613         do i=1,nn
6614           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6615         enddo
6616         call flush(iout)
6617         endif
6618         do i=1,nn
6619           ii=zapas_recv(1,i,iii)
6620 ! Flag the received contacts to prevent double-counting
6621           jj=-zapas_recv(2,i,iii)
6622 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6623 !          call flush(iout)
6624           nnn=num_cont_hb(ii)+1
6625           num_cont_hb(ii)=nnn
6626           jcont_hb(nnn,ii)=jj
6627           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6628           ind=3
6629           do kk=1,3
6630             ind=ind+1
6631             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6632           enddo
6633           do kk=1,2
6634             do ll=1,2
6635               ind=ind+1
6636               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6637             enddo
6638           enddo
6639           do jj=1,5
6640             do kk=1,3
6641               do ll=1,2
6642                 do mm=1,2
6643                   ind=ind+1
6644                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6645                 enddo
6646               enddo
6647             enddo
6648           enddo
6649         enddo
6650       enddo
6651       call flush(iout)
6652       if (lprn) then
6653         write (iout,'(a)') 'Contact function values after receive:'
6654         do i=nnt,nct-2
6655           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6656           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6657           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6658         enddo
6659         call flush(iout)
6660       endif
6661    30 continue
6662 #endif
6663       if (lprn) then
6664         write (iout,'(a)') 'Contact function values:'
6665         do i=nnt,nct-2
6666           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6667           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6668           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6669         enddo
6670       endif
6671       ecorr=0.0D0
6672       ecorr5=0.0d0
6673       ecorr6=0.0d0
6674
6675 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6676 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6677 ! Remove the loop below after debugging !!!
6678       do i=nnt,nct
6679         do j=1,3
6680           gradcorr(j,i)=0.0D0
6681           gradxorr(j,i)=0.0D0
6682         enddo
6683       enddo
6684 ! Calculate the dipole-dipole interaction energies
6685       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6686       do i=iatel_s,iatel_e+1
6687         num_conti=num_cont_hb(i)
6688         do jj=1,num_conti
6689           j=jcont_hb(jj,i)
6690 #ifdef MOMENT
6691           call dipole(i,j,jj)
6692 #endif
6693         enddo
6694       enddo
6695       endif
6696 ! Calculate the local-electrostatic correlation terms
6697 !                write (iout,*) "gradcorr5 in eello5 before loop"
6698 !                do iii=1,nres
6699 !                  write (iout,'(i5,3f10.5)')
6700 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6701 !                enddo
6702       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6703 !        write (iout,*) "corr loop i",i
6704         i1=i+1
6705         num_conti=num_cont_hb(i)
6706         num_conti1=num_cont_hb(i+1)
6707         do jj=1,num_conti
6708           j=jcont_hb(jj,i)
6709           jp=iabs(j)
6710           do kk=1,num_conti1
6711             j1=jcont_hb(kk,i1)
6712             jp1=iabs(j1)
6713 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6714 !     &         ' jj=',jj,' kk=',kk
6715 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6716             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6717                 .or. j.lt.0 .and. j1.gt.0) .and. &
6718                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6719 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6720 ! The system gains extra energy.
6721               n_corr=n_corr+1
6722               sqd1=dsqrt(d_cont(jj,i))
6723               sqd2=dsqrt(d_cont(kk,i1))
6724               sred_geom = sqd1*sqd2
6725               IF (sred_geom.lt.cutoff_corr) THEN
6726                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6727                   ekont,fprimcont)
6728 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6729 !d     &         ' jj=',jj,' kk=',kk
6730                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6731                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6732                 do l=1,3
6733                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6734                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6735                 enddo
6736                 n_corr1=n_corr1+1
6737 !d               write (iout,*) 'sred_geom=',sred_geom,
6738 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6739 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6740 !d               write (iout,*) "g_contij",g_contij
6741 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6742 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6743                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6744                 if (wcorr4.gt.0.0d0) &
6745                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6746                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6747                        write (iout,'(a6,4i5,0pf7.3)') &
6748                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6749 !                write (iout,*) "gradcorr5 before eello5"
6750 !                do iii=1,nres
6751 !                  write (iout,'(i5,3f10.5)')
6752 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6753 !                enddo
6754                 if (wcorr5.gt.0.0d0) &
6755                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6756 !                write (iout,*) "gradcorr5 after eello5"
6757 !                do iii=1,nres
6758 !                  write (iout,'(i5,3f10.5)')
6759 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6760 !                enddo
6761                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6762                        write (iout,'(a6,4i5,0pf7.3)') &
6763                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6764 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6765 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6766                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6767                      .or. wturn6.eq.0.0d0))then
6768 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6769                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6770                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6771                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6772 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6773 !d     &            'ecorr6=',ecorr6
6774 !d                write (iout,'(4e15.5)') sred_geom,
6775 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6776 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6777 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6778                 else if (wturn6.gt.0.0d0 &
6779                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6780 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6781                   eturn6=eturn6+eello_turn6(i,jj,kk)
6782                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6783                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6784 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6785                 endif
6786               ENDIF
6787 1111          continue
6788             endif
6789           enddo ! kk
6790         enddo ! jj
6791       enddo ! i
6792       do i=1,nres
6793         num_cont_hb(i)=num_cont_hb_old(i)
6794       enddo
6795 !                write (iout,*) "gradcorr5 in eello5"
6796 !                do iii=1,nres
6797 !                  write (iout,'(i5,3f10.5)')
6798 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6799 !                enddo
6800       return
6801       end subroutine multibody_eello
6802 !-----------------------------------------------------------------------------
6803       subroutine add_hb_contact_eello(ii,jj,itask)
6804 !      implicit real*8 (a-h,o-z)
6805 !      include "DIMENSIONS"
6806 !      include "COMMON.IOUNITS"
6807 !      include "COMMON.CONTACTS"
6808 !      integer,parameter :: maxconts=nres/4
6809       integer,parameter :: max_dim=70
6810       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6811 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6812 !      common /przechowalnia/ zapas
6813
6814       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6815       integer,dimension(4) ::itask
6816 !      write (iout,*) "itask",itask
6817       do i=1,2
6818         iproc=itask(i)
6819         if (iproc.gt.0) then
6820           do j=1,num_cont_hb(ii)
6821             jjc=jcont_hb(j,ii)
6822 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6823             if (jjc.eq.jj) then
6824               ncont_sent(iproc)=ncont_sent(iproc)+1
6825               nn=ncont_sent(iproc)
6826               zapas(1,nn,iproc)=ii
6827               zapas(2,nn,iproc)=jjc
6828               zapas(3,nn,iproc)=d_cont(j,ii)
6829               ind=3
6830               do kk=1,3
6831                 ind=ind+1
6832                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6833               enddo
6834               do kk=1,2
6835                 do ll=1,2
6836                   ind=ind+1
6837                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6838                 enddo
6839               enddo
6840               do jj=1,5
6841                 do kk=1,3
6842                   do ll=1,2
6843                     do mm=1,2
6844                       ind=ind+1
6845                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6846                     enddo
6847                   enddo
6848                 enddo
6849               enddo
6850               exit
6851             endif
6852           enddo
6853         endif
6854       enddo
6855       return
6856       end subroutine add_hb_contact_eello
6857 !-----------------------------------------------------------------------------
6858       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6859 !      implicit real*8 (a-h,o-z)
6860 !      include 'DIMENSIONS'
6861 !      include 'COMMON.IOUNITS'
6862 !      include 'COMMON.DERIV'
6863 !      include 'COMMON.INTERACT'
6864 !      include 'COMMON.CONTACTS'
6865       real(kind=8),dimension(3) :: gx,gx1
6866       logical :: lprn
6867 !el local variables
6868       integer :: i,j,k,l,jj,kk,ll
6869       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6870                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6871                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6872
6873       lprn=.false.
6874       eij=facont_hb(jj,i)
6875       ekl=facont_hb(kk,k)
6876       ees0pij=ees0p(jj,i)
6877       ees0pkl=ees0p(kk,k)
6878       ees0mij=ees0m(jj,i)
6879       ees0mkl=ees0m(kk,k)
6880       ekont=eij*ekl
6881       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6882 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6883 ! Following 4 lines for diagnostics.
6884 !d    ees0pkl=0.0D0
6885 !d    ees0pij=1.0D0
6886 !d    ees0mkl=0.0D0
6887 !d    ees0mij=1.0D0
6888 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6889 !     & 'Contacts ',i,j,
6890 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6891 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6892 !     & 'gradcorr_long'
6893 ! Calculate the multi-body contribution to energy.
6894 !      ecorr=ecorr+ekont*ees
6895 ! Calculate multi-body contributions to the gradient.
6896       coeffpees0pij=coeffp*ees0pij
6897       coeffmees0mij=coeffm*ees0mij
6898       coeffpees0pkl=coeffp*ees0pkl
6899       coeffmees0mkl=coeffm*ees0mkl
6900       do ll=1,3
6901 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6902         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6903         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6904         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6905         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6906         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6907         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6908 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6909         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6910         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6911         coeffmees0mij*gacontm_hb1(ll,kk,k))
6912         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6913         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6914         coeffmees0mij*gacontm_hb2(ll,kk,k))
6915         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6916            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6917            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6918         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6919         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6920         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6921            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6922            coeffmees0mij*gacontm_hb3(ll,kk,k))
6923         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6924         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6925 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6926       enddo
6927 !      write (iout,*)
6928 !grad      do m=i+1,j-1
6929 !grad        do ll=1,3
6930 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6931 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6932 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6933 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6934 !grad        enddo
6935 !grad      enddo
6936 !grad      do m=k+1,l-1
6937 !grad        do ll=1,3
6938 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6939 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6940 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6941 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6942 !grad        enddo
6943 !grad      enddo
6944 !      write (iout,*) "ehbcorr",ekont*ees
6945       ehbcorr=ekont*ees
6946       return
6947       end function ehbcorr
6948 #ifdef MOMENT
6949 !-----------------------------------------------------------------------------
6950       subroutine dipole(i,j,jj)
6951 !      implicit real*8 (a-h,o-z)
6952 !      include 'DIMENSIONS'
6953 !      include 'COMMON.IOUNITS'
6954 !      include 'COMMON.CHAIN'
6955 !      include 'COMMON.FFIELD'
6956 !      include 'COMMON.DERIV'
6957 !      include 'COMMON.INTERACT'
6958 !      include 'COMMON.CONTACTS'
6959 !      include 'COMMON.TORSION'
6960 !      include 'COMMON.VAR'
6961 !      include 'COMMON.GEO'
6962       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
6963       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
6964       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
6965
6966       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
6967       allocate(dipderx(3,5,4,maxconts,nres))
6968 !
6969
6970       iti1 = itortyp(itype(i+1))
6971       if (j.lt.nres-1) then
6972         itj1 = itortyp(itype(j+1))
6973       else
6974         itj1=ntortyp+1
6975       endif
6976       do iii=1,2
6977         dipi(iii,1)=Ub2(iii,i)
6978         dipderi(iii)=Ub2der(iii,i)
6979         dipi(iii,2)=b1(iii,iti1)
6980         dipj(iii,1)=Ub2(iii,j)
6981         dipderj(iii)=Ub2der(iii,j)
6982         dipj(iii,2)=b1(iii,itj1)
6983       enddo
6984       kkk=0
6985       do iii=1,2
6986         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6987         do jjj=1,2
6988           kkk=kkk+1
6989           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6990         enddo
6991       enddo
6992       do kkk=1,5
6993         do lll=1,3
6994           mmm=0
6995           do iii=1,2
6996             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
6997               auxvec(1))
6998             do jjj=1,2
6999               mmm=mmm+1
7000               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7001             enddo
7002           enddo
7003         enddo
7004       enddo
7005       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7006       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7007       do iii=1,2
7008         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7009       enddo
7010       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7011       do iii=1,2
7012         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7013       enddo
7014       return
7015       end subroutine dipole
7016 #endif
7017 !-----------------------------------------------------------------------------
7018       subroutine calc_eello(i,j,k,l,jj,kk)
7019 !
7020 ! This subroutine computes matrices and vectors needed to calculate
7021 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7022 !
7023       use comm_kut
7024 !      implicit real*8 (a-h,o-z)
7025 !      include 'DIMENSIONS'
7026 !      include 'COMMON.IOUNITS'
7027 !      include 'COMMON.CHAIN'
7028 !      include 'COMMON.DERIV'
7029 !      include 'COMMON.INTERACT'
7030 !      include 'COMMON.CONTACTS'
7031 !      include 'COMMON.TORSION'
7032 !      include 'COMMON.VAR'
7033 !      include 'COMMON.GEO'
7034 !      include 'COMMON.FFIELD'
7035       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
7036       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
7037       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
7038               itj1
7039 !el      logical :: lprn
7040 !el      common /kutas/ lprn
7041 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7042 !d     & ' jj=',jj,' kk=',kk
7043 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7044 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7045 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7046       do iii=1,2
7047         do jjj=1,2
7048           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7049           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7050         enddo
7051       enddo
7052       call transpose2(aa1(1,1),aa1t(1,1))
7053       call transpose2(aa2(1,1),aa2t(1,1))
7054       do kkk=1,5
7055         do lll=1,3
7056           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
7057             aa1tder(1,1,lll,kkk))
7058           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
7059             aa2tder(1,1,lll,kkk))
7060         enddo
7061       enddo
7062       if (l.eq.j+1) then
7063 ! parallel orientation of the two CA-CA-CA frames.
7064         if (i.gt.1) then
7065           iti=itortyp(itype(i))
7066         else
7067           iti=ntortyp+1
7068         endif
7069         itk1=itortyp(itype(k+1))
7070         itj=itortyp(itype(j))
7071         if (l.lt.nres-1) then
7072           itl1=itortyp(itype(l+1))
7073         else
7074           itl1=ntortyp+1
7075         endif
7076 ! A1 kernel(j+1) A2T
7077 !d        do iii=1,2
7078 !d          write (iout,'(3f10.5,5x,3f10.5)')
7079 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7080 !d        enddo
7081         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7082          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7083          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7084 ! Following matrices are needed only for 6-th order cumulants
7085         IF (wcorr6.gt.0.0d0) THEN
7086         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7087          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7088          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7089         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7090          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7091          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7092          ADtEAderx(1,1,1,1,1,1))
7093         lprn=.false.
7094         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7095          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7096          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7097          ADtEA1derx(1,1,1,1,1,1))
7098         ENDIF
7099 ! End 6-th order cumulants
7100 !d        lprn=.false.
7101 !d        if (lprn) then
7102 !d        write (2,*) 'In calc_eello6'
7103 !d        do iii=1,2
7104 !d          write (2,*) 'iii=',iii
7105 !d          do kkk=1,5
7106 !d            write (2,*) 'kkk=',kkk
7107 !d            do jjj=1,2
7108 !d              write (2,'(3(2f10.5),5x)')
7109 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7110 !d            enddo
7111 !d          enddo
7112 !d        enddo
7113 !d        endif
7114         call transpose2(EUgder(1,1,k),auxmat(1,1))
7115         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7116         call transpose2(EUg(1,1,k),auxmat(1,1))
7117         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7118         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7119         do iii=1,2
7120           do kkk=1,5
7121             do lll=1,3
7122               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7123                 EAEAderx(1,1,lll,kkk,iii,1))
7124             enddo
7125           enddo
7126         enddo
7127 ! A1T kernel(i+1) A2
7128         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7129          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7130          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7131 ! Following matrices are needed only for 6-th order cumulants
7132         IF (wcorr6.gt.0.0d0) THEN
7133         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7134          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7135          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7136         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7137          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7138          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7139          ADtEAderx(1,1,1,1,1,2))
7140         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7141          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7142          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7143          ADtEA1derx(1,1,1,1,1,2))
7144         ENDIF
7145 ! End 6-th order cumulants
7146         call transpose2(EUgder(1,1,l),auxmat(1,1))
7147         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7148         call transpose2(EUg(1,1,l),auxmat(1,1))
7149         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7150         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7151         do iii=1,2
7152           do kkk=1,5
7153             do lll=1,3
7154               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7155                 EAEAderx(1,1,lll,kkk,iii,2))
7156             enddo
7157           enddo
7158         enddo
7159 ! AEAb1 and AEAb2
7160 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7161 ! They are needed only when the fifth- or the sixth-order cumulants are
7162 ! indluded.
7163         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7164         call transpose2(AEA(1,1,1),auxmat(1,1))
7165         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7166         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7167         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7168         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7169         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7170         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7171         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7172         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7173         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7174         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7175         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7176         call transpose2(AEA(1,1,2),auxmat(1,1))
7177         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7178         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7179         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7180         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7181         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7182         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7183         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7184         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7185         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7186         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7187         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7188 ! Calculate the Cartesian derivatives of the vectors.
7189         do iii=1,2
7190           do kkk=1,5
7191             do lll=1,3
7192               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7193               call matvec2(auxmat(1,1),b1(1,iti),&
7194                 AEAb1derx(1,lll,kkk,iii,1,1))
7195               call matvec2(auxmat(1,1),Ub2(1,i),&
7196                 AEAb2derx(1,lll,kkk,iii,1,1))
7197               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7198                 AEAb1derx(1,lll,kkk,iii,2,1))
7199               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7200                 AEAb2derx(1,lll,kkk,iii,2,1))
7201               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7202               call matvec2(auxmat(1,1),b1(1,itj),&
7203                 AEAb1derx(1,lll,kkk,iii,1,2))
7204               call matvec2(auxmat(1,1),Ub2(1,j),&
7205                 AEAb2derx(1,lll,kkk,iii,1,2))
7206               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7207                 AEAb1derx(1,lll,kkk,iii,2,2))
7208               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7209                 AEAb2derx(1,lll,kkk,iii,2,2))
7210             enddo
7211           enddo
7212         enddo
7213         ENDIF
7214 ! End vectors
7215       else
7216 ! Antiparallel orientation of the two CA-CA-CA frames.
7217         if (i.gt.1) then
7218           iti=itortyp(itype(i))
7219         else
7220           iti=ntortyp+1
7221         endif
7222         itk1=itortyp(itype(k+1))
7223         itl=itortyp(itype(l))
7224         itj=itortyp(itype(j))
7225         if (j.lt.nres-1) then
7226           itj1=itortyp(itype(j+1))
7227         else
7228           itj1=ntortyp+1
7229         endif
7230 ! A2 kernel(j-1)T A1T
7231         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7232          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7233          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7234 ! Following matrices are needed only for 6-th order cumulants
7235         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7236            j.eq.i+4 .and. l.eq.i+3)) THEN
7237         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7238          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7239          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7240         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7241          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7242          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7243          ADtEAderx(1,1,1,1,1,1))
7244         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7245          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7246          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7247          ADtEA1derx(1,1,1,1,1,1))
7248         ENDIF
7249 ! End 6-th order cumulants
7250         call transpose2(EUgder(1,1,k),auxmat(1,1))
7251         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7252         call transpose2(EUg(1,1,k),auxmat(1,1))
7253         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7254         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7255         do iii=1,2
7256           do kkk=1,5
7257             do lll=1,3
7258               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7259                 EAEAderx(1,1,lll,kkk,iii,1))
7260             enddo
7261           enddo
7262         enddo
7263 ! A2T kernel(i+1)T A1
7264         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7265          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7266          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7267 ! Following matrices are needed only for 6-th order cumulants
7268         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7269            j.eq.i+4 .and. l.eq.i+3)) THEN
7270         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7271          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7272          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7273         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7274          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7275          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7276          ADtEAderx(1,1,1,1,1,2))
7277         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7278          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7279          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7280          ADtEA1derx(1,1,1,1,1,2))
7281         ENDIF
7282 ! End 6-th order cumulants
7283         call transpose2(EUgder(1,1,j),auxmat(1,1))
7284         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7285         call transpose2(EUg(1,1,j),auxmat(1,1))
7286         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7287         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7288         do iii=1,2
7289           do kkk=1,5
7290             do lll=1,3
7291               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7292                 EAEAderx(1,1,lll,kkk,iii,2))
7293             enddo
7294           enddo
7295         enddo
7296 ! AEAb1 and AEAb2
7297 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7298 ! They are needed only when the fifth- or the sixth-order cumulants are
7299 ! indluded.
7300         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7301           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7302         call transpose2(AEA(1,1,1),auxmat(1,1))
7303         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7304         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7305         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7306         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7307         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7308         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7309         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7310         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7311         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7312         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7313         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7314         call transpose2(AEA(1,1,2),auxmat(1,1))
7315         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7316         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7317         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7318         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7319         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7320         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7321         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7322         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7323         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7324         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7325         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7326 ! Calculate the Cartesian derivatives of the vectors.
7327         do iii=1,2
7328           do kkk=1,5
7329             do lll=1,3
7330               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7331               call matvec2(auxmat(1,1),b1(1,iti),&
7332                 AEAb1derx(1,lll,kkk,iii,1,1))
7333               call matvec2(auxmat(1,1),Ub2(1,i),&
7334                 AEAb2derx(1,lll,kkk,iii,1,1))
7335               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7336                 AEAb1derx(1,lll,kkk,iii,2,1))
7337               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7338                 AEAb2derx(1,lll,kkk,iii,2,1))
7339               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7340               call matvec2(auxmat(1,1),b1(1,itl),&
7341                 AEAb1derx(1,lll,kkk,iii,1,2))
7342               call matvec2(auxmat(1,1),Ub2(1,l),&
7343                 AEAb2derx(1,lll,kkk,iii,1,2))
7344               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7345                 AEAb1derx(1,lll,kkk,iii,2,2))
7346               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7347                 AEAb2derx(1,lll,kkk,iii,2,2))
7348             enddo
7349           enddo
7350         enddo
7351         ENDIF
7352 ! End vectors
7353       endif
7354       return
7355       end subroutine calc_eello
7356 !-----------------------------------------------------------------------------
7357       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7358       use comm_kut
7359       implicit none
7360       integer :: nderg
7361       logical :: transp
7362       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7363       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7364       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7365       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7366       integer :: iii,kkk,lll
7367       integer :: jjj,mmm
7368 !el      logical :: lprn
7369 !el      common /kutas/ lprn
7370       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7371       do iii=1,nderg
7372         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7373           AKAderg(1,1,iii))
7374       enddo
7375 !d      if (lprn) write (2,*) 'In kernel'
7376       do kkk=1,5
7377 !d        if (lprn) write (2,*) 'kkk=',kkk
7378         do lll=1,3
7379           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7380             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7381 !d          if (lprn) then
7382 !d            write (2,*) 'lll=',lll
7383 !d            write (2,*) 'iii=1'
7384 !d            do jjj=1,2
7385 !d              write (2,'(3(2f10.5),5x)')
7386 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7387 !d            enddo
7388 !d          endif
7389           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7390             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7391 !d          if (lprn) then
7392 !d            write (2,*) 'lll=',lll
7393 !d            write (2,*) 'iii=2'
7394 !d            do jjj=1,2
7395 !d              write (2,'(3(2f10.5),5x)')
7396 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7397 !d            enddo
7398 !d          endif
7399         enddo
7400       enddo
7401       return
7402       end subroutine kernel
7403 !-----------------------------------------------------------------------------
7404       real(kind=8) function eello4(i,j,k,l,jj,kk)
7405 !      implicit real*8 (a-h,o-z)
7406 !      include 'DIMENSIONS'
7407 !      include 'COMMON.IOUNITS'
7408 !      include 'COMMON.CHAIN'
7409 !      include 'COMMON.DERIV'
7410 !      include 'COMMON.INTERACT'
7411 !      include 'COMMON.CONTACTS'
7412 !      include 'COMMON.TORSION'
7413 !      include 'COMMON.VAR'
7414 !      include 'COMMON.GEO'
7415       real(kind=8),dimension(2,2) :: pizda
7416       real(kind=8),dimension(3) :: ggg1,ggg2
7417       real(kind=8) ::  eel4,glongij,glongkl
7418       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7419 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7420 !d        eello4=0.0d0
7421 !d        return
7422 !d      endif
7423 !d      print *,'eello4:',i,j,k,l,jj,kk
7424 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7425 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7426 !old      eij=facont_hb(jj,i)
7427 !old      ekl=facont_hb(kk,k)
7428 !old      ekont=eij*ekl
7429       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7430 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7431       gcorr_loc(k-1)=gcorr_loc(k-1) &
7432          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7433       if (l.eq.j+1) then
7434         gcorr_loc(l-1)=gcorr_loc(l-1) &
7435            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7436       else
7437         gcorr_loc(j-1)=gcorr_loc(j-1) &
7438            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7439       endif
7440       do iii=1,2
7441         do kkk=1,5
7442           do lll=1,3
7443             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7444                               -EAEAderx(2,2,lll,kkk,iii,1)
7445 !d            derx(lll,kkk,iii)=0.0d0
7446           enddo
7447         enddo
7448       enddo
7449 !d      gcorr_loc(l-1)=0.0d0
7450 !d      gcorr_loc(j-1)=0.0d0
7451 !d      gcorr_loc(k-1)=0.0d0
7452 !d      eel4=1.0d0
7453 !d      write (iout,*)'Contacts have occurred for peptide groups',
7454 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7455 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7456       if (j.lt.nres-1) then
7457         j1=j+1
7458         j2=j-1
7459       else
7460         j1=j-1
7461         j2=j-2
7462       endif
7463       if (l.lt.nres-1) then
7464         l1=l+1
7465         l2=l-1
7466       else
7467         l1=l-1
7468         l2=l-2
7469       endif
7470       do ll=1,3
7471 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7472 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7473         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7474         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7475 !grad        ghalf=0.5d0*ggg1(ll)
7476         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7477         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7478         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7479         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7480         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7481         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7482 !grad        ghalf=0.5d0*ggg2(ll)
7483         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7484         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7485         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7486         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7487         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7488         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7489       enddo
7490 !grad      do m=i+1,j-1
7491 !grad        do ll=1,3
7492 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7493 !grad        enddo
7494 !grad      enddo
7495 !grad      do m=k+1,l-1
7496 !grad        do ll=1,3
7497 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7498 !grad        enddo
7499 !grad      enddo
7500 !grad      do m=i+2,j2
7501 !grad        do ll=1,3
7502 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7503 !grad        enddo
7504 !grad      enddo
7505 !grad      do m=k+2,l2
7506 !grad        do ll=1,3
7507 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7508 !grad        enddo
7509 !grad      enddo
7510 !d      do iii=1,nres-3
7511 !d        write (2,*) iii,gcorr_loc(iii)
7512 !d      enddo
7513       eello4=ekont*eel4
7514 !d      write (2,*) 'ekont',ekont
7515 !d      write (iout,*) 'eello4',ekont*eel4
7516       return
7517       end function eello4
7518 !-----------------------------------------------------------------------------
7519       real(kind=8) function eello5(i,j,k,l,jj,kk)
7520 !      implicit real*8 (a-h,o-z)
7521 !      include 'DIMENSIONS'
7522 !      include 'COMMON.IOUNITS'
7523 !      include 'COMMON.CHAIN'
7524 !      include 'COMMON.DERIV'
7525 !      include 'COMMON.INTERACT'
7526 !      include 'COMMON.CONTACTS'
7527 !      include 'COMMON.TORSION'
7528 !      include 'COMMON.VAR'
7529 !      include 'COMMON.GEO'
7530       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7531       real(kind=8),dimension(2) :: vv
7532       real(kind=8),dimension(3) :: ggg1,ggg2
7533       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7534       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7535       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7536 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7537 !                                                                              C
7538 !                            Parallel chains                                   C
7539 !                                                                              C
7540 !          o             o                   o             o                   C
7541 !         /l\           / \             \   / \           / \   /              C
7542 !        /   \         /   \             \ /   \         /   \ /               C
7543 !       j| o |l1       | o |              o| o |         | o |o                C
7544 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7545 !      \i/   \         /   \ /             /   \         /   \                 C
7546 !       o    k1             o                                                  C
7547 !         (I)          (II)                (III)          (IV)                 C
7548 !                                                                              C
7549 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7550 !                                                                              C
7551 !                            Antiparallel chains                               C
7552 !                                                                              C
7553 !          o             o                   o             o                   C
7554 !         /j\           / \             \   / \           / \   /              C
7555 !        /   \         /   \             \ /   \         /   \ /               C
7556 !      j1| o |l        | o |              o| o |         | o |o                C
7557 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7558 !      \i/   \         /   \ /             /   \         /   \                 C
7559 !       o     k1            o                                                  C
7560 !         (I)          (II)                (III)          (IV)                 C
7561 !                                                                              C
7562 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7563 !                                                                              C
7564 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7565 !                                                                              C
7566 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7567 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7568 !d        eello5=0.0d0
7569 !d        return
7570 !d      endif
7571 !d      write (iout,*)
7572 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7573 !d     &   ' and',k,l
7574       itk=itortyp(itype(k))
7575       itl=itortyp(itype(l))
7576       itj=itortyp(itype(j))
7577       eello5_1=0.0d0
7578       eello5_2=0.0d0
7579       eello5_3=0.0d0
7580       eello5_4=0.0d0
7581 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7582 !d     &   eel5_3_num,eel5_4_num)
7583       do iii=1,2
7584         do kkk=1,5
7585           do lll=1,3
7586             derx(lll,kkk,iii)=0.0d0
7587           enddo
7588         enddo
7589       enddo
7590 !d      eij=facont_hb(jj,i)
7591 !d      ekl=facont_hb(kk,k)
7592 !d      ekont=eij*ekl
7593 !d      write (iout,*)'Contacts have occurred for peptide groups',
7594 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7595 !d      goto 1111
7596 ! Contribution from the graph I.
7597 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7598 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7599       call transpose2(EUg(1,1,k),auxmat(1,1))
7600       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7601       vv(1)=pizda(1,1)-pizda(2,2)
7602       vv(2)=pizda(1,2)+pizda(2,1)
7603       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7604        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7605 ! Explicit gradient in virtual-dihedral angles.
7606       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7607        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7608        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7609       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7610       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7611       vv(1)=pizda(1,1)-pizda(2,2)
7612       vv(2)=pizda(1,2)+pizda(2,1)
7613       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7614        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7615        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7616       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7617       vv(1)=pizda(1,1)-pizda(2,2)
7618       vv(2)=pizda(1,2)+pizda(2,1)
7619       if (l.eq.j+1) then
7620         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7621          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7622          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7623       else
7624         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7625          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7626          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7627       endif
7628 ! Cartesian gradient
7629       do iii=1,2
7630         do kkk=1,5
7631           do lll=1,3
7632             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7633               pizda(1,1))
7634             vv(1)=pizda(1,1)-pizda(2,2)
7635             vv(2)=pizda(1,2)+pizda(2,1)
7636             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7637              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7638              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7639           enddo
7640         enddo
7641       enddo
7642 !      goto 1112
7643 !1111  continue
7644 ! Contribution from graph II
7645       call transpose2(EE(1,1,itk),auxmat(1,1))
7646       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7647       vv(1)=pizda(1,1)+pizda(2,2)
7648       vv(2)=pizda(2,1)-pizda(1,2)
7649       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7650        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7651 ! Explicit gradient in virtual-dihedral angles.
7652       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7653        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7654       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7655       vv(1)=pizda(1,1)+pizda(2,2)
7656       vv(2)=pizda(2,1)-pizda(1,2)
7657       if (l.eq.j+1) then
7658         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7659          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7660          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7661       else
7662         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7663          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7664          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7665       endif
7666 ! Cartesian gradient
7667       do iii=1,2
7668         do kkk=1,5
7669           do lll=1,3
7670             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7671               pizda(1,1))
7672             vv(1)=pizda(1,1)+pizda(2,2)
7673             vv(2)=pizda(2,1)-pizda(1,2)
7674             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7675              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7676              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7677           enddo
7678         enddo
7679       enddo
7680 !d      goto 1112
7681 !d1111  continue
7682       if (l.eq.j+1) then
7683 !d        goto 1110
7684 ! Parallel orientation
7685 ! Contribution from graph III
7686         call transpose2(EUg(1,1,l),auxmat(1,1))
7687         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7688         vv(1)=pizda(1,1)-pizda(2,2)
7689         vv(2)=pizda(1,2)+pizda(2,1)
7690         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7691          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7692 ! Explicit gradient in virtual-dihedral angles.
7693         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7694          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7695          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7696         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7697         vv(1)=pizda(1,1)-pizda(2,2)
7698         vv(2)=pizda(1,2)+pizda(2,1)
7699         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7700          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7701          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7702         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7703         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7704         vv(1)=pizda(1,1)-pizda(2,2)
7705         vv(2)=pizda(1,2)+pizda(2,1)
7706         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7707          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7708          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7709 ! Cartesian gradient
7710         do iii=1,2
7711           do kkk=1,5
7712             do lll=1,3
7713               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7714                 pizda(1,1))
7715               vv(1)=pizda(1,1)-pizda(2,2)
7716               vv(2)=pizda(1,2)+pizda(2,1)
7717               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7718                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7719                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7720             enddo
7721           enddo
7722         enddo
7723 !d        goto 1112
7724 ! Contribution from graph IV
7725 !d1110    continue
7726         call transpose2(EE(1,1,itl),auxmat(1,1))
7727         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7728         vv(1)=pizda(1,1)+pizda(2,2)
7729         vv(2)=pizda(2,1)-pizda(1,2)
7730         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7731          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7732 ! Explicit gradient in virtual-dihedral angles.
7733         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7734          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7735         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7736         vv(1)=pizda(1,1)+pizda(2,2)
7737         vv(2)=pizda(2,1)-pizda(1,2)
7738         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7739          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7740          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7741 ! Cartesian gradient
7742         do iii=1,2
7743           do kkk=1,5
7744             do lll=1,3
7745               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7746                 pizda(1,1))
7747               vv(1)=pizda(1,1)+pizda(2,2)
7748               vv(2)=pizda(2,1)-pizda(1,2)
7749               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7750                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7751                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7752             enddo
7753           enddo
7754         enddo
7755       else
7756 ! Antiparallel orientation
7757 ! Contribution from graph III
7758 !        goto 1110
7759         call transpose2(EUg(1,1,j),auxmat(1,1))
7760         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7761         vv(1)=pizda(1,1)-pizda(2,2)
7762         vv(2)=pizda(1,2)+pizda(2,1)
7763         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7764          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7765 ! Explicit gradient in virtual-dihedral angles.
7766         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7767          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7768          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7769         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7770         vv(1)=pizda(1,1)-pizda(2,2)
7771         vv(2)=pizda(1,2)+pizda(2,1)
7772         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7773          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7774          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7775         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7776         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7777         vv(1)=pizda(1,1)-pizda(2,2)
7778         vv(2)=pizda(1,2)+pizda(2,1)
7779         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7780          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7781          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7782 ! Cartesian gradient
7783         do iii=1,2
7784           do kkk=1,5
7785             do lll=1,3
7786               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7787                 pizda(1,1))
7788               vv(1)=pizda(1,1)-pizda(2,2)
7789               vv(2)=pizda(1,2)+pizda(2,1)
7790               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7791                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7792                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7793             enddo
7794           enddo
7795         enddo
7796 !d        goto 1112
7797 ! Contribution from graph IV
7798 1110    continue
7799         call transpose2(EE(1,1,itj),auxmat(1,1))
7800         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7801         vv(1)=pizda(1,1)+pizda(2,2)
7802         vv(2)=pizda(2,1)-pizda(1,2)
7803         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7804          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7805 ! Explicit gradient in virtual-dihedral angles.
7806         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7807          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7808         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7809         vv(1)=pizda(1,1)+pizda(2,2)
7810         vv(2)=pizda(2,1)-pizda(1,2)
7811         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7812          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7813          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7814 ! Cartesian gradient
7815         do iii=1,2
7816           do kkk=1,5
7817             do lll=1,3
7818               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7819                 pizda(1,1))
7820               vv(1)=pizda(1,1)+pizda(2,2)
7821               vv(2)=pizda(2,1)-pizda(1,2)
7822               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7823                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7824                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7825             enddo
7826           enddo
7827         enddo
7828       endif
7829 1112  continue
7830       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7831 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7832 !d        write (2,*) 'ijkl',i,j,k,l
7833 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7834 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7835 !d      endif
7836 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7837 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7838 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7839 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7840       if (j.lt.nres-1) then
7841         j1=j+1
7842         j2=j-1
7843       else
7844         j1=j-1
7845         j2=j-2
7846       endif
7847       if (l.lt.nres-1) then
7848         l1=l+1
7849         l2=l-1
7850       else
7851         l1=l-1
7852         l2=l-2
7853       endif
7854 !d      eij=1.0d0
7855 !d      ekl=1.0d0
7856 !d      ekont=1.0d0
7857 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7858 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7859 !        summed up outside the subrouine as for the other subroutines
7860 !        handling long-range interactions. The old code is commented out
7861 !        with "cgrad" to keep track of changes.
7862       do ll=1,3
7863 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7864 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7865         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7866         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7867 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7868 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7869 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7870 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7871 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7872 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7873 !     &   gradcorr5ij,
7874 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7875 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7876 !grad        ghalf=0.5d0*ggg1(ll)
7877 !d        ghalf=0.0d0
7878         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7879         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7880         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7881         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7882         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7883         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7884 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7885 !grad        ghalf=0.5d0*ggg2(ll)
7886         ghalf=0.0d0
7887         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7888         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7889         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7890         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7891         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7892         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7893       enddo
7894 !d      goto 1112
7895 !grad      do m=i+1,j-1
7896 !grad        do ll=1,3
7897 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7898 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7899 !grad        enddo
7900 !grad      enddo
7901 !grad      do m=k+1,l-1
7902 !grad        do ll=1,3
7903 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7904 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7905 !grad        enddo
7906 !grad      enddo
7907 !1112  continue
7908 !grad      do m=i+2,j2
7909 !grad        do ll=1,3
7910 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7911 !grad        enddo
7912 !grad      enddo
7913 !grad      do m=k+2,l2
7914 !grad        do ll=1,3
7915 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7916 !grad        enddo
7917 !grad      enddo
7918 !d      do iii=1,nres-3
7919 !d        write (2,*) iii,g_corr5_loc(iii)
7920 !d      enddo
7921       eello5=ekont*eel5
7922 !d      write (2,*) 'ekont',ekont
7923 !d      write (iout,*) 'eello5',ekont*eel5
7924       return
7925       end function eello5
7926 !-----------------------------------------------------------------------------
7927       real(kind=8) function eello6(i,j,k,l,jj,kk)
7928 !      implicit real*8 (a-h,o-z)
7929 !      include 'DIMENSIONS'
7930 !      include 'COMMON.IOUNITS'
7931 !      include 'COMMON.CHAIN'
7932 !      include 'COMMON.DERIV'
7933 !      include 'COMMON.INTERACT'
7934 !      include 'COMMON.CONTACTS'
7935 !      include 'COMMON.TORSION'
7936 !      include 'COMMON.VAR'
7937 !      include 'COMMON.GEO'
7938 !      include 'COMMON.FFIELD'
7939       real(kind=8),dimension(3) :: ggg1,ggg2
7940       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7941                    eello6_6,eel6
7942       real(kind=8) :: gradcorr6ij,gradcorr6kl
7943       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7944 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7945 !d        eello6=0.0d0
7946 !d        return
7947 !d      endif
7948 !d      write (iout,*)
7949 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7950 !d     &   ' and',k,l
7951       eello6_1=0.0d0
7952       eello6_2=0.0d0
7953       eello6_3=0.0d0
7954       eello6_4=0.0d0
7955       eello6_5=0.0d0
7956       eello6_6=0.0d0
7957 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7958 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7959       do iii=1,2
7960         do kkk=1,5
7961           do lll=1,3
7962             derx(lll,kkk,iii)=0.0d0
7963           enddo
7964         enddo
7965       enddo
7966 !d      eij=facont_hb(jj,i)
7967 !d      ekl=facont_hb(kk,k)
7968 !d      ekont=eij*ekl
7969 !d      eij=1.0d0
7970 !d      ekl=1.0d0
7971 !d      ekont=1.0d0
7972       if (l.eq.j+1) then
7973         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7974         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7975         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7976         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7977         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7978         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7979       else
7980         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7981         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7982         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7983         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7984         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7985           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7986         else
7987           eello6_5=0.0d0
7988         endif
7989         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7990       endif
7991 ! If turn contributions are considered, they will be handled separately.
7992       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7993 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7994 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7995 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7996 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7997 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7998 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7999 !d      goto 1112
8000       if (j.lt.nres-1) then
8001         j1=j+1
8002         j2=j-1
8003       else
8004         j1=j-1
8005         j2=j-2
8006       endif
8007       if (l.lt.nres-1) then
8008         l1=l+1
8009         l2=l-1
8010       else
8011         l1=l-1
8012         l2=l-2
8013       endif
8014       do ll=1,3
8015 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8016 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8017 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8018 !grad        ghalf=0.5d0*ggg1(ll)
8019 !d        ghalf=0.0d0
8020         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8021         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8022         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8023         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8024         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8025         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8026         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8027         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8028 !grad        ghalf=0.5d0*ggg2(ll)
8029 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8030 !d        ghalf=0.0d0
8031         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8032         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8033         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8034         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8035         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8036         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8037       enddo
8038 !d      goto 1112
8039 !grad      do m=i+1,j-1
8040 !grad        do ll=1,3
8041 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8042 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8043 !grad        enddo
8044 !grad      enddo
8045 !grad      do m=k+1,l-1
8046 !grad        do ll=1,3
8047 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8048 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8049 !grad        enddo
8050 !grad      enddo
8051 !grad1112  continue
8052 !grad      do m=i+2,j2
8053 !grad        do ll=1,3
8054 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8055 !grad        enddo
8056 !grad      enddo
8057 !grad      do m=k+2,l2
8058 !grad        do ll=1,3
8059 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8060 !grad        enddo
8061 !grad      enddo
8062 !d      do iii=1,nres-3
8063 !d        write (2,*) iii,g_corr6_loc(iii)
8064 !d      enddo
8065       eello6=ekont*eel6
8066 !d      write (2,*) 'ekont',ekont
8067 !d      write (iout,*) 'eello6',ekont*eel6
8068       return
8069       end function eello6
8070 !-----------------------------------------------------------------------------
8071       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
8072       use comm_kut
8073 !      implicit real*8 (a-h,o-z)
8074 !      include 'DIMENSIONS'
8075 !      include 'COMMON.IOUNITS'
8076 !      include 'COMMON.CHAIN'
8077 !      include 'COMMON.DERIV'
8078 !      include 'COMMON.INTERACT'
8079 !      include 'COMMON.CONTACTS'
8080 !      include 'COMMON.TORSION'
8081 !      include 'COMMON.VAR'
8082 !      include 'COMMON.GEO'
8083       real(kind=8),dimension(2) :: vv,vv1
8084       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8085       logical :: swap
8086 !el      logical :: lprn
8087 !el      common /kutas/ lprn
8088       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8089       real(kind=8) :: s1,s2,s3,s4,s5
8090 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8091 !                                                                              C
8092 !      Parallel       Antiparallel                                             C
8093 !                                                                              C
8094 !          o             o                                                     C
8095 !         /l\           /j\                                                    C
8096 !        /   \         /   \                                                   C
8097 !       /| o |         | o |\                                                  C
8098 !     \ j|/k\|  /   \  |/k\|l /                                                C
8099 !      \ /   \ /     \ /   \ /                                                 C
8100 !       o     o       o     o                                                  C
8101 !       i             i                                                        C
8102 !                                                                              C
8103 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8104       itk=itortyp(itype(k))
8105       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8106       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8107       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8108       call transpose2(EUgC(1,1,k),auxmat(1,1))
8109       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8110       vv1(1)=pizda1(1,1)-pizda1(2,2)
8111       vv1(2)=pizda1(1,2)+pizda1(2,1)
8112       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8113       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8114       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8115       s5=scalar2(vv(1),Dtobr2(1,i))
8116 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8117       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8118       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8119        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8120        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8121        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8122        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8123        +scalar2(vv(1),Dtobr2der(1,i)))
8124       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8125       vv1(1)=pizda1(1,1)-pizda1(2,2)
8126       vv1(2)=pizda1(1,2)+pizda1(2,1)
8127       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8128       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8129       if (l.eq.j+1) then
8130         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8131        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8132        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8133        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8134        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8135       else
8136         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8137        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8138        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8139        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8140        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8141       endif
8142       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8143       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8144       vv1(1)=pizda1(1,1)-pizda1(2,2)
8145       vv1(2)=pizda1(1,2)+pizda1(2,1)
8146       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8147        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8148        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8149        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8150       do iii=1,2
8151         if (swap) then
8152           ind=3-iii
8153         else
8154           ind=iii
8155         endif
8156         do kkk=1,5
8157           do lll=1,3
8158             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8159             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8160             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8161             call transpose2(EUgC(1,1,k),auxmat(1,1))
8162             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8163               pizda1(1,1))
8164             vv1(1)=pizda1(1,1)-pizda1(2,2)
8165             vv1(2)=pizda1(1,2)+pizda1(2,1)
8166             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8167             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8168              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8169             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8170              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8171             s5=scalar2(vv(1),Dtobr2(1,i))
8172             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8173           enddo
8174         enddo
8175       enddo
8176       return
8177       end function eello6_graph1
8178 !-----------------------------------------------------------------------------
8179       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8180       use comm_kut
8181 !      implicit real*8 (a-h,o-z)
8182 !      include 'DIMENSIONS'
8183 !      include 'COMMON.IOUNITS'
8184 !      include 'COMMON.CHAIN'
8185 !      include 'COMMON.DERIV'
8186 !      include 'COMMON.INTERACT'
8187 !      include 'COMMON.CONTACTS'
8188 !      include 'COMMON.TORSION'
8189 !      include 'COMMON.VAR'
8190 !      include 'COMMON.GEO'
8191       logical :: swap
8192       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8193       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8194 !el      logical :: lprn
8195 !el      common /kutas/ lprn
8196       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8197       real(kind=8) :: s2,s3,s4
8198 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8199 !                                                                              C
8200 !      Parallel       Antiparallel                                             C
8201 !                                                                              C
8202 !          o             o                                                     C
8203 !     \   /l\           /j\   /                                                C
8204 !      \ /   \         /   \ /                                                 C
8205 !       o| o |         | o |o                                                  C
8206 !     \ j|/k\|      \  |/k\|l                                                  C
8207 !      \ /   \       \ /   \                                                   C
8208 !       o             o                                                        C
8209 !       i             i                                                        C
8210 !                                                                              C
8211 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8212 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8213 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8214 !           but not in a cluster cumulant
8215 #ifdef MOMENT
8216       s1=dip(1,jj,i)*dip(1,kk,k)
8217 #endif
8218       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8219       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8220       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8221       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8222       call transpose2(EUg(1,1,k),auxmat(1,1))
8223       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8224       vv(1)=pizda(1,1)-pizda(2,2)
8225       vv(2)=pizda(1,2)+pizda(2,1)
8226       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8227 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8228 #ifdef MOMENT
8229       eello6_graph2=-(s1+s2+s3+s4)
8230 #else
8231       eello6_graph2=-(s2+s3+s4)
8232 #endif
8233 !      eello6_graph2=-s3
8234 ! Derivatives in gamma(i-1)
8235       if (i.gt.1) then
8236 #ifdef MOMENT
8237         s1=dipderg(1,jj,i)*dip(1,kk,k)
8238 #endif
8239         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8240         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8241         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8242         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8243 #ifdef MOMENT
8244         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8245 #else
8246         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8247 #endif
8248 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8249       endif
8250 ! Derivatives in gamma(k-1)
8251 #ifdef MOMENT
8252       s1=dip(1,jj,i)*dipderg(1,kk,k)
8253 #endif
8254       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8255       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8256       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8257       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8258       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8259       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8260       vv(1)=pizda(1,1)-pizda(2,2)
8261       vv(2)=pizda(1,2)+pizda(2,1)
8262       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8263 #ifdef MOMENT
8264       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8265 #else
8266       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8267 #endif
8268 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8269 ! Derivatives in gamma(j-1) or gamma(l-1)
8270       if (j.gt.1) then
8271 #ifdef MOMENT
8272         s1=dipderg(3,jj,i)*dip(1,kk,k)
8273 #endif
8274         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8275         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8276         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8277         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8278         vv(1)=pizda(1,1)-pizda(2,2)
8279         vv(2)=pizda(1,2)+pizda(2,1)
8280         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8281 #ifdef MOMENT
8282         if (swap) then
8283           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8284         else
8285           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8286         endif
8287 #endif
8288         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8289 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8290       endif
8291 ! Derivatives in gamma(l-1) or gamma(j-1)
8292       if (l.gt.1) then
8293 #ifdef MOMENT
8294         s1=dip(1,jj,i)*dipderg(3,kk,k)
8295 #endif
8296         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8297         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8298         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8299         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8300         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8301         vv(1)=pizda(1,1)-pizda(2,2)
8302         vv(2)=pizda(1,2)+pizda(2,1)
8303         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8304 #ifdef MOMENT
8305         if (swap) then
8306           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8307         else
8308           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8309         endif
8310 #endif
8311         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8312 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8313       endif
8314 ! Cartesian derivatives.
8315       if (lprn) then
8316         write (2,*) 'In eello6_graph2'
8317         do iii=1,2
8318           write (2,*) 'iii=',iii
8319           do kkk=1,5
8320             write (2,*) 'kkk=',kkk
8321             do jjj=1,2
8322               write (2,'(3(2f10.5),5x)') &
8323               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8324             enddo
8325           enddo
8326         enddo
8327       endif
8328       do iii=1,2
8329         do kkk=1,5
8330           do lll=1,3
8331 #ifdef MOMENT
8332             if (iii.eq.1) then
8333               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8334             else
8335               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8336             endif
8337 #endif
8338             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8339               auxvec(1))
8340             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8341             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8342               auxvec(1))
8343             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8344             call transpose2(EUg(1,1,k),auxmat(1,1))
8345             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8346               pizda(1,1))
8347             vv(1)=pizda(1,1)-pizda(2,2)
8348             vv(2)=pizda(1,2)+pizda(2,1)
8349             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8350 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8351 #ifdef MOMENT
8352             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8353 #else
8354             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8355 #endif
8356             if (swap) then
8357               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8358             else
8359               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8360             endif
8361           enddo
8362         enddo
8363       enddo
8364       return
8365       end function eello6_graph2
8366 !-----------------------------------------------------------------------------
8367       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8368 !      implicit real*8 (a-h,o-z)
8369 !      include 'DIMENSIONS'
8370 !      include 'COMMON.IOUNITS'
8371 !      include 'COMMON.CHAIN'
8372 !      include 'COMMON.DERIV'
8373 !      include 'COMMON.INTERACT'
8374 !      include 'COMMON.CONTACTS'
8375 !      include 'COMMON.TORSION'
8376 !      include 'COMMON.VAR'
8377 !      include 'COMMON.GEO'
8378       real(kind=8),dimension(2) :: vv,auxvec
8379       real(kind=8),dimension(2,2) :: pizda,auxmat
8380       logical :: swap
8381       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8382       real(kind=8) :: s1,s2,s3,s4
8383 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8384 !                                                                              C
8385 !      Parallel       Antiparallel                                             C
8386 !                                                                              C
8387 !          o             o                                                     C
8388 !         /l\   /   \   /j\                                                    C
8389 !        /   \ /     \ /   \                                                   C
8390 !       /| o |o       o| o |\                                                  C
8391 !       j|/k\|  /      |/k\|l /                                                C
8392 !        /   \ /       /   \ /                                                 C
8393 !       /     o       /     o                                                  C
8394 !       i             i                                                        C
8395 !                                                                              C
8396 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8397 !
8398 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8399 !           energy moment and not to the cluster cumulant.
8400       iti=itortyp(itype(i))
8401       if (j.lt.nres-1) then
8402         itj1=itortyp(itype(j+1))
8403       else
8404         itj1=ntortyp+1
8405       endif
8406       itk=itortyp(itype(k))
8407       itk1=itortyp(itype(k+1))
8408       if (l.lt.nres-1) then
8409         itl1=itortyp(itype(l+1))
8410       else
8411         itl1=ntortyp+1
8412       endif
8413 #ifdef MOMENT
8414       s1=dip(4,jj,i)*dip(4,kk,k)
8415 #endif
8416       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8417       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8418       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8419       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8420       call transpose2(EE(1,1,itk),auxmat(1,1))
8421       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8422       vv(1)=pizda(1,1)+pizda(2,2)
8423       vv(2)=pizda(2,1)-pizda(1,2)
8424       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8425 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8426 !d     & "sum",-(s2+s3+s4)
8427 #ifdef MOMENT
8428       eello6_graph3=-(s1+s2+s3+s4)
8429 #else
8430       eello6_graph3=-(s2+s3+s4)
8431 #endif
8432 !      eello6_graph3=-s4
8433 ! Derivatives in gamma(k-1)
8434       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8435       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8436       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8437       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8438 ! Derivatives in gamma(l-1)
8439       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8440       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8441       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8442       vv(1)=pizda(1,1)+pizda(2,2)
8443       vv(2)=pizda(2,1)-pizda(1,2)
8444       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8445       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8446 ! Cartesian derivatives.
8447       do iii=1,2
8448         do kkk=1,5
8449           do lll=1,3
8450 #ifdef MOMENT
8451             if (iii.eq.1) then
8452               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8453             else
8454               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8455             endif
8456 #endif
8457             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8458               auxvec(1))
8459             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8460             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8461               auxvec(1))
8462             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8463             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8464               pizda(1,1))
8465             vv(1)=pizda(1,1)+pizda(2,2)
8466             vv(2)=pizda(2,1)-pizda(1,2)
8467             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8468 #ifdef MOMENT
8469             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8470 #else
8471             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8472 #endif
8473             if (swap) then
8474               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8475             else
8476               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8477             endif
8478 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8479           enddo
8480         enddo
8481       enddo
8482       return
8483       end function eello6_graph3
8484 !-----------------------------------------------------------------------------
8485       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8486 !      implicit real*8 (a-h,o-z)
8487 !      include 'DIMENSIONS'
8488 !      include 'COMMON.IOUNITS'
8489 !      include 'COMMON.CHAIN'
8490 !      include 'COMMON.DERIV'
8491 !      include 'COMMON.INTERACT'
8492 !      include 'COMMON.CONTACTS'
8493 !      include 'COMMON.TORSION'
8494 !      include 'COMMON.VAR'
8495 !      include 'COMMON.GEO'
8496 !      include 'COMMON.FFIELD'
8497       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8498       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8499       logical :: swap
8500       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8501               iii,kkk,lll
8502       real(kind=8) :: s1,s2,s3,s4
8503 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8504 !                                                                              C
8505 !      Parallel       Antiparallel                                             C
8506 !                                                                              C
8507 !          o             o                                                     C
8508 !         /l\   /   \   /j\                                                    C
8509 !        /   \ /     \ /   \                                                   C
8510 !       /| o |o       o| o |\                                                  C
8511 !     \ j|/k\|      \  |/k\|l                                                  C
8512 !      \ /   \       \ /   \                                                   C
8513 !       o     \       o     \                                                  C
8514 !       i             i                                                        C
8515 !                                                                              C
8516 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8517 !
8518 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8519 !           energy moment and not to the cluster cumulant.
8520 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8521       iti=itortyp(itype(i))
8522       itj=itortyp(itype(j))
8523       if (j.lt.nres-1) then
8524         itj1=itortyp(itype(j+1))
8525       else
8526         itj1=ntortyp+1
8527       endif
8528       itk=itortyp(itype(k))
8529       if (k.lt.nres-1) then
8530         itk1=itortyp(itype(k+1))
8531       else
8532         itk1=ntortyp+1
8533       endif
8534       itl=itortyp(itype(l))
8535       if (l.lt.nres-1) then
8536         itl1=itortyp(itype(l+1))
8537       else
8538         itl1=ntortyp+1
8539       endif
8540 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8541 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8542 !d     & ' itl',itl,' itl1',itl1
8543 #ifdef MOMENT
8544       if (imat.eq.1) then
8545         s1=dip(3,jj,i)*dip(3,kk,k)
8546       else
8547         s1=dip(2,jj,j)*dip(2,kk,l)
8548       endif
8549 #endif
8550       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8551       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8552       if (j.eq.l+1) then
8553         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8554         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8555       else
8556         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8557         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8558       endif
8559       call transpose2(EUg(1,1,k),auxmat(1,1))
8560       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8561       vv(1)=pizda(1,1)-pizda(2,2)
8562       vv(2)=pizda(2,1)+pizda(1,2)
8563       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8564 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8565 #ifdef MOMENT
8566       eello6_graph4=-(s1+s2+s3+s4)
8567 #else
8568       eello6_graph4=-(s2+s3+s4)
8569 #endif
8570 ! Derivatives in gamma(i-1)
8571       if (i.gt.1) then
8572 #ifdef MOMENT
8573         if (imat.eq.1) then
8574           s1=dipderg(2,jj,i)*dip(3,kk,k)
8575         else
8576           s1=dipderg(4,jj,j)*dip(2,kk,l)
8577         endif
8578 #endif
8579         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8580         if (j.eq.l+1) then
8581           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8582           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8583         else
8584           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8585           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8586         endif
8587         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8588         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8589 !d          write (2,*) 'turn6 derivatives'
8590 #ifdef MOMENT
8591           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8592 #else
8593           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8594 #endif
8595         else
8596 #ifdef MOMENT
8597           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8598 #else
8599           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8600 #endif
8601         endif
8602       endif
8603 ! Derivatives in gamma(k-1)
8604 #ifdef MOMENT
8605       if (imat.eq.1) then
8606         s1=dip(3,jj,i)*dipderg(2,kk,k)
8607       else
8608         s1=dip(2,jj,j)*dipderg(4,kk,l)
8609       endif
8610 #endif
8611       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8612       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8613       if (j.eq.l+1) then
8614         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8615         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8616       else
8617         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8618         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8619       endif
8620       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8621       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8622       vv(1)=pizda(1,1)-pizda(2,2)
8623       vv(2)=pizda(2,1)+pizda(1,2)
8624       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8625       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8626 #ifdef MOMENT
8627         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8628 #else
8629         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8630 #endif
8631       else
8632 #ifdef MOMENT
8633         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8634 #else
8635         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8636 #endif
8637       endif
8638 ! Derivatives in gamma(j-1) or gamma(l-1)
8639       if (l.eq.j+1 .and. l.gt.1) then
8640         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8641         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8642         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8643         vv(1)=pizda(1,1)-pizda(2,2)
8644         vv(2)=pizda(2,1)+pizda(1,2)
8645         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8646         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8647       else if (j.gt.1) then
8648         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8649         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8650         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8651         vv(1)=pizda(1,1)-pizda(2,2)
8652         vv(2)=pizda(2,1)+pizda(1,2)
8653         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8654         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8655           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8656         else
8657           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8658         endif
8659       endif
8660 ! Cartesian derivatives.
8661       do iii=1,2
8662         do kkk=1,5
8663           do lll=1,3
8664 #ifdef MOMENT
8665             if (iii.eq.1) then
8666               if (imat.eq.1) then
8667                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8668               else
8669                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8670               endif
8671             else
8672               if (imat.eq.1) then
8673                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8674               else
8675                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8676               endif
8677             endif
8678 #endif
8679             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8680               auxvec(1))
8681             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8682             if (j.eq.l+1) then
8683               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8684                 b1(1,itj1),auxvec(1))
8685               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8686             else
8687               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8688                 b1(1,itl1),auxvec(1))
8689               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8690             endif
8691             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8692               pizda(1,1))
8693             vv(1)=pizda(1,1)-pizda(2,2)
8694             vv(2)=pizda(2,1)+pizda(1,2)
8695             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8696             if (swap) then
8697               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8698 #ifdef MOMENT
8699                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8700                    -(s1+s2+s4)
8701 #else
8702                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8703                    -(s2+s4)
8704 #endif
8705                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8706               else
8707 #ifdef MOMENT
8708                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8709 #else
8710                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8711 #endif
8712                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8713               endif
8714             else
8715 #ifdef MOMENT
8716               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8717 #else
8718               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8719 #endif
8720               if (l.eq.j+1) then
8721                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8722               else
8723                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8724               endif
8725             endif
8726           enddo
8727         enddo
8728       enddo
8729       return
8730       end function eello6_graph4
8731 !-----------------------------------------------------------------------------
8732       real(kind=8) function eello_turn6(i,jj,kk)
8733 !      implicit real*8 (a-h,o-z)
8734 !      include 'DIMENSIONS'
8735 !      include 'COMMON.IOUNITS'
8736 !      include 'COMMON.CHAIN'
8737 !      include 'COMMON.DERIV'
8738 !      include 'COMMON.INTERACT'
8739 !      include 'COMMON.CONTACTS'
8740 !      include 'COMMON.TORSION'
8741 !      include 'COMMON.VAR'
8742 !      include 'COMMON.GEO'
8743       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8744       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8745       real(kind=8),dimension(3) :: ggg1,ggg2
8746       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8747       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8748 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8749 !           the respective energy moment and not to the cluster cumulant.
8750 !el local variables
8751       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8752       integer :: j1,j2,l1,l2,ll
8753       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8754       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8755       s1=0.0d0
8756       s8=0.0d0
8757       s13=0.0d0
8758 !
8759       eello_turn6=0.0d0
8760       j=i+4
8761       k=i+1
8762       l=i+3
8763       iti=itortyp(itype(i))
8764       itk=itortyp(itype(k))
8765       itk1=itortyp(itype(k+1))
8766       itl=itortyp(itype(l))
8767       itj=itortyp(itype(j))
8768 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8769 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8770 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8771 !d        eello6=0.0d0
8772 !d        return
8773 !d      endif
8774 !d      write (iout,*)
8775 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8776 !d     &   ' and',k,l
8777 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8778       do iii=1,2
8779         do kkk=1,5
8780           do lll=1,3
8781             derx_turn(lll,kkk,iii)=0.0d0
8782           enddo
8783         enddo
8784       enddo
8785 !d      eij=1.0d0
8786 !d      ekl=1.0d0
8787 !d      ekont=1.0d0
8788       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8789 !d      eello6_5=0.0d0
8790 !d      write (2,*) 'eello6_5',eello6_5
8791 #ifdef MOMENT
8792       call transpose2(AEA(1,1,1),auxmat(1,1))
8793       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8794       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8795       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8796 #endif
8797       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8798       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8799       s2 = scalar2(b1(1,itk),vtemp1(1))
8800 #ifdef MOMENT
8801       call transpose2(AEA(1,1,2),atemp(1,1))
8802       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8803       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8804       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8805 #endif
8806       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8807       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8808       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8809 #ifdef MOMENT
8810       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8811       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8812       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8813       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8814       ss13 = scalar2(b1(1,itk),vtemp4(1))
8815       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8816 #endif
8817 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8818 !      s1=0.0d0
8819 !      s2=0.0d0
8820 !      s8=0.0d0
8821 !      s12=0.0d0
8822 !      s13=0.0d0
8823       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8824 ! Derivatives in gamma(i+2)
8825       s1d =0.0d0
8826       s8d =0.0d0
8827 #ifdef MOMENT
8828       call transpose2(AEA(1,1,1),auxmatd(1,1))
8829       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8830       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8831       call transpose2(AEAderg(1,1,2),atempd(1,1))
8832       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8833       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8834 #endif
8835       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8836       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8837       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8838 !      s1d=0.0d0
8839 !      s2d=0.0d0
8840 !      s8d=0.0d0
8841 !      s12d=0.0d0
8842 !      s13d=0.0d0
8843       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8844 ! Derivatives in gamma(i+3)
8845 #ifdef MOMENT
8846       call transpose2(AEA(1,1,1),auxmatd(1,1))
8847       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8848       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8849       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8850 #endif
8851       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8852       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8853       s2d = scalar2(b1(1,itk),vtemp1d(1))
8854 #ifdef MOMENT
8855       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8856       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8857 #endif
8858       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8859 #ifdef MOMENT
8860       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8861       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8862       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8863 #endif
8864 !      s1d=0.0d0
8865 !      s2d=0.0d0
8866 !      s8d=0.0d0
8867 !      s12d=0.0d0
8868 !      s13d=0.0d0
8869 #ifdef MOMENT
8870       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8871                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8872 #else
8873       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8874                     -0.5d0*ekont*(s2d+s12d)
8875 #endif
8876 ! Derivatives in gamma(i+4)
8877       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8878       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8879       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8880 #ifdef MOMENT
8881       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8882       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8883       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8884 #endif
8885 !      s1d=0.0d0
8886 !      s2d=0.0d0
8887 !      s8d=0.0d0
8888 !      s12d=0.0d0
8889 !      s13d=0.0d0
8890 #ifdef MOMENT
8891       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8892 #else
8893       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8894 #endif
8895 ! Derivatives in gamma(i+5)
8896 #ifdef MOMENT
8897       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8898       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8899       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8900 #endif
8901       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8902       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8903       s2d = scalar2(b1(1,itk),vtemp1d(1))
8904 #ifdef MOMENT
8905       call transpose2(AEA(1,1,2),atempd(1,1))
8906       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8907       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8908 #endif
8909       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8910       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8911 #ifdef MOMENT
8912       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8913       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8914       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8915 #endif
8916 !      s1d=0.0d0
8917 !      s2d=0.0d0
8918 !      s8d=0.0d0
8919 !      s12d=0.0d0
8920 !      s13d=0.0d0
8921 #ifdef MOMENT
8922       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8923                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8924 #else
8925       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8926                     -0.5d0*ekont*(s2d+s12d)
8927 #endif
8928 ! Cartesian derivatives
8929       do iii=1,2
8930         do kkk=1,5
8931           do lll=1,3
8932 #ifdef MOMENT
8933             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8934             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8935             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8936 #endif
8937             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8938             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8939                 vtemp1d(1))
8940             s2d = scalar2(b1(1,itk),vtemp1d(1))
8941 #ifdef MOMENT
8942             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8943             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8944             s8d = -(atempd(1,1)+atempd(2,2))* &
8945                  scalar2(cc(1,1,itl),vtemp2(1))
8946 #endif
8947             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8948                  auxmatd(1,1))
8949             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8950             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8951 !      s1d=0.0d0
8952 !      s2d=0.0d0
8953 !      s8d=0.0d0
8954 !      s12d=0.0d0
8955 !      s13d=0.0d0
8956 #ifdef MOMENT
8957             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8958               - 0.5d0*(s1d+s2d)
8959 #else
8960             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8961               - 0.5d0*s2d
8962 #endif
8963 #ifdef MOMENT
8964             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8965               - 0.5d0*(s8d+s12d)
8966 #else
8967             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8968               - 0.5d0*s12d
8969 #endif
8970           enddo
8971         enddo
8972       enddo
8973 #ifdef MOMENT
8974       do kkk=1,5
8975         do lll=1,3
8976           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
8977             achuj_tempd(1,1))
8978           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8979           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8980           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8981           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8982           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
8983             vtemp4d(1))
8984           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8985           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8986           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8987         enddo
8988       enddo
8989 #endif
8990 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8991 !d     &  16*eel_turn6_num
8992 !d      goto 1112
8993       if (j.lt.nres-1) then
8994         j1=j+1
8995         j2=j-1
8996       else
8997         j1=j-1
8998         j2=j-2
8999       endif
9000       if (l.lt.nres-1) then
9001         l1=l+1
9002         l2=l-1
9003       else
9004         l1=l-1
9005         l2=l-2
9006       endif
9007       do ll=1,3
9008 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9009 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9010 !grad        ghalf=0.5d0*ggg1(ll)
9011 !d        ghalf=0.0d0
9012         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9013         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9014         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9015           +ekont*derx_turn(ll,2,1)
9016         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9017         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9018           +ekont*derx_turn(ll,4,1)
9019         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9020         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9021         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9022 !grad        ghalf=0.5d0*ggg2(ll)
9023 !d        ghalf=0.0d0
9024         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9025           +ekont*derx_turn(ll,2,2)
9026         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9027         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
9028           +ekont*derx_turn(ll,4,2)
9029         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9030         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9031         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9032       enddo
9033 !d      goto 1112
9034 !grad      do m=i+1,j-1
9035 !grad        do ll=1,3
9036 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9037 !grad        enddo
9038 !grad      enddo
9039 !grad      do m=k+1,l-1
9040 !grad        do ll=1,3
9041 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9042 !grad        enddo
9043 !grad      enddo
9044 !grad1112  continue
9045 !grad      do m=i+2,j2
9046 !grad        do ll=1,3
9047 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9048 !grad        enddo
9049 !grad      enddo
9050 !grad      do m=k+2,l2
9051 !grad        do ll=1,3
9052 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9053 !grad        enddo
9054 !grad      enddo
9055 !d      do iii=1,nres-3
9056 !d        write (2,*) iii,g_corr6_loc(iii)
9057 !d      enddo
9058       eello_turn6=ekont*eel_turn6
9059 !d      write (2,*) 'ekont',ekont
9060 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
9061       return
9062       end function eello_turn6
9063 !-----------------------------------------------------------------------------
9064       subroutine MATVEC2(A1,V1,V2)
9065 !DIR$ INLINEALWAYS MATVEC2
9066 #ifndef OSF
9067 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9068 #endif
9069 !      implicit real*8 (a-h,o-z)
9070 !      include 'DIMENSIONS'
9071       real(kind=8),dimension(2) :: V1,V2
9072       real(kind=8),dimension(2,2) :: A1
9073       real(kind=8) :: vaux1,vaux2
9074 !      DO 1 I=1,2
9075 !        VI=0.0
9076 !        DO 3 K=1,2
9077 !    3     VI=VI+A1(I,K)*V1(K)
9078 !        Vaux(I)=VI
9079 !    1 CONTINUE
9080
9081       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9082       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9083
9084       v2(1)=vaux1
9085       v2(2)=vaux2
9086       end subroutine MATVEC2
9087 !-----------------------------------------------------------------------------
9088       subroutine MATMAT2(A1,A2,A3)
9089 #ifndef OSF
9090 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9091 #endif
9092 !      implicit real*8 (a-h,o-z)
9093 !      include 'DIMENSIONS'
9094       real(kind=8),dimension(2,2) :: A1,A2,A3
9095       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9096 !      DIMENSION AI3(2,2)
9097 !        DO  J=1,2
9098 !          A3IJ=0.0
9099 !          DO K=1,2
9100 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9101 !          enddo
9102 !          A3(I,J)=A3IJ
9103 !       enddo
9104 !      enddo
9105
9106       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9107       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9108       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9109       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9110
9111       A3(1,1)=AI3_11
9112       A3(2,1)=AI3_21
9113       A3(1,2)=AI3_12
9114       A3(2,2)=AI3_22
9115       end subroutine MATMAT2
9116 !-----------------------------------------------------------------------------
9117       real(kind=8) function scalar2(u,v)
9118 !DIR$ INLINEALWAYS scalar2
9119       implicit none
9120       real(kind=8),dimension(2) :: u,v
9121       real(kind=8) :: sc
9122       integer :: i
9123       scalar2=u(1)*v(1)+u(2)*v(2)
9124       return
9125       end function scalar2
9126 !-----------------------------------------------------------------------------
9127       subroutine transpose2(a,at)
9128 !DIR$ INLINEALWAYS transpose2
9129 #ifndef OSF
9130 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9131 #endif
9132       implicit none
9133       real(kind=8),dimension(2,2) :: a,at
9134       at(1,1)=a(1,1)
9135       at(1,2)=a(2,1)
9136       at(2,1)=a(1,2)
9137       at(2,2)=a(2,2)
9138       return
9139       end subroutine transpose2
9140 !-----------------------------------------------------------------------------
9141       subroutine transpose(n,a,at)
9142       implicit none
9143       integer :: n,i,j
9144       real(kind=8),dimension(n,n) :: a,at
9145       do i=1,n
9146         do j=1,n
9147           at(j,i)=a(i,j)
9148         enddo
9149       enddo
9150       return
9151       end subroutine transpose
9152 !-----------------------------------------------------------------------------
9153       subroutine prodmat3(a1,a2,kk,transp,prod)
9154 !DIR$ INLINEALWAYS prodmat3
9155 #ifndef OSF
9156 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9157 #endif
9158       implicit none
9159       integer :: i,j
9160       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9161       logical :: transp
9162 !rc      double precision auxmat(2,2),prod_(2,2)
9163
9164       if (transp) then
9165 !rc        call transpose2(kk(1,1),auxmat(1,1))
9166 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9167 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9168
9169            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9170        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9171            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9172        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9173            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9174        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9175            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9176        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9177
9178       else
9179 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9180 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9181
9182            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9183         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9184            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9185         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9186            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9187         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9188            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9189         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9190
9191       endif
9192 !      call transpose2(a2(1,1),a2t(1,1))
9193
9194 !rc      print *,transp
9195 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9196 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9197
9198       return
9199       end subroutine prodmat3
9200 !-----------------------------------------------------------------------------
9201 ! energy_p_new_barrier.F
9202 !-----------------------------------------------------------------------------
9203       subroutine sum_gradient
9204 !      implicit real*8 (a-h,o-z)
9205       use io_base, only: pdbout
9206 !      include 'DIMENSIONS'
9207 #ifndef ISNAN
9208       external proc_proc
9209 #ifdef WINPGI
9210 !MS$ATTRIBUTES C ::  proc_proc
9211 #endif
9212 #endif
9213 #ifdef MPI
9214       include 'mpif.h'
9215 #endif
9216       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9217                    gloc_scbuf !(3,maxres)
9218
9219       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9220 !#endif
9221 !el local variables
9222       integer :: i,j,k,ierror,ierr
9223       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9224                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9225                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9226                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9227                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9228                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9229                    gsccorr_max,gsccorrx_max,time00
9230
9231 !      include 'COMMON.SETUP'
9232 !      include 'COMMON.IOUNITS'
9233 !      include 'COMMON.FFIELD'
9234 !      include 'COMMON.DERIV'
9235 !      include 'COMMON.INTERACT'
9236 !      include 'COMMON.SBRIDGE'
9237 !      include 'COMMON.CHAIN'
9238 !      include 'COMMON.VAR'
9239 !      include 'COMMON.CONTROL'
9240 !      include 'COMMON.TIME1'
9241 !      include 'COMMON.MAXGRAD'
9242 !      include 'COMMON.SCCOR'
9243 #ifdef TIMING
9244       time01=MPI_Wtime()
9245 #endif
9246 #ifdef DEBUG
9247       write (iout,*) "sum_gradient gvdwc, gvdwx"
9248       do i=1,nres
9249         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9250          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9251       enddo
9252       call flush(iout)
9253 #endif
9254 #ifdef MPI
9255         gradbufc=0.0d0
9256         gradbufx=0.0d0
9257         gradbufc_sum=0.0d0
9258         gloc_scbuf=0.0d0
9259         glocbuf=0.0d0
9260 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9261         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9262           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9263 #endif
9264 !
9265 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9266 !            in virtual-bond-vector coordinates
9267 !
9268 #ifdef DEBUG
9269 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9270 !      do i=1,nres-1
9271 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9272 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9273 !      enddo
9274 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9275 !      do i=1,nres-1
9276 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9277 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9278 !      enddo
9279       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9280       do i=1,nres
9281         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9282          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9283          (gvdwc_scpp(j,i),j=1,3)
9284       enddo
9285       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9286       do i=1,nres
9287         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9288          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9289          (gelc_loc_long(j,i),j=1,3)
9290       enddo
9291       call flush(iout)
9292 #endif
9293 #ifdef SPLITELE
9294       do i=1,nct
9295         do j=1,3
9296           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9297                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9298                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9299                       wel_loc*gel_loc_long(j,i)+ &
9300                       wcorr*gradcorr_long(j,i)+ &
9301                       wcorr5*gradcorr5_long(j,i)+ &
9302                       wcorr6*gradcorr6_long(j,i)+ &
9303                       wturn6*gcorr6_turn_long(j,i)+ &
9304                       wstrain*ghpbc(j,i)
9305         enddo
9306       enddo
9307 #else
9308       do i=1,nct
9309         do j=1,3
9310           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9311                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9312                       welec*gelc_long(j,i)+ &
9313                       wbond*gradb(j,i)+ &
9314                       wel_loc*gel_loc_long(j,i)+ &
9315                       wcorr*gradcorr_long(j,i)+ &
9316                       wcorr5*gradcorr5_long(j,i)+ &
9317                       wcorr6*gradcorr6_long(j,i)+ &
9318                       wturn6*gcorr6_turn_long(j,i)+ &
9319                       wstrain*ghpbc(j,i)
9320         enddo
9321       enddo
9322 #endif
9323 #ifdef MPI
9324       if (nfgtasks.gt.1) then
9325       time00=MPI_Wtime()
9326 #ifdef DEBUG
9327       write (iout,*) "gradbufc before allreduce"
9328       do i=1,nres
9329         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9330       enddo
9331       call flush(iout)
9332 #endif
9333       do i=1,nres
9334         do j=1,3
9335           gradbufc_sum(j,i)=gradbufc(j,i)
9336         enddo
9337       enddo
9338 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9339 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9340 !      time_reduce=time_reduce+MPI_Wtime()-time00
9341 #ifdef DEBUG
9342 !      write (iout,*) "gradbufc_sum after allreduce"
9343 !      do i=1,nres
9344 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9345 !      enddo
9346 !      call flush(iout)
9347 #endif
9348 #ifdef TIMING
9349 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9350 #endif
9351       do i=nnt,nres
9352         do k=1,3
9353           gradbufc(k,i)=0.0d0
9354         enddo
9355       enddo
9356 #ifdef DEBUG
9357       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9358       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9359                         " jgrad_end  ",jgrad_end(i),&
9360                         i=igrad_start,igrad_end)
9361 #endif
9362 !
9363 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9364 ! do not parallelize this part.
9365 !
9366 !      do i=igrad_start,igrad_end
9367 !        do j=jgrad_start(i),jgrad_end(i)
9368 !          do k=1,3
9369 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9370 !          enddo
9371 !        enddo
9372 !      enddo
9373       do j=1,3
9374         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9375       enddo
9376       do i=nres-2,nnt,-1
9377         do j=1,3
9378           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9379         enddo
9380       enddo
9381 #ifdef DEBUG
9382       write (iout,*) "gradbufc after summing"
9383       do i=1,nres
9384         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9385       enddo
9386       call flush(iout)
9387 #endif
9388       else
9389 #endif
9390 !el#define DEBUG
9391 #ifdef DEBUG
9392       write (iout,*) "gradbufc"
9393       do i=1,nres
9394         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9395       enddo
9396       call flush(iout)
9397 #endif
9398 !el#undef DEBUG
9399       do i=1,nres
9400         do j=1,3
9401           gradbufc_sum(j,i)=gradbufc(j,i)
9402           gradbufc(j,i)=0.0d0
9403         enddo
9404       enddo
9405       do j=1,3
9406         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9407       enddo
9408       do i=nres-2,nnt,-1
9409         do j=1,3
9410           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9411         enddo
9412       enddo
9413 !      do i=nnt,nres-1
9414 !        do k=1,3
9415 !          gradbufc(k,i)=0.0d0
9416 !        enddo
9417 !        do j=i+1,nres
9418 !          do k=1,3
9419 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9420 !          enddo
9421 !        enddo
9422 !      enddo
9423 !el#define DEBUG
9424 #ifdef DEBUG
9425       write (iout,*) "gradbufc after summing"
9426       do i=1,nres
9427         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9428       enddo
9429       call flush(iout)
9430 #endif
9431 !el#undef DEBUG
9432 #ifdef MPI
9433       endif
9434 #endif
9435       do k=1,3
9436         gradbufc(k,nres)=0.0d0
9437       enddo
9438 !el----------------
9439 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9440 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9441 !el-----------------
9442       do i=1,nct
9443         do j=1,3
9444 #ifdef SPLITELE
9445           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9446                       wel_loc*gel_loc(j,i)+ &
9447                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9448                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9449                       wel_loc*gel_loc_long(j,i)+ &
9450                       wcorr*gradcorr_long(j,i)+ &
9451                       wcorr5*gradcorr5_long(j,i)+ &
9452                       wcorr6*gradcorr6_long(j,i)+ &
9453                       wturn6*gcorr6_turn_long(j,i))+ &
9454                       wbond*gradb(j,i)+ &
9455                       wcorr*gradcorr(j,i)+ &
9456                       wturn3*gcorr3_turn(j,i)+ &
9457                       wturn4*gcorr4_turn(j,i)+ &
9458                       wcorr5*gradcorr5(j,i)+ &
9459                       wcorr6*gradcorr6(j,i)+ &
9460                       wturn6*gcorr6_turn(j,i)+ &
9461                       wsccor*gsccorc(j,i) &
9462                      +wscloc*gscloc(j,i)
9463 #else
9464           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9465                       wel_loc*gel_loc(j,i)+ &
9466                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9467                       welec*gelc_long(j,i)+ &
9468                       wel_loc*gel_loc_long(j,i)+ &
9469 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9470                       wcorr5*gradcorr5_long(j,i)+ &
9471                       wcorr6*gradcorr6_long(j,i)+ &
9472                       wturn6*gcorr6_turn_long(j,i))+ &
9473                       wbond*gradb(j,i)+ &
9474                       wcorr*gradcorr(j,i)+ &
9475                       wturn3*gcorr3_turn(j,i)+ &
9476                       wturn4*gcorr4_turn(j,i)+ &
9477                       wcorr5*gradcorr5(j,i)+ &
9478                       wcorr6*gradcorr6(j,i)+ &
9479                       wturn6*gcorr6_turn(j,i)+ &
9480                       wsccor*gsccorc(j,i) &
9481                      +wscloc*gscloc(j,i)
9482 #endif
9483           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9484                         wbond*gradbx(j,i)+ &
9485                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9486                         wsccor*gsccorx(j,i) &
9487                        +wscloc*gsclocx(j,i)
9488         enddo
9489       enddo
9490 #ifdef DEBUG
9491       write (iout,*) "gloc before adding corr"
9492       do i=1,4*nres
9493         write (iout,*) i,gloc(i,icg)
9494       enddo
9495 #endif
9496       do i=1,nres-3
9497         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9498          +wcorr5*g_corr5_loc(i) &
9499          +wcorr6*g_corr6_loc(i) &
9500          +wturn4*gel_loc_turn4(i) &
9501          +wturn3*gel_loc_turn3(i) &
9502          +wturn6*gel_loc_turn6(i) &
9503          +wel_loc*gel_loc_loc(i)
9504       enddo
9505 #ifdef DEBUG
9506       write (iout,*) "gloc after adding corr"
9507       do i=1,4*nres
9508         write (iout,*) i,gloc(i,icg)
9509       enddo
9510 #endif
9511 #ifdef MPI
9512       if (nfgtasks.gt.1) then
9513         do j=1,3
9514           do i=1,nres
9515             gradbufc(j,i)=gradc(j,i,icg)
9516             gradbufx(j,i)=gradx(j,i,icg)
9517           enddo
9518         enddo
9519         do i=1,4*nres
9520           glocbuf(i)=gloc(i,icg)
9521         enddo
9522 !#define DEBUG
9523 #ifdef DEBUG
9524       write (iout,*) "gloc_sc before reduce"
9525       do i=1,nres
9526        do j=1,1
9527         write (iout,*) i,j,gloc_sc(j,i,icg)
9528        enddo
9529       enddo
9530 #endif
9531 !#undef DEBUG
9532         do i=1,nres
9533          do j=1,3
9534           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9535          enddo
9536         enddo
9537         time00=MPI_Wtime()
9538         call MPI_Barrier(FG_COMM,IERR)
9539         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9540         time00=MPI_Wtime()
9541         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9542           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9543         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9544           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9545         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9546           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9547         time_reduce=time_reduce+MPI_Wtime()-time00
9548         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9549           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9550         time_reduce=time_reduce+MPI_Wtime()-time00
9551 !#define DEBUG
9552 #ifdef DEBUG
9553       write (iout,*) "gloc_sc after reduce"
9554       do i=1,nres
9555        do j=1,1
9556         write (iout,*) i,j,gloc_sc(j,i,icg)
9557        enddo
9558       enddo
9559 #endif
9560 !#undef DEBUG
9561 #ifdef DEBUG
9562       write (iout,*) "gloc after reduce"
9563       do i=1,4*nres
9564         write (iout,*) i,gloc(i,icg)
9565       enddo
9566 #endif
9567       endif
9568 #endif
9569       if (gnorm_check) then
9570 !
9571 ! Compute the maximum elements of the gradient
9572 !
9573       gvdwc_max=0.0d0
9574       gvdwc_scp_max=0.0d0
9575       gelc_max=0.0d0
9576       gvdwpp_max=0.0d0
9577       gradb_max=0.0d0
9578       ghpbc_max=0.0d0
9579       gradcorr_max=0.0d0
9580       gel_loc_max=0.0d0
9581       gcorr3_turn_max=0.0d0
9582       gcorr4_turn_max=0.0d0
9583       gradcorr5_max=0.0d0
9584       gradcorr6_max=0.0d0
9585       gcorr6_turn_max=0.0d0
9586       gsccorc_max=0.0d0
9587       gscloc_max=0.0d0
9588       gvdwx_max=0.0d0
9589       gradx_scp_max=0.0d0
9590       ghpbx_max=0.0d0
9591       gradxorr_max=0.0d0
9592       gsccorx_max=0.0d0
9593       gsclocx_max=0.0d0
9594       do i=1,nct
9595         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9596         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9597         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9598         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9599          gvdwc_scp_max=gvdwc_scp_norm
9600         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9601         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9602         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9603         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9604         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9605         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9606         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9607         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9608         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9609         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9610         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9611         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9612         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9613           gcorr3_turn(1,i)))
9614         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9615           gcorr3_turn_max=gcorr3_turn_norm
9616         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9617           gcorr4_turn(1,i)))
9618         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9619           gcorr4_turn_max=gcorr4_turn_norm
9620         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9621         if (gradcorr5_norm.gt.gradcorr5_max) &
9622           gradcorr5_max=gradcorr5_norm
9623         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9624         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9625         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9626           gcorr6_turn(1,i)))
9627         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9628           gcorr6_turn_max=gcorr6_turn_norm
9629         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9630         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9631         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9632         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9633         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9634         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9635         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9636         if (gradx_scp_norm.gt.gradx_scp_max) &
9637           gradx_scp_max=gradx_scp_norm
9638         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9639         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9640         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9641         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9642         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9643         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9644         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9645         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9646       enddo
9647       if (gradout) then
9648 #ifdef AIX
9649         open(istat,file=statname,position="append")
9650 #else
9651         open(istat,file=statname,access="append")
9652 #endif
9653         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9654            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9655            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9656            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9657            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9658            gsccorx_max,gsclocx_max
9659         close(istat)
9660         if (gvdwc_max.gt.1.0d4) then
9661           write (iout,*) "gvdwc gvdwx gradb gradbx"
9662           do i=nnt,nct
9663             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9664               gradb(j,i),gradbx(j,i),j=1,3)
9665           enddo
9666           call pdbout(0.0d0,'cipiszcze',iout)
9667           call flush(iout)
9668         endif
9669       endif
9670       endif
9671 !el#define DEBUG
9672 #ifdef DEBUG
9673       write (iout,*) "gradc gradx gloc"
9674       do i=1,nres
9675         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9676          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9677       enddo
9678 #endif
9679 !el#undef DEBUG
9680 #ifdef TIMING
9681       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9682 #endif
9683       return
9684       end subroutine sum_gradient
9685 !-----------------------------------------------------------------------------
9686       subroutine sc_grad
9687 !      implicit real*8 (a-h,o-z)
9688       use calc_data
9689 !      include 'DIMENSIONS'
9690 !      include 'COMMON.CHAIN'
9691 !      include 'COMMON.DERIV'
9692 !      include 'COMMON.CALC'
9693 !      include 'COMMON.IOUNITS'
9694       real(kind=8), dimension(3) :: dcosom1,dcosom2
9695
9696       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9697       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9698       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9699            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9700 ! diagnostics only
9701 !      eom1=0.0d0
9702 !      eom2=0.0d0
9703 !      eom12=evdwij*eps1_om12
9704 ! end diagnostics
9705 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9706 !       " sigder",sigder
9707 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9708 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9709 !C      print *,sss_ele_cut,'in sc_grad'
9710       do k=1,3
9711         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9712         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9713       enddo
9714       do k=1,3
9715         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
9716 !C      print *,'gg',k,gg(k)
9717       enddo
9718 !      write (iout,*) "gg",(gg(k),k=1,3)
9719       do k=1,3
9720         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9721                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9722                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
9723                   *sss_ele_cut
9724
9725         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9726                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9727                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
9728                   *sss_ele_cut
9729
9730 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9731 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9732 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9733 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9734       enddo
9735 !
9736 ! Calculate the components of the gradient in DC and X
9737 !
9738 !grad      do k=i,j-1
9739 !grad        do l=1,3
9740 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9741 !grad        enddo
9742 !grad      enddo
9743       do l=1,3
9744         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9745         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9746       enddo
9747       return
9748       end subroutine sc_grad
9749 #ifdef CRYST_THETA
9750 !-----------------------------------------------------------------------------
9751       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9752
9753       use comm_calcthet
9754 !      implicit real*8 (a-h,o-z)
9755 !      include 'DIMENSIONS'
9756 !      include 'COMMON.LOCAL'
9757 !      include 'COMMON.IOUNITS'
9758 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9759 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9760 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9761       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9762       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9763 !el      integer :: it
9764 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9765 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9766 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9767 !el local variables
9768
9769       delthec=thetai-thet_pred_mean
9770       delthe0=thetai-theta0i
9771 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9772       t3 = thetai-thet_pred_mean
9773       t6 = t3**2
9774       t9 = term1
9775       t12 = t3*sigcsq
9776       t14 = t12+t6*sigsqtc
9777       t16 = 1.0d0
9778       t21 = thetai-theta0i
9779       t23 = t21**2
9780       t26 = term2
9781       t27 = t21*t26
9782       t32 = termexp
9783       t40 = t32**2
9784       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9785        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9786        *(-t12*t9-ak*sig0inv*t27)
9787       return
9788       end subroutine mixder
9789 #endif
9790 !-----------------------------------------------------------------------------
9791 ! cartder.F
9792 !-----------------------------------------------------------------------------
9793       subroutine cartder
9794 !-----------------------------------------------------------------------------
9795 ! This subroutine calculates the derivatives of the consecutive virtual
9796 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9797 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9798 ! in the angles alpha and omega, describing the location of a side chain
9799 ! in its local coordinate system.
9800 !
9801 ! The derivatives are stored in the following arrays:
9802 !
9803 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9804 ! The structure is as follows:
9805 !
9806 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9807 ! 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)
9808 !         . . . . . . . . . . . .  . . . . . .
9809 ! 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)
9810 !                          .
9811 !                          .
9812 !                          .
9813 ! 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)
9814 !
9815 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9816 ! The structure is same as above.
9817 !
9818 ! DCDS - the derivatives of the side chain vectors in the local spherical
9819 ! andgles alph and omega:
9820 !
9821 ! 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)
9822 ! 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)
9823 !                          .
9824 !                          .
9825 !                          .
9826 ! 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)
9827 !
9828 ! Version of March '95, based on an early version of November '91.
9829 !
9830 !**********************************************************************
9831 !      implicit real*8 (a-h,o-z)
9832 !      include 'DIMENSIONS'
9833 !      include 'COMMON.VAR'
9834 !      include 'COMMON.CHAIN'
9835 !      include 'COMMON.DERIV'
9836 !      include 'COMMON.GEO'
9837 !      include 'COMMON.LOCAL'
9838 !      include 'COMMON.INTERACT'
9839       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9840       real(kind=8),dimension(3,3) :: dp,temp
9841 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9842       real(kind=8),dimension(3) :: xx,xx1
9843 !el local variables
9844       integer :: i,k,l,j,m,ind,ind1,jjj
9845       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9846                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9847                  sint2,xp,yp,xxp,yyp,zzp,dj
9848
9849 !      common /przechowalnia/ fromto
9850       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9851 ! get the position of the jth ijth fragment of the chain coordinate system
9852 ! in the fromto array.
9853 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9854 !
9855 !      maxdim=(nres-1)*(nres-2)/2
9856 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9857 ! calculate the derivatives of transformation matrix elements in theta
9858 !
9859
9860 !el      call flush(iout) !el
9861       do i=1,nres-2
9862         rdt(1,1,i)=-rt(1,2,i)
9863         rdt(1,2,i)= rt(1,1,i)
9864         rdt(1,3,i)= 0.0d0
9865         rdt(2,1,i)=-rt(2,2,i)
9866         rdt(2,2,i)= rt(2,1,i)
9867         rdt(2,3,i)= 0.0d0
9868         rdt(3,1,i)=-rt(3,2,i)
9869         rdt(3,2,i)= rt(3,1,i)
9870         rdt(3,3,i)= 0.0d0
9871       enddo
9872 !
9873 ! derivatives in phi
9874 !
9875       do i=2,nres-2
9876         drt(1,1,i)= 0.0d0
9877         drt(1,2,i)= 0.0d0
9878         drt(1,3,i)= 0.0d0
9879         drt(2,1,i)= rt(3,1,i)
9880         drt(2,2,i)= rt(3,2,i)
9881         drt(2,3,i)= rt(3,3,i)
9882         drt(3,1,i)=-rt(2,1,i)
9883         drt(3,2,i)=-rt(2,2,i)
9884         drt(3,3,i)=-rt(2,3,i)
9885       enddo
9886 !
9887 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9888 !
9889       do i=2,nres-2
9890         ind=indmat(i,i+1)
9891         do k=1,3
9892           do l=1,3
9893             temp(k,l)=rt(k,l,i)
9894           enddo
9895         enddo
9896         do k=1,3
9897           do l=1,3
9898             fromto(k,l,ind)=temp(k,l)
9899           enddo
9900         enddo
9901         do j=i+1,nres-2
9902           ind=indmat(i,j+1)
9903           do k=1,3
9904             do l=1,3
9905               dpkl=0.0d0
9906               do m=1,3
9907                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9908               enddo
9909               dp(k,l)=dpkl
9910               fromto(k,l,ind)=dpkl
9911             enddo
9912           enddo
9913           do k=1,3
9914             do l=1,3
9915               temp(k,l)=dp(k,l)
9916             enddo
9917           enddo
9918         enddo
9919       enddo
9920 !
9921 ! Calculate derivatives.
9922 !
9923       ind1=0
9924       do i=1,nres-2
9925         ind1=ind1+1
9926 !
9927 ! Derivatives of DC(i+1) in theta(i+2)
9928 !
9929         do j=1,3
9930           do k=1,2
9931             dpjk=0.0D0
9932             do l=1,3
9933               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9934             enddo
9935             dp(j,k)=dpjk
9936             prordt(j,k,i)=dp(j,k)
9937           enddo
9938           dp(j,3)=0.0D0
9939           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9940         enddo
9941 !
9942 ! Derivatives of SC(i+1) in theta(i+2)
9943 !
9944         xx1(1)=-0.5D0*xloc(2,i+1)
9945         xx1(2)= 0.5D0*xloc(1,i+1)
9946         do j=1,3
9947           xj=0.0D0
9948           do k=1,2
9949             xj=xj+r(j,k,i)*xx1(k)
9950           enddo
9951           xx(j)=xj
9952         enddo
9953         do j=1,3
9954           rj=0.0D0
9955           do k=1,3
9956             rj=rj+prod(j,k,i)*xx(k)
9957           enddo
9958           dxdv(j,ind1)=rj
9959         enddo
9960 !
9961 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
9962 ! than the other off-diagonal derivatives.
9963 !
9964         do j=1,3
9965           dxoiij=0.0D0
9966           do k=1,3
9967             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9968           enddo
9969           dxdv(j,ind1+1)=dxoiij
9970         enddo
9971 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
9972 !
9973 ! Derivatives of DC(i+1) in phi(i+2)
9974 !
9975         do j=1,3
9976           do k=1,3
9977             dpjk=0.0
9978             do l=2,3
9979               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
9980             enddo
9981             dp(j,k)=dpjk
9982             prodrt(j,k,i)=dp(j,k)
9983           enddo
9984           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
9985         enddo
9986 !
9987 ! Derivatives of SC(i+1) in phi(i+2)
9988 !
9989         xx(1)= 0.0D0
9990         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
9991         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
9992         do j=1,3
9993           rj=0.0D0
9994           do k=2,3
9995             rj=rj+prod(j,k,i)*xx(k)
9996           enddo
9997           dxdv(j+3,ind1)=-rj
9998         enddo
9999 !
10000 ! Derivatives of SC(i+1) in phi(i+3).
10001 !
10002         do j=1,3
10003           dxoiij=0.0D0
10004           do k=1,3
10005             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10006           enddo
10007           dxdv(j+3,ind1+1)=dxoiij
10008         enddo
10009 !
10010 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
10011 ! theta(nres) and phi(i+3) thru phi(nres).
10012 !
10013         do j=i+1,nres-2
10014           ind1=ind1+1
10015           ind=indmat(i+1,j+1)
10016 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
10017           do k=1,3
10018             do l=1,3
10019               tempkl=0.0D0
10020               do m=1,2
10021                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
10022               enddo
10023               temp(k,l)=tempkl
10024             enddo
10025           enddo
10026 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
10027 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
10028 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
10029 ! Derivatives of virtual-bond vectors in theta
10030           do k=1,3
10031             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
10032           enddo
10033 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
10034 ! Derivatives of SC vectors in theta
10035           do k=1,3
10036             dxoijk=0.0D0
10037             do l=1,3
10038               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10039             enddo
10040             dxdv(k,ind1+1)=dxoijk
10041           enddo
10042 !
10043 !--- Calculate the derivatives in phi
10044 !
10045           do k=1,3
10046             do l=1,3
10047               tempkl=0.0D0
10048               do m=1,3
10049                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
10050               enddo
10051               temp(k,l)=tempkl
10052             enddo
10053           enddo
10054           do k=1,3
10055             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
10056           enddo
10057           do k=1,3
10058             dxoijk=0.0D0
10059             do l=1,3
10060               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10061             enddo
10062             dxdv(k+3,ind1+1)=dxoijk
10063           enddo
10064         enddo
10065       enddo
10066 !
10067 ! Derivatives in alpha and omega:
10068 !
10069       do i=2,nres-1
10070 !       dsci=dsc(itype(i))
10071         dsci=vbld(i+nres)
10072 #ifdef OSF
10073         alphi=alph(i)
10074         omegi=omeg(i)
10075         if(alphi.ne.alphi) alphi=100.0
10076         if(omegi.ne.omegi) omegi=-100.0
10077 #else
10078         alphi=alph(i)
10079         omegi=omeg(i)
10080 #endif
10081 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10082         cosalphi=dcos(alphi)
10083         sinalphi=dsin(alphi)
10084         cosomegi=dcos(omegi)
10085         sinomegi=dsin(omegi)
10086         temp(1,1)=-dsci*sinalphi
10087         temp(2,1)= dsci*cosalphi*cosomegi
10088         temp(3,1)=-dsci*cosalphi*sinomegi
10089         temp(1,2)=0.0D0
10090         temp(2,2)=-dsci*sinalphi*sinomegi
10091         temp(3,2)=-dsci*sinalphi*cosomegi
10092         theta2=pi-0.5D0*theta(i+1)
10093         cost2=dcos(theta2)
10094         sint2=dsin(theta2)
10095         jjj=0
10096 !d      print *,((temp(l,k),l=1,3),k=1,2)
10097         do j=1,2
10098           xp=temp(1,j)
10099           yp=temp(2,j)
10100           xxp= xp*cost2+yp*sint2
10101           yyp=-xp*sint2+yp*cost2
10102           zzp=temp(3,j)
10103           xx(1)=xxp
10104           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
10105           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
10106           do k=1,3
10107             dj=0.0D0
10108             do l=1,3
10109               dj=dj+prod(k,l,i-1)*xx(l)
10110             enddo
10111             dxds(jjj+k,i)=dj
10112           enddo
10113           jjj=jjj+3
10114         enddo
10115       enddo
10116       return
10117       end subroutine cartder
10118 !-----------------------------------------------------------------------------
10119 ! checkder_p.F
10120 !-----------------------------------------------------------------------------
10121       subroutine check_cartgrad
10122 ! Check the gradient of Cartesian coordinates in internal coordinates.
10123 !      implicit real*8 (a-h,o-z)
10124 !      include 'DIMENSIONS'
10125 !      include 'COMMON.IOUNITS'
10126 !      include 'COMMON.VAR'
10127 !      include 'COMMON.CHAIN'
10128 !      include 'COMMON.GEO'
10129 !      include 'COMMON.LOCAL'
10130 !      include 'COMMON.DERIV'
10131       real(kind=8),dimension(6,nres) :: temp
10132       real(kind=8),dimension(3) :: xx,gg
10133       integer :: i,k,j,ii
10134       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
10135 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10136 !
10137 ! Check the gradient of the virtual-bond and SC vectors in the internal
10138 ! coordinates.
10139 !
10140       aincr=1.0d-7
10141       aincr2=5.0d-8
10142       call cartder
10143       write (iout,'(a)') '**************** dx/dalpha'
10144       write (iout,'(a)')
10145       do i=2,nres-1
10146         alphi=alph(i)
10147         alph(i)=alph(i)+aincr
10148         do k=1,3
10149           temp(k,i)=dc(k,nres+i)
10150         enddo
10151         call chainbuild
10152         do k=1,3
10153           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10154           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10155         enddo
10156         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10157         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10158         write (iout,'(a)')
10159         alph(i)=alphi
10160         call chainbuild
10161       enddo
10162       write (iout,'(a)')
10163       write (iout,'(a)') '**************** dx/domega'
10164       write (iout,'(a)')
10165       do i=2,nres-1
10166         omegi=omeg(i)
10167         omeg(i)=omeg(i)+aincr
10168         do k=1,3
10169           temp(k,i)=dc(k,nres+i)
10170         enddo
10171         call chainbuild
10172         do k=1,3
10173           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10174           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10175                 (aincr*dabs(dxds(k+3,i))+aincr))
10176         enddo
10177         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10178             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10179         write (iout,'(a)')
10180         omeg(i)=omegi
10181         call chainbuild
10182       enddo
10183       write (iout,'(a)')
10184       write (iout,'(a)') '**************** dx/dtheta'
10185       write (iout,'(a)')
10186       do i=3,nres
10187         theti=theta(i)
10188         theta(i)=theta(i)+aincr
10189         do j=i-1,nres-1
10190           do k=1,3
10191             temp(k,j)=dc(k,nres+j)
10192           enddo
10193         enddo
10194         call chainbuild
10195         do j=i-1,nres-1
10196           ii = indmat(i-2,j)
10197 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10198           do k=1,3
10199             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10200             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10201                   (aincr*dabs(dxdv(k,ii))+aincr))
10202           enddo
10203           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10204               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10205           write(iout,'(a)')
10206         enddo
10207         write (iout,'(a)')
10208         theta(i)=theti
10209         call chainbuild
10210       enddo
10211       write (iout,'(a)') '***************** dx/dphi'
10212       write (iout,'(a)')
10213       do i=4,nres
10214         phi(i)=phi(i)+aincr
10215         do j=i-1,nres-1
10216           do k=1,3
10217             temp(k,j)=dc(k,nres+j)
10218           enddo
10219         enddo
10220         call chainbuild
10221         do j=i-1,nres-1
10222           ii = indmat(i-2,j)
10223 !         print *,'ii=',ii
10224           do k=1,3
10225             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10226             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10227                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10228           enddo
10229           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10230               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10231           write(iout,'(a)')
10232         enddo
10233         phi(i)=phi(i)-aincr
10234         call chainbuild
10235       enddo
10236       write (iout,'(a)') '****************** ddc/dtheta'
10237       do i=1,nres-2
10238         thet=theta(i+2)
10239         theta(i+2)=thet+aincr
10240         do j=i,nres
10241           do k=1,3
10242             temp(k,j)=dc(k,j)
10243           enddo
10244         enddo
10245         call chainbuild
10246         do j=i+1,nres-1
10247           ii = indmat(i,j)
10248 !         print *,'ii=',ii
10249           do k=1,3
10250             gg(k)=(dc(k,j)-temp(k,j))/aincr
10251             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10252                  (aincr*dabs(dcdv(k,ii))+aincr))
10253           enddo
10254           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10255                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10256           write (iout,'(a)')
10257         enddo
10258         do j=1,nres
10259           do k=1,3
10260             dc(k,j)=temp(k,j)
10261           enddo
10262         enddo
10263         theta(i+2)=thet
10264       enddo
10265       write (iout,'(a)') '******************* ddc/dphi'
10266       do i=1,nres-3
10267         phii=phi(i+3)
10268         phi(i+3)=phii+aincr
10269         do j=1,nres
10270           do k=1,3
10271             temp(k,j)=dc(k,j)
10272           enddo
10273         enddo
10274         call chainbuild
10275         do j=i+2,nres-1
10276           ii = indmat(i+1,j)
10277 !         print *,'ii=',ii
10278           do k=1,3
10279             gg(k)=(dc(k,j)-temp(k,j))/aincr
10280             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10281                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10282           enddo
10283           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10284                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10285           write (iout,'(a)')
10286         enddo
10287         do j=1,nres
10288           do k=1,3
10289             dc(k,j)=temp(k,j)
10290           enddo
10291         enddo
10292         phi(i+3)=phii
10293       enddo
10294       return
10295       end subroutine check_cartgrad
10296 !-----------------------------------------------------------------------------
10297       subroutine check_ecart
10298 ! Check the gradient of the energy in Cartesian coordinates.
10299 !     implicit real*8 (a-h,o-z)
10300 !     include 'DIMENSIONS'
10301 !     include 'COMMON.CHAIN'
10302 !     include 'COMMON.DERIV'
10303 !     include 'COMMON.IOUNITS'
10304 !     include 'COMMON.VAR'
10305 !     include 'COMMON.CONTACTS'
10306       use comm_srutu
10307 !el      integer :: icall
10308 !el      common /srutu/ icall
10309       real(kind=8),dimension(6) :: ggg
10310       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10311       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10312       real(kind=8),dimension(6,nres) :: grad_s
10313       real(kind=8),dimension(0:n_ene) :: energia,energia1
10314       integer :: uiparm(1)
10315       real(kind=8) :: urparm(1)
10316 !EL      external fdum
10317       integer :: nf,i,j,k
10318       real(kind=8) :: aincr,etot,etot1
10319       icg=1
10320       nf=0
10321       nfl=0
10322       call zerograd
10323       aincr=1.0D-7
10324       print '(a)','CG processor',me,' calling CHECK_CART.'
10325       nf=0
10326       icall=0
10327       call geom_to_var(nvar,x)
10328       call etotal(energia)
10329       etot=energia(0)
10330 !el      call enerprint(energia)
10331       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10332       icall =1
10333       do i=1,nres
10334         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10335       enddo
10336       do i=1,nres
10337         do j=1,3
10338           grad_s(j,i)=gradc(j,i,icg)
10339           grad_s(j+3,i)=gradx(j,i,icg)
10340         enddo
10341       enddo
10342       call flush(iout)
10343       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10344       do i=1,nres
10345         do j=1,3
10346           xx(j)=c(j,i+nres)
10347           ddc(j)=dc(j,i)
10348           ddx(j)=dc(j,i+nres)
10349         enddo
10350         do j=1,3
10351           dc(j,i)=dc(j,i)+aincr
10352           do k=i+1,nres
10353             c(j,k)=c(j,k)+aincr
10354             c(j,k+nres)=c(j,k+nres)+aincr
10355           enddo
10356           call etotal(energia1)
10357           etot1=energia1(0)
10358           ggg(j)=(etot1-etot)/aincr
10359           dc(j,i)=ddc(j)
10360           do k=i+1,nres
10361             c(j,k)=c(j,k)-aincr
10362             c(j,k+nres)=c(j,k+nres)-aincr
10363           enddo
10364         enddo
10365         do j=1,3
10366           c(j,i+nres)=c(j,i+nres)+aincr
10367           dc(j,i+nres)=dc(j,i+nres)+aincr
10368           call etotal(energia1)
10369           etot1=energia1(0)
10370           ggg(j+3)=(etot1-etot)/aincr
10371           c(j,i+nres)=xx(j)
10372           dc(j,i+nres)=ddx(j)
10373         enddo
10374         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10375          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10376       enddo
10377       return
10378       end subroutine check_ecart
10379 #ifdef CARGRAD
10380 !-----------------------------------------------------------------------------
10381       subroutine check_ecartint
10382 ! Check the gradient of the energy in Cartesian coordinates.
10383       use io_base, only: intout
10384 !      implicit real*8 (a-h,o-z)
10385 !      include 'DIMENSIONS'
10386 !      include 'COMMON.CONTROL'
10387 !      include 'COMMON.CHAIN'
10388 !      include 'COMMON.DERIV'
10389 !      include 'COMMON.IOUNITS'
10390 !      include 'COMMON.VAR'
10391 !      include 'COMMON.CONTACTS'
10392 !      include 'COMMON.MD'
10393 !      include 'COMMON.LOCAL'
10394 !      include 'COMMON.SPLITELE'
10395       use comm_srutu
10396 !el      integer :: icall
10397 !el      common /srutu/ icall
10398       real(kind=8),dimension(6) :: ggg,ggg1
10399       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
10400       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10401       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
10402       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10403       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10404       real(kind=8),dimension(0:n_ene) :: energia,energia1
10405       integer :: uiparm(1)
10406       real(kind=8) :: urparm(1)
10407 !EL      external fdum
10408       integer :: i,j,k,nf
10409       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10410                    etot21,etot22
10411       r_cut=2.0d0
10412       rlambd=0.3d0
10413       icg=1
10414       nf=0
10415       nfl=0
10416       call intout
10417 !      call intcartderiv
10418 !      call checkintcartgrad
10419       call zerograd
10420       aincr=1.0D-5
10421       write(iout,*) 'Calling CHECK_ECARTINT.'
10422       nf=0
10423       icall=0
10424       write (iout,*) "Before geom_to_var"
10425       call geom_to_var(nvar,x)
10426       write (iout,*) "after geom_to_var"
10427       write (iout,*) "split_ene ",split_ene
10428       call flush(iout)
10429       if (.not.split_ene) then
10430         write(iout,*) 'Calling CHECK_ECARTINT if'
10431         call etotal(energia)
10432 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10433         etot=energia(0)
10434         write (iout,*) "etot",etot
10435         call flush(iout)
10436 !el        call enerprint(energia)
10437 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10438         call flush(iout)
10439         write (iout,*) "enter cartgrad"
10440         call flush(iout)
10441         call cartgrad
10442 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10443         write (iout,*) "exit cartgrad"
10444         call flush(iout)
10445         icall =1
10446         do i=1,nres
10447           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10448         enddo
10449         do j=1,3
10450           grad_s(j,0)=gcart(j,0)
10451         enddo
10452 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10453         do i=1,nres
10454           do j=1,3
10455             grad_s(j,i)=gcart(j,i)
10456             grad_s(j+3,i)=gxcart(j,i)
10457           enddo
10458         enddo
10459       else
10460 write(iout,*) 'Calling CHECK_ECARTIN else.'
10461 !- split gradient check
10462         call zerograd
10463         call etotal_long(energia)
10464 !el        call enerprint(energia)
10465         call flush(iout)
10466         write (iout,*) "enter cartgrad"
10467         call flush(iout)
10468         call cartgrad
10469         write (iout,*) "exit cartgrad"
10470         call flush(iout)
10471         icall =1
10472         write (iout,*) "longrange grad"
10473         do i=1,nres
10474           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10475           (gxcart(j,i),j=1,3)
10476         enddo
10477         do j=1,3
10478           grad_s(j,0)=gcart(j,0)
10479         enddo
10480         do i=1,nres
10481           do j=1,3
10482             grad_s(j,i)=gcart(j,i)
10483             grad_s(j+3,i)=gxcart(j,i)
10484           enddo
10485         enddo
10486         call zerograd
10487         call etotal_short(energia)
10488 !el        call enerprint(energia)
10489         call flush(iout)
10490         write (iout,*) "enter cartgrad"
10491         call flush(iout)
10492         call cartgrad
10493         write (iout,*) "exit cartgrad"
10494         call flush(iout)
10495         icall =1
10496         write (iout,*) "shortrange grad"
10497         do i=1,nres
10498           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10499           (gxcart(j,i),j=1,3)
10500         enddo
10501         do j=1,3
10502           grad_s1(j,0)=gcart(j,0)
10503         enddo
10504         do i=1,nres
10505           do j=1,3
10506             grad_s1(j,i)=gcart(j,i)
10507             grad_s1(j+3,i)=gxcart(j,i)
10508           enddo
10509         enddo
10510       endif
10511       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10512 !      do i=1,nres
10513       do i=nnt,nct
10514         do j=1,3
10515           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
10516           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
10517           ddc(j)=c(j,i)
10518           ddx(j)=c(j,i+nres)
10519           dcnorm_safe1(j)=dc_norm(j,i-1)
10520           dcnorm_safe2(j)=dc_norm(j,i)
10521           dxnorm_safe(j)=dc_norm(j,i+nres)
10522         enddo
10523         do j=1,3
10524           c(j,i)=ddc(j)+aincr
10525           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
10526           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
10527           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10528           dc(j,i)=c(j,i+1)-c(j,i)
10529           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10530           call int_from_cart1(.false.)
10531           if (.not.split_ene) then
10532             call etotal(energia1)
10533             etot1=energia1(0)
10534             write (iout,*) "ij",i,j," etot1",etot1
10535           else
10536 !- split gradient
10537             call etotal_long(energia1)
10538             etot11=energia1(0)
10539             call etotal_short(energia1)
10540             etot12=energia1(0)
10541           endif
10542 !- end split gradient
10543 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10544           c(j,i)=ddc(j)-aincr
10545           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
10546           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
10547           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10548           dc(j,i)=c(j,i+1)-c(j,i)
10549           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10550           call int_from_cart1(.false.)
10551           if (.not.split_ene) then
10552             call etotal(energia1)
10553             etot2=energia1(0)
10554             write (iout,*) "ij",i,j," etot2",etot2
10555             ggg(j)=(etot1-etot2)/(2*aincr)
10556           else
10557 !- split gradient
10558             call etotal_long(energia1)
10559             etot21=energia1(0)
10560             ggg(j)=(etot11-etot21)/(2*aincr)
10561             call etotal_short(energia1)
10562             etot22=energia1(0)
10563             ggg1(j)=(etot12-etot22)/(2*aincr)
10564 !- end split gradient
10565 !            write (iout,*) "etot21",etot21," etot22",etot22
10566           endif
10567 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10568           c(j,i)=ddc(j)
10569           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
10570           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
10571           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10572           dc(j,i)=c(j,i+1)-c(j,i)
10573           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10574           dc_norm(j,i-1)=dcnorm_safe1(j)
10575           dc_norm(j,i)=dcnorm_safe2(j)
10576           dc_norm(j,i+nres)=dxnorm_safe(j)
10577         enddo
10578         do j=1,3
10579           c(j,i+nres)=ddx(j)+aincr
10580           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10581           call int_from_cart1(.false.)
10582           if (.not.split_ene) then
10583             call etotal(energia1)
10584             etot1=energia1(0)
10585           else
10586 !- split gradient
10587             call etotal_long(energia1)
10588             etot11=energia1(0)
10589             call etotal_short(energia1)
10590             etot12=energia1(0)
10591           endif
10592 !- end split gradient
10593           c(j,i+nres)=ddx(j)-aincr
10594           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10595           call int_from_cart1(.false.)
10596           if (.not.split_ene) then
10597             call etotal(energia1)
10598             etot2=energia1(0)
10599             ggg(j+3)=(etot1-etot2)/(2*aincr)
10600           else
10601 !- split gradient
10602             call etotal_long(energia1)
10603             etot21=energia1(0)
10604             ggg(j+3)=(etot11-etot21)/(2*aincr)
10605             call etotal_short(energia1)
10606             etot22=energia1(0)
10607             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10608 !- end split gradient
10609           endif
10610 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10611           c(j,i+nres)=ddx(j)
10612           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10613           dc_norm(j,i+nres)=dxnorm_safe(j)
10614           call int_from_cart1(.false.)
10615         enddo
10616         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10617          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10618         if (split_ene) then
10619           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10620          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10621          k=1,6)
10622          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10623          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10624          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10625         endif
10626       enddo
10627       return
10628       end subroutine check_ecartint
10629 #else
10630 !-----------------------------------------------------------------------------
10631       subroutine check_ecartint
10632 ! Check the gradient of the energy in Cartesian coordinates.
10633       use io_base, only: intout
10634 !      implicit real*8 (a-h,o-z)
10635 !      include 'DIMENSIONS'
10636 !      include 'COMMON.CONTROL'
10637 !      include 'COMMON.CHAIN'
10638 !      include 'COMMON.DERIV'
10639 !      include 'COMMON.IOUNITS'
10640 !      include 'COMMON.VAR'
10641 !      include 'COMMON.CONTACTS'
10642 !      include 'COMMON.MD'
10643 !      include 'COMMON.LOCAL'
10644 !      include 'COMMON.SPLITELE'
10645       use comm_srutu
10646 !el      integer :: icall
10647 !el      common /srutu/ icall
10648       real(kind=8),dimension(6) :: ggg,ggg1
10649       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10650       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10651       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10652       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10653       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10654       real(kind=8),dimension(0:n_ene) :: energia,energia1
10655       integer :: uiparm(1)
10656       real(kind=8) :: urparm(1)
10657 !EL      external fdum
10658       integer :: i,j,k,nf
10659       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10660                    etot21,etot22
10661       r_cut=2.0d0
10662       rlambd=0.3d0
10663       icg=1
10664       nf=0
10665       nfl=0
10666       call intout
10667 !      call intcartderiv
10668 !      call checkintcartgrad
10669       call zerograd
10670       aincr=1.0D-6
10671       write(iout,*) 'Calling CHECK_ECARTINT.'
10672       nf=0
10673       icall=0
10674       call geom_to_var(nvar,x)
10675       if (.not.split_ene) then
10676         call etotal(energia)
10677         etot=energia(0)
10678 !el        call enerprint(energia)
10679         call flush(iout)
10680         write (iout,*) "enter cartgrad"
10681         call flush(iout)
10682         call cartgrad
10683         write (iout,*) "exit cartgrad"
10684         call flush(iout)
10685         icall =1
10686         do i=1,nres
10687           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10688         enddo
10689         do j=1,3
10690           grad_s(j,0)=gcart(j,0)
10691         enddo
10692         do i=1,nres
10693           do j=1,3
10694             grad_s(j,i)=gcart(j,i)
10695             grad_s(j+3,i)=gxcart(j,i)
10696           enddo
10697         enddo
10698       else
10699 !- split gradient check
10700         call zerograd
10701         call etotal_long(energia)
10702 !el        call enerprint(energia)
10703         call flush(iout)
10704         write (iout,*) "enter cartgrad"
10705         call flush(iout)
10706         call cartgrad
10707         write (iout,*) "exit cartgrad"
10708         call flush(iout)
10709         icall =1
10710         write (iout,*) "longrange grad"
10711         do i=1,nres
10712           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10713           (gxcart(j,i),j=1,3)
10714         enddo
10715         do j=1,3
10716           grad_s(j,0)=gcart(j,0)
10717         enddo
10718         do i=1,nres
10719           do j=1,3
10720             grad_s(j,i)=gcart(j,i)
10721             grad_s(j+3,i)=gxcart(j,i)
10722           enddo
10723         enddo
10724         call zerograd
10725         call etotal_short(energia)
10726 !el        call enerprint(energia)
10727         call flush(iout)
10728         write (iout,*) "enter cartgrad"
10729         call flush(iout)
10730         call cartgrad
10731         write (iout,*) "exit cartgrad"
10732         call flush(iout)
10733         icall =1
10734         write (iout,*) "shortrange grad"
10735         do i=1,nres
10736           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10737           (gxcart(j,i),j=1,3)
10738         enddo
10739         do j=1,3
10740           grad_s1(j,0)=gcart(j,0)
10741         enddo
10742         do i=1,nres
10743           do j=1,3
10744             grad_s1(j,i)=gcart(j,i)
10745             grad_s1(j+3,i)=gxcart(j,i)
10746           enddo
10747         enddo
10748       endif
10749       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10750       do i=0,nres
10751         do j=1,3
10752           xx(j)=c(j,i+nres)
10753           ddc(j)=dc(j,i)
10754           ddx(j)=dc(j,i+nres)
10755           do k=1,3
10756             dcnorm_safe(k)=dc_norm(k,i)
10757             dxnorm_safe(k)=dc_norm(k,i+nres)
10758           enddo
10759         enddo
10760         do j=1,3
10761           dc(j,i)=ddc(j)+aincr
10762           call chainbuild_cart
10763 #ifdef MPI
10764 ! Broadcast the order to compute internal coordinates to the slaves.
10765 !          if (nfgtasks.gt.1)
10766 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10767 #endif
10768 !          call int_from_cart1(.false.)
10769           if (.not.split_ene) then
10770             call etotal(energia1)
10771             etot1=energia1(0)
10772           else
10773 !- split gradient
10774             call etotal_long(energia1)
10775             etot11=energia1(0)
10776             call etotal_short(energia1)
10777             etot12=energia1(0)
10778 !            write (iout,*) "etot11",etot11," etot12",etot12
10779           endif
10780 !- end split gradient
10781 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10782           dc(j,i)=ddc(j)-aincr
10783           call chainbuild_cart
10784 !          call int_from_cart1(.false.)
10785           if (.not.split_ene) then
10786             call etotal(energia1)
10787             etot2=energia1(0)
10788             ggg(j)=(etot1-etot2)/(2*aincr)
10789           else
10790 !- split gradient
10791             call etotal_long(energia1)
10792             etot21=energia1(0)
10793             ggg(j)=(etot11-etot21)/(2*aincr)
10794             call etotal_short(energia1)
10795             etot22=energia1(0)
10796             ggg1(j)=(etot12-etot22)/(2*aincr)
10797 !- end split gradient
10798 !            write (iout,*) "etot21",etot21," etot22",etot22
10799           endif
10800 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10801           dc(j,i)=ddc(j)
10802           call chainbuild_cart
10803         enddo
10804         do j=1,3
10805           dc(j,i+nres)=ddx(j)+aincr
10806           call chainbuild_cart
10807 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10808 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10809 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10810 !          write (iout,*) "dxnormnorm",dsqrt(
10811 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10812 !          write (iout,*) "dxnormnormsafe",dsqrt(
10813 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10814 !          write (iout,*)
10815           if (.not.split_ene) then
10816             call etotal(energia1)
10817             etot1=energia1(0)
10818           else
10819 !- split gradient
10820             call etotal_long(energia1)
10821             etot11=energia1(0)
10822             call etotal_short(energia1)
10823             etot12=energia1(0)
10824           endif
10825 !- end split gradient
10826 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10827           dc(j,i+nres)=ddx(j)-aincr
10828           call chainbuild_cart
10829 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10830 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10831 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10832 !          write (iout,*)
10833 !          write (iout,*) "dxnormnorm",dsqrt(
10834 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10835 !          write (iout,*) "dxnormnormsafe",dsqrt(
10836 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10837           if (.not.split_ene) then
10838             call etotal(energia1)
10839             etot2=energia1(0)
10840             ggg(j+3)=(etot1-etot2)/(2*aincr)
10841           else
10842 !- split gradient
10843             call etotal_long(energia1)
10844             etot21=energia1(0)
10845             ggg(j+3)=(etot11-etot21)/(2*aincr)
10846             call etotal_short(energia1)
10847             etot22=energia1(0)
10848             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10849 !- end split gradient
10850           endif
10851 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10852           dc(j,i+nres)=ddx(j)
10853           call chainbuild_cart
10854         enddo
10855         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10856          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10857         if (split_ene) then
10858           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10859          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10860          k=1,6)
10861          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10862          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10863          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10864         endif
10865       enddo
10866       return
10867       end subroutine check_ecartint
10868 #endif
10869 !-----------------------------------------------------------------------------
10870       subroutine check_eint
10871 ! Check the gradient of energy in internal coordinates.
10872 !      implicit real*8 (a-h,o-z)
10873 !      include 'DIMENSIONS'
10874 !      include 'COMMON.CHAIN'
10875 !      include 'COMMON.DERIV'
10876 !      include 'COMMON.IOUNITS'
10877 !      include 'COMMON.VAR'
10878 !      include 'COMMON.GEO'
10879       use comm_srutu
10880 !el      integer :: icall
10881 !el      common /srutu/ icall
10882       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10883       integer :: uiparm(1)
10884       real(kind=8) :: urparm(1)
10885       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10886       character(len=6) :: key
10887 !EL      external fdum
10888       integer :: i,ii,nf
10889       real(kind=8) :: xi,aincr,etot,etot1,etot2
10890       call zerograd
10891       aincr=1.0D-7
10892       print '(a)','Calling CHECK_INT.'
10893       nf=0
10894       nfl=0
10895       icg=1
10896       call geom_to_var(nvar,x)
10897       call var_to_geom(nvar,x)
10898       call chainbuild
10899       icall=1
10900       print *,'ICG=',ICG
10901       call etotal(energia)
10902       etot = energia(0)
10903 !el      call enerprint(energia)
10904       print *,'ICG=',ICG
10905 #ifdef MPL
10906       if (MyID.ne.BossID) then
10907         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10908         nf=x(nvar+1)
10909         nfl=x(nvar+2)
10910         icg=x(nvar+3)
10911       endif
10912 #endif
10913       nf=1
10914       nfl=3
10915 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10916       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10917 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10918       icall=1
10919       do i=1,nvar
10920         xi=x(i)
10921         x(i)=xi-0.5D0*aincr
10922         call var_to_geom(nvar,x)
10923         call chainbuild
10924         call etotal(energia1)
10925         etot1=energia1(0)
10926         x(i)=xi+0.5D0*aincr
10927         call var_to_geom(nvar,x)
10928         call chainbuild
10929         call etotal(energia2)
10930         etot2=energia2(0)
10931         gg(i)=(etot2-etot1)/aincr
10932         write (iout,*) i,etot1,etot2
10933         x(i)=xi
10934       enddo
10935       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10936           '     RelDiff*100% '
10937       do i=1,nvar
10938         if (i.le.nphi) then
10939           ii=i
10940           key = ' phi'
10941         else if (i.le.nphi+ntheta) then
10942           ii=i-nphi
10943           key=' theta'
10944         else if (i.le.nphi+ntheta+nside) then
10945            ii=i-(nphi+ntheta)
10946            key=' alpha'
10947         else
10948            ii=i-(nphi+ntheta+nside)
10949            key=' omega'
10950         endif
10951         write (iout,'(i3,a,i3,3(1pd16.6))') &
10952        i,key,ii,gg(i),gana(i),&
10953        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10954       enddo
10955       return
10956       end subroutine check_eint
10957 !-----------------------------------------------------------------------------
10958 ! econstr_local.F
10959 !-----------------------------------------------------------------------------
10960       subroutine Econstr_back
10961 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
10962 !      implicit real*8 (a-h,o-z)
10963 !      include 'DIMENSIONS'
10964 !      include 'COMMON.CONTROL'
10965 !      include 'COMMON.VAR'
10966 !      include 'COMMON.MD'
10967       use MD_data
10968 !#ifndef LANG0
10969 !      include 'COMMON.LANGEVIN'
10970 !#else
10971 !      include 'COMMON.LANGEVIN.lang0'
10972 !#endif
10973 !      include 'COMMON.CHAIN'
10974 !      include 'COMMON.DERIV'
10975 !      include 'COMMON.GEO'
10976 !      include 'COMMON.LOCAL'
10977 !      include 'COMMON.INTERACT'
10978 !      include 'COMMON.IOUNITS'
10979 !      include 'COMMON.NAMES'
10980 !      include 'COMMON.TIME1'
10981       integer :: i,j,ii,k
10982       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
10983
10984       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
10985       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
10986       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
10987
10988       Uconst_back=0.0d0
10989       do i=1,nres
10990         dutheta(i)=0.0d0
10991         dugamma(i)=0.0d0
10992         do j=1,3
10993           duscdiff(j,i)=0.0d0
10994           duscdiffx(j,i)=0.0d0
10995         enddo
10996       enddo
10997       do i=1,nfrag_back
10998         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10999 !
11000 ! Deviations from theta angles
11001 !
11002         utheta_i=0.0d0
11003         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
11004           dtheta_i=theta(j)-thetaref(j)
11005           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
11006           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
11007         enddo
11008         utheta(i)=utheta_i/(ii-1)
11009 !
11010 ! Deviations from gamma angles
11011 !
11012         ugamma_i=0.0d0
11013         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
11014           dgamma_i=pinorm(phi(j)-phiref(j))
11015 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
11016           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
11017           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
11018 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
11019         enddo
11020         ugamma(i)=ugamma_i/(ii-2)
11021 !
11022 ! Deviations from local SC geometry
11023 !
11024         uscdiff(i)=0.0d0
11025         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
11026           dxx=xxtab(j)-xxref(j)
11027           dyy=yytab(j)-yyref(j)
11028           dzz=zztab(j)-zzref(j)
11029           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
11030           do k=1,3
11031             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
11032              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
11033              (ii-1)
11034             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
11035              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
11036              (ii-1)
11037             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
11038            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
11039             /(ii-1)
11040           enddo
11041 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
11042 !     &      xxref(j),yyref(j),zzref(j)
11043         enddo
11044         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
11045 !        write (iout,*) i," uscdiff",uscdiff(i)
11046 !
11047 ! Put together deviations from local geometry
11048 !
11049         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
11050           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
11051 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
11052 !     &   " uconst_back",uconst_back
11053         utheta(i)=dsqrt(utheta(i))
11054         ugamma(i)=dsqrt(ugamma(i))
11055         uscdiff(i)=dsqrt(uscdiff(i))
11056       enddo
11057       return
11058       end subroutine Econstr_back
11059 !-----------------------------------------------------------------------------
11060 ! energy_p_new-sep_barrier.F
11061 !-----------------------------------------------------------------------------
11062       real(kind=8) function sscale(r)
11063 !      include "COMMON.SPLITELE"
11064       real(kind=8) :: r,gamm
11065       if(r.lt.r_cut-rlamb) then
11066         sscale=1.0d0
11067       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11068         gamm=(r-(r_cut-rlamb))/rlamb
11069         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11070       else
11071         sscale=0d0
11072       endif
11073       return
11074       end function sscale
11075       real(kind=8) function sscale_grad(r)
11076 !      include "COMMON.SPLITELE"
11077       real(kind=8) :: r,gamm
11078       if(r.lt.r_cut-rlamb) then
11079         sscale_grad=0.0d0
11080       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11081         gamm=(r-(r_cut-rlamb))/rlamb
11082         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
11083       else
11084         sscale_grad=0d0
11085       endif
11086       return
11087       end function sscale_grad
11088
11089 !!!!!!!!!! PBCSCALE
11090       real(kind=8) function sscale_ele(r)
11091 !      include "COMMON.SPLITELE"
11092       real(kind=8) :: r,gamm
11093       if(r.lt.r_cut_ele-rlamb_ele) then
11094         sscale_ele=1.0d0
11095       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11096         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11097         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11098       else
11099         sscale_ele=0d0
11100       endif
11101       return
11102       end function sscale_ele
11103
11104       real(kind=8)  function sscagrad_ele(r)
11105       real(kind=8) :: r,gamm
11106 !      include "COMMON.SPLITELE"
11107       if(r.lt.r_cut_ele-rlamb_ele) then
11108         sscagrad_ele=0.0d0
11109       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11110         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11111         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
11112       else
11113         sscagrad_ele=0.0d0
11114       endif
11115       return
11116       end function sscagrad_ele
11117 !!!!!!!!!!!!!!!
11118 !-----------------------------------------------------------------------------
11119       subroutine elj_long(evdw)
11120 !
11121 ! This subroutine calculates the interaction energy of nonbonded side chains
11122 ! assuming the LJ potential of interaction.
11123 !
11124 !      implicit real*8 (a-h,o-z)
11125 !      include 'DIMENSIONS'
11126 !      include 'COMMON.GEO'
11127 !      include 'COMMON.VAR'
11128 !      include 'COMMON.LOCAL'
11129 !      include 'COMMON.CHAIN'
11130 !      include 'COMMON.DERIV'
11131 !      include 'COMMON.INTERACT'
11132 !      include 'COMMON.TORSION'
11133 !      include 'COMMON.SBRIDGE'
11134 !      include 'COMMON.NAMES'
11135 !      include 'COMMON.IOUNITS'
11136 !      include 'COMMON.CONTACTS'
11137       real(kind=8),parameter :: accur=1.0d-10
11138       real(kind=8),dimension(3) :: gg
11139 !el local variables
11140       integer :: i,iint,j,k,itypi,itypi1,itypj
11141       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11142       real(kind=8) :: e1,e2,evdwij,evdw
11143 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11144       evdw=0.0D0
11145       do i=iatsc_s,iatsc_e
11146         itypi=itype(i)
11147         if (itypi.eq.ntyp1) cycle
11148         itypi1=itype(i+1)
11149         xi=c(1,nres+i)
11150         yi=c(2,nres+i)
11151         zi=c(3,nres+i)
11152 !
11153 ! Calculate SC interaction energy.
11154 !
11155         do iint=1,nint_gr(i)
11156 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11157 !d   &                  'iend=',iend(i,iint)
11158           do j=istart(i,iint),iend(i,iint)
11159             itypj=itype(j)
11160             if (itypj.eq.ntyp1) cycle
11161             xj=c(1,nres+j)-xi
11162             yj=c(2,nres+j)-yi
11163             zj=c(3,nres+j)-zi
11164             rij=xj*xj+yj*yj+zj*zj
11165             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11166             if (sss.lt.1.0d0) then
11167               rrij=1.0D0/rij
11168               eps0ij=eps(itypi,itypj)
11169               fac=rrij**expon2
11170               e1=fac*fac*aa(itypi,itypj)
11171               e2=fac*bb(itypi,itypj)
11172               evdwij=e1+e2
11173               evdw=evdw+(1.0d0-sss)*evdwij
11174 !
11175 ! Calculate the components of the gradient in DC and X
11176 !
11177               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
11178               gg(1)=xj*fac
11179               gg(2)=yj*fac
11180               gg(3)=zj*fac
11181               do k=1,3
11182                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11183                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11184                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11185                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11186               enddo
11187             endif
11188           enddo      ! j
11189         enddo        ! iint
11190       enddo          ! i
11191       do i=1,nct
11192         do j=1,3
11193           gvdwc(j,i)=expon*gvdwc(j,i)
11194           gvdwx(j,i)=expon*gvdwx(j,i)
11195         enddo
11196       enddo
11197 !******************************************************************************
11198 !
11199 !                              N O T E !!!
11200 !
11201 ! To save time, the factor of EXPON has been extracted from ALL components
11202 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11203 ! use!
11204 !
11205 !******************************************************************************
11206       return
11207       end subroutine elj_long
11208 !-----------------------------------------------------------------------------
11209       subroutine elj_short(evdw)
11210 !
11211 ! This subroutine calculates the interaction energy of nonbonded side chains
11212 ! assuming the LJ potential of interaction.
11213 !
11214 !      implicit real*8 (a-h,o-z)
11215 !      include 'DIMENSIONS'
11216 !      include 'COMMON.GEO'
11217 !      include 'COMMON.VAR'
11218 !      include 'COMMON.LOCAL'
11219 !      include 'COMMON.CHAIN'
11220 !      include 'COMMON.DERIV'
11221 !      include 'COMMON.INTERACT'
11222 !      include 'COMMON.TORSION'
11223 !      include 'COMMON.SBRIDGE'
11224 !      include 'COMMON.NAMES'
11225 !      include 'COMMON.IOUNITS'
11226 !      include 'COMMON.CONTACTS'
11227       real(kind=8),parameter :: accur=1.0d-10
11228       real(kind=8),dimension(3) :: gg
11229 !el local variables
11230       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
11231       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11232       real(kind=8) :: e1,e2,evdwij,evdw
11233 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11234       evdw=0.0D0
11235       do i=iatsc_s,iatsc_e
11236         itypi=itype(i)
11237         if (itypi.eq.ntyp1) cycle
11238         itypi1=itype(i+1)
11239         xi=c(1,nres+i)
11240         yi=c(2,nres+i)
11241         zi=c(3,nres+i)
11242 ! Change 12/1/95
11243         num_conti=0
11244 !
11245 ! Calculate SC interaction energy.
11246 !
11247         do iint=1,nint_gr(i)
11248 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11249 !d   &                  'iend=',iend(i,iint)
11250           do j=istart(i,iint),iend(i,iint)
11251             itypj=itype(j)
11252             if (itypj.eq.ntyp1) cycle
11253             xj=c(1,nres+j)-xi
11254             yj=c(2,nres+j)-yi
11255             zj=c(3,nres+j)-zi
11256 ! Change 12/1/95 to calculate four-body interactions
11257             rij=xj*xj+yj*yj+zj*zj
11258             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11259             if (sss.gt.0.0d0) then
11260               rrij=1.0D0/rij
11261               eps0ij=eps(itypi,itypj)
11262               fac=rrij**expon2
11263               e1=fac*fac*aa(itypi,itypj)
11264               e2=fac*bb(itypi,itypj)
11265               evdwij=e1+e2
11266               evdw=evdw+sss*evdwij
11267 !
11268 ! Calculate the components of the gradient in DC and X
11269 !
11270               fac=-rrij*(e1+evdwij)*sss
11271               gg(1)=xj*fac
11272               gg(2)=yj*fac
11273               gg(3)=zj*fac
11274               do k=1,3
11275                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11276                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11277                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11278                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11279               enddo
11280             endif
11281           enddo      ! j
11282         enddo        ! iint
11283       enddo          ! i
11284       do i=1,nct
11285         do j=1,3
11286           gvdwc(j,i)=expon*gvdwc(j,i)
11287           gvdwx(j,i)=expon*gvdwx(j,i)
11288         enddo
11289       enddo
11290 !******************************************************************************
11291 !
11292 !                              N O T E !!!
11293 !
11294 ! To save time, the factor of EXPON has been extracted from ALL components
11295 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11296 ! use!
11297 !
11298 !******************************************************************************
11299       return
11300       end subroutine elj_short
11301 !-----------------------------------------------------------------------------
11302       subroutine eljk_long(evdw)
11303 !
11304 ! This subroutine calculates the interaction energy of nonbonded side chains
11305 ! assuming the LJK potential of interaction.
11306 !
11307 !      implicit real*8 (a-h,o-z)
11308 !      include 'DIMENSIONS'
11309 !      include 'COMMON.GEO'
11310 !      include 'COMMON.VAR'
11311 !      include 'COMMON.LOCAL'
11312 !      include 'COMMON.CHAIN'
11313 !      include 'COMMON.DERIV'
11314 !      include 'COMMON.INTERACT'
11315 !      include 'COMMON.IOUNITS'
11316 !      include 'COMMON.NAMES'
11317       real(kind=8),dimension(3) :: gg
11318       logical :: scheck
11319 !el local variables
11320       integer :: i,iint,j,k,itypi,itypi1,itypj
11321       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11322                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11323 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11324       evdw=0.0D0
11325       do i=iatsc_s,iatsc_e
11326         itypi=itype(i)
11327         if (itypi.eq.ntyp1) cycle
11328         itypi1=itype(i+1)
11329         xi=c(1,nres+i)
11330         yi=c(2,nres+i)
11331         zi=c(3,nres+i)
11332 !
11333 ! Calculate SC interaction energy.
11334 !
11335         do iint=1,nint_gr(i)
11336           do j=istart(i,iint),iend(i,iint)
11337             itypj=itype(j)
11338             if (itypj.eq.ntyp1) cycle
11339             xj=c(1,nres+j)-xi
11340             yj=c(2,nres+j)-yi
11341             zj=c(3,nres+j)-zi
11342             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11343             fac_augm=rrij**expon
11344             e_augm=augm(itypi,itypj)*fac_augm
11345             r_inv_ij=dsqrt(rrij)
11346             rij=1.0D0/r_inv_ij
11347             sss=sscale(rij/sigma(itypi,itypj))
11348             if (sss.lt.1.0d0) then
11349               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11350               fac=r_shift_inv**expon
11351               e1=fac*fac*aa(itypi,itypj)
11352               e2=fac*bb(itypi,itypj)
11353               evdwij=e_augm+e1+e2
11354 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11355 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11356 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11357 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11358 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11359 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11360 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11361               evdw=evdw+(1.0d0-sss)*evdwij
11362 !
11363 ! Calculate the components of the gradient in DC and X
11364 !
11365               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11366               fac=fac*(1.0d0-sss)
11367               gg(1)=xj*fac
11368               gg(2)=yj*fac
11369               gg(3)=zj*fac
11370               do k=1,3
11371                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11372                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11373                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11374                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11375               enddo
11376             endif
11377           enddo      ! j
11378         enddo        ! iint
11379       enddo          ! i
11380       do i=1,nct
11381         do j=1,3
11382           gvdwc(j,i)=expon*gvdwc(j,i)
11383           gvdwx(j,i)=expon*gvdwx(j,i)
11384         enddo
11385       enddo
11386       return
11387       end subroutine eljk_long
11388 !-----------------------------------------------------------------------------
11389       subroutine eljk_short(evdw)
11390 !
11391 ! This subroutine calculates the interaction energy of nonbonded side chains
11392 ! assuming the LJK potential of interaction.
11393 !
11394 !      implicit real*8 (a-h,o-z)
11395 !      include 'DIMENSIONS'
11396 !      include 'COMMON.GEO'
11397 !      include 'COMMON.VAR'
11398 !      include 'COMMON.LOCAL'
11399 !      include 'COMMON.CHAIN'
11400 !      include 'COMMON.DERIV'
11401 !      include 'COMMON.INTERACT'
11402 !      include 'COMMON.IOUNITS'
11403 !      include 'COMMON.NAMES'
11404       real(kind=8),dimension(3) :: gg
11405       logical :: scheck
11406 !el local variables
11407       integer :: i,iint,j,k,itypi,itypi1,itypj
11408       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11409                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11410 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11411       evdw=0.0D0
11412       do i=iatsc_s,iatsc_e
11413         itypi=itype(i)
11414         if (itypi.eq.ntyp1) cycle
11415         itypi1=itype(i+1)
11416         xi=c(1,nres+i)
11417         yi=c(2,nres+i)
11418         zi=c(3,nres+i)
11419 !
11420 ! Calculate SC interaction energy.
11421 !
11422         do iint=1,nint_gr(i)
11423           do j=istart(i,iint),iend(i,iint)
11424             itypj=itype(j)
11425             if (itypj.eq.ntyp1) cycle
11426             xj=c(1,nres+j)-xi
11427             yj=c(2,nres+j)-yi
11428             zj=c(3,nres+j)-zi
11429             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11430             fac_augm=rrij**expon
11431             e_augm=augm(itypi,itypj)*fac_augm
11432             r_inv_ij=dsqrt(rrij)
11433             rij=1.0D0/r_inv_ij
11434             sss=sscale(rij/sigma(itypi,itypj))
11435             if (sss.gt.0.0d0) then
11436               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11437               fac=r_shift_inv**expon
11438               e1=fac*fac*aa(itypi,itypj)
11439               e2=fac*bb(itypi,itypj)
11440               evdwij=e_augm+e1+e2
11441 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11442 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11443 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11444 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11445 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11446 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11447 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11448               evdw=evdw+sss*evdwij
11449 !
11450 ! Calculate the components of the gradient in DC and X
11451 !
11452               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11453               fac=fac*sss
11454               gg(1)=xj*fac
11455               gg(2)=yj*fac
11456               gg(3)=zj*fac
11457               do k=1,3
11458                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11459                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11460                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11461                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11462               enddo
11463             endif
11464           enddo      ! j
11465         enddo        ! iint
11466       enddo          ! i
11467       do i=1,nct
11468         do j=1,3
11469           gvdwc(j,i)=expon*gvdwc(j,i)
11470           gvdwx(j,i)=expon*gvdwx(j,i)
11471         enddo
11472       enddo
11473       return
11474       end subroutine eljk_short
11475 !-----------------------------------------------------------------------------
11476       subroutine ebp_long(evdw)
11477 !
11478 ! This subroutine calculates the interaction energy of nonbonded side chains
11479 ! assuming the Berne-Pechukas potential of interaction.
11480 !
11481       use calc_data
11482 !      implicit real*8 (a-h,o-z)
11483 !      include 'DIMENSIONS'
11484 !      include 'COMMON.GEO'
11485 !      include 'COMMON.VAR'
11486 !      include 'COMMON.LOCAL'
11487 !      include 'COMMON.CHAIN'
11488 !      include 'COMMON.DERIV'
11489 !      include 'COMMON.NAMES'
11490 !      include 'COMMON.INTERACT'
11491 !      include 'COMMON.IOUNITS'
11492 !      include 'COMMON.CALC'
11493       use comm_srutu
11494 !el      integer :: icall
11495 !el      common /srutu/ icall
11496 !     double precision rrsave(maxdim)
11497       logical :: lprn
11498 !el local variables
11499       integer :: iint,itypi,itypi1,itypj
11500       real(kind=8) :: rrij,xi,yi,zi,fac
11501       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11502       evdw=0.0D0
11503 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11504       evdw=0.0D0
11505 !     if (icall.eq.0) then
11506 !       lprn=.true.
11507 !     else
11508         lprn=.false.
11509 !     endif
11510 !el      ind=0
11511       do i=iatsc_s,iatsc_e
11512         itypi=itype(i)
11513         if (itypi.eq.ntyp1) cycle
11514         itypi1=itype(i+1)
11515         xi=c(1,nres+i)
11516         yi=c(2,nres+i)
11517         zi=c(3,nres+i)
11518         dxi=dc_norm(1,nres+i)
11519         dyi=dc_norm(2,nres+i)
11520         dzi=dc_norm(3,nres+i)
11521 !        dsci_inv=dsc_inv(itypi)
11522         dsci_inv=vbld_inv(i+nres)
11523 !
11524 ! Calculate SC interaction energy.
11525 !
11526         do iint=1,nint_gr(i)
11527           do j=istart(i,iint),iend(i,iint)
11528 !el            ind=ind+1
11529             itypj=itype(j)
11530             if (itypj.eq.ntyp1) cycle
11531 !            dscj_inv=dsc_inv(itypj)
11532             dscj_inv=vbld_inv(j+nres)
11533             chi1=chi(itypi,itypj)
11534             chi2=chi(itypj,itypi)
11535             chi12=chi1*chi2
11536             chip1=chip(itypi)
11537             chip2=chip(itypj)
11538             chip12=chip1*chip2
11539             alf1=alp(itypi)
11540             alf2=alp(itypj)
11541             alf12=0.5D0*(alf1+alf2)
11542             xj=c(1,nres+j)-xi
11543             yj=c(2,nres+j)-yi
11544             zj=c(3,nres+j)-zi
11545             dxj=dc_norm(1,nres+j)
11546             dyj=dc_norm(2,nres+j)
11547             dzj=dc_norm(3,nres+j)
11548             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11549             rij=dsqrt(rrij)
11550             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11551
11552             if (sss.lt.1.0d0) then
11553
11554 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11555               call sc_angular
11556 ! Calculate whole angle-dependent part of epsilon and contributions
11557 ! to its derivatives
11558               fac=(rrij*sigsq)**expon2
11559               e1=fac*fac*aa(itypi,itypj)
11560               e2=fac*bb(itypi,itypj)
11561               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11562               eps2der=evdwij*eps3rt
11563               eps3der=evdwij*eps2rt
11564               evdwij=evdwij*eps2rt*eps3rt
11565               evdw=evdw+evdwij*(1.0d0-sss)
11566               if (lprn) then
11567               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11568               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11569 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11570 !d     &          restyp(itypi),i,restyp(itypj),j,
11571 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11572 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11573 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11574 !d     &          evdwij
11575               endif
11576 ! Calculate gradient components.
11577               e1=e1*eps1*eps2rt**2*eps3rt**2
11578               fac=-expon*(e1+evdwij)
11579               sigder=fac/sigsq
11580               fac=rrij*fac
11581 ! Calculate radial part of the gradient
11582               gg(1)=xj*fac
11583               gg(2)=yj*fac
11584               gg(3)=zj*fac
11585 ! Calculate the angular part of the gradient and sum add the contributions
11586 ! to the appropriate components of the Cartesian gradient.
11587               call sc_grad_scale(1.0d0-sss)
11588             endif
11589           enddo      ! j
11590         enddo        ! iint
11591       enddo          ! i
11592 !     stop
11593       return
11594       end subroutine ebp_long
11595 !-----------------------------------------------------------------------------
11596       subroutine ebp_short(evdw)
11597 !
11598 ! This subroutine calculates the interaction energy of nonbonded side chains
11599 ! assuming the Berne-Pechukas potential of interaction.
11600 !
11601       use calc_data
11602 !      implicit real*8 (a-h,o-z)
11603 !      include 'DIMENSIONS'
11604 !      include 'COMMON.GEO'
11605 !      include 'COMMON.VAR'
11606 !      include 'COMMON.LOCAL'
11607 !      include 'COMMON.CHAIN'
11608 !      include 'COMMON.DERIV'
11609 !      include 'COMMON.NAMES'
11610 !      include 'COMMON.INTERACT'
11611 !      include 'COMMON.IOUNITS'
11612 !      include 'COMMON.CALC'
11613       use comm_srutu
11614 !el      integer :: icall
11615 !el      common /srutu/ icall
11616 !     double precision rrsave(maxdim)
11617       logical :: lprn
11618 !el local variables
11619       integer :: iint,itypi,itypi1,itypj
11620       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11621       real(kind=8) :: sss,e1,e2,evdw
11622       evdw=0.0D0
11623 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11624       evdw=0.0D0
11625 !     if (icall.eq.0) then
11626 !       lprn=.true.
11627 !     else
11628         lprn=.false.
11629 !     endif
11630 !el      ind=0
11631       do i=iatsc_s,iatsc_e
11632         itypi=itype(i)
11633         if (itypi.eq.ntyp1) cycle
11634         itypi1=itype(i+1)
11635         xi=c(1,nres+i)
11636         yi=c(2,nres+i)
11637         zi=c(3,nres+i)
11638         dxi=dc_norm(1,nres+i)
11639         dyi=dc_norm(2,nres+i)
11640         dzi=dc_norm(3,nres+i)
11641 !        dsci_inv=dsc_inv(itypi)
11642         dsci_inv=vbld_inv(i+nres)
11643 !
11644 ! Calculate SC interaction energy.
11645 !
11646         do iint=1,nint_gr(i)
11647           do j=istart(i,iint),iend(i,iint)
11648 !el            ind=ind+1
11649             itypj=itype(j)
11650             if (itypj.eq.ntyp1) cycle
11651 !            dscj_inv=dsc_inv(itypj)
11652             dscj_inv=vbld_inv(j+nres)
11653             chi1=chi(itypi,itypj)
11654             chi2=chi(itypj,itypi)
11655             chi12=chi1*chi2
11656             chip1=chip(itypi)
11657             chip2=chip(itypj)
11658             chip12=chip1*chip2
11659             alf1=alp(itypi)
11660             alf2=alp(itypj)
11661             alf12=0.5D0*(alf1+alf2)
11662             xj=c(1,nres+j)-xi
11663             yj=c(2,nres+j)-yi
11664             zj=c(3,nres+j)-zi
11665             dxj=dc_norm(1,nres+j)
11666             dyj=dc_norm(2,nres+j)
11667             dzj=dc_norm(3,nres+j)
11668             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11669             rij=dsqrt(rrij)
11670             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11671
11672             if (sss.gt.0.0d0) then
11673
11674 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11675               call sc_angular
11676 ! Calculate whole angle-dependent part of epsilon and contributions
11677 ! to its derivatives
11678               fac=(rrij*sigsq)**expon2
11679               e1=fac*fac*aa(itypi,itypj)
11680               e2=fac*bb(itypi,itypj)
11681               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11682               eps2der=evdwij*eps3rt
11683               eps3der=evdwij*eps2rt
11684               evdwij=evdwij*eps2rt*eps3rt
11685               evdw=evdw+evdwij*sss
11686               if (lprn) then
11687               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11688               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11689 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11690 !d     &          restyp(itypi),i,restyp(itypj),j,
11691 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11692 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11693 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11694 !d     &          evdwij
11695               endif
11696 ! Calculate gradient components.
11697               e1=e1*eps1*eps2rt**2*eps3rt**2
11698               fac=-expon*(e1+evdwij)
11699               sigder=fac/sigsq
11700               fac=rrij*fac
11701 ! Calculate radial part of the gradient
11702               gg(1)=xj*fac
11703               gg(2)=yj*fac
11704               gg(3)=zj*fac
11705 ! Calculate the angular part of the gradient and sum add the contributions
11706 ! to the appropriate components of the Cartesian gradient.
11707               call sc_grad_scale(sss)
11708             endif
11709           enddo      ! j
11710         enddo        ! iint
11711       enddo          ! i
11712 !     stop
11713       return
11714       end subroutine ebp_short
11715 !-----------------------------------------------------------------------------
11716       subroutine egb_long(evdw)
11717 !
11718 ! This subroutine calculates the interaction energy of nonbonded side chains
11719 ! assuming the Gay-Berne potential of interaction.
11720 !
11721       use calc_data
11722 !      implicit real*8 (a-h,o-z)
11723 !      include 'DIMENSIONS'
11724 !      include 'COMMON.GEO'
11725 !      include 'COMMON.VAR'
11726 !      include 'COMMON.LOCAL'
11727 !      include 'COMMON.CHAIN'
11728 !      include 'COMMON.DERIV'
11729 !      include 'COMMON.NAMES'
11730 !      include 'COMMON.INTERACT'
11731 !      include 'COMMON.IOUNITS'
11732 !      include 'COMMON.CALC'
11733 !      include 'COMMON.CONTROL'
11734       logical :: lprn
11735 !el local variables
11736       integer :: iint,itypi,itypi1,itypj,subchap
11737       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11738       real(kind=8) :: sss,e1,e2,evdw,sss_grad
11739       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11740                     dist_temp, dist_init
11741
11742       evdw=0.0D0
11743 !cccc      energy_dec=.false.
11744 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11745       evdw=0.0D0
11746       lprn=.false.
11747 !     if (icall.eq.0) lprn=.false.
11748 !el      ind=0
11749       do i=iatsc_s,iatsc_e
11750         itypi=itype(i)
11751         if (itypi.eq.ntyp1) cycle
11752         itypi1=itype(i+1)
11753         xi=c(1,nres+i)
11754         yi=c(2,nres+i)
11755         zi=c(3,nres+i)
11756           xi=mod(xi,boxxsize)
11757           if (xi.lt.0) xi=xi+boxxsize
11758           yi=mod(yi,boxysize)
11759           if (yi.lt.0) yi=yi+boxysize
11760           zi=mod(zi,boxzsize)
11761           if (zi.lt.0) zi=zi+boxzsize
11762         dxi=dc_norm(1,nres+i)
11763         dyi=dc_norm(2,nres+i)
11764         dzi=dc_norm(3,nres+i)
11765 !        dsci_inv=dsc_inv(itypi)
11766         dsci_inv=vbld_inv(i+nres)
11767 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11768 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11769 !
11770 ! Calculate SC interaction energy.
11771 !
11772         do iint=1,nint_gr(i)
11773           do j=istart(i,iint),iend(i,iint)
11774 !el            ind=ind+1
11775             itypj=itype(j)
11776             if (itypj.eq.ntyp1) cycle
11777 !            dscj_inv=dsc_inv(itypj)
11778             dscj_inv=vbld_inv(j+nres)
11779 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11780 !     &       1.0d0/vbld(j+nres)
11781 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11782             sig0ij=sigma(itypi,itypj)
11783             chi1=chi(itypi,itypj)
11784             chi2=chi(itypj,itypi)
11785             chi12=chi1*chi2
11786             chip1=chip(itypi)
11787             chip2=chip(itypj)
11788             chip12=chip1*chip2
11789             alf1=alp(itypi)
11790             alf2=alp(itypj)
11791             alf12=0.5D0*(alf1+alf2)
11792             xj=c(1,nres+j)
11793             yj=c(2,nres+j)
11794             zj=c(3,nres+j)
11795 ! Searching for nearest neighbour
11796           xj=mod(xj,boxxsize)
11797           if (xj.lt.0) xj=xj+boxxsize
11798           yj=mod(yj,boxysize)
11799           if (yj.lt.0) yj=yj+boxysize
11800           zj=mod(zj,boxzsize)
11801           if (zj.lt.0) zj=zj+boxzsize
11802           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11803           xj_safe=xj
11804           yj_safe=yj
11805           zj_safe=zj
11806           subchap=0
11807           do xshift=-1,1
11808           do yshift=-1,1
11809           do zshift=-1,1
11810           xj=xj_safe+xshift*boxxsize
11811           yj=yj_safe+yshift*boxysize
11812           zj=zj_safe+zshift*boxzsize
11813           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11814           if(dist_temp.lt.dist_init) then
11815             dist_init=dist_temp
11816             xj_temp=xj
11817             yj_temp=yj
11818             zj_temp=zj
11819             subchap=1
11820           endif
11821           enddo
11822           enddo
11823           enddo
11824           if (subchap.eq.1) then
11825           xj=xj_temp-xi
11826           yj=yj_temp-yi
11827           zj=zj_temp-zi
11828           else
11829           xj=xj_safe-xi
11830           yj=yj_safe-yi
11831           zj=zj_safe-zi
11832           endif
11833
11834             dxj=dc_norm(1,nres+j)
11835             dyj=dc_norm(2,nres+j)
11836             dzj=dc_norm(3,nres+j)
11837             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11838             rij=dsqrt(rrij)
11839             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11840             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
11841             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
11842             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
11843             if (sss_ele_cut.le.0.0) cycle
11844             if (sss.lt.1.0d0) then
11845
11846 ! Calculate angle-dependent terms of energy and contributions to their
11847 ! derivatives.
11848               call sc_angular
11849               sigsq=1.0D0/sigsq
11850               sig=sig0ij*dsqrt(sigsq)
11851               rij_shift=1.0D0/rij-sig+sig0ij
11852 ! for diagnostics; uncomment
11853 !              rij_shift=1.2*sig0ij
11854 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11855               if (rij_shift.le.0.0D0) then
11856                 evdw=1.0D20
11857 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11858 !d     &          restyp(itypi),i,restyp(itypj),j,
11859 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11860                 return
11861               endif
11862               sigder=-sig*sigsq
11863 !---------------------------------------------------------------
11864               rij_shift=1.0D0/rij_shift
11865               fac=rij_shift**expon
11866               e1=fac*fac*aa(itypi,itypj)
11867               e2=fac*bb(itypi,itypj)
11868               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11869               eps2der=evdwij*eps3rt
11870               eps3der=evdwij*eps2rt
11871 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11872 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11873               evdwij=evdwij*eps2rt*eps3rt
11874               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
11875               if (lprn) then
11876               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11877               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11878               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11879                 restyp(itypi),i,restyp(itypj),j,&
11880                 epsi,sigm,chi1,chi2,chip1,chip2,&
11881                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11882                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11883                 evdwij
11884               endif
11885
11886               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11887                               'evdw',i,j,evdwij
11888 !              if (energy_dec) write (iout,*) &
11889 !                              'evdw',i,j,evdwij,"egb_long"
11890
11891 ! Calculate gradient components.
11892               e1=e1*eps1*eps2rt**2*eps3rt**2
11893               fac=-expon*(e1+evdwij)*rij_shift
11894               sigder=fac*sigder
11895               fac=rij*fac
11896               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
11897             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
11898             /sigmaii(itypi,itypj))
11899 !              fac=0.0d0
11900 ! Calculate the radial part of the gradient
11901               gg(1)=xj*fac
11902               gg(2)=yj*fac
11903               gg(3)=zj*fac
11904 ! Calculate angular part of the gradient.
11905               call sc_grad_scale(1.0d0-sss)
11906             endif
11907           enddo      ! j
11908         enddo        ! iint
11909       enddo          ! i
11910 !      write (iout,*) "Number of loop steps in EGB:",ind
11911 !ccc      energy_dec=.false.
11912       return
11913       end subroutine egb_long
11914 !-----------------------------------------------------------------------------
11915       subroutine egb_short(evdw)
11916 !
11917 ! This subroutine calculates the interaction energy of nonbonded side chains
11918 ! assuming the Gay-Berne potential of interaction.
11919 !
11920       use calc_data
11921 !      implicit real*8 (a-h,o-z)
11922 !      include 'DIMENSIONS'
11923 !      include 'COMMON.GEO'
11924 !      include 'COMMON.VAR'
11925 !      include 'COMMON.LOCAL'
11926 !      include 'COMMON.CHAIN'
11927 !      include 'COMMON.DERIV'
11928 !      include 'COMMON.NAMES'
11929 !      include 'COMMON.INTERACT'
11930 !      include 'COMMON.IOUNITS'
11931 !      include 'COMMON.CALC'
11932 !      include 'COMMON.CONTROL'
11933       logical :: lprn
11934 !el local variables
11935       integer :: iint,itypi,itypi1,itypj,subchap
11936       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11937       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
11938       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11939                     dist_temp, dist_init
11940       evdw=0.0D0
11941 !cccc      energy_dec=.false.
11942 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11943       evdw=0.0D0
11944       lprn=.false.
11945 !     if (icall.eq.0) lprn=.false.
11946 !el      ind=0
11947       do i=iatsc_s,iatsc_e
11948         itypi=itype(i)
11949         if (itypi.eq.ntyp1) cycle
11950         itypi1=itype(i+1)
11951         xi=c(1,nres+i)
11952         yi=c(2,nres+i)
11953         zi=c(3,nres+i)
11954           xi=mod(xi,boxxsize)
11955           if (xi.lt.0) xi=xi+boxxsize
11956           yi=mod(yi,boxysize)
11957           if (yi.lt.0) yi=yi+boxysize
11958           zi=mod(zi,boxzsize)
11959           if (zi.lt.0) zi=zi+boxzsize
11960         dxi=dc_norm(1,nres+i)
11961         dyi=dc_norm(2,nres+i)
11962         dzi=dc_norm(3,nres+i)
11963 !        dsci_inv=dsc_inv(itypi)
11964         dsci_inv=vbld_inv(i+nres)
11965
11966         dxi=dc_norm(1,nres+i)
11967         dyi=dc_norm(2,nres+i)
11968         dzi=dc_norm(3,nres+i)
11969 !        dsci_inv=dsc_inv(itypi)
11970         dsci_inv=vbld_inv(i+nres)
11971 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11972 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11973 !
11974 ! Calculate SC interaction energy.
11975 !
11976         do iint=1,nint_gr(i)
11977           do j=istart(i,iint),iend(i,iint)
11978 !el            ind=ind+1
11979             itypj=itype(j)
11980             if (itypj.eq.ntyp1) cycle
11981 !            dscj_inv=dsc_inv(itypj)
11982             dscj_inv=vbld_inv(j+nres)
11983 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11984 !     &       1.0d0/vbld(j+nres)
11985 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11986             sig0ij=sigma(itypi,itypj)
11987             chi1=chi(itypi,itypj)
11988             chi2=chi(itypj,itypi)
11989             chi12=chi1*chi2
11990             chip1=chip(itypi)
11991             chip2=chip(itypj)
11992             chip12=chip1*chip2
11993             alf1=alp(itypi)
11994             alf2=alp(itypj)
11995             alf12=0.5D0*(alf1+alf2)
11996 !            xj=c(1,nres+j)-xi
11997 !            yj=c(2,nres+j)-yi
11998 !            zj=c(3,nres+j)-zi
11999             xj=c(1,nres+j)
12000             yj=c(2,nres+j)
12001             zj=c(3,nres+j)
12002 ! Searching for nearest neighbour
12003           xj=mod(xj,boxxsize)
12004           if (xj.lt.0) xj=xj+boxxsize
12005           yj=mod(yj,boxysize)
12006           if (yj.lt.0) yj=yj+boxysize
12007           zj=mod(zj,boxzsize)
12008           if (zj.lt.0) zj=zj+boxzsize
12009           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12010           xj_safe=xj
12011           yj_safe=yj
12012           zj_safe=zj
12013           subchap=0
12014           do xshift=-1,1
12015           do yshift=-1,1
12016           do zshift=-1,1
12017           xj=xj_safe+xshift*boxxsize
12018           yj=yj_safe+yshift*boxysize
12019           zj=zj_safe+zshift*boxzsize
12020           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12021           if(dist_temp.lt.dist_init) then
12022             dist_init=dist_temp
12023             xj_temp=xj
12024             yj_temp=yj
12025             zj_temp=zj
12026             subchap=1
12027           endif
12028           enddo
12029           enddo
12030           enddo
12031           if (subchap.eq.1) then
12032           xj=xj_temp-xi
12033           yj=yj_temp-yi
12034           zj=zj_temp-zi
12035           else
12036           xj=xj_safe-xi
12037           yj=yj_safe-yi
12038           zj=zj_safe-zi
12039           endif
12040
12041             dxj=dc_norm(1,nres+j)
12042             dyj=dc_norm(2,nres+j)
12043             dzj=dc_norm(3,nres+j)
12044             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12045             rij=dsqrt(rrij)
12046             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12047             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12048             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12049             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12050             if (sss_ele_cut.le.0.0) cycle
12051
12052             if (sss.gt.0.0d0) then
12053
12054 ! Calculate angle-dependent terms of energy and contributions to their
12055 ! derivatives.
12056               call sc_angular
12057               sigsq=1.0D0/sigsq
12058               sig=sig0ij*dsqrt(sigsq)
12059               rij_shift=1.0D0/rij-sig+sig0ij
12060 ! for diagnostics; uncomment
12061 !              rij_shift=1.2*sig0ij
12062 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12063               if (rij_shift.le.0.0D0) then
12064                 evdw=1.0D20
12065 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12066 !d     &          restyp(itypi),i,restyp(itypj),j,
12067 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12068                 return
12069               endif
12070               sigder=-sig*sigsq
12071 !---------------------------------------------------------------
12072               rij_shift=1.0D0/rij_shift
12073               fac=rij_shift**expon
12074               e1=fac*fac*aa(itypi,itypj)
12075               e2=fac*bb(itypi,itypj)
12076               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12077               eps2der=evdwij*eps3rt
12078               eps3der=evdwij*eps2rt
12079 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12080 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
12081               evdwij=evdwij*eps2rt*eps3rt
12082               evdw=evdw+evdwij*sss*sss_ele_cut
12083               if (lprn) then
12084               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12085               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12086               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12087                 restyp(itypi),i,restyp(itypj),j,&
12088                 epsi,sigm,chi1,chi2,chip1,chip2,&
12089                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12090                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12091                 evdwij
12092               endif
12093
12094               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12095                               'evdw',i,j,evdwij
12096 !              if (energy_dec) write (iout,*) &
12097 !                              'evdw',i,j,evdwij,"egb_short"
12098
12099 ! Calculate gradient components.
12100               e1=e1*eps1*eps2rt**2*eps3rt**2
12101               fac=-expon*(e1+evdwij)*rij_shift
12102               sigder=fac*sigder
12103               fac=rij*fac
12104               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12105             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
12106             /sigmaii(itypi,itypj))
12107
12108 !              fac=0.0d0
12109 ! Calculate the radial part of the gradient
12110               gg(1)=xj*fac
12111               gg(2)=yj*fac
12112               gg(3)=zj*fac
12113 ! Calculate angular part of the gradient.
12114               call sc_grad_scale(sss)
12115             endif
12116           enddo      ! j
12117         enddo        ! iint
12118       enddo          ! i
12119 !      write (iout,*) "Number of loop steps in EGB:",ind
12120 !ccc      energy_dec=.false.
12121       return
12122       end subroutine egb_short
12123 !-----------------------------------------------------------------------------
12124       subroutine egbv_long(evdw)
12125 !
12126 ! This subroutine calculates the interaction energy of nonbonded side chains
12127 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12128 !
12129       use calc_data
12130 !      implicit real*8 (a-h,o-z)
12131 !      include 'DIMENSIONS'
12132 !      include 'COMMON.GEO'
12133 !      include 'COMMON.VAR'
12134 !      include 'COMMON.LOCAL'
12135 !      include 'COMMON.CHAIN'
12136 !      include 'COMMON.DERIV'
12137 !      include 'COMMON.NAMES'
12138 !      include 'COMMON.INTERACT'
12139 !      include 'COMMON.IOUNITS'
12140 !      include 'COMMON.CALC'
12141       use comm_srutu
12142 !el      integer :: icall
12143 !el      common /srutu/ icall
12144       logical :: lprn
12145 !el local variables
12146       integer :: iint,itypi,itypi1,itypj
12147       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
12148       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
12149       evdw=0.0D0
12150 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12151       evdw=0.0D0
12152       lprn=.false.
12153 !     if (icall.eq.0) lprn=.true.
12154 !el      ind=0
12155       do i=iatsc_s,iatsc_e
12156         itypi=itype(i)
12157         if (itypi.eq.ntyp1) cycle
12158         itypi1=itype(i+1)
12159         xi=c(1,nres+i)
12160         yi=c(2,nres+i)
12161         zi=c(3,nres+i)
12162         dxi=dc_norm(1,nres+i)
12163         dyi=dc_norm(2,nres+i)
12164         dzi=dc_norm(3,nres+i)
12165 !        dsci_inv=dsc_inv(itypi)
12166         dsci_inv=vbld_inv(i+nres)
12167 !
12168 ! Calculate SC interaction energy.
12169 !
12170         do iint=1,nint_gr(i)
12171           do j=istart(i,iint),iend(i,iint)
12172 !el            ind=ind+1
12173             itypj=itype(j)
12174             if (itypj.eq.ntyp1) cycle
12175 !            dscj_inv=dsc_inv(itypj)
12176             dscj_inv=vbld_inv(j+nres)
12177             sig0ij=sigma(itypi,itypj)
12178             r0ij=r0(itypi,itypj)
12179             chi1=chi(itypi,itypj)
12180             chi2=chi(itypj,itypi)
12181             chi12=chi1*chi2
12182             chip1=chip(itypi)
12183             chip2=chip(itypj)
12184             chip12=chip1*chip2
12185             alf1=alp(itypi)
12186             alf2=alp(itypj)
12187             alf12=0.5D0*(alf1+alf2)
12188             xj=c(1,nres+j)-xi
12189             yj=c(2,nres+j)-yi
12190             zj=c(3,nres+j)-zi
12191             dxj=dc_norm(1,nres+j)
12192             dyj=dc_norm(2,nres+j)
12193             dzj=dc_norm(3,nres+j)
12194             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12195             rij=dsqrt(rrij)
12196
12197             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12198
12199             if (sss.lt.1.0d0) then
12200
12201 ! Calculate angle-dependent terms of energy and contributions to their
12202 ! derivatives.
12203               call sc_angular
12204               sigsq=1.0D0/sigsq
12205               sig=sig0ij*dsqrt(sigsq)
12206               rij_shift=1.0D0/rij-sig+r0ij
12207 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12208               if (rij_shift.le.0.0D0) then
12209                 evdw=1.0D20
12210                 return
12211               endif
12212               sigder=-sig*sigsq
12213 !---------------------------------------------------------------
12214               rij_shift=1.0D0/rij_shift
12215               fac=rij_shift**expon
12216               e1=fac*fac*aa(itypi,itypj)
12217               e2=fac*bb(itypi,itypj)
12218               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12219               eps2der=evdwij*eps3rt
12220               eps3der=evdwij*eps2rt
12221               fac_augm=rrij**expon
12222               e_augm=augm(itypi,itypj)*fac_augm
12223               evdwij=evdwij*eps2rt*eps3rt
12224               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
12225               if (lprn) then
12226               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12227               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12228               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12229                 restyp(itypi),i,restyp(itypj),j,&
12230                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12231                 chi1,chi2,chip1,chip2,&
12232                 eps1,eps2rt**2,eps3rt**2,&
12233                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12234                 evdwij+e_augm
12235               endif
12236 ! Calculate gradient components.
12237               e1=e1*eps1*eps2rt**2*eps3rt**2
12238               fac=-expon*(e1+evdwij)*rij_shift
12239               sigder=fac*sigder
12240               fac=rij*fac-2*expon*rrij*e_augm
12241 ! Calculate the radial part of the gradient
12242               gg(1)=xj*fac
12243               gg(2)=yj*fac
12244               gg(3)=zj*fac
12245 ! Calculate angular part of the gradient.
12246               call sc_grad_scale(1.0d0-sss)
12247             endif
12248           enddo      ! j
12249         enddo        ! iint
12250       enddo          ! i
12251       end subroutine egbv_long
12252 !-----------------------------------------------------------------------------
12253       subroutine egbv_short(evdw)
12254 !
12255 ! This subroutine calculates the interaction energy of nonbonded side chains
12256 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12257 !
12258       use calc_data
12259 !      implicit real*8 (a-h,o-z)
12260 !      include 'DIMENSIONS'
12261 !      include 'COMMON.GEO'
12262 !      include 'COMMON.VAR'
12263 !      include 'COMMON.LOCAL'
12264 !      include 'COMMON.CHAIN'
12265 !      include 'COMMON.DERIV'
12266 !      include 'COMMON.NAMES'
12267 !      include 'COMMON.INTERACT'
12268 !      include 'COMMON.IOUNITS'
12269 !      include 'COMMON.CALC'
12270       use comm_srutu
12271 !el      integer :: icall
12272 !el      common /srutu/ icall
12273       logical :: lprn
12274 !el local variables
12275       integer :: iint,itypi,itypi1,itypj
12276       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
12277       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
12278       evdw=0.0D0
12279 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12280       evdw=0.0D0
12281       lprn=.false.
12282 !     if (icall.eq.0) lprn=.true.
12283 !el      ind=0
12284       do i=iatsc_s,iatsc_e
12285         itypi=itype(i)
12286         if (itypi.eq.ntyp1) cycle
12287         itypi1=itype(i+1)
12288         xi=c(1,nres+i)
12289         yi=c(2,nres+i)
12290         zi=c(3,nres+i)
12291         dxi=dc_norm(1,nres+i)
12292         dyi=dc_norm(2,nres+i)
12293         dzi=dc_norm(3,nres+i)
12294 !        dsci_inv=dsc_inv(itypi)
12295         dsci_inv=vbld_inv(i+nres)
12296 !
12297 ! Calculate SC interaction energy.
12298 !
12299         do iint=1,nint_gr(i)
12300           do j=istart(i,iint),iend(i,iint)
12301 !el            ind=ind+1
12302             itypj=itype(j)
12303             if (itypj.eq.ntyp1) cycle
12304 !            dscj_inv=dsc_inv(itypj)
12305             dscj_inv=vbld_inv(j+nres)
12306             sig0ij=sigma(itypi,itypj)
12307             r0ij=r0(itypi,itypj)
12308             chi1=chi(itypi,itypj)
12309             chi2=chi(itypj,itypi)
12310             chi12=chi1*chi2
12311             chip1=chip(itypi)
12312             chip2=chip(itypj)
12313             chip12=chip1*chip2
12314             alf1=alp(itypi)
12315             alf2=alp(itypj)
12316             alf12=0.5D0*(alf1+alf2)
12317             xj=c(1,nres+j)-xi
12318             yj=c(2,nres+j)-yi
12319             zj=c(3,nres+j)-zi
12320             dxj=dc_norm(1,nres+j)
12321             dyj=dc_norm(2,nres+j)
12322             dzj=dc_norm(3,nres+j)
12323             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12324             rij=dsqrt(rrij)
12325
12326             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12327
12328             if (sss.gt.0.0d0) then
12329
12330 ! Calculate angle-dependent terms of energy and contributions to their
12331 ! derivatives.
12332               call sc_angular
12333               sigsq=1.0D0/sigsq
12334               sig=sig0ij*dsqrt(sigsq)
12335               rij_shift=1.0D0/rij-sig+r0ij
12336 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12337               if (rij_shift.le.0.0D0) then
12338                 evdw=1.0D20
12339                 return
12340               endif
12341               sigder=-sig*sigsq
12342 !---------------------------------------------------------------
12343               rij_shift=1.0D0/rij_shift
12344               fac=rij_shift**expon
12345               e1=fac*fac*aa(itypi,itypj)
12346               e2=fac*bb(itypi,itypj)
12347               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12348               eps2der=evdwij*eps3rt
12349               eps3der=evdwij*eps2rt
12350               fac_augm=rrij**expon
12351               e_augm=augm(itypi,itypj)*fac_augm
12352               evdwij=evdwij*eps2rt*eps3rt
12353               evdw=evdw+(evdwij+e_augm)*sss
12354               if (lprn) then
12355               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12356               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12357               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12358                 restyp(itypi),i,restyp(itypj),j,&
12359                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12360                 chi1,chi2,chip1,chip2,&
12361                 eps1,eps2rt**2,eps3rt**2,&
12362                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12363                 evdwij+e_augm
12364               endif
12365 ! Calculate gradient components.
12366               e1=e1*eps1*eps2rt**2*eps3rt**2
12367               fac=-expon*(e1+evdwij)*rij_shift
12368               sigder=fac*sigder
12369               fac=rij*fac-2*expon*rrij*e_augm
12370 ! Calculate the radial part of the gradient
12371               gg(1)=xj*fac
12372               gg(2)=yj*fac
12373               gg(3)=zj*fac
12374 ! Calculate angular part of the gradient.
12375               call sc_grad_scale(sss)
12376             endif
12377           enddo      ! j
12378         enddo        ! iint
12379       enddo          ! i
12380       end subroutine egbv_short
12381 !-----------------------------------------------------------------------------
12382       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
12383 !
12384 ! This subroutine calculates the average interaction energy and its gradient
12385 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
12386 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
12387 ! The potential depends both on the distance of peptide-group centers and on
12388 ! the orientation of the CA-CA virtual bonds.
12389 !
12390 !      implicit real*8 (a-h,o-z)
12391
12392       use comm_locel
12393 #ifdef MPI
12394       include 'mpif.h'
12395 #endif
12396 !      include 'DIMENSIONS'
12397 !      include 'COMMON.CONTROL'
12398 !      include 'COMMON.SETUP'
12399 !      include 'COMMON.IOUNITS'
12400 !      include 'COMMON.GEO'
12401 !      include 'COMMON.VAR'
12402 !      include 'COMMON.LOCAL'
12403 !      include 'COMMON.CHAIN'
12404 !      include 'COMMON.DERIV'
12405 !      include 'COMMON.INTERACT'
12406 !      include 'COMMON.CONTACTS'
12407 !      include 'COMMON.TORSION'
12408 !      include 'COMMON.VECTORS'
12409 !      include 'COMMON.FFIELD'
12410 !      include 'COMMON.TIME1'
12411       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
12412       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
12413       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12414 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12415       real(kind=8),dimension(4) :: muij
12416 !el      integer :: num_conti,j1,j2
12417 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12418 !el                   dz_normi,xmedi,ymedi,zmedi
12419 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12420 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12421 !el          num_conti,j1,j2
12422 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12423 #ifdef MOMENT
12424       real(kind=8) :: scal_el=1.0d0
12425 #else
12426       real(kind=8) :: scal_el=0.5d0
12427 #endif
12428 ! 12/13/98
12429 ! 13-go grudnia roku pamietnego...
12430       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12431                                              0.0d0,1.0d0,0.0d0,&
12432                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12433 !el local variables
12434       integer :: i,j,k
12435       real(kind=8) :: fac
12436       real(kind=8) :: dxj,dyj,dzj
12437       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
12438
12439 !      allocate(num_cont_hb(nres)) !(maxres)
12440 !d      write(iout,*) 'In EELEC'
12441 !d      do i=1,nloctyp
12442 !d        write(iout,*) 'Type',i
12443 !d        write(iout,*) 'B1',B1(:,i)
12444 !d        write(iout,*) 'B2',B2(:,i)
12445 !d        write(iout,*) 'CC',CC(:,:,i)
12446 !d        write(iout,*) 'DD',DD(:,:,i)
12447 !d        write(iout,*) 'EE',EE(:,:,i)
12448 !d      enddo
12449 !d      call check_vecgrad
12450 !d      stop
12451       if (icheckgrad.eq.1) then
12452         do i=1,nres-1
12453           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
12454           do k=1,3
12455             dc_norm(k,i)=dc(k,i)*fac
12456           enddo
12457 !          write (iout,*) 'i',i,' fac',fac
12458         enddo
12459       endif
12460       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12461           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
12462           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
12463 !        call vec_and_deriv
12464 #ifdef TIMING
12465         time01=MPI_Wtime()
12466 #endif
12467         call set_matrices
12468 #ifdef TIMING
12469         time_mat=time_mat+MPI_Wtime()-time01
12470 #endif
12471       endif
12472 !d      do i=1,nres-1
12473 !d        write (iout,*) 'i=',i
12474 !d        do k=1,3
12475 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
12476 !d        enddo
12477 !d        do k=1,3
12478 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
12479 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
12480 !d        enddo
12481 !d      enddo
12482       t_eelecij=0.0d0
12483       ees=0.0D0
12484       evdw1=0.0D0
12485       eel_loc=0.0d0
12486       eello_turn3=0.0d0
12487       eello_turn4=0.0d0
12488 !el      ind=0
12489       do i=1,nres
12490         num_cont_hb(i)=0
12491       enddo
12492 !d      print '(a)','Enter EELEC'
12493 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
12494 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
12495 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
12496       do i=1,nres
12497         gel_loc_loc(i)=0.0d0
12498         gcorr_loc(i)=0.0d0
12499       enddo
12500 !
12501 !
12502 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
12503 !
12504 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
12505 !
12506       do i=iturn3_start,iturn3_end
12507         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
12508         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
12509         dxi=dc(1,i)
12510         dyi=dc(2,i)
12511         dzi=dc(3,i)
12512         dx_normi=dc_norm(1,i)
12513         dy_normi=dc_norm(2,i)
12514         dz_normi=dc_norm(3,i)
12515         xmedi=c(1,i)+0.5d0*dxi
12516         ymedi=c(2,i)+0.5d0*dyi
12517         zmedi=c(3,i)+0.5d0*dzi
12518         num_conti=0
12519         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
12520         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
12521         num_cont_hb(i)=num_conti
12522       enddo
12523       do i=iturn4_start,iturn4_end
12524         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
12525           .or. itype(i+3).eq.ntyp1 &
12526           .or. itype(i+4).eq.ntyp1) cycle
12527         dxi=dc(1,i)
12528         dyi=dc(2,i)
12529         dzi=dc(3,i)
12530         dx_normi=dc_norm(1,i)
12531         dy_normi=dc_norm(2,i)
12532         dz_normi=dc_norm(3,i)
12533         xmedi=c(1,i)+0.5d0*dxi
12534         ymedi=c(2,i)+0.5d0*dyi
12535         zmedi=c(3,i)+0.5d0*dzi
12536         num_conti=num_cont_hb(i)
12537         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
12538         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
12539           call eturn4(i,eello_turn4)
12540         num_cont_hb(i)=num_conti
12541       enddo   ! i
12542 !
12543 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
12544 !
12545       do i=iatel_s,iatel_e
12546         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12547         dxi=dc(1,i)
12548         dyi=dc(2,i)
12549         dzi=dc(3,i)
12550         dx_normi=dc_norm(1,i)
12551         dy_normi=dc_norm(2,i)
12552         dz_normi=dc_norm(3,i)
12553         xmedi=c(1,i)+0.5d0*dxi
12554         ymedi=c(2,i)+0.5d0*dyi
12555         zmedi=c(3,i)+0.5d0*dzi
12556 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
12557         num_conti=num_cont_hb(i)
12558         do j=ielstart(i),ielend(i)
12559           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12560           call eelecij_scale(i,j,ees,evdw1,eel_loc)
12561         enddo ! j
12562         num_cont_hb(i)=num_conti
12563       enddo   ! i
12564 !      write (iout,*) "Number of loop steps in EELEC:",ind
12565 !d      do i=1,nres
12566 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12567 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12568 !d      enddo
12569 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12570 !cc      eel_loc=eel_loc+eello_turn3
12571 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12572       return
12573       end subroutine eelec_scale
12574 !-----------------------------------------------------------------------------
12575       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12576 !      implicit real*8 (a-h,o-z)
12577
12578       use comm_locel
12579 !      include 'DIMENSIONS'
12580 #ifdef MPI
12581       include "mpif.h"
12582 #endif
12583 !      include 'COMMON.CONTROL'
12584 !      include 'COMMON.IOUNITS'
12585 !      include 'COMMON.GEO'
12586 !      include 'COMMON.VAR'
12587 !      include 'COMMON.LOCAL'
12588 !      include 'COMMON.CHAIN'
12589 !      include 'COMMON.DERIV'
12590 !      include 'COMMON.INTERACT'
12591 !      include 'COMMON.CONTACTS'
12592 !      include 'COMMON.TORSION'
12593 !      include 'COMMON.VECTORS'
12594 !      include 'COMMON.FFIELD'
12595 !      include 'COMMON.TIME1'
12596       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12597       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12598       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12599 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12600       real(kind=8),dimension(4) :: muij
12601 !el      integer :: num_conti,j1,j2
12602 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12603 !el                   dz_normi,xmedi,ymedi,zmedi
12604 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12605 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12606 !el          num_conti,j1,j2
12607 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12608 #ifdef MOMENT
12609       real(kind=8) :: scal_el=1.0d0
12610 #else
12611       real(kind=8) :: scal_el=0.5d0
12612 #endif
12613 ! 12/13/98
12614 ! 13-go grudnia roku pamietnego...
12615       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12616                                              0.0d0,1.0d0,0.0d0,&
12617                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12618 !el local variables
12619       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12620       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12621       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12622       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12623       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12624       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12625       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12626                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12627                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12628                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12629                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12630                   ecosam,ecosbm,ecosgm,ghalf,time00
12631 !      integer :: maxconts
12632 !      maxconts = nres/4
12633 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12634 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12635 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12636 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12637 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12638 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12639 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12640 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12641 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12642 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12643 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12644 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12645 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12646
12647 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12648 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12649
12650 #ifdef MPI
12651           time00=MPI_Wtime()
12652 #endif
12653 !d      write (iout,*) "eelecij",i,j
12654 !el          ind=ind+1
12655           iteli=itel(i)
12656           itelj=itel(j)
12657           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12658           aaa=app(iteli,itelj)
12659           bbb=bpp(iteli,itelj)
12660           ael6i=ael6(iteli,itelj)
12661           ael3i=ael3(iteli,itelj)
12662           dxj=dc(1,j)
12663           dyj=dc(2,j)
12664           dzj=dc(3,j)
12665           dx_normj=dc_norm(1,j)
12666           dy_normj=dc_norm(2,j)
12667           dz_normj=dc_norm(3,j)
12668           xj=c(1,j)+0.5D0*dxj-xmedi
12669           yj=c(2,j)+0.5D0*dyj-ymedi
12670           zj=c(3,j)+0.5D0*dzj-zmedi
12671           rij=xj*xj+yj*yj+zj*zj
12672           rrmij=1.0D0/rij
12673           rij=dsqrt(rij)
12674           rmij=1.0D0/rij
12675 ! For extracting the short-range part of Evdwpp
12676           sss=sscale(rij/rpp(iteli,itelj))
12677
12678           r3ij=rrmij*rmij
12679           r6ij=r3ij*r3ij
12680           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12681           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12682           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12683           fac=cosa-3.0D0*cosb*cosg
12684           ev1=aaa*r6ij*r6ij
12685 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12686           if (j.eq.i+2) ev1=scal_el*ev1
12687           ev2=bbb*r6ij
12688           fac3=ael6i*r6ij
12689           fac4=ael3i*r3ij
12690           evdwij=ev1+ev2
12691           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12692           el2=fac4*fac
12693           eesij=el1+el2
12694 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12695           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12696           ees=ees+eesij
12697           evdw1=evdw1+evdwij*(1.0d0-sss)
12698 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12699 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12700 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12701 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12702
12703           if (energy_dec) then
12704               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12705               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12706           endif
12707
12708 !
12709 ! Calculate contributions to the Cartesian gradient.
12710 !
12711 #ifdef SPLITELE
12712           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12713           facel=-3*rrmij*(el1+eesij)
12714           fac1=fac
12715           erij(1)=xj*rmij
12716           erij(2)=yj*rmij
12717           erij(3)=zj*rmij
12718 !
12719 ! Radial derivatives. First process both termini of the fragment (i,j)
12720 !
12721           ggg(1)=facel*xj
12722           ggg(2)=facel*yj
12723           ggg(3)=facel*zj
12724 !          do k=1,3
12725 !            ghalf=0.5D0*ggg(k)
12726 !            gelc(k,i)=gelc(k,i)+ghalf
12727 !            gelc(k,j)=gelc(k,j)+ghalf
12728 !          enddo
12729 ! 9/28/08 AL Gradient compotents will be summed only at the end
12730           do k=1,3
12731             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12732             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12733           enddo
12734 !
12735 ! Loop over residues i+1 thru j-1.
12736 !
12737 !grad          do k=i+1,j-1
12738 !grad            do l=1,3
12739 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12740 !grad            enddo
12741 !grad          enddo
12742           ggg(1)=facvdw*xj
12743           ggg(2)=facvdw*yj
12744           ggg(3)=facvdw*zj
12745 !          do k=1,3
12746 !            ghalf=0.5D0*ggg(k)
12747 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12748 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12749 !          enddo
12750 ! 9/28/08 AL Gradient compotents will be summed only at the end
12751           do k=1,3
12752             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12753             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12754           enddo
12755 !
12756 ! Loop over residues i+1 thru j-1.
12757 !
12758 !grad          do k=i+1,j-1
12759 !grad            do l=1,3
12760 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12761 !grad            enddo
12762 !grad          enddo
12763 #else
12764           facvdw=ev1+evdwij*(1.0d0-sss)
12765           facel=el1+eesij
12766           fac1=fac
12767           fac=-3*rrmij*(facvdw+facvdw+facel)
12768           erij(1)=xj*rmij
12769           erij(2)=yj*rmij
12770           erij(3)=zj*rmij
12771 !
12772 ! Radial derivatives. First process both termini of the fragment (i,j)
12773 !
12774           ggg(1)=fac*xj
12775           ggg(2)=fac*yj
12776           ggg(3)=fac*zj
12777 !          do k=1,3
12778 !            ghalf=0.5D0*ggg(k)
12779 !            gelc(k,i)=gelc(k,i)+ghalf
12780 !            gelc(k,j)=gelc(k,j)+ghalf
12781 !          enddo
12782 ! 9/28/08 AL Gradient compotents will be summed only at the end
12783           do k=1,3
12784             gelc_long(k,j)=gelc(k,j)+ggg(k)
12785             gelc_long(k,i)=gelc(k,i)-ggg(k)
12786           enddo
12787 !
12788 ! Loop over residues i+1 thru j-1.
12789 !
12790 !grad          do k=i+1,j-1
12791 !grad            do l=1,3
12792 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12793 !grad            enddo
12794 !grad          enddo
12795 ! 9/28/08 AL Gradient compotents will be summed only at the end
12796           ggg(1)=facvdw*xj
12797           ggg(2)=facvdw*yj
12798           ggg(3)=facvdw*zj
12799           do k=1,3
12800             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12801             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12802           enddo
12803 #endif
12804 !
12805 ! Angular part
12806 !
12807           ecosa=2.0D0*fac3*fac1+fac4
12808           fac4=-3.0D0*fac4
12809           fac3=-6.0D0*fac3
12810           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12811           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12812           do k=1,3
12813             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12814             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12815           enddo
12816 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12817 !d   &          (dcosg(k),k=1,3)
12818           do k=1,3
12819             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12820           enddo
12821 !          do k=1,3
12822 !            ghalf=0.5D0*ggg(k)
12823 !            gelc(k,i)=gelc(k,i)+ghalf
12824 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12825 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12826 !            gelc(k,j)=gelc(k,j)+ghalf
12827 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12828 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12829 !          enddo
12830 !grad          do k=i+1,j-1
12831 !grad            do l=1,3
12832 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12833 !grad            enddo
12834 !grad          enddo
12835           do k=1,3
12836             gelc(k,i)=gelc(k,i) &
12837                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12838                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12839             gelc(k,j)=gelc(k,j) &
12840                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12841                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12842             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12843             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12844           enddo
12845           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12846               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12847               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12848 !
12849 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12850 !   energy of a peptide unit is assumed in the form of a second-order
12851 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12852 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12853 !   are computed for EVERY pair of non-contiguous peptide groups.
12854 !
12855           if (j.lt.nres-1) then
12856             j1=j+1
12857             j2=j-1
12858           else
12859             j1=j-1
12860             j2=j-2
12861           endif
12862           kkk=0
12863           do k=1,2
12864             do l=1,2
12865               kkk=kkk+1
12866               muij(kkk)=mu(k,i)*mu(l,j)
12867             enddo
12868           enddo
12869 !d         write (iout,*) 'EELEC: i',i,' j',j
12870 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12871 !d          write(iout,*) 'muij',muij
12872           ury=scalar(uy(1,i),erij)
12873           urz=scalar(uz(1,i),erij)
12874           vry=scalar(uy(1,j),erij)
12875           vrz=scalar(uz(1,j),erij)
12876           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12877           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12878           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12879           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12880           fac=dsqrt(-ael6i)*r3ij
12881           a22=a22*fac
12882           a23=a23*fac
12883           a32=a32*fac
12884           a33=a33*fac
12885 !d          write (iout,'(4i5,4f10.5)')
12886 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12887 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12888 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12889 !d     &      uy(:,j),uz(:,j)
12890 !d          write (iout,'(4f10.5)')
12891 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12892 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12893 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12894 !d           write (iout,'(9f10.5/)')
12895 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12896 ! Derivatives of the elements of A in virtual-bond vectors
12897           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12898           do k=1,3
12899             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12900             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12901             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12902             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12903             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12904             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12905             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12906             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12907             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12908             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12909             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12910             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12911           enddo
12912 ! Compute radial contributions to the gradient
12913           facr=-3.0d0*rrmij
12914           a22der=a22*facr
12915           a23der=a23*facr
12916           a32der=a32*facr
12917           a33der=a33*facr
12918           agg(1,1)=a22der*xj
12919           agg(2,1)=a22der*yj
12920           agg(3,1)=a22der*zj
12921           agg(1,2)=a23der*xj
12922           agg(2,2)=a23der*yj
12923           agg(3,2)=a23der*zj
12924           agg(1,3)=a32der*xj
12925           agg(2,3)=a32der*yj
12926           agg(3,3)=a32der*zj
12927           agg(1,4)=a33der*xj
12928           agg(2,4)=a33der*yj
12929           agg(3,4)=a33der*zj
12930 ! Add the contributions coming from er
12931           fac3=-3.0d0*fac
12932           do k=1,3
12933             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12934             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12935             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12936             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12937           enddo
12938           do k=1,3
12939 ! Derivatives in DC(i)
12940 !grad            ghalf1=0.5d0*agg(k,1)
12941 !grad            ghalf2=0.5d0*agg(k,2)
12942 !grad            ghalf3=0.5d0*agg(k,3)
12943 !grad            ghalf4=0.5d0*agg(k,4)
12944             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12945             -3.0d0*uryg(k,2)*vry)!+ghalf1
12946             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12947             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12948             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12949             -3.0d0*urzg(k,2)*vry)!+ghalf3
12950             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12951             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12952 ! Derivatives in DC(i+1)
12953             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12954             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12955             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12956             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12957             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
12958             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
12959             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
12960             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
12961 ! Derivatives in DC(j)
12962             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
12963             -3.0d0*vryg(k,2)*ury)!+ghalf1
12964             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
12965             -3.0d0*vrzg(k,2)*ury)!+ghalf2
12966             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
12967             -3.0d0*vryg(k,2)*urz)!+ghalf3
12968             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
12969             -3.0d0*vrzg(k,2)*urz)!+ghalf4
12970 ! Derivatives in DC(j+1) or DC(nres-1)
12971             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
12972             -3.0d0*vryg(k,3)*ury)
12973             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
12974             -3.0d0*vrzg(k,3)*ury)
12975             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
12976             -3.0d0*vryg(k,3)*urz)
12977             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
12978             -3.0d0*vrzg(k,3)*urz)
12979 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
12980 !grad              do l=1,4
12981 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
12982 !grad              enddo
12983 !grad            endif
12984           enddo
12985           acipa(1,1)=a22
12986           acipa(1,2)=a23
12987           acipa(2,1)=a32
12988           acipa(2,2)=a33
12989           a22=-a22
12990           a23=-a23
12991           do l=1,2
12992             do k=1,3
12993               agg(k,l)=-agg(k,l)
12994               aggi(k,l)=-aggi(k,l)
12995               aggi1(k,l)=-aggi1(k,l)
12996               aggj(k,l)=-aggj(k,l)
12997               aggj1(k,l)=-aggj1(k,l)
12998             enddo
12999           enddo
13000           if (j.lt.nres-1) then
13001             a22=-a22
13002             a32=-a32
13003             do l=1,3,2
13004               do k=1,3
13005                 agg(k,l)=-agg(k,l)
13006                 aggi(k,l)=-aggi(k,l)
13007                 aggi1(k,l)=-aggi1(k,l)
13008                 aggj(k,l)=-aggj(k,l)
13009                 aggj1(k,l)=-aggj1(k,l)
13010               enddo
13011             enddo
13012           else
13013             a22=-a22
13014             a23=-a23
13015             a32=-a32
13016             a33=-a33
13017             do l=1,4
13018               do k=1,3
13019                 agg(k,l)=-agg(k,l)
13020                 aggi(k,l)=-aggi(k,l)
13021                 aggi1(k,l)=-aggi1(k,l)
13022                 aggj(k,l)=-aggj(k,l)
13023                 aggj1(k,l)=-aggj1(k,l)
13024               enddo
13025             enddo
13026           endif
13027           ENDIF ! WCORR
13028           IF (wel_loc.gt.0.0d0) THEN
13029 ! Contribution to the local-electrostatic energy coming from the i-j pair
13030           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
13031            +a33*muij(4)
13032 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
13033
13034           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13035                   'eelloc',i,j,eel_loc_ij
13036 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
13037
13038           eel_loc=eel_loc+eel_loc_ij
13039 ! Partial derivatives in virtual-bond dihedral angles gamma
13040           if (i.gt.1) &
13041           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
13042                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
13043                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
13044           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
13045                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
13046                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
13047 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
13048           do l=1,3
13049             ggg(l)=agg(l,1)*muij(1)+ &
13050                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
13051             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
13052             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
13053 !grad            ghalf=0.5d0*ggg(l)
13054 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
13055 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
13056           enddo
13057 !grad          do k=i+1,j2
13058 !grad            do l=1,3
13059 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
13060 !grad            enddo
13061 !grad          enddo
13062 ! Remaining derivatives of eello
13063           do l=1,3
13064             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
13065                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
13066             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
13067                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
13068             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
13069                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
13070             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
13071                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
13072           enddo
13073           ENDIF
13074 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
13075 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
13076           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
13077              .and. num_conti.le.maxconts) then
13078 !            write (iout,*) i,j," entered corr"
13079 !
13080 ! Calculate the contact function. The ith column of the array JCONT will
13081 ! contain the numbers of atoms that make contacts with the atom I (of numbers
13082 ! greater than I). The arrays FACONT and GACONT will contain the values of
13083 ! the contact function and its derivative.
13084 !           r0ij=1.02D0*rpp(iteli,itelj)
13085 !           r0ij=1.11D0*rpp(iteli,itelj)
13086             r0ij=2.20D0*rpp(iteli,itelj)
13087 !           r0ij=1.55D0*rpp(iteli,itelj)
13088             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
13089 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13090             if (fcont.gt.0.0D0) then
13091               num_conti=num_conti+1
13092               if (num_conti.gt.maxconts) then
13093 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13094                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
13095                                ' will skip next contacts for this conf.',num_conti
13096               else
13097                 jcont_hb(num_conti,i)=j
13098 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
13099 !d     &           " jcont_hb",jcont_hb(num_conti,i)
13100                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
13101                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13102 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
13103 !  terms.
13104                 d_cont(num_conti,i)=rij
13105 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
13106 !     --- Electrostatic-interaction matrix ---
13107                 a_chuj(1,1,num_conti,i)=a22
13108                 a_chuj(1,2,num_conti,i)=a23
13109                 a_chuj(2,1,num_conti,i)=a32
13110                 a_chuj(2,2,num_conti,i)=a33
13111 !     --- Gradient of rij
13112                 do kkk=1,3
13113                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
13114                 enddo
13115                 kkll=0
13116                 do k=1,2
13117                   do l=1,2
13118                     kkll=kkll+1
13119                     do m=1,3
13120                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
13121                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
13122                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
13123                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
13124                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
13125                     enddo
13126                   enddo
13127                 enddo
13128                 ENDIF
13129                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
13130 ! Calculate contact energies
13131                 cosa4=4.0D0*cosa
13132                 wij=cosa-3.0D0*cosb*cosg
13133                 cosbg1=cosb+cosg
13134                 cosbg2=cosb-cosg
13135 !               fac3=dsqrt(-ael6i)/r0ij**3
13136                 fac3=dsqrt(-ael6i)*r3ij
13137 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
13138                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
13139                 if (ees0tmp.gt.0) then
13140                   ees0pij=dsqrt(ees0tmp)
13141                 else
13142                   ees0pij=0
13143                 endif
13144 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
13145                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
13146                 if (ees0tmp.gt.0) then
13147                   ees0mij=dsqrt(ees0tmp)
13148                 else
13149                   ees0mij=0
13150                 endif
13151 !               ees0mij=0.0D0
13152                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
13153                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
13154 ! Diagnostics. Comment out or remove after debugging!
13155 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
13156 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
13157 !               ees0m(num_conti,i)=0.0D0
13158 ! End diagnostics.
13159 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
13160 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
13161 ! Angular derivatives of the contact function
13162                 ees0pij1=fac3/ees0pij
13163                 ees0mij1=fac3/ees0mij
13164                 fac3p=-3.0D0*fac3*rrmij
13165                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
13166                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
13167 !               ees0mij1=0.0D0
13168                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
13169                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
13170                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
13171                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
13172                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
13173                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
13174                 ecosap=ecosa1+ecosa2
13175                 ecosbp=ecosb1+ecosb2
13176                 ecosgp=ecosg1+ecosg2
13177                 ecosam=ecosa1-ecosa2
13178                 ecosbm=ecosb1-ecosb2
13179                 ecosgm=ecosg1-ecosg2
13180 ! Diagnostics
13181 !               ecosap=ecosa1
13182 !               ecosbp=ecosb1
13183 !               ecosgp=ecosg1
13184 !               ecosam=0.0D0
13185 !               ecosbm=0.0D0
13186 !               ecosgm=0.0D0
13187 ! End diagnostics
13188                 facont_hb(num_conti,i)=fcont
13189                 fprimcont=fprimcont/rij
13190 !d              facont_hb(num_conti,i)=1.0D0
13191 ! Following line is for diagnostics.
13192 !d              fprimcont=0.0D0
13193                 do k=1,3
13194                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13195                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13196                 enddo
13197                 do k=1,3
13198                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
13199                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
13200                 enddo
13201                 gggp(1)=gggp(1)+ees0pijp*xj
13202                 gggp(2)=gggp(2)+ees0pijp*yj
13203                 gggp(3)=gggp(3)+ees0pijp*zj
13204                 gggm(1)=gggm(1)+ees0mijp*xj
13205                 gggm(2)=gggm(2)+ees0mijp*yj
13206                 gggm(3)=gggm(3)+ees0mijp*zj
13207 ! Derivatives due to the contact function
13208                 gacont_hbr(1,num_conti,i)=fprimcont*xj
13209                 gacont_hbr(2,num_conti,i)=fprimcont*yj
13210                 gacont_hbr(3,num_conti,i)=fprimcont*zj
13211                 do k=1,3
13212 !
13213 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
13214 !          following the change of gradient-summation algorithm.
13215 !
13216 !grad                  ghalfp=0.5D0*gggp(k)
13217 !grad                  ghalfm=0.5D0*gggm(k)
13218                   gacontp_hb1(k,num_conti,i)= & !ghalfp
13219                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13220                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13221                   gacontp_hb2(k,num_conti,i)= & !ghalfp
13222                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13223                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13224                   gacontp_hb3(k,num_conti,i)=gggp(k)
13225                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
13226                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13227                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13228                   gacontm_hb2(k,num_conti,i)= & !ghalfm
13229                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13230                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13231                   gacontm_hb3(k,num_conti,i)=gggm(k)
13232                 enddo
13233               ENDIF ! wcorr
13234               endif  ! num_conti.le.maxconts
13235             endif  ! fcont.gt.0
13236           endif    ! j.gt.i+1
13237           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
13238             do k=1,4
13239               do l=1,3
13240                 ghalf=0.5d0*agg(l,k)
13241                 aggi(l,k)=aggi(l,k)+ghalf
13242                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
13243                 aggj(l,k)=aggj(l,k)+ghalf
13244               enddo
13245             enddo
13246             if (j.eq.nres-1 .and. i.lt.j-2) then
13247               do k=1,4
13248                 do l=1,3
13249                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
13250                 enddo
13251               enddo
13252             endif
13253           endif
13254 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
13255       return
13256       end subroutine eelecij_scale
13257 !-----------------------------------------------------------------------------
13258       subroutine evdwpp_short(evdw1)
13259 !
13260 ! Compute Evdwpp
13261 !
13262 !      implicit real*8 (a-h,o-z)
13263 !      include 'DIMENSIONS'
13264 !      include 'COMMON.CONTROL'
13265 !      include 'COMMON.IOUNITS'
13266 !      include 'COMMON.GEO'
13267 !      include 'COMMON.VAR'
13268 !      include 'COMMON.LOCAL'
13269 !      include 'COMMON.CHAIN'
13270 !      include 'COMMON.DERIV'
13271 !      include 'COMMON.INTERACT'
13272 !      include 'COMMON.CONTACTS'
13273 !      include 'COMMON.TORSION'
13274 !      include 'COMMON.VECTORS'
13275 !      include 'COMMON.FFIELD'
13276       real(kind=8),dimension(3) :: ggg
13277 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13278 #ifdef MOMENT
13279       real(kind=8) :: scal_el=1.0d0
13280 #else
13281       real(kind=8) :: scal_el=0.5d0
13282 #endif
13283 !el local variables
13284       integer :: i,j,k,iteli,itelj,num_conti
13285       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
13286       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
13287                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13288                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
13289
13290       evdw1=0.0D0
13291 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
13292 !     & " iatel_e_vdw",iatel_e_vdw
13293       call flush(iout)
13294       do i=iatel_s_vdw,iatel_e_vdw
13295         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
13296         dxi=dc(1,i)
13297         dyi=dc(2,i)
13298         dzi=dc(3,i)
13299         dx_normi=dc_norm(1,i)
13300         dy_normi=dc_norm(2,i)
13301         dz_normi=dc_norm(3,i)
13302         xmedi=c(1,i)+0.5d0*dxi
13303         ymedi=c(2,i)+0.5d0*dyi
13304         zmedi=c(3,i)+0.5d0*dzi
13305         num_conti=0
13306 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
13307 !     &   ' ielend',ielend_vdw(i)
13308         call flush(iout)
13309         do j=ielstart_vdw(i),ielend_vdw(i)
13310           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13311 !el          ind=ind+1
13312           iteli=itel(i)
13313           itelj=itel(j)
13314           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13315           aaa=app(iteli,itelj)
13316           bbb=bpp(iteli,itelj)
13317           dxj=dc(1,j)
13318           dyj=dc(2,j)
13319           dzj=dc(3,j)
13320           dx_normj=dc_norm(1,j)
13321           dy_normj=dc_norm(2,j)
13322           dz_normj=dc_norm(3,j)
13323           xj=c(1,j)+0.5D0*dxj-xmedi
13324           yj=c(2,j)+0.5D0*dyj-ymedi
13325           zj=c(3,j)+0.5D0*dzj-zmedi
13326           rij=xj*xj+yj*yj+zj*zj
13327           rrmij=1.0D0/rij
13328           rij=dsqrt(rij)
13329           sss=sscale(rij/rpp(iteli,itelj))
13330           if (sss.gt.0.0d0) then
13331             rmij=1.0D0/rij
13332             r3ij=rrmij*rmij
13333             r6ij=r3ij*r3ij
13334             ev1=aaa*r6ij*r6ij
13335 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13336             if (j.eq.i+2) ev1=scal_el*ev1
13337             ev2=bbb*r6ij
13338             evdwij=ev1+ev2
13339             if (energy_dec) then
13340               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13341             endif
13342             evdw1=evdw1+evdwij*sss
13343 !
13344 ! Calculate contributions to the Cartesian gradient.
13345 !
13346             facvdw=-6*rrmij*(ev1+evdwij)*sss
13347             ggg(1)=facvdw*xj
13348             ggg(2)=facvdw*yj
13349             ggg(3)=facvdw*zj
13350             do k=1,3
13351               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13352               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13353             enddo
13354           endif
13355         enddo ! j
13356       enddo   ! i
13357       return
13358       end subroutine evdwpp_short
13359 !-----------------------------------------------------------------------------
13360       subroutine escp_long(evdw2,evdw2_14)
13361 !
13362 ! This subroutine calculates the excluded-volume interaction energy between
13363 ! peptide-group centers and side chains and its gradient in virtual-bond and
13364 ! side-chain vectors.
13365 !
13366 !      implicit real*8 (a-h,o-z)
13367 !      include 'DIMENSIONS'
13368 !      include 'COMMON.GEO'
13369 !      include 'COMMON.VAR'
13370 !      include 'COMMON.LOCAL'
13371 !      include 'COMMON.CHAIN'
13372 !      include 'COMMON.DERIV'
13373 !      include 'COMMON.INTERACT'
13374 !      include 'COMMON.FFIELD'
13375 !      include 'COMMON.IOUNITS'
13376 !      include 'COMMON.CONTROL'
13377       real(kind=8),dimension(3) :: ggg
13378 !el local variables
13379       integer :: i,iint,j,k,iteli,itypj
13380       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13381       real(kind=8) :: evdw2,evdw2_14,evdwij
13382       evdw2=0.0D0
13383       evdw2_14=0.0d0
13384 !d    print '(a)','Enter ESCP'
13385 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13386       do i=iatscp_s,iatscp_e
13387         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13388         iteli=itel(i)
13389         xi=0.5D0*(c(1,i)+c(1,i+1))
13390         yi=0.5D0*(c(2,i)+c(2,i+1))
13391         zi=0.5D0*(c(3,i)+c(3,i+1))
13392
13393         do iint=1,nscp_gr(i)
13394
13395         do j=iscpstart(i,iint),iscpend(i,iint)
13396           itypj=itype(j)
13397           if (itypj.eq.ntyp1) cycle
13398 ! Uncomment following three lines for SC-p interactions
13399 !         xj=c(1,nres+j)-xi
13400 !         yj=c(2,nres+j)-yi
13401 !         zj=c(3,nres+j)-zi
13402 ! Uncomment following three lines for Ca-p interactions
13403           xj=c(1,j)-xi
13404           yj=c(2,j)-yi
13405           zj=c(3,j)-zi
13406           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13407
13408           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13409
13410           if (sss.lt.1.0d0) then
13411
13412             fac=rrij**expon2
13413             e1=fac*fac*aad(itypj,iteli)
13414             e2=fac*bad(itypj,iteli)
13415             if (iabs(j-i) .le. 2) then
13416               e1=scal14*e1
13417               e2=scal14*e2
13418               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
13419             endif
13420             evdwij=e1+e2
13421             evdw2=evdw2+evdwij*(1.0d0-sss)
13422             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13423                 'evdw2',i,j,sss,evdwij
13424 !
13425 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13426 !
13427             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
13428             ggg(1)=xj*fac
13429             ggg(2)=yj*fac
13430             ggg(3)=zj*fac
13431 ! Uncomment following three lines for SC-p interactions
13432 !           do k=1,3
13433 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13434 !           enddo
13435 ! Uncomment following line for SC-p interactions
13436 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13437             do k=1,3
13438               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13439               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13440             enddo
13441           endif
13442         enddo
13443
13444         enddo ! iint
13445       enddo ! i
13446       do i=1,nct
13447         do j=1,3
13448           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13449           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13450           gradx_scp(j,i)=expon*gradx_scp(j,i)
13451         enddo
13452       enddo
13453 !******************************************************************************
13454 !
13455 !                              N O T E !!!
13456 !
13457 ! To save time the factor EXPON has been extracted from ALL components
13458 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13459 ! use!
13460 !
13461 !******************************************************************************
13462       return
13463       end subroutine escp_long
13464 !-----------------------------------------------------------------------------
13465       subroutine escp_short(evdw2,evdw2_14)
13466 !
13467 ! This subroutine calculates the excluded-volume interaction energy between
13468 ! peptide-group centers and side chains and its gradient in virtual-bond and
13469 ! side-chain vectors.
13470 !
13471 !      implicit real*8 (a-h,o-z)
13472 !      include 'DIMENSIONS'
13473 !      include 'COMMON.GEO'
13474 !      include 'COMMON.VAR'
13475 !      include 'COMMON.LOCAL'
13476 !      include 'COMMON.CHAIN'
13477 !      include 'COMMON.DERIV'
13478 !      include 'COMMON.INTERACT'
13479 !      include 'COMMON.FFIELD'
13480 !      include 'COMMON.IOUNITS'
13481 !      include 'COMMON.CONTROL'
13482       real(kind=8),dimension(3) :: ggg
13483 !el local variables
13484       integer :: i,iint,j,k,iteli,itypj
13485       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13486       real(kind=8) :: evdw2,evdw2_14,evdwij
13487       evdw2=0.0D0
13488       evdw2_14=0.0d0
13489 !d    print '(a)','Enter ESCP'
13490 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13491       do i=iatscp_s,iatscp_e
13492         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13493         iteli=itel(i)
13494         xi=0.5D0*(c(1,i)+c(1,i+1))
13495         yi=0.5D0*(c(2,i)+c(2,i+1))
13496         zi=0.5D0*(c(3,i)+c(3,i+1))
13497
13498         do iint=1,nscp_gr(i)
13499
13500         do j=iscpstart(i,iint),iscpend(i,iint)
13501           itypj=itype(j)
13502           if (itypj.eq.ntyp1) cycle
13503 ! Uncomment following three lines for SC-p interactions
13504 !         xj=c(1,nres+j)-xi
13505 !         yj=c(2,nres+j)-yi
13506 !         zj=c(3,nres+j)-zi
13507 ! Uncomment following three lines for Ca-p interactions
13508           xj=c(1,j)-xi
13509           yj=c(2,j)-yi
13510           zj=c(3,j)-zi
13511           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13512
13513           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13514
13515           if (sss.gt.0.0d0) then
13516
13517             fac=rrij**expon2
13518             e1=fac*fac*aad(itypj,iteli)
13519             e2=fac*bad(itypj,iteli)
13520             if (iabs(j-i) .le. 2) then
13521               e1=scal14*e1
13522               e2=scal14*e2
13523               evdw2_14=evdw2_14+(e1+e2)*sss
13524             endif
13525             evdwij=e1+e2
13526             evdw2=evdw2+evdwij*sss
13527             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13528                 'evdw2',i,j,sss,evdwij
13529 !
13530 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13531 !
13532             fac=-(evdwij+e1)*rrij*sss
13533             ggg(1)=xj*fac
13534             ggg(2)=yj*fac
13535             ggg(3)=zj*fac
13536 ! Uncomment following three lines for SC-p interactions
13537 !           do k=1,3
13538 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13539 !           enddo
13540 ! Uncomment following line for SC-p interactions
13541 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13542             do k=1,3
13543               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13544               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13545             enddo
13546           endif
13547         enddo
13548
13549         enddo ! iint
13550       enddo ! i
13551       do i=1,nct
13552         do j=1,3
13553           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13554           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13555           gradx_scp(j,i)=expon*gradx_scp(j,i)
13556         enddo
13557       enddo
13558 !******************************************************************************
13559 !
13560 !                              N O T E !!!
13561 !
13562 ! To save time the factor EXPON has been extracted from ALL components
13563 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13564 ! use!
13565 !
13566 !******************************************************************************
13567       return
13568       end subroutine escp_short
13569 !-----------------------------------------------------------------------------
13570 ! energy_p_new-sep_barrier.F
13571 !-----------------------------------------------------------------------------
13572       subroutine sc_grad_scale(scalfac)
13573 !      implicit real*8 (a-h,o-z)
13574       use calc_data
13575 !      include 'DIMENSIONS'
13576 !      include 'COMMON.CHAIN'
13577 !      include 'COMMON.DERIV'
13578 !      include 'COMMON.CALC'
13579 !      include 'COMMON.IOUNITS'
13580       real(kind=8),dimension(3) :: dcosom1,dcosom2
13581       real(kind=8) :: scalfac
13582 !el local variables
13583 !      integer :: i,j,k,l
13584
13585       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13586       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13587       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13588            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13589 ! diagnostics only
13590 !      eom1=0.0d0
13591 !      eom2=0.0d0
13592 !      eom12=evdwij*eps1_om12
13593 ! end diagnostics
13594 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13595 !     &  " sigder",sigder
13596 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13597 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13598       do k=1,3
13599         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13600         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13601       enddo
13602       do k=1,3
13603         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
13604          *sss_ele_cut
13605       enddo
13606 !      write (iout,*) "gg",(gg(k),k=1,3)
13607       do k=1,3
13608         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13609                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13610                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
13611                  *sss_ele_cut
13612         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13613                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13614                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
13615          *sss_ele_cut
13616 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13617 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13618 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13619 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13620       enddo
13621 !
13622 ! Calculate the components of the gradient in DC and X
13623 !
13624       do l=1,3
13625         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13626         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13627       enddo
13628       return
13629       end subroutine sc_grad_scale
13630 !-----------------------------------------------------------------------------
13631 ! energy_split-sep.F
13632 !-----------------------------------------------------------------------------
13633       subroutine etotal_long(energia)
13634 !
13635 ! Compute the long-range slow-varying contributions to the energy
13636 !
13637 !      implicit real*8 (a-h,o-z)
13638 !      include 'DIMENSIONS'
13639       use MD_data, only: totT,usampl,eq_time
13640 #ifndef ISNAN
13641       external proc_proc
13642 #ifdef WINPGI
13643 !MS$ATTRIBUTES C ::  proc_proc
13644 #endif
13645 #endif
13646 #ifdef MPI
13647       include "mpif.h"
13648       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13649 #endif
13650 !      include 'COMMON.SETUP'
13651 !      include 'COMMON.IOUNITS'
13652 !      include 'COMMON.FFIELD'
13653 !      include 'COMMON.DERIV'
13654 !      include 'COMMON.INTERACT'
13655 !      include 'COMMON.SBRIDGE'
13656 !      include 'COMMON.CHAIN'
13657 !      include 'COMMON.VAR'
13658 !      include 'COMMON.LOCAL'
13659 !      include 'COMMON.MD'
13660       real(kind=8),dimension(0:n_ene) :: energia
13661 !el local variables
13662       integer :: i,n_corr,n_corr1,ierror,ierr
13663       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13664                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13665                   ecorr,ecorr5,ecorr6,eturn6,time00
13666 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13667 !elwrite(iout,*)"in etotal long"
13668
13669       if (modecalc.eq.12.or.modecalc.eq.14) then
13670 #ifdef MPI
13671 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13672 #else
13673         call int_from_cart1(.false.)
13674 #endif
13675       endif
13676 !elwrite(iout,*)"in etotal long"
13677
13678 #ifdef MPI
13679 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13680 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13681       call flush(iout)
13682       if (nfgtasks.gt.1) then
13683         time00=MPI_Wtime()
13684 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13685         if (fg_rank.eq.0) then
13686           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13687 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13688 !          call flush(iout)
13689 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13690 ! FG slaves as WEIGHTS array.
13691           weights_(1)=wsc
13692           weights_(2)=wscp
13693           weights_(3)=welec
13694           weights_(4)=wcorr
13695           weights_(5)=wcorr5
13696           weights_(6)=wcorr6
13697           weights_(7)=wel_loc
13698           weights_(8)=wturn3
13699           weights_(9)=wturn4
13700           weights_(10)=wturn6
13701           weights_(11)=wang
13702           weights_(12)=wscloc
13703           weights_(13)=wtor
13704           weights_(14)=wtor_d
13705           weights_(15)=wstrain
13706           weights_(16)=wvdwpp
13707           weights_(17)=wbond
13708           weights_(18)=scal14
13709           weights_(21)=wsccor
13710 ! FG Master broadcasts the WEIGHTS_ array
13711           call MPI_Bcast(weights_(1),n_ene,&
13712               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13713         else
13714 ! FG slaves receive the WEIGHTS array
13715           call MPI_Bcast(weights(1),n_ene,&
13716               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13717           wsc=weights(1)
13718           wscp=weights(2)
13719           welec=weights(3)
13720           wcorr=weights(4)
13721           wcorr5=weights(5)
13722           wcorr6=weights(6)
13723           wel_loc=weights(7)
13724           wturn3=weights(8)
13725           wturn4=weights(9)
13726           wturn6=weights(10)
13727           wang=weights(11)
13728           wscloc=weights(12)
13729           wtor=weights(13)
13730           wtor_d=weights(14)
13731           wstrain=weights(15)
13732           wvdwpp=weights(16)
13733           wbond=weights(17)
13734           scal14=weights(18)
13735           wsccor=weights(21)
13736         endif
13737         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13738           king,FG_COMM,IERR)
13739          time_Bcast=time_Bcast+MPI_Wtime()-time00
13740          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13741 !        call chainbuild_cart
13742 !        call int_from_cart1(.false.)
13743       endif
13744 !      write (iout,*) 'Processor',myrank,
13745 !     &  ' calling etotal_short ipot=',ipot
13746 !      call flush(iout)
13747 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13748 #endif
13749 !d    print *,'nnt=',nnt,' nct=',nct
13750 !
13751 !elwrite(iout,*)"in etotal long"
13752 ! Compute the side-chain and electrostatic interaction energy
13753 !
13754       goto (101,102,103,104,105,106) ipot
13755 ! Lennard-Jones potential.
13756   101 call elj_long(evdw)
13757 !d    print '(a)','Exit ELJ'
13758       goto 107
13759 ! Lennard-Jones-Kihara potential (shifted).
13760   102 call eljk_long(evdw)
13761       goto 107
13762 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13763   103 call ebp_long(evdw)
13764       goto 107
13765 ! Gay-Berne potential (shifted LJ, angular dependence).
13766   104 call egb_long(evdw)
13767       goto 107
13768 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13769   105 call egbv_long(evdw)
13770       goto 107
13771 ! Soft-sphere potential
13772   106 call e_softsphere(evdw)
13773 !
13774 ! Calculate electrostatic (H-bonding) energy of the main chain.
13775 !
13776   107 continue
13777       call vec_and_deriv
13778       if (ipot.lt.6) then
13779 #ifdef SPLITELE
13780          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13781              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13782              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13783              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13784 #else
13785          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13786              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13787              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13788              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13789 #endif
13790            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13791          else
13792             ees=0
13793             evdw1=0
13794             eel_loc=0
13795             eello_turn3=0
13796             eello_turn4=0
13797          endif
13798       else
13799 !        write (iout,*) "Soft-spheer ELEC potential"
13800         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13801          eello_turn4)
13802       endif
13803 !
13804 ! Calculate excluded-volume interaction energy between peptide groups
13805 ! and side chains.
13806 !
13807       if (ipot.lt.6) then
13808        if(wscp.gt.0d0) then
13809         call escp_long(evdw2,evdw2_14)
13810        else
13811         evdw2=0
13812         evdw2_14=0
13813        endif
13814       else
13815         call escp_soft_sphere(evdw2,evdw2_14)
13816       endif
13817 !
13818 ! 12/1/95 Multi-body terms
13819 !
13820       n_corr=0
13821       n_corr1=0
13822       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13823           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13824          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13825 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13826 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13827       else
13828          ecorr=0.0d0
13829          ecorr5=0.0d0
13830          ecorr6=0.0d0
13831          eturn6=0.0d0
13832       endif
13833       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13834          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13835       endif
13836 !
13837 ! If performing constraint dynamics, call the constraint energy
13838 !  after the equilibration time
13839       if(usampl.and.totT.gt.eq_time) then
13840          call EconstrQ
13841          call Econstr_back
13842       else
13843          Uconst=0.0d0
13844          Uconst_back=0.0d0
13845       endif
13846 !
13847 ! Sum the energies
13848 !
13849       do i=1,n_ene
13850         energia(i)=0.0d0
13851       enddo
13852       energia(1)=evdw
13853 #ifdef SCP14
13854       energia(2)=evdw2-evdw2_14
13855       energia(18)=evdw2_14
13856 #else
13857       energia(2)=evdw2
13858       energia(18)=0.0d0
13859 #endif
13860 #ifdef SPLITELE
13861       energia(3)=ees
13862       energia(16)=evdw1
13863 #else
13864       energia(3)=ees+evdw1
13865       energia(16)=0.0d0
13866 #endif
13867       energia(4)=ecorr
13868       energia(5)=ecorr5
13869       energia(6)=ecorr6
13870       energia(7)=eel_loc
13871       energia(8)=eello_turn3
13872       energia(9)=eello_turn4
13873       energia(10)=eturn6
13874       energia(20)=Uconst+Uconst_back
13875       call sum_energy(energia,.true.)
13876 !      write (iout,*) "Exit ETOTAL_LONG"
13877       call flush(iout)
13878       return
13879       end subroutine etotal_long
13880 !-----------------------------------------------------------------------------
13881       subroutine etotal_short(energia)
13882 !
13883 ! Compute the short-range fast-varying contributions to the energy
13884 !
13885 !      implicit real*8 (a-h,o-z)
13886 !      include 'DIMENSIONS'
13887 #ifndef ISNAN
13888       external proc_proc
13889 #ifdef WINPGI
13890 !MS$ATTRIBUTES C ::  proc_proc
13891 #endif
13892 #endif
13893 #ifdef MPI
13894       include "mpif.h"
13895       integer :: ierror,ierr
13896       real(kind=8),dimension(n_ene) :: weights_
13897       real(kind=8) :: time00
13898 #endif
13899 !      include 'COMMON.SETUP'
13900 !      include 'COMMON.IOUNITS'
13901 !      include 'COMMON.FFIELD'
13902 !      include 'COMMON.DERIV'
13903 !      include 'COMMON.INTERACT'
13904 !      include 'COMMON.SBRIDGE'
13905 !      include 'COMMON.CHAIN'
13906 !      include 'COMMON.VAR'
13907 !      include 'COMMON.LOCAL'
13908       real(kind=8),dimension(0:n_ene) :: energia
13909 !el local variables
13910       integer :: i,nres6
13911       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13912       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13913       nres6=6*nres
13914
13915 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13916 !      call flush(iout)
13917       if (modecalc.eq.12.or.modecalc.eq.14) then
13918 #ifdef MPI
13919         if (fg_rank.eq.0) call int_from_cart1(.false.)
13920 #else
13921         call int_from_cart1(.false.)
13922 #endif
13923       endif
13924 #ifdef MPI
13925 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13926 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13927 !      call flush(iout)
13928       if (nfgtasks.gt.1) then
13929         time00=MPI_Wtime()
13930 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13931         if (fg_rank.eq.0) then
13932           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13933 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13934 !          call flush(iout)
13935 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13936 ! FG slaves as WEIGHTS array.
13937           weights_(1)=wsc
13938           weights_(2)=wscp
13939           weights_(3)=welec
13940           weights_(4)=wcorr
13941           weights_(5)=wcorr5
13942           weights_(6)=wcorr6
13943           weights_(7)=wel_loc
13944           weights_(8)=wturn3
13945           weights_(9)=wturn4
13946           weights_(10)=wturn6
13947           weights_(11)=wang
13948           weights_(12)=wscloc
13949           weights_(13)=wtor
13950           weights_(14)=wtor_d
13951           weights_(15)=wstrain
13952           weights_(16)=wvdwpp
13953           weights_(17)=wbond
13954           weights_(18)=scal14
13955           weights_(21)=wsccor
13956 ! FG Master broadcasts the WEIGHTS_ array
13957           call MPI_Bcast(weights_(1),n_ene,&
13958               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13959         else
13960 ! FG slaves receive the WEIGHTS array
13961           call MPI_Bcast(weights(1),n_ene,&
13962               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13963           wsc=weights(1)
13964           wscp=weights(2)
13965           welec=weights(3)
13966           wcorr=weights(4)
13967           wcorr5=weights(5)
13968           wcorr6=weights(6)
13969           wel_loc=weights(7)
13970           wturn3=weights(8)
13971           wturn4=weights(9)
13972           wturn6=weights(10)
13973           wang=weights(11)
13974           wscloc=weights(12)
13975           wtor=weights(13)
13976           wtor_d=weights(14)
13977           wstrain=weights(15)
13978           wvdwpp=weights(16)
13979           wbond=weights(17)
13980           scal14=weights(18)
13981           wsccor=weights(21)
13982         endif
13983 !        write (iout,*),"Processor",myrank," BROADCAST weights"
13984         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
13985           king,FG_COMM,IERR)
13986 !        write (iout,*) "Processor",myrank," BROADCAST c"
13987         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
13988           king,FG_COMM,IERR)
13989 !        write (iout,*) "Processor",myrank," BROADCAST dc"
13990         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
13991           king,FG_COMM,IERR)
13992 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
13993         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
13994           king,FG_COMM,IERR)
13995 !        write (iout,*) "Processor",myrank," BROADCAST theta"
13996         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
13997           king,FG_COMM,IERR)
13998 !        write (iout,*) "Processor",myrank," BROADCAST phi"
13999         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
14000           king,FG_COMM,IERR)
14001 !        write (iout,*) "Processor",myrank," BROADCAST alph"
14002         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
14003           king,FG_COMM,IERR)
14004 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
14005         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
14006           king,FG_COMM,IERR)
14007 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
14008         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
14009           king,FG_COMM,IERR)
14010          time_Bcast=time_Bcast+MPI_Wtime()-time00
14011 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
14012       endif
14013 !      write (iout,*) 'Processor',myrank,
14014 !     &  ' calling etotal_short ipot=',ipot
14015 !      call flush(iout)
14016 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
14017 #endif
14018 !      call int_from_cart1(.false.)
14019 !
14020 ! Compute the side-chain and electrostatic interaction energy
14021 !
14022       goto (101,102,103,104,105,106) ipot
14023 ! Lennard-Jones potential.
14024   101 call elj_short(evdw)
14025 !d    print '(a)','Exit ELJ'
14026       goto 107
14027 ! Lennard-Jones-Kihara potential (shifted).
14028   102 call eljk_short(evdw)
14029       goto 107
14030 ! Berne-Pechukas potential (dilated LJ, angular dependence).
14031   103 call ebp_short(evdw)
14032       goto 107
14033 ! Gay-Berne potential (shifted LJ, angular dependence).
14034   104 call egb_short(evdw)
14035       goto 107
14036 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
14037   105 call egbv_short(evdw)
14038       goto 107
14039 ! Soft-sphere potential - already dealt with in the long-range part
14040   106 evdw=0.0d0
14041 !  106 call e_softsphere_short(evdw)
14042 !
14043 ! Calculate electrostatic (H-bonding) energy of the main chain.
14044 !
14045   107 continue
14046 !
14047 ! Calculate the short-range part of Evdwpp
14048 !
14049       call evdwpp_short(evdw1)
14050 !
14051 ! Calculate the short-range part of ESCp
14052 !
14053       if (ipot.lt.6) then
14054         call escp_short(evdw2,evdw2_14)
14055       endif
14056 !
14057 ! Calculate the bond-stretching energy
14058 !
14059       call ebond(estr)
14060 !
14061 ! Calculate the disulfide-bridge and other energy and the contributions
14062 ! from other distance constraints.
14063       call edis(ehpb)
14064 !
14065 ! Calculate the virtual-bond-angle energy.
14066 !
14067       call ebend(ebe)
14068 !
14069 ! Calculate the SC local energy.
14070 !
14071       call vec_and_deriv
14072       call esc(escloc)
14073 !
14074 ! Calculate the virtual-bond torsional energy.
14075 !
14076       call etor(etors,edihcnstr)
14077 !
14078 ! 6/23/01 Calculate double-torsional energy
14079 !
14080       call etor_d(etors_d)
14081 !
14082 ! 21/5/07 Calculate local sicdechain correlation energy
14083 !
14084       if (wsccor.gt.0.0d0) then
14085         call eback_sc_corr(esccor)
14086       else
14087         esccor=0.0d0
14088       endif
14089 !
14090 ! Put energy components into an array
14091 !
14092       do i=1,n_ene
14093         energia(i)=0.0d0
14094       enddo
14095       energia(1)=evdw
14096 #ifdef SCP14
14097       energia(2)=evdw2-evdw2_14
14098       energia(18)=evdw2_14
14099 #else
14100       energia(2)=evdw2
14101       energia(18)=0.0d0
14102 #endif
14103 #ifdef SPLITELE
14104       energia(16)=evdw1
14105 #else
14106       energia(3)=evdw1
14107 #endif
14108       energia(11)=ebe
14109       energia(12)=escloc
14110       energia(13)=etors
14111       energia(14)=etors_d
14112       energia(15)=ehpb
14113       energia(17)=estr
14114       energia(19)=edihcnstr
14115       energia(21)=esccor
14116 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
14117       call flush(iout)
14118       call sum_energy(energia,.true.)
14119 !      write (iout,*) "Exit ETOTAL_SHORT"
14120       call flush(iout)
14121       return
14122       end subroutine etotal_short
14123 !-----------------------------------------------------------------------------
14124 ! gnmr1.f
14125 !-----------------------------------------------------------------------------
14126       real(kind=8) function gnmr1(y,ymin,ymax)
14127 !      implicit none
14128       real(kind=8) :: y,ymin,ymax
14129       real(kind=8) :: wykl=4.0d0
14130       if (y.lt.ymin) then
14131         gnmr1=(ymin-y)**wykl/wykl
14132       else if (y.gt.ymax) then
14133         gnmr1=(y-ymax)**wykl/wykl
14134       else
14135         gnmr1=0.0d0
14136       endif
14137       return
14138       end function gnmr1
14139 !-----------------------------------------------------------------------------
14140       real(kind=8) function gnmr1prim(y,ymin,ymax)
14141 !      implicit none
14142       real(kind=8) :: y,ymin,ymax
14143       real(kind=8) :: wykl=4.0d0
14144       if (y.lt.ymin) then
14145         gnmr1prim=-(ymin-y)**(wykl-1)
14146       else if (y.gt.ymax) then
14147         gnmr1prim=(y-ymax)**(wykl-1)
14148       else
14149         gnmr1prim=0.0d0
14150       endif
14151       return
14152       end function gnmr1prim
14153 !-----------------------------------------------------------------------------
14154       real(kind=8) function harmonic(y,ymax)
14155 !      implicit none
14156       real(kind=8) :: y,ymax
14157       real(kind=8) :: wykl=2.0d0
14158       harmonic=(y-ymax)**wykl
14159       return
14160       end function harmonic
14161 !-----------------------------------------------------------------------------
14162       real(kind=8) function harmonicprim(y,ymax)
14163       real(kind=8) :: y,ymin,ymax
14164       real(kind=8) :: wykl=2.0d0
14165       harmonicprim=(y-ymax)*wykl
14166       return
14167       end function harmonicprim
14168 !-----------------------------------------------------------------------------
14169 ! gradient_p.F
14170 !-----------------------------------------------------------------------------
14171       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
14172
14173       use io_base, only:intout,briefout
14174 !      implicit real*8 (a-h,o-z)
14175 !      include 'DIMENSIONS'
14176 !      include 'COMMON.CHAIN'
14177 !      include 'COMMON.DERIV'
14178 !      include 'COMMON.VAR'
14179 !      include 'COMMON.INTERACT'
14180 !      include 'COMMON.FFIELD'
14181 !      include 'COMMON.MD'
14182 !      include 'COMMON.IOUNITS'
14183       real(kind=8),external :: ufparm
14184       integer :: uiparm(1)
14185       real(kind=8) :: urparm(1)
14186       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
14187       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
14188       integer :: n,nf,ind,ind1,i,k,j
14189 !
14190 ! This subroutine calculates total internal coordinate gradient.
14191 ! Depending on the number of function evaluations, either whole energy
14192 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
14193 ! internal coordinates are reevaluated or only the cartesian-in-internal
14194 ! coordinate derivatives are evaluated. The subroutine was designed to work
14195 ! with SUMSL.
14196 !
14197 !
14198       icg=mod(nf,2)+1
14199
14200 !d      print *,'grad',nf,icg
14201       if (nf-nfl+1) 20,30,40
14202    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
14203 !    write (iout,*) 'grad 20'
14204       if (nf.eq.0) return
14205       goto 40
14206    30 call var_to_geom(n,x)
14207       call chainbuild
14208 !    write (iout,*) 'grad 30'
14209 !
14210 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
14211 !
14212    40 call cartder
14213 !     write (iout,*) 'grad 40'
14214 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
14215 !
14216 ! Convert the Cartesian gradient into internal-coordinate gradient.
14217 !
14218       ind=0
14219       ind1=0
14220       do i=1,nres-2
14221         gthetai=0.0D0
14222         gphii=0.0D0
14223         do j=i+1,nres-1
14224           ind=ind+1
14225 !         ind=indmat(i,j)
14226 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
14227           do k=1,3
14228             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
14229           enddo
14230           do k=1,3
14231             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
14232           enddo
14233         enddo
14234         do j=i+1,nres-1
14235           ind1=ind1+1
14236 !         ind1=indmat(i,j)
14237 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
14238           do k=1,3
14239             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
14240             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
14241           enddo
14242         enddo
14243         if (i.gt.1) g(i-1)=gphii
14244         if (n.gt.nphi) g(nphi+i)=gthetai
14245       enddo
14246       if (n.le.nphi+ntheta) goto 10
14247       do i=2,nres-1
14248         if (itype(i).ne.10) then
14249           galphai=0.0D0
14250           gomegai=0.0D0
14251           do k=1,3
14252             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
14253           enddo
14254           do k=1,3
14255             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
14256           enddo
14257           g(ialph(i,1))=galphai
14258           g(ialph(i,1)+nside)=gomegai
14259         endif
14260       enddo
14261 !
14262 ! Add the components corresponding to local energy terms.
14263 !
14264    10 continue
14265       do i=1,nvar
14266 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
14267         g(i)=g(i)+gloc(i,icg)
14268       enddo
14269 ! Uncomment following three lines for diagnostics.
14270 !d    call intout
14271 !elwrite(iout,*) "in gradient after calling intout"
14272 !d    call briefout(0,0.0d0)
14273 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
14274       return
14275       end subroutine gradient
14276 !-----------------------------------------------------------------------------
14277       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
14278
14279       use comm_chu
14280 !      implicit real*8 (a-h,o-z)
14281 !      include 'DIMENSIONS'
14282 !      include 'COMMON.DERIV'
14283 !      include 'COMMON.IOUNITS'
14284 !      include 'COMMON.GEO'
14285       integer :: n,nf
14286 !el      integer :: jjj
14287 !el      common /chuju/ jjj
14288       real(kind=8) :: energia(0:n_ene)
14289       integer :: uiparm(1)
14290       real(kind=8) :: urparm(1)
14291       real(kind=8) :: f
14292       real(kind=8),external :: ufparm
14293       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
14294 !     if (jjj.gt.0) then
14295 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14296 !     endif
14297       nfl=nf
14298       icg=mod(nf,2)+1
14299 !d      print *,'func',nf,nfl,icg
14300       call var_to_geom(n,x)
14301       call zerograd
14302       call chainbuild
14303 !d    write (iout,*) 'ETOTAL called from FUNC'
14304       call etotal(energia)
14305       call sum_gradient
14306       f=energia(0)
14307 !     if (jjj.gt.0) then
14308 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14309 !       write (iout,*) 'f=',etot
14310 !       jjj=0
14311 !     endif
14312       return
14313       end subroutine func
14314 !-----------------------------------------------------------------------------
14315       subroutine cartgrad
14316 !      implicit real*8 (a-h,o-z)
14317 !      include 'DIMENSIONS'
14318       use energy_data
14319       use MD_data, only: totT,usampl,eq_time
14320 #ifdef MPI
14321       include 'mpif.h'
14322 #endif
14323 !      include 'COMMON.CHAIN'
14324 !      include 'COMMON.DERIV'
14325 !      include 'COMMON.VAR'
14326 !      include 'COMMON.INTERACT'
14327 !      include 'COMMON.FFIELD'
14328 !      include 'COMMON.MD'
14329 !      include 'COMMON.IOUNITS'
14330 !      include 'COMMON.TIME1'
14331 !
14332       integer :: i,j
14333
14334 ! This subrouting calculates total Cartesian coordinate gradient.
14335 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
14336 !
14337 !el#define DEBUG
14338 #ifdef TIMING
14339       time00=MPI_Wtime()
14340 #endif
14341       icg=1
14342       call sum_gradient
14343 #ifdef TIMING
14344 #endif
14345 !el      write (iout,*) "After sum_gradient"
14346 #ifdef DEBUG
14347 !el      write (iout,*) "After sum_gradient"
14348       do i=1,nres-1
14349         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
14350         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
14351       enddo
14352 #endif
14353 ! If performing constraint dynamics, add the gradients of the constraint energy
14354       if(usampl.and.totT.gt.eq_time) then
14355          do i=1,nct
14356            do j=1,3
14357              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
14358              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
14359            enddo
14360          enddo
14361          do i=1,nres-3
14362            gloc(i,icg)=gloc(i,icg)+dugamma(i)
14363          enddo
14364          do i=1,nres-2
14365            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
14366          enddo
14367       endif
14368 !elwrite (iout,*) "After sum_gradient"
14369 #ifdef TIMING
14370       time01=MPI_Wtime()
14371 #endif
14372       call intcartderiv
14373 !elwrite (iout,*) "After sum_gradient"
14374 #ifdef TIMING
14375       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
14376 #endif
14377 !     call checkintcartgrad
14378 !     write(iout,*) 'calling int_to_cart'
14379 #ifdef DEBUG
14380       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
14381 #endif
14382       do i=1,nct
14383         do j=1,3
14384           gcart(j,i)=gradc(j,i,icg)
14385           gxcart(j,i)=gradx(j,i,icg)
14386         enddo
14387 #ifdef DEBUG
14388         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
14389           (gxcart(j,i),j=1,3),gloc(i,icg)
14390 #endif
14391       enddo
14392 #ifdef TIMING
14393       time01=MPI_Wtime()
14394 #endif
14395       call int_to_cart
14396 #ifdef TIMING
14397       time_inttocart=time_inttocart+MPI_Wtime()-time01
14398 #endif
14399 #ifdef DEBUG
14400       write (iout,*) "gcart and gxcart after int_to_cart"
14401       do i=0,nres-1
14402         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
14403             (gxcart(j,i),j=1,3)
14404       enddo
14405 #endif
14406 #ifdef CARGRAD
14407 #ifdef DEBUG
14408       write (iout,*) "CARGRAD"
14409 #endif
14410       do i=nres,1,-1
14411         do j=1,3
14412           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14413 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14414         enddo
14415 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
14416 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
14417       enddo
14418 ! Correction: dummy residues
14419         if (nnt.gt.1) then
14420           do j=1,3
14421 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
14422             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
14423           enddo
14424         endif
14425         if (nct.lt.nres) then
14426           do j=1,3
14427 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
14428             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
14429           enddo
14430         endif
14431 #endif
14432 #ifdef TIMING
14433       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
14434 #endif
14435 !el#undef DEBUG
14436       return
14437       end subroutine cartgrad
14438 !-----------------------------------------------------------------------------
14439       subroutine zerograd
14440 !      implicit real*8 (a-h,o-z)
14441 !      include 'DIMENSIONS'
14442 !      include 'COMMON.DERIV'
14443 !      include 'COMMON.CHAIN'
14444 !      include 'COMMON.VAR'
14445 !      include 'COMMON.MD'
14446 !      include 'COMMON.SCCOR'
14447 !
14448 !el local variables
14449       integer :: i,j,intertyp
14450 ! Initialize Cartesian-coordinate gradient
14451 !
14452 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
14453 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
14454
14455 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
14456 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
14457 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
14458 !      allocate(gradcorr_long(3,nres))
14459 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
14460 !      allocate(gcorr6_turn_long(3,nres))
14461 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
14462
14463 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
14464
14465 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
14466 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
14467
14468 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
14469 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
14470
14471 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
14472 !      allocate(gscloc(3,nres)) !(3,maxres)
14473 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
14474
14475
14476
14477 !      common /deriv_scloc/
14478 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
14479 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
14480 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
14481 !      common /mpgrad/
14482 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
14483
14484
14485
14486 !          gradc(j,i,icg)=0.0d0
14487 !          gradx(j,i,icg)=0.0d0
14488
14489 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
14490 !elwrite(iout,*) "icg",icg
14491       do i=1,nres
14492         do j=1,3
14493           gvdwx(j,i)=0.0D0
14494           gradx_scp(j,i)=0.0D0
14495           gvdwc(j,i)=0.0D0
14496           gvdwc_scp(j,i)=0.0D0
14497           gvdwc_scpp(j,i)=0.0d0
14498           gelc(j,i)=0.0D0
14499           gelc_long(j,i)=0.0D0
14500           gradb(j,i)=0.0d0
14501           gradbx(j,i)=0.0d0
14502           gvdwpp(j,i)=0.0d0
14503           gel_loc(j,i)=0.0d0
14504           gel_loc_long(j,i)=0.0d0
14505           ghpbc(j,i)=0.0D0
14506           ghpbx(j,i)=0.0D0
14507           gcorr3_turn(j,i)=0.0d0
14508           gcorr4_turn(j,i)=0.0d0
14509           gradcorr(j,i)=0.0d0
14510           gradcorr_long(j,i)=0.0d0
14511           gradcorr5_long(j,i)=0.0d0
14512           gradcorr6_long(j,i)=0.0d0
14513           gcorr6_turn_long(j,i)=0.0d0
14514           gradcorr5(j,i)=0.0d0
14515           gradcorr6(j,i)=0.0d0
14516           gcorr6_turn(j,i)=0.0d0
14517           gsccorc(j,i)=0.0d0
14518           gsccorx(j,i)=0.0d0
14519           gradc(j,i,icg)=0.0d0
14520           gradx(j,i,icg)=0.0d0
14521           gscloc(j,i)=0.0d0
14522           gsclocx(j,i)=0.0d0
14523           do intertyp=1,3
14524            gloc_sc(intertyp,i,icg)=0.0d0
14525           enddo
14526         enddo
14527       enddo
14528 !
14529 ! Initialize the gradient of local energy terms.
14530 !
14531 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
14532 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14533 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14534 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
14535 !      allocate(gel_loc_turn3(nres))
14536 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
14537 !      allocate(gsccor_loc(nres))       !(maxres)
14538
14539       do i=1,4*nres
14540         gloc(i,icg)=0.0D0
14541       enddo
14542       do i=1,nres
14543         gel_loc_loc(i)=0.0d0
14544         gcorr_loc(i)=0.0d0
14545         g_corr5_loc(i)=0.0d0
14546         g_corr6_loc(i)=0.0d0
14547         gel_loc_turn3(i)=0.0d0
14548         gel_loc_turn4(i)=0.0d0
14549         gel_loc_turn6(i)=0.0d0
14550         gsccor_loc(i)=0.0d0
14551       enddo
14552 ! initialize gcart and gxcart
14553 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
14554       do i=0,nres
14555         do j=1,3
14556           gcart(j,i)=0.0d0
14557           gxcart(j,i)=0.0d0
14558         enddo
14559       enddo
14560       return
14561       end subroutine zerograd
14562 !-----------------------------------------------------------------------------
14563       real(kind=8) function fdum()
14564       fdum=0.0D0
14565       return
14566       end function fdum
14567 !-----------------------------------------------------------------------------
14568 ! intcartderiv.F
14569 !-----------------------------------------------------------------------------
14570       subroutine intcartderiv
14571 !      implicit real*8 (a-h,o-z)
14572 !      include 'DIMENSIONS'
14573 #ifdef MPI
14574       include 'mpif.h'
14575 #endif
14576 !      include 'COMMON.SETUP'
14577 !      include 'COMMON.CHAIN'
14578 !      include 'COMMON.VAR'
14579 !      include 'COMMON.GEO'
14580 !      include 'COMMON.INTERACT'
14581 !      include 'COMMON.DERIV'
14582 !      include 'COMMON.IOUNITS'
14583 !      include 'COMMON.LOCAL'
14584 !      include 'COMMON.SCCOR'
14585       real(kind=8) :: pi4,pi34
14586       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
14587       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
14588                     dcosomega,dsinomega !(3,3,maxres)
14589       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
14590
14591       integer :: i,j,k
14592       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
14593                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
14594                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
14595                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
14596       integer :: nres2
14597       nres2=2*nres
14598
14599 !el from module energy-------------
14600 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
14601 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
14602 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
14603
14604 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
14605 !el      allocate(dsintau(3,3,3,0:nres2))
14606 !el      allocate(dtauangle(3,3,3,0:nres2))
14607 !el      allocate(domicron(3,2,2,0:nres2))
14608 !el      allocate(dcosomicron(3,2,2,0:nres2))
14609
14610
14611
14612 #if defined(MPI) && defined(PARINTDER)
14613       if (nfgtasks.gt.1 .and. me.eq.king) &
14614         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14615 #endif
14616       pi4 = 0.5d0*pipol
14617       pi34 = 3*pi4
14618
14619 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14620 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14621
14622 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14623       do i=1,nres
14624         do j=1,3
14625           dtheta(j,1,i)=0.0d0
14626           dtheta(j,2,i)=0.0d0
14627           dphi(j,1,i)=0.0d0
14628           dphi(j,2,i)=0.0d0
14629           dphi(j,3,i)=0.0d0
14630         enddo
14631       enddo
14632 ! Derivatives of theta's
14633 #if defined(MPI) && defined(PARINTDER)
14634 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14635       do i=max0(ithet_start-1,3),ithet_end
14636 #else
14637       do i=3,nres
14638 #endif
14639         cost=dcos(theta(i))
14640         sint=sqrt(1-cost*cost)
14641         do j=1,3
14642           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14643           vbld(i-1)
14644           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14645           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14646           vbld(i)
14647           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14648         enddo
14649       enddo
14650 #if defined(MPI) && defined(PARINTDER)
14651 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14652       do i=max0(ithet_start-1,3),ithet_end
14653 #else
14654       do i=3,nres
14655 #endif
14656       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14657         cost1=dcos(omicron(1,i))
14658         sint1=sqrt(1-cost1*cost1)
14659         cost2=dcos(omicron(2,i))
14660         sint2=sqrt(1-cost2*cost2)
14661        do j=1,3
14662 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14663           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14664           cost1*dc_norm(j,i-2))/ &
14665           vbld(i-1)
14666           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14667           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14668           +cost1*(dc_norm(j,i-1+nres)))/ &
14669           vbld(i-1+nres)
14670           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14671 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14672 !C Looks messy but better than if in loop
14673           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14674           +cost2*dc_norm(j,i-1))/ &
14675           vbld(i)
14676           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14677           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14678            +cost2*(-dc_norm(j,i-1+nres)))/ &
14679           vbld(i-1+nres)
14680 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14681           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14682         enddo
14683        endif
14684       enddo
14685 !elwrite(iout,*) "after vbld write"
14686 ! Derivatives of phi:
14687 ! If phi is 0 or 180 degrees, then the formulas
14688 ! have to be derived by power series expansion of the
14689 ! conventional formulas around 0 and 180.
14690 #ifdef PARINTDER
14691       do i=iphi1_start,iphi1_end
14692 #else
14693       do i=4,nres
14694 #endif
14695 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14696 ! the conventional case
14697         sint=dsin(theta(i))
14698         sint1=dsin(theta(i-1))
14699         sing=dsin(phi(i))
14700         cost=dcos(theta(i))
14701         cost1=dcos(theta(i-1))
14702         cosg=dcos(phi(i))
14703         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14704         fac0=1.0d0/(sint1*sint)
14705         fac1=cost*fac0
14706         fac2=cost1*fac0
14707         fac3=cosg*cost1/(sint1*sint1)
14708         fac4=cosg*cost/(sint*sint)
14709 !    Obtaining the gamma derivatives from sine derivative
14710        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14711            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14712            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14713          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14714          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14715          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14716          do j=1,3
14717             ctgt=cost/sint
14718             ctgt1=cost1/sint1
14719             cosg_inv=1.0d0/cosg
14720             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14721             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14722               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14723             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14724             dsinphi(j,2,i)= &
14725               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14726               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14727             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14728             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14729               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14730 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14731             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14732             endif
14733 ! Bug fixed 3/24/05 (AL)
14734          enddo
14735 !   Obtaining the gamma derivatives from cosine derivative
14736         else
14737            do j=1,3
14738            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14739            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14740            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14741            dc_norm(j,i-3))/vbld(i-2)
14742            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14743            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14744            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14745            dcostheta(j,1,i)
14746            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14747            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14748            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14749            dc_norm(j,i-1))/vbld(i)
14750            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14751            endif
14752          enddo
14753         endif
14754       enddo
14755 !alculate derivative of Tauangle
14756 #ifdef PARINTDER
14757       do i=itau_start,itau_end
14758 #else
14759       do i=3,nres
14760 !elwrite(iout,*) " vecpr",i,nres
14761 #endif
14762        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14763 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14764 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14765 !c dtauangle(j,intertyp,dervityp,residue number)
14766 !c INTERTYP=1 SC...Ca...Ca..Ca
14767 ! the conventional case
14768         sint=dsin(theta(i))
14769         sint1=dsin(omicron(2,i-1))
14770         sing=dsin(tauangle(1,i))
14771         cost=dcos(theta(i))
14772         cost1=dcos(omicron(2,i-1))
14773         cosg=dcos(tauangle(1,i))
14774 !elwrite(iout,*) " vecpr5",i,nres
14775         do j=1,3
14776 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14777 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14778         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14779 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14780         enddo
14781         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14782         fac0=1.0d0/(sint1*sint)
14783         fac1=cost*fac0
14784         fac2=cost1*fac0
14785         fac3=cosg*cost1/(sint1*sint1)
14786         fac4=cosg*cost/(sint*sint)
14787 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14788 !    Obtaining the gamma derivatives from sine derivative
14789        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14790            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14791            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14792          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14793          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14794          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14795         do j=1,3
14796             ctgt=cost/sint
14797             ctgt1=cost1/sint1
14798             cosg_inv=1.0d0/cosg
14799             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14800        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14801        *vbld_inv(i-2+nres)
14802             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14803             dsintau(j,1,2,i)= &
14804               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14805               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14806 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14807             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14808 ! Bug fixed 3/24/05 (AL)
14809             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14810               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14811 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14812             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14813          enddo
14814 !   Obtaining the gamma derivatives from cosine derivative
14815         else
14816            do j=1,3
14817            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14818            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14819            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14820            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14821            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14822            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14823            dcostheta(j,1,i)
14824            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14825            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14826            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14827            dc_norm(j,i-1))/vbld(i)
14828            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14829 !         write (iout,*) "else",i
14830          enddo
14831         endif
14832 !        do k=1,3
14833 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14834 !        enddo
14835       enddo
14836 !C Second case Ca...Ca...Ca...SC
14837 #ifdef PARINTDER
14838       do i=itau_start,itau_end
14839 #else
14840       do i=4,nres
14841 #endif
14842        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14843           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14844 ! the conventional case
14845         sint=dsin(omicron(1,i))
14846         sint1=dsin(theta(i-1))
14847         sing=dsin(tauangle(2,i))
14848         cost=dcos(omicron(1,i))
14849         cost1=dcos(theta(i-1))
14850         cosg=dcos(tauangle(2,i))
14851 !        do j=1,3
14852 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14853 !        enddo
14854         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14855         fac0=1.0d0/(sint1*sint)
14856         fac1=cost*fac0
14857         fac2=cost1*fac0
14858         fac3=cosg*cost1/(sint1*sint1)
14859         fac4=cosg*cost/(sint*sint)
14860 !    Obtaining the gamma derivatives from sine derivative
14861        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14862            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14863            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14864          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14865          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14866          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14867         do j=1,3
14868             ctgt=cost/sint
14869             ctgt1=cost1/sint1
14870             cosg_inv=1.0d0/cosg
14871             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14872               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14873 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14874 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14875             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14876             dsintau(j,2,2,i)= &
14877               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14878               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14879 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14880 !     & sing*ctgt*domicron(j,1,2,i),
14881 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14882             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14883 ! Bug fixed 3/24/05 (AL)
14884             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14885              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14886 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14887             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14888          enddo
14889 !   Obtaining the gamma derivatives from cosine derivative
14890         else
14891            do j=1,3
14892            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14893            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14894            dc_norm(j,i-3))/vbld(i-2)
14895            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14896            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14897            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14898            dcosomicron(j,1,1,i)
14899            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14900            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14901            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14902            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14903            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14904 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14905          enddo
14906         endif
14907       enddo
14908
14909 !CC third case SC...Ca...Ca...SC
14910 #ifdef PARINTDER
14911
14912       do i=itau_start,itau_end
14913 #else
14914       do i=3,nres
14915 #endif
14916 ! the conventional case
14917       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14918       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14919         sint=dsin(omicron(1,i))
14920         sint1=dsin(omicron(2,i-1))
14921         sing=dsin(tauangle(3,i))
14922         cost=dcos(omicron(1,i))
14923         cost1=dcos(omicron(2,i-1))
14924         cosg=dcos(tauangle(3,i))
14925         do j=1,3
14926         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14927 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14928         enddo
14929         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14930         fac0=1.0d0/(sint1*sint)
14931         fac1=cost*fac0
14932         fac2=cost1*fac0
14933         fac3=cosg*cost1/(sint1*sint1)
14934         fac4=cosg*cost/(sint*sint)
14935 !    Obtaining the gamma derivatives from sine derivative
14936        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14937            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14938            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14939          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14940          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14941          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14942         do j=1,3
14943             ctgt=cost/sint
14944             ctgt1=cost1/sint1
14945             cosg_inv=1.0d0/cosg
14946             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14947               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14948               *vbld_inv(i-2+nres)
14949             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14950             dsintau(j,3,2,i)= &
14951               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14952               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14953             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14954 ! Bug fixed 3/24/05 (AL)
14955             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14956               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14957               *vbld_inv(i-1+nres)
14958 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14959             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
14960          enddo
14961 !   Obtaining the gamma derivatives from cosine derivative
14962         else
14963            do j=1,3
14964            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14965            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14966            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
14967            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
14968            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14969            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14970            dcosomicron(j,1,1,i)
14971            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
14972            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14973            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
14974            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14975            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
14976 !          write(iout,*) "else",i
14977          enddo
14978         endif
14979       enddo
14980
14981 #ifdef CRYST_SC
14982 !   Derivatives of side-chain angles alpha and omega
14983 #if defined(MPI) && defined(PARINTDER)
14984         do i=ibond_start,ibond_end
14985 #else
14986         do i=2,nres-1
14987 #endif
14988           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
14989              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
14990              fac6=fac5/vbld(i)
14991              fac7=fac5*fac5
14992              fac8=fac5/vbld(i+1)
14993              fac9=fac5/vbld(i+nres)
14994              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
14995              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
14996              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
14997              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
14998              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
14999              sina=sqrt(1-cosa*cosa)
15000              sino=dsin(omeg(i))
15001 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
15002              do j=1,3
15003                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
15004                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
15005                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
15006                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
15007                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
15008                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
15009                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
15010                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
15011                 vbld(i+nres))
15012                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
15013             enddo
15014 ! obtaining the derivatives of omega from sines
15015             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
15016                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
15017                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
15018                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
15019                dsin(theta(i+1)))
15020                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
15021                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
15022                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
15023                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
15024                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
15025                coso_inv=1.0d0/dcos(omeg(i))
15026                do j=1,3
15027                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
15028                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
15029                  (sino*dc_norm(j,i-1))/vbld(i)
15030                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
15031                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
15032                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
15033                  -sino*dc_norm(j,i)/vbld(i+1)
15034                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
15035                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
15036                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
15037                  vbld(i+nres)
15038                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
15039               enddo
15040            else
15041 !   obtaining the derivatives of omega from cosines
15042              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
15043              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
15044              fac12=fac10*sina
15045              fac13=fac12*fac12
15046              fac14=sina*sina
15047              do j=1,3
15048                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
15049                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
15050                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
15051                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
15052                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
15053                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
15054                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
15055                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
15056                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
15057                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
15058                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
15059                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
15060                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
15061                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
15062                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
15063             enddo
15064           endif
15065          else
15066            do j=1,3
15067              do k=1,3
15068                dalpha(k,j,i)=0.0d0
15069                domega(k,j,i)=0.0d0
15070              enddo
15071            enddo
15072          endif
15073        enddo
15074 #endif
15075 #if defined(MPI) && defined(PARINTDER)
15076       if (nfgtasks.gt.1) then
15077 #ifdef DEBUG
15078 !d      write (iout,*) "Gather dtheta"
15079 !d      call flush(iout)
15080       write (iout,*) "dtheta before gather"
15081       do i=1,nres
15082         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
15083       enddo
15084 #endif
15085       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
15086         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
15087         king,FG_COMM,IERROR)
15088 #ifdef DEBUG
15089 !d      write (iout,*) "Gather dphi"
15090 !d      call flush(iout)
15091       write (iout,*) "dphi before gather"
15092       do i=1,nres
15093         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
15094       enddo
15095 #endif
15096       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
15097         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
15098         king,FG_COMM,IERROR)
15099 !d      write (iout,*) "Gather dalpha"
15100 !d      call flush(iout)
15101 #ifdef CRYST_SC
15102       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
15103         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15104         king,FG_COMM,IERROR)
15105 !d      write (iout,*) "Gather domega"
15106 !d      call flush(iout)
15107       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
15108         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15109         king,FG_COMM,IERROR)
15110 #endif
15111       endif
15112 #endif
15113 #ifdef DEBUG
15114       write (iout,*) "dtheta after gather"
15115       do i=1,nres
15116         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
15117       enddo
15118       write (iout,*) "dphi after gather"
15119       do i=1,nres
15120         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
15121       enddo
15122       write (iout,*) "dalpha after gather"
15123       do i=1,nres
15124         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
15125       enddo
15126       write (iout,*) "domega after gather"
15127       do i=1,nres
15128         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
15129       enddo
15130 #endif
15131       return
15132       end subroutine intcartderiv
15133 !-----------------------------------------------------------------------------
15134       subroutine checkintcartgrad
15135 !      implicit real*8 (a-h,o-z)
15136 !      include 'DIMENSIONS'
15137 #ifdef MPI
15138       include 'mpif.h'
15139 #endif
15140 !      include 'COMMON.CHAIN'
15141 !      include 'COMMON.VAR'
15142 !      include 'COMMON.GEO'
15143 !      include 'COMMON.INTERACT'
15144 !      include 'COMMON.DERIV'
15145 !      include 'COMMON.IOUNITS'
15146 !      include 'COMMON.SETUP'
15147       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
15148       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
15149       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
15150       real(kind=8),dimension(3) :: dc_norm_s
15151       real(kind=8) :: aincr=1.0d-5
15152       integer :: i,j
15153       real(kind=8) :: dcji
15154       do i=1,nres
15155         phi_s(i)=phi(i)
15156         theta_s(i)=theta(i)
15157         alph_s(i)=alph(i)
15158         omeg_s(i)=omeg(i)
15159       enddo
15160 ! Check theta gradient
15161       write (iout,*) &
15162        "Analytical (upper) and numerical (lower) gradient of theta"
15163       write (iout,*)
15164       do i=3,nres
15165         do j=1,3
15166           dcji=dc(j,i-2)
15167           dc(j,i-2)=dcji+aincr
15168           call chainbuild_cart
15169           call int_from_cart1(.false.)
15170           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
15171           dc(j,i-2)=dcji
15172           dcji=dc(j,i-1)
15173           dc(j,i-1)=dc(j,i-1)+aincr
15174           call chainbuild_cart
15175           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
15176           dc(j,i-1)=dcji
15177         enddo
15178 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
15179 !el          (dtheta(j,2,i),j=1,3)
15180 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
15181 !el          (dthetanum(j,2,i),j=1,3)
15182 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
15183 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
15184 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
15185 !el        write (iout,*)
15186       enddo
15187 ! Check gamma gradient
15188       write (iout,*) &
15189        "Analytical (upper) and numerical (lower) gradient of gamma"
15190       do i=4,nres
15191         do j=1,3
15192           dcji=dc(j,i-3)
15193           dc(j,i-3)=dcji+aincr
15194           call chainbuild_cart
15195           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
15196           dc(j,i-3)=dcji
15197           dcji=dc(j,i-2)
15198           dc(j,i-2)=dcji+aincr
15199           call chainbuild_cart
15200           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
15201           dc(j,i-2)=dcji
15202           dcji=dc(j,i-1)
15203           dc(j,i-1)=dc(j,i-1)+aincr
15204           call chainbuild_cart
15205           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
15206           dc(j,i-1)=dcji
15207         enddo
15208 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
15209 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
15210 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
15211 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
15212 !el        write (iout,'(5x,3(3f10.5,5x))') &
15213 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
15214 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
15215 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
15216 !el        write (iout,*)
15217       enddo
15218 ! Check alpha gradient
15219       write (iout,*) &
15220        "Analytical (upper) and numerical (lower) gradient of alpha"
15221       do i=2,nres-1
15222        if(itype(i).ne.10) then
15223             do j=1,3
15224               dcji=dc(j,i-1)
15225               dc(j,i-1)=dcji+aincr
15226               call chainbuild_cart
15227               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
15228               /aincr
15229               dc(j,i-1)=dcji
15230               dcji=dc(j,i)
15231               dc(j,i)=dcji+aincr
15232               call chainbuild_cart
15233               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
15234               /aincr
15235               dc(j,i)=dcji
15236               dcji=dc(j,i+nres)
15237               dc(j,i+nres)=dc(j,i+nres)+aincr
15238               call chainbuild_cart
15239               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
15240               /aincr
15241              dc(j,i+nres)=dcji
15242             enddo
15243           endif
15244 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
15245 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
15246 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
15247 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
15248 !el        write (iout,'(5x,3(3f10.5,5x))') &
15249 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
15250 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
15251 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
15252 !el        write (iout,*)
15253       enddo
15254 !     Check omega gradient
15255       write (iout,*) &
15256        "Analytical (upper) and numerical (lower) gradient of omega"
15257       do i=2,nres-1
15258        if(itype(i).ne.10) then
15259             do j=1,3
15260               dcji=dc(j,i-1)
15261               dc(j,i-1)=dcji+aincr
15262               call chainbuild_cart
15263               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
15264               /aincr
15265               dc(j,i-1)=dcji
15266               dcji=dc(j,i)
15267               dc(j,i)=dcji+aincr
15268               call chainbuild_cart
15269               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
15270               /aincr
15271               dc(j,i)=dcji
15272               dcji=dc(j,i+nres)
15273               dc(j,i+nres)=dc(j,i+nres)+aincr
15274               call chainbuild_cart
15275               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
15276               /aincr
15277              dc(j,i+nres)=dcji
15278             enddo
15279           endif
15280 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
15281 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
15282 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
15283 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
15284 !el        write (iout,'(5x,3(3f10.5,5x))') &
15285 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
15286 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
15287 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
15288 !el        write (iout,*)
15289       enddo
15290       return
15291       end subroutine checkintcartgrad
15292 !-----------------------------------------------------------------------------
15293 ! q_measure.F
15294 !-----------------------------------------------------------------------------
15295       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
15296 !      implicit real*8 (a-h,o-z)
15297 !      include 'DIMENSIONS'
15298 !      include 'COMMON.IOUNITS'
15299 !      include 'COMMON.CHAIN'
15300 !      include 'COMMON.INTERACT'
15301 !      include 'COMMON.VAR'
15302       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
15303       integer :: kkk,nsep=3
15304       real(kind=8) :: qm        !dist,
15305       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
15306       logical :: lprn=.false.
15307       logical :: flag
15308 !      real(kind=8) :: sigm,x
15309
15310 !el      sigm(x)=0.25d0*x     ! local function
15311       qqmax=1.0d10
15312       do kkk=1,nperm
15313       qq = 0.0d0
15314       nl=0
15315        if(flag) then
15316         do il=seg1+nsep,seg2
15317           do jl=seg1,il-nsep
15318             nl=nl+1
15319             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
15320                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
15321                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15322             dij=dist(il,jl)
15323             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15324             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15325               nl=nl+1
15326               d0ijCM=dsqrt( &
15327                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15328                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15329                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15330               dijCM=dist(il+nres,jl+nres)
15331               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15332             endif
15333             qq = qq+qqij+qqijCM
15334           enddo
15335         enddo
15336         qq = qq/nl
15337       else
15338       do il=seg1,seg2
15339         if((seg3-il).lt.3) then
15340              secseg=il+3
15341         else
15342              secseg=seg3
15343         endif
15344           do jl=secseg,seg4
15345             nl=nl+1
15346             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15347                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15348                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15349             dij=dist(il,jl)
15350             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15351             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15352               nl=nl+1
15353               d0ijCM=dsqrt( &
15354                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15355                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15356                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15357               dijCM=dist(il+nres,jl+nres)
15358               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15359             endif
15360             qq = qq+qqij+qqijCM
15361           enddo
15362         enddo
15363       qq = qq/nl
15364       endif
15365       if (qqmax.le.qq) qqmax=qq
15366       enddo
15367       qwolynes=1.0d0-qqmax
15368       return
15369       end function qwolynes
15370 !-----------------------------------------------------------------------------
15371       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
15372 !      implicit real*8 (a-h,o-z)
15373 !      include 'DIMENSIONS'
15374 !      include 'COMMON.IOUNITS'
15375 !      include 'COMMON.CHAIN'
15376 !      include 'COMMON.INTERACT'
15377 !      include 'COMMON.VAR'
15378 !      include 'COMMON.MD'
15379       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
15380       integer :: nsep=3, kkk
15381 !el      real(kind=8) :: dist
15382       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
15383       logical :: lprn=.false.
15384       logical :: flag
15385       real(kind=8) :: sim,dd0,fac,ddqij
15386 !el      sigm(x)=0.25d0*x            ! local function
15387       do kkk=1,nperm
15388       do i=0,nres
15389         do j=1,3
15390           dqwol(j,i)=0.0d0
15391           dxqwol(j,i)=0.0d0
15392         enddo
15393       enddo
15394       nl=0
15395        if(flag) then
15396         do il=seg1+nsep,seg2
15397           do jl=seg1,il-nsep
15398             nl=nl+1
15399             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15400                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15401                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15402             dij=dist(il,jl)
15403             sim = 1.0d0/sigm(d0ij)
15404             sim = sim*sim
15405             dd0 = dij-d0ij
15406             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15407             do k=1,3
15408               ddqij = (c(k,il)-c(k,jl))*fac
15409               dqwol(k,il)=dqwol(k,il)+ddqij
15410               dqwol(k,jl)=dqwol(k,jl)-ddqij
15411             enddo
15412
15413             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15414               nl=nl+1
15415               d0ijCM=dsqrt( &
15416                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15417                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15418                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15419               dijCM=dist(il+nres,jl+nres)
15420               sim = 1.0d0/sigm(d0ijCM)
15421               sim = sim*sim
15422               dd0=dijCM-d0ijCM
15423               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15424               do k=1,3
15425                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15426                 dxqwol(k,il)=dxqwol(k,il)+ddqij
15427                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15428               enddo
15429             endif
15430           enddo
15431         enddo
15432        else
15433         do il=seg1,seg2
15434         if((seg3-il).lt.3) then
15435              secseg=il+3
15436         else
15437              secseg=seg3
15438         endif
15439           do jl=secseg,seg4
15440             nl=nl+1
15441             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15442                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15443                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15444             dij=dist(il,jl)
15445             sim = 1.0d0/sigm(d0ij)
15446             sim = sim*sim
15447             dd0 = dij-d0ij
15448             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15449             do k=1,3
15450               ddqij = (c(k,il)-c(k,jl))*fac
15451               dqwol(k,il)=dqwol(k,il)+ddqij
15452               dqwol(k,jl)=dqwol(k,jl)-ddqij
15453             enddo
15454             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15455               nl=nl+1
15456               d0ijCM=dsqrt( &
15457                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15458                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15459                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15460               dijCM=dist(il+nres,jl+nres)
15461               sim = 1.0d0/sigm(d0ijCM)
15462               sim=sim*sim
15463               dd0 = dijCM-d0ijCM
15464               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15465               do k=1,3
15466                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15467                dxqwol(k,il)=dxqwol(k,il)+ddqij
15468                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15469               enddo
15470             endif
15471           enddo
15472         enddo
15473       endif
15474       enddo
15475        do i=0,nres
15476          do j=1,3
15477            dqwol(j,i)=dqwol(j,i)/nl
15478            dxqwol(j,i)=dxqwol(j,i)/nl
15479          enddo
15480        enddo
15481       return
15482       end subroutine qwolynes_prim
15483 !-----------------------------------------------------------------------------
15484       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
15485 !      implicit real*8 (a-h,o-z)
15486 !      include 'DIMENSIONS'
15487 !      include 'COMMON.IOUNITS'
15488 !      include 'COMMON.CHAIN'
15489 !      include 'COMMON.INTERACT'
15490 !      include 'COMMON.VAR'
15491       integer :: seg1,seg2,seg3,seg4
15492       logical :: flag
15493       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
15494       real(kind=8),dimension(3,0:2*nres) :: cdummy
15495       real(kind=8) :: q1,q2
15496       real(kind=8) :: delta=1.0d-10
15497       integer :: i,j
15498
15499       do i=0,nres
15500         do j=1,3
15501           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15502           cdummy(j,i)=c(j,i)
15503           c(j,i)=c(j,i)+delta
15504           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15505           qwolan(j,i)=(q2-q1)/delta
15506           c(j,i)=cdummy(j,i)
15507         enddo
15508       enddo
15509       do i=0,nres
15510         do j=1,3
15511           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15512           cdummy(j,i+nres)=c(j,i+nres)
15513           c(j,i+nres)=c(j,i+nres)+delta
15514           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15515           qwolxan(j,i)=(q2-q1)/delta
15516           c(j,i+nres)=cdummy(j,i+nres)
15517         enddo
15518       enddo
15519 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
15520 !      do i=0,nct
15521 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
15522 !      enddo
15523 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
15524 !      do i=0,nct
15525 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
15526 !      enddo
15527       return
15528       end subroutine qwol_num
15529 !-----------------------------------------------------------------------------
15530       subroutine EconstrQ
15531 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
15532 !      implicit real*8 (a-h,o-z)
15533 !      include 'DIMENSIONS'
15534 !      include 'COMMON.CONTROL'
15535 !      include 'COMMON.VAR'
15536 !      include 'COMMON.MD'
15537       use MD_data
15538 !#ifndef LANG0
15539 !      include 'COMMON.LANGEVIN'
15540 !#else
15541 !      include 'COMMON.LANGEVIN.lang0'
15542 !#endif
15543 !      include 'COMMON.CHAIN'
15544 !      include 'COMMON.DERIV'
15545 !      include 'COMMON.GEO'
15546 !      include 'COMMON.LOCAL'
15547 !      include 'COMMON.INTERACT'
15548 !      include 'COMMON.IOUNITS'
15549 !      include 'COMMON.NAMES'
15550 !      include 'COMMON.TIME1'
15551       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
15552       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
15553                    duconst,duxconst
15554       integer :: kstart,kend,lstart,lend,idummy
15555       real(kind=8) :: delta=1.0d-7
15556       integer :: i,j,k,ii
15557       do i=0,nres
15558          do j=1,3
15559             duconst(j,i)=0.0d0
15560             dudconst(j,i)=0.0d0
15561             duxconst(j,i)=0.0d0
15562             dudxconst(j,i)=0.0d0
15563          enddo
15564       enddo
15565       Uconst=0.0d0
15566       do i=1,nfrag
15567          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15568            idummy,idummy)
15569          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
15570 ! Calculating the derivatives of Constraint energy with respect to Q
15571          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
15572            qinfrag(i,iset))
15573 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
15574 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
15575 !         hmnum=(hm2-hm1)/delta
15576 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
15577 !     &   qinfrag(i,iset))
15578 !         write(iout,*) "harmonicnum frag", hmnum
15579 ! Calculating the derivatives of Q with respect to cartesian coordinates
15580          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15581           idummy,idummy)
15582 !         write(iout,*) "dqwol "
15583 !         do ii=1,nres
15584 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15585 !         enddo
15586 !         write(iout,*) "dxqwol "
15587 !         do ii=1,nres
15588 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15589 !         enddo
15590 ! Calculating numerical gradients of dU/dQi and dQi/dxi
15591 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
15592 !     &  ,idummy,idummy)
15593 !  The gradients of Uconst in Cs
15594          do ii=0,nres
15595             do j=1,3
15596                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
15597                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
15598             enddo
15599          enddo
15600       enddo
15601       do i=1,npair
15602          kstart=ifrag(1,ipair(1,i,iset),iset)
15603          kend=ifrag(2,ipair(1,i,iset),iset)
15604          lstart=ifrag(1,ipair(2,i,iset),iset)
15605          lend=ifrag(2,ipair(2,i,iset),iset)
15606          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
15607          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
15608 !  Calculating dU/dQ
15609          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15610 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15611 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15612 !         hmnum=(hm2-hm1)/delta
15613 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15614 !     &   qinpair(i,iset))
15615 !         write(iout,*) "harmonicnum pair ", hmnum
15616 ! Calculating dQ/dXi
15617          call qwolynes_prim(kstart,kend,.false.,&
15618           lstart,lend)
15619 !         write(iout,*) "dqwol "
15620 !         do ii=1,nres
15621 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15622 !         enddo
15623 !         write(iout,*) "dxqwol "
15624 !         do ii=1,nres
15625 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15626 !        enddo
15627 ! Calculating numerical gradients
15628 !        call qwol_num(kstart,kend,.false.
15629 !     &  ,lstart,lend)
15630 ! The gradients of Uconst in Cs
15631          do ii=0,nres
15632             do j=1,3
15633                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15634                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15635             enddo
15636          enddo
15637       enddo
15638 !      write(iout,*) "Uconst inside subroutine ", Uconst
15639 ! Transforming the gradients from Cs to dCs for the backbone
15640       do i=0,nres
15641          do j=i+1,nres
15642            do k=1,3
15643              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15644            enddo
15645          enddo
15646       enddo
15647 !  Transforming the gradients from Cs to dCs for the side chains
15648       do i=1,nres
15649          do j=1,3
15650            dudxconst(j,i)=duxconst(j,i)
15651          enddo
15652       enddo
15653 !      write(iout,*) "dU/ddc backbone "
15654 !       do ii=0,nres
15655 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15656 !      enddo
15657 !      write(iout,*) "dU/ddX side chain "
15658 !      do ii=1,nres
15659 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15660 !      enddo
15661 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15662 !      call dEconstrQ_num
15663       return
15664       end subroutine EconstrQ
15665 !-----------------------------------------------------------------------------
15666       subroutine dEconstrQ_num
15667 ! Calculating numerical dUconst/ddc and dUconst/ddx
15668 !      implicit real*8 (a-h,o-z)
15669 !      include 'DIMENSIONS'
15670 !      include 'COMMON.CONTROL'
15671 !      include 'COMMON.VAR'
15672 !      include 'COMMON.MD'
15673       use MD_data
15674 !#ifndef LANG0
15675 !      include 'COMMON.LANGEVIN'
15676 !#else
15677 !      include 'COMMON.LANGEVIN.lang0'
15678 !#endif
15679 !      include 'COMMON.CHAIN'
15680 !      include 'COMMON.DERIV'
15681 !      include 'COMMON.GEO'
15682 !      include 'COMMON.LOCAL'
15683 !      include 'COMMON.INTERACT'
15684 !      include 'COMMON.IOUNITS'
15685 !      include 'COMMON.NAMES'
15686 !      include 'COMMON.TIME1'
15687       real(kind=8) :: uzap1,uzap2
15688       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15689       integer :: kstart,kend,lstart,lend,idummy
15690       real(kind=8) :: delta=1.0d-7
15691 !el local variables
15692       integer :: i,ii,j
15693 !     real(kind=8) ::
15694 !     For the backbone
15695       do i=0,nres-1
15696          do j=1,3
15697             dUcartan(j,i)=0.0d0
15698             cdummy(j,i)=dc(j,i)
15699             dc(j,i)=dc(j,i)+delta
15700             call chainbuild_cart
15701             uzap2=0.0d0
15702             do ii=1,nfrag
15703              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15704                 idummy,idummy)
15705                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15706                 qinfrag(ii,iset))
15707             enddo
15708             do ii=1,npair
15709                kstart=ifrag(1,ipair(1,ii,iset),iset)
15710                kend=ifrag(2,ipair(1,ii,iset),iset)
15711                lstart=ifrag(1,ipair(2,ii,iset),iset)
15712                lend=ifrag(2,ipair(2,ii,iset),iset)
15713                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15714                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15715                  qinpair(ii,iset))
15716             enddo
15717             dc(j,i)=cdummy(j,i)
15718             call chainbuild_cart
15719             uzap1=0.0d0
15720              do ii=1,nfrag
15721              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15722                 idummy,idummy)
15723                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15724                 qinfrag(ii,iset))
15725             enddo
15726             do ii=1,npair
15727                kstart=ifrag(1,ipair(1,ii,iset),iset)
15728                kend=ifrag(2,ipair(1,ii,iset),iset)
15729                lstart=ifrag(1,ipair(2,ii,iset),iset)
15730                lend=ifrag(2,ipair(2,ii,iset),iset)
15731                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15732                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15733                 qinpair(ii,iset))
15734             enddo
15735             ducartan(j,i)=(uzap2-uzap1)/(delta)
15736          enddo
15737       enddo
15738 ! Calculating numerical gradients for dU/ddx
15739       do i=0,nres-1
15740          duxcartan(j,i)=0.0d0
15741          do j=1,3
15742             cdummy(j,i)=dc(j,i+nres)
15743             dc(j,i+nres)=dc(j,i+nres)+delta
15744             call chainbuild_cart
15745             uzap2=0.0d0
15746             do ii=1,nfrag
15747              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15748                 idummy,idummy)
15749                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15750                 qinfrag(ii,iset))
15751             enddo
15752             do ii=1,npair
15753                kstart=ifrag(1,ipair(1,ii,iset),iset)
15754                kend=ifrag(2,ipair(1,ii,iset),iset)
15755                lstart=ifrag(1,ipair(2,ii,iset),iset)
15756                lend=ifrag(2,ipair(2,ii,iset),iset)
15757                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15758                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15759                 qinpair(ii,iset))
15760             enddo
15761             dc(j,i+nres)=cdummy(j,i)
15762             call chainbuild_cart
15763             uzap1=0.0d0
15764              do ii=1,nfrag
15765                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15766                 ifrag(2,ii,iset),.true.,idummy,idummy)
15767                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15768                 qinfrag(ii,iset))
15769             enddo
15770             do ii=1,npair
15771                kstart=ifrag(1,ipair(1,ii,iset),iset)
15772                kend=ifrag(2,ipair(1,ii,iset),iset)
15773                lstart=ifrag(1,ipair(2,ii,iset),iset)
15774                lend=ifrag(2,ipair(2,ii,iset),iset)
15775                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15776                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15777                 qinpair(ii,iset))
15778             enddo
15779             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15780          enddo
15781       enddo
15782       write(iout,*) "Numerical dUconst/ddc backbone "
15783       do ii=0,nres
15784         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15785       enddo
15786 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15787 !      do ii=1,nres
15788 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15789 !      enddo
15790       return
15791       end subroutine dEconstrQ_num
15792 !-----------------------------------------------------------------------------
15793 ! ssMD.F
15794 !-----------------------------------------------------------------------------
15795       subroutine check_energies
15796
15797 !      use random, only: ran_number
15798
15799 !      implicit none
15800 !     Includes
15801 !      include 'DIMENSIONS'
15802 !      include 'COMMON.CHAIN'
15803 !      include 'COMMON.VAR'
15804 !      include 'COMMON.IOUNITS'
15805 !      include 'COMMON.SBRIDGE'
15806 !      include 'COMMON.LOCAL'
15807 !      include 'COMMON.GEO'
15808
15809 !     External functions
15810 !EL      double precision ran_number
15811 !EL      external ran_number
15812
15813 !     Local variables
15814       integer :: i,j,k,l,lmax,p,pmax
15815       real(kind=8) :: rmin,rmax
15816       real(kind=8) :: eij
15817
15818       real(kind=8) :: d
15819       real(kind=8) :: wi,rij,tj,pj
15820 !      return
15821
15822       i=5
15823       j=14
15824
15825       d=dsc(1)
15826       rmin=2.0D0
15827       rmax=12.0D0
15828
15829       lmax=10000
15830       pmax=1
15831
15832       do k=1,3
15833         c(k,i)=0.0D0
15834         c(k,j)=0.0D0
15835         c(k,nres+i)=0.0D0
15836         c(k,nres+j)=0.0D0
15837       enddo
15838
15839       do l=1,lmax
15840
15841 !t        wi=ran_number(0.0D0,pi)
15842 !        wi=ran_number(0.0D0,pi/6.0D0)
15843 !        wi=0.0D0
15844 !t        tj=ran_number(0.0D0,pi)
15845 !t        pj=ran_number(0.0D0,pi)
15846 !        pj=ran_number(0.0D0,pi/6.0D0)
15847 !        pj=0.0D0
15848
15849         do p=1,pmax
15850 !t           rij=ran_number(rmin,rmax)
15851
15852            c(1,j)=d*sin(pj)*cos(tj)
15853            c(2,j)=d*sin(pj)*sin(tj)
15854            c(3,j)=d*cos(pj)
15855
15856            c(3,nres+i)=-rij
15857
15858            c(1,i)=d*sin(wi)
15859            c(3,i)=-rij-d*cos(wi)
15860
15861            do k=1,3
15862               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15863               dc_norm(k,nres+i)=dc(k,nres+i)/d
15864               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15865               dc_norm(k,nres+j)=dc(k,nres+j)/d
15866            enddo
15867
15868            call dyn_ssbond_ene(i,j,eij)
15869         enddo
15870       enddo
15871       call exit(1)
15872       return
15873       end subroutine check_energies
15874 !-----------------------------------------------------------------------------
15875       subroutine dyn_ssbond_ene(resi,resj,eij)
15876 !      implicit none
15877 !      Includes
15878       use calc_data
15879       use comm_sschecks
15880 !      include 'DIMENSIONS'
15881 !      include 'COMMON.SBRIDGE'
15882 !      include 'COMMON.CHAIN'
15883 !      include 'COMMON.DERIV'
15884 !      include 'COMMON.LOCAL'
15885 !      include 'COMMON.INTERACT'
15886 !      include 'COMMON.VAR'
15887 !      include 'COMMON.IOUNITS'
15888 !      include 'COMMON.CALC'
15889 #ifndef CLUST
15890 #ifndef WHAM
15891        use MD_data
15892 !      include 'COMMON.MD'
15893 !      use MD, only: totT,t_bath
15894 #endif
15895 #endif
15896 !     External functions
15897 !EL      double precision h_base
15898 !EL      external h_base
15899
15900 !     Input arguments
15901       integer :: resi,resj
15902
15903 !     Output arguments
15904       real(kind=8) :: eij
15905
15906 !     Local variables
15907       logical :: havebond
15908       integer itypi,itypj
15909       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15910       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15911       real(kind=8),dimension(3) :: dcosom1,dcosom2
15912       real(kind=8) :: ed
15913       real(kind=8) :: pom1,pom2
15914       real(kind=8) :: ljA,ljB,ljXs
15915       real(kind=8),dimension(1:3) :: d_ljB
15916       real(kind=8) :: ssA,ssB,ssC,ssXs
15917       real(kind=8) :: ssxm,ljxm,ssm,ljm
15918       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15919       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15920       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15921 !-------FIRST METHOD
15922       real(kind=8) :: xm
15923       real(kind=8),dimension(1:3) :: d_xm
15924 !-------END FIRST METHOD
15925 !-------SECOND METHOD
15926 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15927 !-------END SECOND METHOD
15928
15929 !-------TESTING CODE
15930 !el      logical :: checkstop,transgrad
15931 !el      common /sschecks/ checkstop,transgrad
15932
15933       integer :: icheck,nicheck,jcheck,njcheck
15934       real(kind=8),dimension(-1:1) :: echeck
15935       real(kind=8) :: deps,ssx0,ljx0
15936 !-------END TESTING CODE
15937
15938       eij=0.0d0
15939       i=resi
15940       j=resj
15941
15942 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15943 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15944
15945       itypi=itype(i)
15946       dxi=dc_norm(1,nres+i)
15947       dyi=dc_norm(2,nres+i)
15948       dzi=dc_norm(3,nres+i)
15949       dsci_inv=vbld_inv(i+nres)
15950
15951       itypj=itype(j)
15952       xj=c(1,nres+j)-c(1,nres+i)
15953       yj=c(2,nres+j)-c(2,nres+i)
15954       zj=c(3,nres+j)-c(3,nres+i)
15955       dxj=dc_norm(1,nres+j)
15956       dyj=dc_norm(2,nres+j)
15957       dzj=dc_norm(3,nres+j)
15958       dscj_inv=vbld_inv(j+nres)
15959
15960       chi1=chi(itypi,itypj)
15961       chi2=chi(itypj,itypi)
15962       chi12=chi1*chi2
15963       chip1=chip(itypi)
15964       chip2=chip(itypj)
15965       chip12=chip1*chip2
15966       alf1=alp(itypi)
15967       alf2=alp(itypj)
15968       alf12=0.5D0*(alf1+alf2)
15969
15970       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15971       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
15972 !     The following are set in sc_angular
15973 !      erij(1)=xj*rij
15974 !      erij(2)=yj*rij
15975 !      erij(3)=zj*rij
15976 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
15977 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
15978 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
15979       call sc_angular
15980       rij=1.0D0/rij  ! Reset this so it makes sense
15981
15982       sig0ij=sigma(itypi,itypj)
15983       sig=sig0ij*dsqrt(1.0D0/sigsq)
15984
15985       ljXs=sig-sig0ij
15986       ljA=eps1*eps2rt**2*eps3rt**2
15987       ljB=ljA*bb(itypi,itypj)
15988       ljA=ljA*aa(itypi,itypj)
15989       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15990
15991       ssXs=d0cm
15992       deltat1=1.0d0-om1
15993       deltat2=1.0d0+om2
15994       deltat12=om2-om1+2.0d0
15995       cosphi=om12-om1*om2
15996       ssA=akcm
15997       ssB=akct*deltat12
15998       ssC=ss_depth &
15999            +akth*(deltat1*deltat1+deltat2*deltat2) &
16000            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
16001       ssxm=ssXs-0.5D0*ssB/ssA
16002
16003 !-------TESTING CODE
16004 !$$$c     Some extra output
16005 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
16006 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16007 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
16008 !$$$      if (ssx0.gt.0.0d0) then
16009 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
16010 !$$$      else
16011 !$$$        ssx0=ssxm
16012 !$$$      endif
16013 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
16014 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
16015 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
16016 !$$$      return
16017 !-------END TESTING CODE
16018
16019 !-------TESTING CODE
16020 !     Stop and plot energy and derivative as a function of distance
16021       if (checkstop) then
16022         ssm=ssC-0.25D0*ssB*ssB/ssA
16023         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16024         if (ssm.lt.ljm .and. &
16025              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
16026           nicheck=1000
16027           njcheck=1
16028           deps=0.5d-7
16029         else
16030           checkstop=.false.
16031         endif
16032       endif
16033       if (.not.checkstop) then
16034         nicheck=0
16035         njcheck=-1
16036       endif
16037
16038       do icheck=0,nicheck
16039       do jcheck=-1,njcheck
16040       if (checkstop) rij=(ssxm-1.0d0)+ &
16041              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
16042 !-------END TESTING CODE
16043
16044       if (rij.gt.ljxm) then
16045         havebond=.false.
16046         ljd=rij-ljXs
16047         fac=(1.0D0/ljd)**expon
16048         e1=fac*fac*aa(itypi,itypj)
16049         e2=fac*bb(itypi,itypj)
16050         eij=eps1*eps2rt*eps3rt*(e1+e2)
16051         eps2der=eij*eps3rt
16052         eps3der=eij*eps2rt
16053         eij=eij*eps2rt*eps3rt
16054
16055         sigder=-sig/sigsq
16056         e1=e1*eps1*eps2rt**2*eps3rt**2
16057         ed=-expon*(e1+eij)/ljd
16058         sigder=ed*sigder
16059         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16060         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16061         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
16062              -2.0D0*alf12*eps3der+sigder*sigsq_om12
16063       else if (rij.lt.ssxm) then
16064         havebond=.true.
16065         ssd=rij-ssXs
16066         eij=ssA*ssd*ssd+ssB*ssd+ssC
16067
16068         ed=2*akcm*ssd+akct*deltat12
16069         pom1=akct*ssd
16070         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
16071         eom1=-2*akth*deltat1-pom1-om2*pom2
16072         eom2= 2*akth*deltat2+pom1-om1*pom2
16073         eom12=pom2
16074       else
16075         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
16076
16077         d_ssxm(1)=0.5D0*akct/ssA
16078         d_ssxm(2)=-d_ssxm(1)
16079         d_ssxm(3)=0.0D0
16080
16081         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
16082         d_ljxm(2)=d_ljxm(1)*sigsq_om2
16083         d_ljxm(3)=d_ljxm(1)*sigsq_om12
16084         d_ljxm(1)=d_ljxm(1)*sigsq_om1
16085
16086 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16087         xm=0.5d0*(ssxm+ljxm)
16088         do k=1,3
16089           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
16090         enddo
16091         if (rij.lt.xm) then
16092           havebond=.true.
16093           ssm=ssC-0.25D0*ssB*ssB/ssA
16094           d_ssm(1)=0.5D0*akct*ssB/ssA
16095           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16096           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16097           d_ssm(3)=omega
16098           f1=(rij-xm)/(ssxm-xm)
16099           f2=(rij-ssxm)/(xm-ssxm)
16100           h1=h_base(f1,hd1)
16101           h2=h_base(f2,hd2)
16102           eij=ssm*h1+Ht*h2
16103           delta_inv=1.0d0/(xm-ssxm)
16104           deltasq_inv=delta_inv*delta_inv
16105           fac=ssm*hd1-Ht*hd2
16106           fac1=deltasq_inv*fac*(xm-rij)
16107           fac2=deltasq_inv*fac*(rij-ssxm)
16108           ed=delta_inv*(Ht*hd2-ssm*hd1)
16109           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
16110           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
16111           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
16112         else
16113           havebond=.false.
16114           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16115           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
16116           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
16117           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
16118                alf12/eps3rt)
16119           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
16120           f1=(rij-ljxm)/(xm-ljxm)
16121           f2=(rij-xm)/(ljxm-xm)
16122           h1=h_base(f1,hd1)
16123           h2=h_base(f2,hd2)
16124           eij=Ht*h1+ljm*h2
16125           delta_inv=1.0d0/(ljxm-xm)
16126           deltasq_inv=delta_inv*delta_inv
16127           fac=Ht*hd1-ljm*hd2
16128           fac1=deltasq_inv*fac*(ljxm-rij)
16129           fac2=deltasq_inv*fac*(rij-xm)
16130           ed=delta_inv*(ljm*hd2-Ht*hd1)
16131           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
16132           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
16133           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
16134         endif
16135 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16136
16137 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16138 !$$$        ssd=rij-ssXs
16139 !$$$        ljd=rij-ljXs
16140 !$$$        fac1=rij-ljxm
16141 !$$$        fac2=rij-ssxm
16142 !$$$
16143 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
16144 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
16145 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
16146 !$$$
16147 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
16148 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
16149 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16150 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16151 !$$$        d_ssm(3)=omega
16152 !$$$
16153 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
16154 !$$$        do k=1,3
16155 !$$$          d_ljm(k)=ljm*d_ljB(k)
16156 !$$$        enddo
16157 !$$$        ljm=ljm*ljB
16158 !$$$
16159 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
16160 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
16161 !$$$        d_ss(2)=akct*ssd
16162 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
16163 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
16164 !$$$        d_ss(3)=omega
16165 !$$$
16166 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
16167 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
16168 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
16169 !$$$        do k=1,3
16170 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
16171 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
16172 !$$$        enddo
16173 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
16174 !$$$
16175 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
16176 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
16177 !$$$        h1=h_base(f1,hd1)
16178 !$$$        h2=h_base(f2,hd2)
16179 !$$$        eij=ss*h1+ljf*h2
16180 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
16181 !$$$        deltasq_inv=delta_inv*delta_inv
16182 !$$$        fac=ljf*hd2-ss*hd1
16183 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
16184 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
16185 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
16186 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
16187 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
16188 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
16189 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
16190 !$$$
16191 !$$$        havebond=.false.
16192 !$$$        if (ed.gt.0.0d0) havebond=.true.
16193 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16194
16195       endif
16196
16197       if (havebond) then
16198 !#ifndef CLUST
16199 !#ifndef WHAM
16200 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
16201 !          write(iout,'(a15,f12.2,f8.1,2i5)')
16202 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
16203 !        endif
16204 !#endif
16205 !#endif
16206         dyn_ssbond_ij(i,j)=eij
16207       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
16208         dyn_ssbond_ij(i,j)=1.0d300
16209 !#ifndef CLUST
16210 !#ifndef WHAM
16211 !        write(iout,'(a15,f12.2,f8.1,2i5)')
16212 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
16213 !#endif
16214 !#endif
16215       endif
16216
16217 !-------TESTING CODE
16218 !el      if (checkstop) then
16219         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
16220              "CHECKSTOP",rij,eij,ed
16221         echeck(jcheck)=eij
16222 !el      endif
16223       enddo
16224       if (checkstop) then
16225         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
16226       endif
16227       enddo
16228       if (checkstop) then
16229         transgrad=.true.
16230         checkstop=.false.
16231       endif
16232 !-------END TESTING CODE
16233
16234       do k=1,3
16235         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
16236         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
16237       enddo
16238       do k=1,3
16239         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
16240       enddo
16241       do k=1,3
16242         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16243              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16244              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16245         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16246              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16247              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16248       enddo
16249 !grad      do k=i,j-1
16250 !grad        do l=1,3
16251 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
16252 !grad        enddo
16253 !grad      enddo
16254
16255       do l=1,3
16256         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16257         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16258       enddo
16259
16260       return
16261       end subroutine dyn_ssbond_ene
16262 !-----------------------------------------------------------------------------
16263       real(kind=8) function h_base(x,deriv)
16264 !     A smooth function going 0->1 in range [0,1]
16265 !     It should NOT be called outside range [0,1], it will not work there.
16266       implicit none
16267
16268 !     Input arguments
16269       real(kind=8) :: x
16270
16271 !     Output arguments
16272       real(kind=8) :: deriv
16273
16274 !     Local variables
16275       real(kind=8) :: xsq
16276
16277
16278 !     Two parabolas put together.  First derivative zero at extrema
16279 !$$$      if (x.lt.0.5D0) then
16280 !$$$        h_base=2.0D0*x*x
16281 !$$$        deriv=4.0D0*x
16282 !$$$      else
16283 !$$$        deriv=1.0D0-x
16284 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
16285 !$$$        deriv=4.0D0*deriv
16286 !$$$      endif
16287
16288 !     Third degree polynomial.  First derivative zero at extrema
16289       h_base=x*x*(3.0d0-2.0d0*x)
16290       deriv=6.0d0*x*(1.0d0-x)
16291
16292 !     Fifth degree polynomial.  First and second derivatives zero at extrema
16293 !$$$      xsq=x*x
16294 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
16295 !$$$      deriv=x-1.0d0
16296 !$$$      deriv=deriv*deriv
16297 !$$$      deriv=30.0d0*xsq*deriv
16298
16299       return
16300       end function h_base
16301 !-----------------------------------------------------------------------------
16302       subroutine dyn_set_nss
16303 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
16304 !      implicit none
16305       use MD_data, only: totT,t_bath
16306 !     Includes
16307 !      include 'DIMENSIONS'
16308 #ifdef MPI
16309       include "mpif.h"
16310 #endif
16311 !      include 'COMMON.SBRIDGE'
16312 !      include 'COMMON.CHAIN'
16313 !      include 'COMMON.IOUNITS'
16314 !      include 'COMMON.SETUP'
16315 !      include 'COMMON.MD'
16316 !     Local variables
16317       real(kind=8) :: emin
16318       integer :: i,j,imin,ierr
16319       integer :: diff,allnss,newnss
16320       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16321                 newihpb,newjhpb
16322       logical :: found
16323       integer,dimension(0:nfgtasks) :: i_newnss
16324       integer,dimension(0:nfgtasks) :: displ
16325       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16326       integer :: g_newnss
16327
16328       allnss=0
16329       do i=1,nres-1
16330         do j=i+1,nres
16331           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
16332             allnss=allnss+1
16333             allflag(allnss)=0
16334             allihpb(allnss)=i
16335             alljhpb(allnss)=j
16336           endif
16337         enddo
16338       enddo
16339
16340 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16341
16342  1    emin=1.0d300
16343       do i=1,allnss
16344         if (allflag(i).eq.0 .and. &
16345              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
16346           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
16347           imin=i
16348         endif
16349       enddo
16350       if (emin.lt.1.0d300) then
16351         allflag(imin)=1
16352         do i=1,allnss
16353           if (allflag(i).eq.0 .and. &
16354                (allihpb(i).eq.allihpb(imin) .or. &
16355                alljhpb(i).eq.allihpb(imin) .or. &
16356                allihpb(i).eq.alljhpb(imin) .or. &
16357                alljhpb(i).eq.alljhpb(imin))) then
16358             allflag(i)=-1
16359           endif
16360         enddo
16361         goto 1
16362       endif
16363
16364 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16365
16366       newnss=0
16367       do i=1,allnss
16368         if (allflag(i).eq.1) then
16369           newnss=newnss+1
16370           newihpb(newnss)=allihpb(i)
16371           newjhpb(newnss)=alljhpb(i)
16372         endif
16373       enddo
16374
16375 #ifdef MPI
16376       if (nfgtasks.gt.1)then
16377
16378         call MPI_Reduce(newnss,g_newnss,1,&
16379           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
16380         call MPI_Gather(newnss,1,MPI_INTEGER,&
16381                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
16382         displ(0)=0
16383         do i=1,nfgtasks-1,1
16384           displ(i)=i_newnss(i-1)+displ(i-1)
16385         enddo
16386         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
16387                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
16388                          king,FG_COMM,IERR)
16389         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
16390                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
16391                          king,FG_COMM,IERR)
16392         if(fg_rank.eq.0) then
16393 !         print *,'g_newnss',g_newnss
16394 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
16395 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
16396          newnss=g_newnss
16397          do i=1,newnss
16398           newihpb(i)=g_newihpb(i)
16399           newjhpb(i)=g_newjhpb(i)
16400          enddo
16401         endif
16402       endif
16403 #endif
16404
16405       diff=newnss-nss
16406
16407 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
16408
16409       do i=1,nss
16410         found=.false.
16411         do j=1,newnss
16412           if (idssb(i).eq.newihpb(j) .and. &
16413                jdssb(i).eq.newjhpb(j)) found=.true.
16414         enddo
16415 #ifndef CLUST
16416 #ifndef WHAM
16417         if (.not.found.and.fg_rank.eq.0) &
16418             write(iout,'(a15,f12.2,f8.1,2i5)') &
16419              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
16420 #endif
16421 #endif
16422       enddo
16423
16424       do i=1,newnss
16425         found=.false.
16426         do j=1,nss
16427           if (newihpb(i).eq.idssb(j) .and. &
16428                newjhpb(i).eq.jdssb(j)) found=.true.
16429         enddo
16430 #ifndef CLUST
16431 #ifndef WHAM
16432         if (.not.found.and.fg_rank.eq.0) &
16433             write(iout,'(a15,f12.2,f8.1,2i5)') &
16434              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
16435 #endif
16436 #endif
16437       enddo
16438
16439       nss=newnss
16440       do i=1,nss
16441         idssb(i)=newihpb(i)
16442         jdssb(i)=newjhpb(i)
16443       enddo
16444
16445       return
16446       end subroutine dyn_set_nss
16447 !-----------------------------------------------------------------------------
16448 #ifdef WHAM
16449       subroutine read_ssHist
16450 !      implicit none
16451 !      Includes
16452 !      include 'DIMENSIONS'
16453 !      include "DIMENSIONS.FREE"
16454 !      include 'COMMON.FREE'
16455 !     Local variables
16456       integer :: i,j
16457       character(len=80) :: controlcard
16458
16459       do i=1,dyn_nssHist
16460         call card_concat(controlcard,.true.)
16461         read(controlcard,*) &
16462              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
16463       enddo
16464
16465       return
16466       end subroutine read_ssHist
16467 #endif
16468 !-----------------------------------------------------------------------------
16469       integer function indmat(i,j)
16470 !el
16471 ! get the position of the jth ijth fragment of the chain coordinate system
16472 ! in the fromto array.
16473         integer :: i,j
16474
16475         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
16476       return
16477       end function indmat
16478 !-----------------------------------------------------------------------------
16479       real(kind=8) function sigm(x)
16480 !el
16481        real(kind=8) :: x
16482         sigm=0.25d0*x
16483       return
16484       end function sigm
16485 !-----------------------------------------------------------------------------
16486 !-----------------------------------------------------------------------------
16487       subroutine alloc_ener_arrays
16488 !EL Allocation of arrays used by module energy
16489       use MD_data, only: mset
16490 !el local variables
16491       integer :: i,j
16492
16493       if(nres.lt.100) then
16494         maxconts=nres
16495       elseif(nres.lt.200) then
16496         maxconts=0.8*nres       ! Max. number of contacts per residue
16497       else
16498         maxconts=0.6*nres ! (maxconts=maxres/4)
16499       endif
16500       maxcont=12*nres   ! Max. number of SC contacts
16501       maxvar=6*nres     ! Max. number of variables
16502 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16503       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16504 !----------------------
16505 ! arrays in subroutine init_int_table
16506 !el#ifdef MPI
16507 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
16508 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
16509 !el#endif
16510       allocate(nint_gr(nres))
16511       allocate(nscp_gr(nres))
16512       allocate(ielstart(nres))
16513       allocate(ielend(nres))
16514 !(maxres)
16515       allocate(istart(nres,maxint_gr))
16516       allocate(iend(nres,maxint_gr))
16517 !(maxres,maxint_gr)
16518       allocate(iscpstart(nres,maxint_gr))
16519       allocate(iscpend(nres,maxint_gr))
16520 !(maxres,maxint_gr)
16521       allocate(ielstart_vdw(nres))
16522       allocate(ielend_vdw(nres))
16523 !(maxres)
16524
16525       allocate(lentyp(0:nfgtasks-1))
16526 !(0:maxprocs-1)
16527 !----------------------
16528 ! commom.contacts
16529 !      common /contacts/
16530       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
16531       allocate(icont(2,maxcont))
16532 !(2,maxcont)
16533 !      common /contacts1/
16534       allocate(num_cont(0:nres+4))
16535 !(maxres)
16536       allocate(jcont(maxconts,nres))
16537 !(maxconts,maxres)
16538       allocate(facont(maxconts,nres))
16539 !(maxconts,maxres)
16540       allocate(gacont(3,maxconts,nres))
16541 !(3,maxconts,maxres)
16542 !      common /contacts_hb/
16543       allocate(gacontp_hb1(3,maxconts,nres))
16544       allocate(gacontp_hb2(3,maxconts,nres))
16545       allocate(gacontp_hb3(3,maxconts,nres))
16546       allocate(gacontm_hb1(3,maxconts,nres))
16547       allocate(gacontm_hb2(3,maxconts,nres))
16548       allocate(gacontm_hb3(3,maxconts,nres))
16549       allocate(gacont_hbr(3,maxconts,nres))
16550       allocate(grij_hb_cont(3,maxconts,nres))
16551 !(3,maxconts,maxres)
16552       allocate(facont_hb(maxconts,nres))
16553       allocate(ees0p(maxconts,nres))
16554       allocate(ees0m(maxconts,nres))
16555       allocate(d_cont(maxconts,nres))
16556 !(maxconts,maxres)
16557       allocate(num_cont_hb(nres))
16558 !(maxres)
16559       allocate(jcont_hb(maxconts,nres))
16560 !(maxconts,maxres)
16561 !      common /rotat/
16562       allocate(Ug(2,2,nres))
16563       allocate(Ugder(2,2,nres))
16564       allocate(Ug2(2,2,nres))
16565       allocate(Ug2der(2,2,nres))
16566 !(2,2,maxres)
16567       allocate(obrot(2,nres))
16568       allocate(obrot2(2,nres))
16569       allocate(obrot_der(2,nres))
16570       allocate(obrot2_der(2,nres))
16571 !(2,maxres)
16572 !      common /precomp1/
16573       allocate(mu(2,nres))
16574       allocate(muder(2,nres))
16575       allocate(Ub2(2,nres))
16576       Ub2(1,:)=0.0d0
16577       Ub2(2,:)=0.0d0
16578       allocate(Ub2der(2,nres))
16579       allocate(Ctobr(2,nres))
16580       allocate(Ctobrder(2,nres))
16581       allocate(Dtobr2(2,nres))
16582       allocate(Dtobr2der(2,nres))
16583 !(2,maxres)
16584       allocate(EUg(2,2,nres))
16585       allocate(EUgder(2,2,nres))
16586       allocate(CUg(2,2,nres))
16587       allocate(CUgder(2,2,nres))
16588       allocate(DUg(2,2,nres))
16589       allocate(Dugder(2,2,nres))
16590       allocate(DtUg2(2,2,nres))
16591       allocate(DtUg2der(2,2,nres))
16592 !(2,2,maxres)
16593 !      common /precomp2/
16594       allocate(Ug2Db1t(2,nres))
16595       allocate(Ug2Db1tder(2,nres))
16596       allocate(CUgb2(2,nres))
16597       allocate(CUgb2der(2,nres))
16598 !(2,maxres)
16599       allocate(EUgC(2,2,nres))
16600       allocate(EUgCder(2,2,nres))
16601       allocate(EUgD(2,2,nres))
16602       allocate(EUgDder(2,2,nres))
16603       allocate(DtUg2EUg(2,2,nres))
16604       allocate(Ug2DtEUg(2,2,nres))
16605 !(2,2,maxres)
16606       allocate(Ug2DtEUgder(2,2,2,nres))
16607       allocate(DtUg2EUgder(2,2,2,nres))
16608 !(2,2,2,maxres)
16609 !      common /rotat_old/
16610       allocate(costab(nres))
16611       allocate(sintab(nres))
16612       allocate(costab2(nres))
16613       allocate(sintab2(nres))
16614 !(maxres)
16615 !      common /dipmat/
16616       allocate(a_chuj(2,2,maxconts,nres))
16617 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16618       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16619 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16620 !      common /contdistrib/
16621       allocate(ncont_sent(nres))
16622       allocate(ncont_recv(nres))
16623
16624       allocate(iat_sent(nres))
16625 !(maxres)
16626       allocate(iint_sent(4,nres,nres))
16627       allocate(iint_sent_local(4,nres,nres))
16628 !(4,maxres,maxres)
16629       allocate(iturn3_sent(4,0:nres+4))
16630       allocate(iturn4_sent(4,0:nres+4))
16631       allocate(iturn3_sent_local(4,nres))
16632       allocate(iturn4_sent_local(4,nres))
16633 !(4,maxres)
16634       allocate(itask_cont_from(0:nfgtasks-1))
16635       allocate(itask_cont_to(0:nfgtasks-1))
16636 !(0:max_fg_procs-1)
16637
16638
16639
16640 !----------------------
16641 ! commom.deriv;
16642 !      common /derivat/
16643       allocate(dcdv(6,maxdim))
16644       allocate(dxdv(6,maxdim))
16645 !(6,maxdim)
16646       allocate(dxds(6,nres))
16647 !(6,maxres)
16648       allocate(gradx(3,nres,0:2))
16649       allocate(gradc(3,nres,0:2))
16650 !(3,maxres,2)
16651       allocate(gvdwx(3,nres))
16652       allocate(gvdwc(3,nres))
16653       allocate(gelc(3,nres))
16654       allocate(gelc_long(3,nres))
16655       allocate(gvdwpp(3,nres))
16656       allocate(gvdwc_scpp(3,nres))
16657       allocate(gradx_scp(3,nres))
16658       allocate(gvdwc_scp(3,nres))
16659       allocate(ghpbx(3,nres))
16660       allocate(ghpbc(3,nres))
16661       allocate(gradcorr(3,nres))
16662       allocate(gradcorr_long(3,nres))
16663       allocate(gradcorr5_long(3,nres))
16664       allocate(gradcorr6_long(3,nres))
16665       allocate(gcorr6_turn_long(3,nres))
16666       allocate(gradxorr(3,nres))
16667       allocate(gradcorr5(3,nres))
16668       allocate(gradcorr6(3,nres))
16669 !(3,maxres)
16670       allocate(gloc(0:maxvar,0:2))
16671       allocate(gloc_x(0:maxvar,2))
16672 !(maxvar,2)
16673       allocate(gel_loc(3,nres))
16674       allocate(gel_loc_long(3,nres))
16675       allocate(gcorr3_turn(3,nres))
16676       allocate(gcorr4_turn(3,nres))
16677       allocate(gcorr6_turn(3,nres))
16678       allocate(gradb(3,nres))
16679       allocate(gradbx(3,nres))
16680 !(3,maxres)
16681       allocate(gel_loc_loc(maxvar))
16682       allocate(gel_loc_turn3(maxvar))
16683       allocate(gel_loc_turn4(maxvar))
16684       allocate(gel_loc_turn6(maxvar))
16685       allocate(gcorr_loc(maxvar))
16686       allocate(g_corr5_loc(maxvar))
16687       allocate(g_corr6_loc(maxvar))
16688 !(maxvar)
16689       allocate(gsccorc(3,nres))
16690       allocate(gsccorx(3,nres))
16691 !(3,maxres)
16692       allocate(gsccor_loc(nres))
16693 !(maxres)
16694       allocate(dtheta(3,2,nres))
16695 !(3,2,maxres)
16696       allocate(gscloc(3,nres))
16697       allocate(gsclocx(3,nres))
16698 !(3,maxres)
16699       allocate(dphi(3,3,nres))
16700       allocate(dalpha(3,3,nres))
16701       allocate(domega(3,3,nres))
16702 !(3,3,maxres)
16703 !      common /deriv_scloc/
16704       allocate(dXX_C1tab(3,nres))
16705       allocate(dYY_C1tab(3,nres))
16706       allocate(dZZ_C1tab(3,nres))
16707       allocate(dXX_Ctab(3,nres))
16708       allocate(dYY_Ctab(3,nres))
16709       allocate(dZZ_Ctab(3,nres))
16710       allocate(dXX_XYZtab(3,nres))
16711       allocate(dYY_XYZtab(3,nres))
16712       allocate(dZZ_XYZtab(3,nres))
16713 !(3,maxres)
16714 !      common /mpgrad/
16715       allocate(jgrad_start(nres))
16716       allocate(jgrad_end(nres))
16717 !(maxres)
16718 !----------------------
16719
16720 !      common /indices/
16721       allocate(ibond_displ(0:nfgtasks-1))
16722       allocate(ibond_count(0:nfgtasks-1))
16723       allocate(ithet_displ(0:nfgtasks-1))
16724       allocate(ithet_count(0:nfgtasks-1))
16725       allocate(iphi_displ(0:nfgtasks-1))
16726       allocate(iphi_count(0:nfgtasks-1))
16727       allocate(iphi1_displ(0:nfgtasks-1))
16728       allocate(iphi1_count(0:nfgtasks-1))
16729       allocate(ivec_displ(0:nfgtasks-1))
16730       allocate(ivec_count(0:nfgtasks-1))
16731       allocate(iset_displ(0:nfgtasks-1))
16732       allocate(iset_count(0:nfgtasks-1))
16733       allocate(iint_count(0:nfgtasks-1))
16734       allocate(iint_displ(0:nfgtasks-1))
16735 !(0:max_fg_procs-1)
16736 !----------------------
16737 ! common.MD
16738 !      common /mdgrad/
16739       allocate(gcart(3,0:nres))
16740       allocate(gxcart(3,0:nres))
16741 !(3,0:MAXRES)
16742       allocate(gradcag(3,nres))
16743       allocate(gradxag(3,nres))
16744 !(3,MAXRES)
16745 !      common /back_constr/
16746 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16747       allocate(dutheta(nres))
16748       allocate(dugamma(nres))
16749 !(maxres)
16750       allocate(duscdiff(3,nres))
16751       allocate(duscdiffx(3,nres))
16752 !(3,maxres)
16753 !el i io:read_fragments
16754 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16755 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16756 !      common /qmeas/
16757 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16758 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16759       allocate(mset(0:nprocs))  !(maxprocs/20)
16760       mset(:)=0
16761 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16762 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16763       allocate(dUdconst(3,0:nres))
16764       allocate(dUdxconst(3,0:nres))
16765       allocate(dqwol(3,0:nres))
16766       allocate(dxqwol(3,0:nres))
16767 !(3,0:MAXRES)
16768 !----------------------
16769 ! common.sbridge
16770 !      common /sbridge/ in io_common: read_bridge
16771 !el    allocate((:),allocatable :: iss  !(maxss)
16772 !      common /links/  in io_common: read_bridge
16773 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16774 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16775 !      common /dyn_ssbond/
16776 ! and side-chain vectors in theta or phi.
16777       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16778 !(maxres,maxres)
16779 !      do i=1,nres
16780 !        do j=i+1,nres
16781       dyn_ssbond_ij(:,:)=1.0d300
16782 !        enddo
16783 !      enddo
16784
16785       if (nss.gt.0) then
16786         allocate(idssb(nss),jdssb(nss))
16787 !(maxdim)
16788       endif
16789       allocate(dyn_ss_mask(nres))
16790 !(maxres)
16791       dyn_ss_mask(:)=.false.
16792 !----------------------
16793 ! common.sccor
16794 ! Parameters of the SCCOR term
16795 !      common/sccor/
16796 !el in io_conf: parmread
16797 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16798 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16799 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16800 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16801 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16802 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16803 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16804 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16805 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16806 !----------------
16807       allocate(gloc_sc(3,0:2*nres,0:10))
16808 !(3,0:maxres2,10)maxres2=2*maxres
16809       allocate(dcostau(3,3,3,2*nres))
16810       allocate(dsintau(3,3,3,2*nres))
16811       allocate(dtauangle(3,3,3,2*nres))
16812       allocate(dcosomicron(3,3,3,2*nres))
16813       allocate(domicron(3,3,3,2*nres))
16814 !(3,3,3,maxres2)maxres2=2*maxres
16815 !----------------------
16816 ! common.var
16817 !      common /restr/
16818       allocate(varall(maxvar))
16819 !(maxvar)(maxvar=6*maxres)
16820       allocate(mask_theta(nres))
16821       allocate(mask_phi(nres))
16822       allocate(mask_side(nres))
16823 !(maxres)
16824 !----------------------
16825 ! common.vectors
16826 !      common /vectors/
16827       allocate(uy(3,nres))
16828       allocate(uz(3,nres))
16829 !(3,maxres)
16830       allocate(uygrad(3,3,2,nres))
16831       allocate(uzgrad(3,3,2,nres))
16832 !(3,3,2,maxres)
16833
16834       return
16835       end subroutine alloc_ener_arrays
16836 !-----------------------------------------------------------------------------
16837 !-----------------------------------------------------------------------------
16838       end module energy