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         num_conti=0
2695         call eelecij(i,i+2,ees,evdw1,eel_loc)
2696         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2697         num_cont_hb(i)=num_conti
2698       enddo
2699       do i=iturn4_start,iturn4_end
2700         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2701           .or. itype(i+3).eq.ntyp1 &
2702           .or. itype(i+4).eq.ntyp1) cycle
2703         dxi=dc(1,i)
2704         dyi=dc(2,i)
2705         dzi=dc(3,i)
2706         dx_normi=dc_norm(1,i)
2707         dy_normi=dc_norm(2,i)
2708         dz_normi=dc_norm(3,i)
2709         xmedi=c(1,i)+0.5d0*dxi
2710         ymedi=c(2,i)+0.5d0*dyi
2711         zmedi=c(3,i)+0.5d0*dzi
2712         num_conti=num_cont_hb(i)
2713         call eelecij(i,i+3,ees,evdw1,eel_loc)
2714         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2715          call eturn4(i,eello_turn4)
2716         num_cont_hb(i)=num_conti
2717       enddo   ! i
2718 !
2719 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2720 !
2721       do i=iatel_s,iatel_e
2722         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2723         dxi=dc(1,i)
2724         dyi=dc(2,i)
2725         dzi=dc(3,i)
2726         dx_normi=dc_norm(1,i)
2727         dy_normi=dc_norm(2,i)
2728         dz_normi=dc_norm(3,i)
2729         xmedi=c(1,i)+0.5d0*dxi
2730         ymedi=c(2,i)+0.5d0*dyi
2731         zmedi=c(3,i)+0.5d0*dzi
2732 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2733         num_conti=num_cont_hb(i)
2734         do j=ielstart(i),ielend(i)
2735 !          write (iout,*) i,j,itype(i),itype(j)
2736           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2737           call eelecij(i,j,ees,evdw1,eel_loc)
2738         enddo ! j
2739         num_cont_hb(i)=num_conti
2740       enddo   ! i
2741 !      write (iout,*) "Number of loop steps in EELEC:",ind
2742 !d      do i=1,nres
2743 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2744 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2745 !d      enddo
2746 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2747 !cc      eel_loc=eel_loc+eello_turn3
2748 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2749       return
2750       end subroutine eelec
2751 !-----------------------------------------------------------------------------
2752       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2753
2754       use comm_locel
2755 !      implicit real*8 (a-h,o-z)
2756 !      include 'DIMENSIONS'
2757 #ifdef MPI
2758       include "mpif.h"
2759 #endif
2760 !      include 'COMMON.CONTROL'
2761 !      include 'COMMON.IOUNITS'
2762 !      include 'COMMON.GEO'
2763 !      include 'COMMON.VAR'
2764 !      include 'COMMON.LOCAL'
2765 !      include 'COMMON.CHAIN'
2766 !      include 'COMMON.DERIV'
2767 !      include 'COMMON.INTERACT'
2768 !      include 'COMMON.CONTACTS'
2769 !      include 'COMMON.TORSION'
2770 !      include 'COMMON.VECTORS'
2771 !      include 'COMMON.FFIELD'
2772 !      include 'COMMON.TIME1'
2773       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2774       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2775       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2776 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2777       real(kind=8),dimension(4) :: muij
2778 !el      integer :: num_conti,j1,j2
2779 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2780 !el        dz_normi,xmedi,ymedi,zmedi
2781
2782 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2783 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2784 !el          num_conti,j1,j2
2785
2786 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2787 #ifdef MOMENT
2788       real(kind=8) :: scal_el=1.0d0
2789 #else
2790       real(kind=8) :: scal_el=0.5d0
2791 #endif
2792 ! 12/13/98
2793 ! 13-go grudnia roku pamietnego...
2794       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2795                                              0.0d0,1.0d0,0.0d0,&
2796                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2797 !      integer :: maxconts=nres/4
2798 !el local variables
2799       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m
2800       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
2801       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
2802       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
2803                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
2804                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
2805                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
2806                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
2807                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
2808                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
2809                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
2810 !      maxconts=nres/4
2811 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
2812 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
2813
2814 !          time00=MPI_Wtime()
2815 !d      write (iout,*) "eelecij",i,j
2816 !          ind=ind+1
2817           iteli=itel(i)
2818           itelj=itel(j)
2819           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2820           aaa=app(iteli,itelj)
2821           bbb=bpp(iteli,itelj)
2822           ael6i=ael6(iteli,itelj)
2823           ael3i=ael3(iteli,itelj)
2824           dxj=dc(1,j)
2825           dyj=dc(2,j)
2826           dzj=dc(3,j)
2827           dx_normj=dc_norm(1,j)
2828           dy_normj=dc_norm(2,j)
2829           dz_normj=dc_norm(3,j)
2830           xj=c(1,j)+0.5D0*dxj-xmedi
2831           yj=c(2,j)+0.5D0*dyj-ymedi
2832           zj=c(3,j)+0.5D0*dzj-zmedi
2833           rij=xj*xj+yj*yj+zj*zj
2834           rrmij=1.0D0/rij
2835           rij=dsqrt(rij)
2836           rmij=1.0D0/rij
2837           r3ij=rrmij*rmij
2838           r6ij=r3ij*r3ij
2839           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2840           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2841           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2842           fac=cosa-3.0D0*cosb*cosg
2843           ev1=aaa*r6ij*r6ij
2844 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2845           if (j.eq.i+2) ev1=scal_el*ev1
2846           ev2=bbb*r6ij
2847           fac3=ael6i*r6ij
2848           fac4=ael3i*r3ij
2849           evdwij=ev1+ev2
2850           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2851           el2=fac4*fac
2852           eesij=el1+el2
2853 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
2854           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2855           ees=ees+eesij
2856           evdw1=evdw1+evdwij
2857 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2858 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2859 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2860 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
2861
2862           if (energy_dec) then
2863 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
2864 !                  'evdw1',i,j,evdwij,&
2865 !                  iteli,itelj,aaa,evdw1
2866               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2867               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2868           endif
2869 !
2870 ! Calculate contributions to the Cartesian gradient.
2871 !
2872 #ifdef SPLITELE
2873           facvdw=-6*rrmij*(ev1+evdwij)
2874           facel=-3*rrmij*(el1+eesij)
2875           fac1=fac
2876           erij(1)=xj*rmij
2877           erij(2)=yj*rmij
2878           erij(3)=zj*rmij
2879 !
2880 ! Radial derivatives. First process both termini of the fragment (i,j)
2881 !
2882           ggg(1)=facel*xj
2883           ggg(2)=facel*yj
2884           ggg(3)=facel*zj
2885 !          do k=1,3
2886 !            ghalf=0.5D0*ggg(k)
2887 !            gelc(k,i)=gelc(k,i)+ghalf
2888 !            gelc(k,j)=gelc(k,j)+ghalf
2889 !          enddo
2890 ! 9/28/08 AL Gradient compotents will be summed only at the end
2891           do k=1,3
2892             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2893             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2894           enddo
2895 !
2896 ! Loop over residues i+1 thru j-1.
2897 !
2898 !grad          do k=i+1,j-1
2899 !grad            do l=1,3
2900 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2901 !grad            enddo
2902 !grad          enddo
2903           ggg(1)=facvdw*xj
2904           ggg(2)=facvdw*yj
2905           ggg(3)=facvdw*zj
2906 !          do k=1,3
2907 !            ghalf=0.5D0*ggg(k)
2908 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2909 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2910 !          enddo
2911 ! 9/28/08 AL Gradient compotents will be summed only at the end
2912           do k=1,3
2913             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2914             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2915           enddo
2916 !
2917 ! Loop over residues i+1 thru j-1.
2918 !
2919 !grad          do k=i+1,j-1
2920 !grad            do l=1,3
2921 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2922 !grad            enddo
2923 !grad          enddo
2924 #else
2925           facvdw=ev1+evdwij
2926           facel=el1+eesij
2927           fac1=fac
2928           fac=-3*rrmij*(facvdw+facvdw+facel)
2929           erij(1)=xj*rmij
2930           erij(2)=yj*rmij
2931           erij(3)=zj*rmij
2932 !
2933 ! Radial derivatives. First process both termini of the fragment (i,j)
2934 !
2935           ggg(1)=fac*xj
2936           ggg(2)=fac*yj
2937           ggg(3)=fac*zj
2938 !          do k=1,3
2939 !            ghalf=0.5D0*ggg(k)
2940 !            gelc(k,i)=gelc(k,i)+ghalf
2941 !            gelc(k,j)=gelc(k,j)+ghalf
2942 !          enddo
2943 ! 9/28/08 AL Gradient compotents will be summed only at the end
2944           do k=1,3
2945             gelc_long(k,j)=gelc(k,j)+ggg(k)
2946             gelc_long(k,i)=gelc(k,i)-ggg(k)
2947           enddo
2948 !
2949 ! Loop over residues i+1 thru j-1.
2950 !
2951 !grad          do k=i+1,j-1
2952 !grad            do l=1,3
2953 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2954 !grad            enddo
2955 !grad          enddo
2956 ! 9/28/08 AL Gradient compotents will be summed only at the end
2957           ggg(1)=facvdw*xj
2958           ggg(2)=facvdw*yj
2959           ggg(3)=facvdw*zj
2960           do k=1,3
2961             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2962             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2963           enddo
2964 #endif
2965 !
2966 ! Angular part
2967 !
2968           ecosa=2.0D0*fac3*fac1+fac4
2969           fac4=-3.0D0*fac4
2970           fac3=-6.0D0*fac3
2971           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2972           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2973           do k=1,3
2974             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2975             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2976           enddo
2977 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2978 !d   &          (dcosg(k),k=1,3)
2979           do k=1,3
2980             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2981           enddo
2982 !          do k=1,3
2983 !            ghalf=0.5D0*ggg(k)
2984 !            gelc(k,i)=gelc(k,i)+ghalf
2985 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2986 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2987 !            gelc(k,j)=gelc(k,j)+ghalf
2988 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2989 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2990 !          enddo
2991 !grad          do k=i+1,j-1
2992 !grad            do l=1,3
2993 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2994 !grad            enddo
2995 !grad          enddo
2996           do k=1,3
2997             gelc(k,i)=gelc(k,i) &
2998                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
2999                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3000             gelc(k,j)=gelc(k,j) &
3001                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3002                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3003             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3004             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3005           enddo
3006           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3007               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3008               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3009 !
3010 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3011 !   energy of a peptide unit is assumed in the form of a second-order
3012 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3013 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3014 !   are computed for EVERY pair of non-contiguous peptide groups.
3015 !
3016           if (j.lt.nres-1) then
3017             j1=j+1
3018             j2=j-1
3019           else
3020             j1=j-1
3021             j2=j-2
3022           endif
3023           kkk=0
3024           do k=1,2
3025             do l=1,2
3026               kkk=kkk+1
3027               muij(kkk)=mu(k,i)*mu(l,j)
3028             enddo
3029           enddo
3030 !d         write (iout,*) 'EELEC: i',i,' j',j
3031 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3032 !d          write(iout,*) 'muij',muij
3033           ury=scalar(uy(1,i),erij)
3034           urz=scalar(uz(1,i),erij)
3035           vry=scalar(uy(1,j),erij)
3036           vrz=scalar(uz(1,j),erij)
3037           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3038           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3039           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3040           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3041           fac=dsqrt(-ael6i)*r3ij
3042           a22=a22*fac
3043           a23=a23*fac
3044           a32=a32*fac
3045           a33=a33*fac
3046 !d          write (iout,'(4i5,4f10.5)')
3047 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3048 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3049 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3050 !d     &      uy(:,j),uz(:,j)
3051 !d          write (iout,'(4f10.5)')
3052 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3053 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3054 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3055 !d           write (iout,'(9f10.5/)')
3056 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3057 ! Derivatives of the elements of A in virtual-bond vectors
3058           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3059           do k=1,3
3060             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3061             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3062             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3063             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3064             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3065             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3066             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3067             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3068             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3069             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3070             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3071             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3072           enddo
3073 ! Compute radial contributions to the gradient
3074           facr=-3.0d0*rrmij
3075           a22der=a22*facr
3076           a23der=a23*facr
3077           a32der=a32*facr
3078           a33der=a33*facr
3079           agg(1,1)=a22der*xj
3080           agg(2,1)=a22der*yj
3081           agg(3,1)=a22der*zj
3082           agg(1,2)=a23der*xj
3083           agg(2,2)=a23der*yj
3084           agg(3,2)=a23der*zj
3085           agg(1,3)=a32der*xj
3086           agg(2,3)=a32der*yj
3087           agg(3,3)=a32der*zj
3088           agg(1,4)=a33der*xj
3089           agg(2,4)=a33der*yj
3090           agg(3,4)=a33der*zj
3091 ! Add the contributions coming from er
3092           fac3=-3.0d0*fac
3093           do k=1,3
3094             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3095             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3096             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3097             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3098           enddo
3099           do k=1,3
3100 ! Derivatives in DC(i)
3101 !grad            ghalf1=0.5d0*agg(k,1)
3102 !grad            ghalf2=0.5d0*agg(k,2)
3103 !grad            ghalf3=0.5d0*agg(k,3)
3104 !grad            ghalf4=0.5d0*agg(k,4)
3105             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3106             -3.0d0*uryg(k,2)*vry)!+ghalf1
3107             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3108             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3109             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3110             -3.0d0*urzg(k,2)*vry)!+ghalf3
3111             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3112             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3113 ! Derivatives in DC(i+1)
3114             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3115             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3116             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3117             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3118             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3119             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3120             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3121             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3122 ! Derivatives in DC(j)
3123             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3124             -3.0d0*vryg(k,2)*ury)!+ghalf1
3125             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3126             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3127             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3128             -3.0d0*vryg(k,2)*urz)!+ghalf3
3129             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3130             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3131 ! Derivatives in DC(j+1) or DC(nres-1)
3132             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3133             -3.0d0*vryg(k,3)*ury)
3134             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3135             -3.0d0*vrzg(k,3)*ury)
3136             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3137             -3.0d0*vryg(k,3)*urz)
3138             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3139             -3.0d0*vrzg(k,3)*urz)
3140 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3141 !grad              do l=1,4
3142 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3143 !grad              enddo
3144 !grad            endif
3145           enddo
3146           acipa(1,1)=a22
3147           acipa(1,2)=a23
3148           acipa(2,1)=a32
3149           acipa(2,2)=a33
3150           a22=-a22
3151           a23=-a23
3152           do l=1,2
3153             do k=1,3
3154               agg(k,l)=-agg(k,l)
3155               aggi(k,l)=-aggi(k,l)
3156               aggi1(k,l)=-aggi1(k,l)
3157               aggj(k,l)=-aggj(k,l)
3158               aggj1(k,l)=-aggj1(k,l)
3159             enddo
3160           enddo
3161           if (j.lt.nres-1) then
3162             a22=-a22
3163             a32=-a32
3164             do l=1,3,2
3165               do k=1,3
3166                 agg(k,l)=-agg(k,l)
3167                 aggi(k,l)=-aggi(k,l)
3168                 aggi1(k,l)=-aggi1(k,l)
3169                 aggj(k,l)=-aggj(k,l)
3170                 aggj1(k,l)=-aggj1(k,l)
3171               enddo
3172             enddo
3173           else
3174             a22=-a22
3175             a23=-a23
3176             a32=-a32
3177             a33=-a33
3178             do l=1,4
3179               do k=1,3
3180                 agg(k,l)=-agg(k,l)
3181                 aggi(k,l)=-aggi(k,l)
3182                 aggi1(k,l)=-aggi1(k,l)
3183                 aggj(k,l)=-aggj(k,l)
3184                 aggj1(k,l)=-aggj1(k,l)
3185               enddo
3186             enddo
3187           endif
3188           ENDIF ! WCORR
3189           IF (wel_loc.gt.0.0d0) THEN
3190 ! Contribution to the local-electrostatic energy coming from the i-j pair
3191           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3192            +a33*muij(4)
3193 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3194
3195           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3196                   'eelloc',i,j,eel_loc_ij
3197 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3198 !          if (energy_dec) write (iout,*) "muij",muij
3199 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3200
3201           eel_loc=eel_loc+eel_loc_ij
3202 ! Partial derivatives in virtual-bond dihedral angles gamma
3203           if (i.gt.1) &
3204           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3205                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3206                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3207           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3208                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3209                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3210 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3211           do l=1,3
3212             ggg(l)=agg(l,1)*muij(1)+ &
3213                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3214             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3215             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3216 !grad            ghalf=0.5d0*ggg(l)
3217 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3218 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3219           enddo
3220 !grad          do k=i+1,j2
3221 !grad            do l=1,3
3222 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3223 !grad            enddo
3224 !grad          enddo
3225 ! Remaining derivatives of eello
3226           do l=1,3
3227             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
3228                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3229             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
3230                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3231             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
3232                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3233             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
3234                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3235           enddo
3236           ENDIF
3237 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3238 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3239           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3240              .and. num_conti.le.maxconts) then
3241 !            write (iout,*) i,j," entered corr"
3242 !
3243 ! Calculate the contact function. The ith column of the array JCONT will
3244 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3245 ! greater than I). The arrays FACONT and GACONT will contain the values of
3246 ! the contact function and its derivative.
3247 !           r0ij=1.02D0*rpp(iteli,itelj)
3248 !           r0ij=1.11D0*rpp(iteli,itelj)
3249             r0ij=2.20D0*rpp(iteli,itelj)
3250 !           r0ij=1.55D0*rpp(iteli,itelj)
3251             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3252 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3253             if (fcont.gt.0.0D0) then
3254               num_conti=num_conti+1
3255               if (num_conti.gt.maxconts) then
3256 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3257 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3258                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3259                                ' will skip next contacts for this conf.', num_conti
3260               else
3261                 jcont_hb(num_conti,i)=j
3262 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3263 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3264                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3265                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3266 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3267 !  terms.
3268                 d_cont(num_conti,i)=rij
3269 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3270 !     --- Electrostatic-interaction matrix ---
3271                 a_chuj(1,1,num_conti,i)=a22
3272                 a_chuj(1,2,num_conti,i)=a23
3273                 a_chuj(2,1,num_conti,i)=a32
3274                 a_chuj(2,2,num_conti,i)=a33
3275 !     --- Gradient of rij
3276                 do kkk=1,3
3277                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3278                 enddo
3279                 kkll=0
3280                 do k=1,2
3281                   do l=1,2
3282                     kkll=kkll+1
3283                     do m=1,3
3284                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3285                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3286                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3287                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3288                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3289                     enddo
3290                   enddo
3291                 enddo
3292                 ENDIF
3293                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3294 ! Calculate contact energies
3295                 cosa4=4.0D0*cosa
3296                 wij=cosa-3.0D0*cosb*cosg
3297                 cosbg1=cosb+cosg
3298                 cosbg2=cosb-cosg
3299 !               fac3=dsqrt(-ael6i)/r0ij**3
3300                 fac3=dsqrt(-ael6i)*r3ij
3301 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3302                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3303                 if (ees0tmp.gt.0) then
3304                   ees0pij=dsqrt(ees0tmp)
3305                 else
3306                   ees0pij=0
3307                 endif
3308 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3309                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3310                 if (ees0tmp.gt.0) then
3311                   ees0mij=dsqrt(ees0tmp)
3312                 else
3313                   ees0mij=0
3314                 endif
3315 !               ees0mij=0.0D0
3316                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3317                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3318 ! Diagnostics. Comment out or remove after debugging!
3319 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3320 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3321 !               ees0m(num_conti,i)=0.0D0
3322 ! End diagnostics.
3323 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3324 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3325 ! Angular derivatives of the contact function
3326                 ees0pij1=fac3/ees0pij
3327                 ees0mij1=fac3/ees0mij
3328                 fac3p=-3.0D0*fac3*rrmij
3329                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3330                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3331 !               ees0mij1=0.0D0
3332                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3333                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3334                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3335                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3336                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3337                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3338                 ecosap=ecosa1+ecosa2
3339                 ecosbp=ecosb1+ecosb2
3340                 ecosgp=ecosg1+ecosg2
3341                 ecosam=ecosa1-ecosa2
3342                 ecosbm=ecosb1-ecosb2
3343                 ecosgm=ecosg1-ecosg2
3344 ! Diagnostics
3345 !               ecosap=ecosa1
3346 !               ecosbp=ecosb1
3347 !               ecosgp=ecosg1
3348 !               ecosam=0.0D0
3349 !               ecosbm=0.0D0
3350 !               ecosgm=0.0D0
3351 ! End diagnostics
3352                 facont_hb(num_conti,i)=fcont
3353                 fprimcont=fprimcont/rij
3354 !d              facont_hb(num_conti,i)=1.0D0
3355 ! Following line is for diagnostics.
3356 !d              fprimcont=0.0D0
3357                 do k=1,3
3358                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3359                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3360                 enddo
3361                 do k=1,3
3362                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3363                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3364                 enddo
3365                 gggp(1)=gggp(1)+ees0pijp*xj
3366                 gggp(2)=gggp(2)+ees0pijp*yj
3367                 gggp(3)=gggp(3)+ees0pijp*zj
3368                 gggm(1)=gggm(1)+ees0mijp*xj
3369                 gggm(2)=gggm(2)+ees0mijp*yj
3370                 gggm(3)=gggm(3)+ees0mijp*zj
3371 ! Derivatives due to the contact function
3372                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3373                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3374                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3375                 do k=1,3
3376 !
3377 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3378 !          following the change of gradient-summation algorithm.
3379 !
3380 !grad                  ghalfp=0.5D0*gggp(k)
3381 !grad                  ghalfm=0.5D0*gggm(k)
3382                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3383                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3384                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3385                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3386                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3387                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3388                   gacontp_hb3(k,num_conti,i)=gggp(k)
3389                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3390                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3391                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3392                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3393                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3394                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3395                   gacontm_hb3(k,num_conti,i)=gggm(k)
3396                 enddo
3397 ! Diagnostics. Comment out or remove after debugging!
3398 !diag           do k=1,3
3399 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3400 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3401 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3402 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3403 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3404 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3405 !diag           enddo
3406               ENDIF ! wcorr
3407               endif  ! num_conti.le.maxconts
3408             endif  ! fcont.gt.0
3409           endif    ! j.gt.i+1
3410           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3411             do k=1,4
3412               do l=1,3
3413                 ghalf=0.5d0*agg(l,k)
3414                 aggi(l,k)=aggi(l,k)+ghalf
3415                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3416                 aggj(l,k)=aggj(l,k)+ghalf
3417               enddo
3418             enddo
3419             if (j.eq.nres-1 .and. i.lt.j-2) then
3420               do k=1,4
3421                 do l=1,3
3422                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3423                 enddo
3424               enddo
3425             endif
3426           endif
3427 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3428       return
3429       end subroutine eelecij
3430 !-----------------------------------------------------------------------------
3431       subroutine eturn3(i,eello_turn3)
3432 ! Third- and fourth-order contributions from turns
3433
3434       use comm_locel
3435 !      implicit real*8 (a-h,o-z)
3436 !      include 'DIMENSIONS'
3437 !      include 'COMMON.IOUNITS'
3438 !      include 'COMMON.GEO'
3439 !      include 'COMMON.VAR'
3440 !      include 'COMMON.LOCAL'
3441 !      include 'COMMON.CHAIN'
3442 !      include 'COMMON.DERIV'
3443 !      include 'COMMON.INTERACT'
3444 !      include 'COMMON.CONTACTS'
3445 !      include 'COMMON.TORSION'
3446 !      include 'COMMON.VECTORS'
3447 !      include 'COMMON.FFIELD'
3448 !      include 'COMMON.CONTROL'
3449       real(kind=8),dimension(3) :: ggg
3450       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3451         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3452       real(kind=8),dimension(2) :: auxvec,auxvec1
3453 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3454       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3455 !el      integer :: num_conti,j1,j2
3456 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3457 !el        dz_normi,xmedi,ymedi,zmedi
3458
3459 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3460 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3461 !el         num_conti,j1,j2
3462 !el local variables
3463       integer :: i,j,l
3464       real(kind=8) :: eello_turn3
3465
3466       j=i+2
3467 !      write (iout,*) "eturn3",i,j,j1,j2
3468       a_temp(1,1)=a22
3469       a_temp(1,2)=a23
3470       a_temp(2,1)=a32
3471       a_temp(2,2)=a33
3472 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3473 !
3474 !               Third-order contributions
3475 !
3476 !                 (i+2)o----(i+3)
3477 !                      | |
3478 !                      | |
3479 !                 (i+1)o----i
3480 !
3481 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3482 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3483         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3484         call transpose2(auxmat(1,1),auxmat1(1,1))
3485         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3486         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3487         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3488                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3489 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3490 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3491 !d     &    ' eello_turn3_num',4*eello_turn3_num
3492 ! Derivatives in gamma(i)
3493         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3494         call transpose2(auxmat2(1,1),auxmat3(1,1))
3495         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3496         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3497 ! Derivatives in gamma(i+1)
3498         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3499         call transpose2(auxmat2(1,1),auxmat3(1,1))
3500         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3501         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3502           +0.5d0*(pizda(1,1)+pizda(2,2))
3503 ! Cartesian derivatives
3504         do l=1,3
3505 !            ghalf1=0.5d0*agg(l,1)
3506 !            ghalf2=0.5d0*agg(l,2)
3507 !            ghalf3=0.5d0*agg(l,3)
3508 !            ghalf4=0.5d0*agg(l,4)
3509           a_temp(1,1)=aggi(l,1)!+ghalf1
3510           a_temp(1,2)=aggi(l,2)!+ghalf2
3511           a_temp(2,1)=aggi(l,3)!+ghalf3
3512           a_temp(2,2)=aggi(l,4)!+ghalf4
3513           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3514           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3515             +0.5d0*(pizda(1,1)+pizda(2,2))
3516           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3517           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3518           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3519           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3520           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3521           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3522             +0.5d0*(pizda(1,1)+pizda(2,2))
3523           a_temp(1,1)=aggj(l,1)!+ghalf1
3524           a_temp(1,2)=aggj(l,2)!+ghalf2
3525           a_temp(2,1)=aggj(l,3)!+ghalf3
3526           a_temp(2,2)=aggj(l,4)!+ghalf4
3527           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3528           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3529             +0.5d0*(pizda(1,1)+pizda(2,2))
3530           a_temp(1,1)=aggj1(l,1)
3531           a_temp(1,2)=aggj1(l,2)
3532           a_temp(2,1)=aggj1(l,3)
3533           a_temp(2,2)=aggj1(l,4)
3534           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3535           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3536             +0.5d0*(pizda(1,1)+pizda(2,2))
3537         enddo
3538       return
3539       end subroutine eturn3
3540 !-----------------------------------------------------------------------------
3541       subroutine eturn4(i,eello_turn4)
3542 ! Third- and fourth-order contributions from turns
3543
3544       use comm_locel
3545 !      implicit real*8 (a-h,o-z)
3546 !      include 'DIMENSIONS'
3547 !      include 'COMMON.IOUNITS'
3548 !      include 'COMMON.GEO'
3549 !      include 'COMMON.VAR'
3550 !      include 'COMMON.LOCAL'
3551 !      include 'COMMON.CHAIN'
3552 !      include 'COMMON.DERIV'
3553 !      include 'COMMON.INTERACT'
3554 !      include 'COMMON.CONTACTS'
3555 !      include 'COMMON.TORSION'
3556 !      include 'COMMON.VECTORS'
3557 !      include 'COMMON.FFIELD'
3558 !      include 'COMMON.CONTROL'
3559       real(kind=8),dimension(3) :: ggg
3560       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3561         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3562       real(kind=8),dimension(2) :: auxvec,auxvec1
3563 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3564       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3565 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3566 !el        dz_normi,xmedi,ymedi,zmedi
3567 !el      integer :: num_conti,j1,j2
3568 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3569 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3570 !el          num_conti,j1,j2
3571 !el local variables
3572       integer :: i,j,iti1,iti2,iti3,l
3573       real(kind=8) :: eello_turn4,s1,s2,s3
3574
3575       j=i+3
3576 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3577 !
3578 !               Fourth-order contributions
3579 !
3580 !                 (i+3)o----(i+4)
3581 !                     /  |
3582 !               (i+2)o   |
3583 !                     \  |
3584 !                 (i+1)o----i
3585 !
3586 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3587 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3588 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3589         a_temp(1,1)=a22
3590         a_temp(1,2)=a23
3591         a_temp(2,1)=a32
3592         a_temp(2,2)=a33
3593         iti1=itortyp(itype(i+1))
3594         iti2=itortyp(itype(i+2))
3595         iti3=itortyp(itype(i+3))
3596 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3597         call transpose2(EUg(1,1,i+1),e1t(1,1))
3598         call transpose2(Eug(1,1,i+2),e2t(1,1))
3599         call transpose2(Eug(1,1,i+3),e3t(1,1))
3600         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3601         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3602         s1=scalar2(b1(1,iti2),auxvec(1))
3603         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3604         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3605         s2=scalar2(b1(1,iti1),auxvec(1))
3606         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3607         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3608         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3609         eello_turn4=eello_turn4-(s1+s2+s3)
3610         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3611            'eturn4',i,j,-(s1+s2+s3)
3612 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3613 !d     &    ' eello_turn4_num',8*eello_turn4_num
3614 ! Derivatives in gamma(i)
3615         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3616         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3617         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3618         s1=scalar2(b1(1,iti2),auxvec(1))
3619         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3620         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3621         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3622 ! Derivatives in gamma(i+1)
3623         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3624         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3625         s2=scalar2(b1(1,iti1),auxvec(1))
3626         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3627         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3628         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3629         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3630 ! Derivatives in gamma(i+2)
3631         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3632         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3633         s1=scalar2(b1(1,iti2),auxvec(1))
3634         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3635         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3636         s2=scalar2(b1(1,iti1),auxvec(1))
3637         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3638         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3639         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3640         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3641 ! Cartesian derivatives
3642 ! Derivatives of this turn contributions in DC(i+2)
3643         if (j.lt.nres-1) then
3644           do l=1,3
3645             a_temp(1,1)=agg(l,1)
3646             a_temp(1,2)=agg(l,2)
3647             a_temp(2,1)=agg(l,3)
3648             a_temp(2,2)=agg(l,4)
3649             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3650             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3651             s1=scalar2(b1(1,iti2),auxvec(1))
3652             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3653             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3654             s2=scalar2(b1(1,iti1),auxvec(1))
3655             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3656             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3657             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3658             ggg(l)=-(s1+s2+s3)
3659             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3660           enddo
3661         endif
3662 ! Remaining derivatives of this turn contribution
3663         do l=1,3
3664           a_temp(1,1)=aggi(l,1)
3665           a_temp(1,2)=aggi(l,2)
3666           a_temp(2,1)=aggi(l,3)
3667           a_temp(2,2)=aggi(l,4)
3668           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3669           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3670           s1=scalar2(b1(1,iti2),auxvec(1))
3671           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3672           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3673           s2=scalar2(b1(1,iti1),auxvec(1))
3674           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3675           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3676           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3677           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3678           a_temp(1,1)=aggi1(l,1)
3679           a_temp(1,2)=aggi1(l,2)
3680           a_temp(2,1)=aggi1(l,3)
3681           a_temp(2,2)=aggi1(l,4)
3682           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3683           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3684           s1=scalar2(b1(1,iti2),auxvec(1))
3685           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3686           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3687           s2=scalar2(b1(1,iti1),auxvec(1))
3688           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3689           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3690           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3691           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3692           a_temp(1,1)=aggj(l,1)
3693           a_temp(1,2)=aggj(l,2)
3694           a_temp(2,1)=aggj(l,3)
3695           a_temp(2,2)=aggj(l,4)
3696           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3697           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3698           s1=scalar2(b1(1,iti2),auxvec(1))
3699           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3700           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3701           s2=scalar2(b1(1,iti1),auxvec(1))
3702           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3703           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3704           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3705           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3706           a_temp(1,1)=aggj1(l,1)
3707           a_temp(1,2)=aggj1(l,2)
3708           a_temp(2,1)=aggj1(l,3)
3709           a_temp(2,2)=aggj1(l,4)
3710           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3711           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3712           s1=scalar2(b1(1,iti2),auxvec(1))
3713           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3714           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3715           s2=scalar2(b1(1,iti1),auxvec(1))
3716           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3717           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3718           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3719 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3720           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3721         enddo
3722       return
3723       end subroutine eturn4
3724 !-----------------------------------------------------------------------------
3725       subroutine unormderiv(u,ugrad,unorm,ungrad)
3726 ! This subroutine computes the derivatives of a normalized vector u, given
3727 ! the derivatives computed without normalization conditions, ugrad. Returns
3728 ! ungrad.
3729 !      implicit none
3730       real(kind=8),dimension(3) :: u,vec
3731       real(kind=8),dimension(3,3) ::ugrad,ungrad
3732       real(kind=8) :: unorm     !,scalar
3733       integer :: i,j
3734 !      write (2,*) 'ugrad',ugrad
3735 !      write (2,*) 'u',u
3736       do i=1,3
3737         vec(i)=scalar(ugrad(1,i),u(1))
3738       enddo
3739 !      write (2,*) 'vec',vec
3740       do i=1,3
3741         do j=1,3
3742           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3743         enddo
3744       enddo
3745 !      write (2,*) 'ungrad',ungrad
3746       return
3747       end subroutine unormderiv
3748 !-----------------------------------------------------------------------------
3749       subroutine escp_soft_sphere(evdw2,evdw2_14)
3750 !
3751 ! This subroutine calculates the excluded-volume interaction energy between
3752 ! peptide-group centers and side chains and its gradient in virtual-bond and
3753 ! side-chain vectors.
3754 !
3755 !      implicit real*8 (a-h,o-z)
3756 !      include 'DIMENSIONS'
3757 !      include 'COMMON.GEO'
3758 !      include 'COMMON.VAR'
3759 !      include 'COMMON.LOCAL'
3760 !      include 'COMMON.CHAIN'
3761 !      include 'COMMON.DERIV'
3762 !      include 'COMMON.INTERACT'
3763 !      include 'COMMON.FFIELD'
3764 !      include 'COMMON.IOUNITS'
3765 !      include 'COMMON.CONTROL'
3766       real(kind=8),dimension(3) :: ggg
3767 !el local variables
3768       integer :: i,iint,j,k,iteli,itypj
3769       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3770                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3771
3772       evdw2=0.0D0
3773       evdw2_14=0.0d0
3774       r0_scp=4.5d0
3775 !d    print '(a)','Enter ESCP'
3776 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3777       do i=iatscp_s,iatscp_e
3778         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3779         iteli=itel(i)
3780         xi=0.5D0*(c(1,i)+c(1,i+1))
3781         yi=0.5D0*(c(2,i)+c(2,i+1))
3782         zi=0.5D0*(c(3,i)+c(3,i+1))
3783
3784         do iint=1,nscp_gr(i)
3785
3786         do j=iscpstart(i,iint),iscpend(i,iint)
3787           if (itype(j).eq.ntyp1) cycle
3788           itypj=iabs(itype(j))
3789 ! Uncomment following three lines for SC-p interactions
3790 !         xj=c(1,nres+j)-xi
3791 !         yj=c(2,nres+j)-yi
3792 !         zj=c(3,nres+j)-zi
3793 ! Uncomment following three lines for Ca-p interactions
3794           xj=c(1,j)-xi
3795           yj=c(2,j)-yi
3796           zj=c(3,j)-zi
3797           rij=xj*xj+yj*yj+zj*zj
3798           r0ij=r0_scp
3799           r0ijsq=r0ij*r0ij
3800           if (rij.lt.r0ijsq) then
3801             evdwij=0.25d0*(rij-r0ijsq)**2
3802             fac=rij-r0ijsq
3803           else
3804             evdwij=0.0d0
3805             fac=0.0d0
3806           endif
3807           evdw2=evdw2+evdwij
3808 !
3809 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3810 !
3811           ggg(1)=xj*fac
3812           ggg(2)=yj*fac
3813           ggg(3)=zj*fac
3814 !grad          if (j.lt.i) then
3815 !d          write (iout,*) 'j<i'
3816 ! Uncomment following three lines for SC-p interactions
3817 !           do k=1,3
3818 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3819 !           enddo
3820 !grad          else
3821 !d          write (iout,*) 'j>i'
3822 !grad            do k=1,3
3823 !grad              ggg(k)=-ggg(k)
3824 ! Uncomment following line for SC-p interactions
3825 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3826 !grad            enddo
3827 !grad          endif
3828 !grad          do k=1,3
3829 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3830 !grad          enddo
3831 !grad          kstart=min0(i+1,j)
3832 !grad          kend=max0(i-1,j-1)
3833 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3834 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3835 !grad          do k=kstart,kend
3836 !grad            do l=1,3
3837 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3838 !grad            enddo
3839 !grad          enddo
3840           do k=1,3
3841             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3842             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3843           enddo
3844         enddo
3845
3846         enddo ! iint
3847       enddo ! i
3848       return
3849       end subroutine escp_soft_sphere
3850 !-----------------------------------------------------------------------------
3851       subroutine escp(evdw2,evdw2_14)
3852 !
3853 ! This subroutine calculates the excluded-volume interaction energy between
3854 ! peptide-group centers and side chains and its gradient in virtual-bond and
3855 ! side-chain vectors.
3856 !
3857 !      implicit real*8 (a-h,o-z)
3858 !      include 'DIMENSIONS'
3859 !      include 'COMMON.GEO'
3860 !      include 'COMMON.VAR'
3861 !      include 'COMMON.LOCAL'
3862 !      include 'COMMON.CHAIN'
3863 !      include 'COMMON.DERIV'
3864 !      include 'COMMON.INTERACT'
3865 !      include 'COMMON.FFIELD'
3866 !      include 'COMMON.IOUNITS'
3867 !      include 'COMMON.CONTROL'
3868       real(kind=8),dimension(3) :: ggg
3869 !el local variables
3870       integer :: i,iint,j,k,iteli,itypj
3871       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
3872                    e1,e2,evdwij
3873
3874       evdw2=0.0D0
3875       evdw2_14=0.0d0
3876 !d    print '(a)','Enter ESCP'
3877 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3878       do i=iatscp_s,iatscp_e
3879         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3880         iteli=itel(i)
3881         xi=0.5D0*(c(1,i)+c(1,i+1))
3882         yi=0.5D0*(c(2,i)+c(2,i+1))
3883         zi=0.5D0*(c(3,i)+c(3,i+1))
3884
3885         do iint=1,nscp_gr(i)
3886
3887         do j=iscpstart(i,iint),iscpend(i,iint)
3888           itypj=iabs(itype(j))
3889           if (itypj.eq.ntyp1) cycle
3890 ! Uncomment following three lines for SC-p interactions
3891 !         xj=c(1,nres+j)-xi
3892 !         yj=c(2,nres+j)-yi
3893 !         zj=c(3,nres+j)-zi
3894 ! Uncomment following three lines for Ca-p interactions
3895           xj=c(1,j)-xi
3896           yj=c(2,j)-yi
3897           zj=c(3,j)-zi
3898           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3899           fac=rrij**expon2
3900           e1=fac*fac*aad(itypj,iteli)
3901           e2=fac*bad(itypj,iteli)
3902           if (iabs(j-i) .le. 2) then
3903             e1=scal14*e1
3904             e2=scal14*e2
3905             evdw2_14=evdw2_14+e1+e2
3906           endif
3907           evdwij=e1+e2
3908           evdw2=evdw2+evdwij
3909 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
3910 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
3911           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3912              'evdw2',i,j,evdwij
3913 !
3914 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3915 !
3916           fac=-(evdwij+e1)*rrij
3917           ggg(1)=xj*fac
3918           ggg(2)=yj*fac
3919           ggg(3)=zj*fac
3920 !grad          if (j.lt.i) then
3921 !d          write (iout,*) 'j<i'
3922 ! Uncomment following three lines for SC-p interactions
3923 !           do k=1,3
3924 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3925 !           enddo
3926 !grad          else
3927 !d          write (iout,*) 'j>i'
3928 !grad            do k=1,3
3929 !grad              ggg(k)=-ggg(k)
3930 ! Uncomment following line for SC-p interactions
3931 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3932 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3933 !grad            enddo
3934 !grad          endif
3935 !grad          do k=1,3
3936 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3937 !grad          enddo
3938 !grad          kstart=min0(i+1,j)
3939 !grad          kend=max0(i-1,j-1)
3940 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3941 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3942 !grad          do k=kstart,kend
3943 !grad            do l=1,3
3944 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3945 !grad            enddo
3946 !grad          enddo
3947           do k=1,3
3948             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3949             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3950           enddo
3951         enddo
3952
3953         enddo ! iint
3954       enddo ! i
3955       do i=1,nct
3956         do j=1,3
3957           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3958           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3959           gradx_scp(j,i)=expon*gradx_scp(j,i)
3960         enddo
3961       enddo
3962 !******************************************************************************
3963 !
3964 !                              N O T E !!!
3965 !
3966 ! To save time the factor EXPON has been extracted from ALL components
3967 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
3968 ! use!
3969 !
3970 !******************************************************************************
3971       return
3972       end subroutine escp
3973 !-----------------------------------------------------------------------------
3974       subroutine edis(ehpb)
3975 !
3976 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3977 !
3978 !      implicit real*8 (a-h,o-z)
3979 !      include 'DIMENSIONS'
3980 !      include 'COMMON.SBRIDGE'
3981 !      include 'COMMON.CHAIN'
3982 !      include 'COMMON.DERIV'
3983 !      include 'COMMON.VAR'
3984 !      include 'COMMON.INTERACT'
3985 !      include 'COMMON.IOUNITS'
3986       real(kind=8),dimension(3) :: ggg
3987 !el local variables
3988       integer :: i,j,ii,jj,iii,jjj,k
3989       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
3990
3991       ehpb=0.0D0
3992 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3993 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
3994       if (link_end.eq.0) return
3995       do i=link_start,link_end
3996 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3997 ! CA-CA distance used in regularization of structure.
3998         ii=ihpb(i)
3999         jj=jhpb(i)
4000 ! iii and jjj point to the residues for which the distance is assigned.
4001         if (ii.gt.nres) then
4002           iii=ii-nres
4003           jjj=jj-nres
4004         else
4005           iii=ii
4006           jjj=jj
4007         endif
4008 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4009 !     &    dhpb(i),dhpb1(i),forcon(i)
4010 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4011 !    distance and angle dependent SS bond potential.
4012 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4013 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4014         if (.not.dyn_ss .and. i.le.nss) then
4015 ! 15/02/13 CC dynamic SSbond - additional check
4016          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4017         iabs(itype(jjj)).eq.1) then
4018           call ssbond_ene(iii,jjj,eij)
4019           ehpb=ehpb+2*eij
4020 !d          write (iout,*) "eij",eij
4021          endif
4022         else
4023 ! Calculate the distance between the two points and its difference from the
4024 ! target distance.
4025         dd=dist(ii,jj)
4026         rdis=dd-dhpb(i)
4027 ! Get the force constant corresponding to this distance.
4028         waga=forcon(i)
4029 ! Calculate the contribution to energy.
4030         ehpb=ehpb+waga*rdis*rdis
4031 !
4032 ! Evaluate gradient.
4033 !
4034         fac=waga*rdis/dd
4035 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4036 !d   &   ' waga=',waga,' fac=',fac
4037         do j=1,3
4038           ggg(j)=fac*(c(j,jj)-c(j,ii))
4039         enddo
4040 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4041 ! If this is a SC-SC distance, we need to calculate the contributions to the
4042 ! Cartesian gradient in the SC vectors (ghpbx).
4043         if (iii.lt.ii) then
4044           do j=1,3
4045             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4046             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4047           enddo
4048         endif
4049 !grad        do j=iii,jjj-1
4050 !grad          do k=1,3
4051 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4052 !grad          enddo
4053 !grad        enddo
4054         do k=1,3
4055           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4056           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4057         enddo
4058         endif
4059       enddo
4060       ehpb=0.5D0*ehpb
4061       return
4062       end subroutine edis
4063 !-----------------------------------------------------------------------------
4064       subroutine ssbond_ene(i,j,eij)
4065 !
4066 ! Calculate the distance and angle dependent SS-bond potential energy
4067 ! using a free-energy function derived based on RHF/6-31G** ab initio
4068 ! calculations of diethyl disulfide.
4069 !
4070 ! A. Liwo and U. Kozlowska, 11/24/03
4071 !
4072 !      implicit real*8 (a-h,o-z)
4073 !      include 'DIMENSIONS'
4074 !      include 'COMMON.SBRIDGE'
4075 !      include 'COMMON.CHAIN'
4076 !      include 'COMMON.DERIV'
4077 !      include 'COMMON.LOCAL'
4078 !      include 'COMMON.INTERACT'
4079 !      include 'COMMON.VAR'
4080 !      include 'COMMON.IOUNITS'
4081       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4082 !el local variables
4083       integer :: i,j,itypi,itypj,k
4084       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4085                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4086                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4087                    cosphi,ggk
4088
4089       itypi=iabs(itype(i))
4090       xi=c(1,nres+i)
4091       yi=c(2,nres+i)
4092       zi=c(3,nres+i)
4093       dxi=dc_norm(1,nres+i)
4094       dyi=dc_norm(2,nres+i)
4095       dzi=dc_norm(3,nres+i)
4096 !      dsci_inv=dsc_inv(itypi)
4097       dsci_inv=vbld_inv(nres+i)
4098       itypj=iabs(itype(j))
4099 !      dscj_inv=dsc_inv(itypj)
4100       dscj_inv=vbld_inv(nres+j)
4101       xj=c(1,nres+j)-xi
4102       yj=c(2,nres+j)-yi
4103       zj=c(3,nres+j)-zi
4104       dxj=dc_norm(1,nres+j)
4105       dyj=dc_norm(2,nres+j)
4106       dzj=dc_norm(3,nres+j)
4107       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4108       rij=dsqrt(rrij)
4109       erij(1)=xj*rij
4110       erij(2)=yj*rij
4111       erij(3)=zj*rij
4112       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4113       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4114       om12=dxi*dxj+dyi*dyj+dzi*dzj
4115       do k=1,3
4116         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4117         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4118       enddo
4119       rij=1.0d0/rij
4120       deltad=rij-d0cm
4121       deltat1=1.0d0-om1
4122       deltat2=1.0d0+om2
4123       deltat12=om2-om1+2.0d0
4124       cosphi=om12-om1*om2
4125       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4126         +akct*deltad*deltat12 &
4127         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4128 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4129 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4130 !     &  " deltat12",deltat12," eij",eij
4131       ed=2*akcm*deltad+akct*deltat12
4132       pom1=akct*deltad
4133       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4134       eom1=-2*akth*deltat1-pom1-om2*pom2
4135       eom2= 2*akth*deltat2+pom1-om1*pom2
4136       eom12=pom2
4137       do k=1,3
4138         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4139         ghpbx(k,i)=ghpbx(k,i)-ggk &
4140                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4141                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4142         ghpbx(k,j)=ghpbx(k,j)+ggk &
4143                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4144                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4145         ghpbc(k,i)=ghpbc(k,i)-ggk
4146         ghpbc(k,j)=ghpbc(k,j)+ggk
4147       enddo
4148 !
4149 ! Calculate the components of the gradient in DC and X
4150 !
4151 !grad      do k=i,j-1
4152 !grad        do l=1,3
4153 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4154 !grad        enddo
4155 !grad      enddo
4156       return
4157       end subroutine ssbond_ene
4158 !-----------------------------------------------------------------------------
4159       subroutine ebond(estr)
4160 !
4161 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4162 !
4163 !      implicit real*8 (a-h,o-z)
4164 !      include 'DIMENSIONS'
4165 !      include 'COMMON.LOCAL'
4166 !      include 'COMMON.GEO'
4167 !      include 'COMMON.INTERACT'
4168 !      include 'COMMON.DERIV'
4169 !      include 'COMMON.VAR'
4170 !      include 'COMMON.CHAIN'
4171 !      include 'COMMON.IOUNITS'
4172 !      include 'COMMON.NAMES'
4173 !      include 'COMMON.FFIELD'
4174 !      include 'COMMON.CONTROL'
4175 !      include 'COMMON.SETUP'
4176       real(kind=8),dimension(3) :: u,ud
4177 !el local variables
4178       integer :: i,j,iti,nbi,k
4179       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4180                    uprod1,uprod2
4181
4182       estr=0.0d0
4183       estr1=0.0d0
4184 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4185 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4186
4187       do i=ibondp_start,ibondp_end
4188         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4189         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4190 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4191 !C          do j=1,3
4192 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4193 !C            *dc(j,i-1)/vbld(i)
4194 !C          enddo
4195 !C          if (energy_dec) write(iout,*) &
4196 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4197         diff = vbld(i)-vbldpDUM
4198         else
4199         diff = vbld(i)-vbldp0
4200         endif
4201         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4202            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4203         estr=estr+diff*diff
4204         do j=1,3
4205           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4206         enddo
4207 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4208 !        endif
4209       enddo
4210       estr=0.5d0*AKP*estr+estr1
4211 !
4212 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4213 !
4214       do i=ibond_start,ibond_end
4215         iti=iabs(itype(i))
4216         if (iti.ne.10 .and. iti.ne.ntyp1) then
4217           nbi=nbondterm(iti)
4218           if (nbi.eq.1) then
4219             diff=vbld(i+nres)-vbldsc0(1,iti)
4220             if (energy_dec) write (iout,*) &
4221             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4222             AKSC(1,iti),AKSC(1,iti)*diff*diff
4223             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4224             do j=1,3
4225               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4226             enddo
4227           else
4228             do j=1,nbi
4229               diff=vbld(i+nres)-vbldsc0(j,iti)
4230               ud(j)=aksc(j,iti)*diff
4231               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4232             enddo
4233             uprod=u(1)
4234             do j=2,nbi
4235               uprod=uprod*u(j)
4236             enddo
4237             usum=0.0d0
4238             usumsqder=0.0d0
4239             do j=1,nbi
4240               uprod1=1.0d0
4241               uprod2=1.0d0
4242               do k=1,nbi
4243                 if (k.ne.j) then
4244                   uprod1=uprod1*u(k)
4245                   uprod2=uprod2*u(k)*u(k)
4246                 endif
4247               enddo
4248               usum=usum+uprod1
4249               usumsqder=usumsqder+ud(j)*uprod2
4250             enddo
4251             estr=estr+uprod/usum
4252             do j=1,3
4253              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4254             enddo
4255           endif
4256         endif
4257       enddo
4258       return
4259       end subroutine ebond
4260 #ifdef CRYST_THETA
4261 !-----------------------------------------------------------------------------
4262       subroutine ebend(etheta)
4263 !
4264 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4265 ! angles gamma and its derivatives in consecutive thetas and gammas.
4266 !
4267       use comm_calcthet
4268 !      implicit real*8 (a-h,o-z)
4269 !      include 'DIMENSIONS'
4270 !      include 'COMMON.LOCAL'
4271 !      include 'COMMON.GEO'
4272 !      include 'COMMON.INTERACT'
4273 !      include 'COMMON.DERIV'
4274 !      include 'COMMON.VAR'
4275 !      include 'COMMON.CHAIN'
4276 !      include 'COMMON.IOUNITS'
4277 !      include 'COMMON.NAMES'
4278 !      include 'COMMON.FFIELD'
4279 !      include 'COMMON.CONTROL'
4280 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4281 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4282 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4283 !el      integer :: it
4284 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4285 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4286 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4287 !el local variables
4288       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4289        ichir21,ichir22
4290       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4291        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4292        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4293       real(kind=8),dimension(2) :: y,z
4294
4295       delta=0.02d0*pi
4296 !      time11=dexp(-2*time)
4297 !      time12=1.0d0
4298       etheta=0.0D0
4299 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4300       do i=ithet_start,ithet_end
4301         if (itype(i-1).eq.ntyp1) cycle
4302 ! Zero the energy function and its derivative at 0 or pi.
4303         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4304         it=itype(i-1)
4305         ichir1=isign(1,itype(i-2))
4306         ichir2=isign(1,itype(i))
4307          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4308          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4309          if (itype(i-1).eq.10) then
4310           itype1=isign(10,itype(i-2))
4311           ichir11=isign(1,itype(i-2))
4312           ichir12=isign(1,itype(i-2))
4313           itype2=isign(10,itype(i))
4314           ichir21=isign(1,itype(i))
4315           ichir22=isign(1,itype(i))
4316          endif
4317
4318         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4319 #ifdef OSF
4320           phii=phi(i)
4321           if (phii.ne.phii) phii=150.0
4322 #else
4323           phii=phi(i)
4324 #endif
4325           y(1)=dcos(phii)
4326           y(2)=dsin(phii)
4327         else
4328           y(1)=0.0D0
4329           y(2)=0.0D0
4330         endif
4331         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4332 #ifdef OSF
4333           phii1=phi(i+1)
4334           if (phii1.ne.phii1) phii1=150.0
4335           phii1=pinorm(phii1)
4336           z(1)=cos(phii1)
4337 #else
4338           phii1=phi(i+1)
4339           z(1)=dcos(phii1)
4340 #endif
4341           z(2)=dsin(phii1)
4342         else
4343           z(1)=0.0D0
4344           z(2)=0.0D0
4345         endif
4346 ! Calculate the "mean" value of theta from the part of the distribution
4347 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4348 ! In following comments this theta will be referred to as t_c.
4349         thet_pred_mean=0.0d0
4350         do k=1,2
4351             athetk=athet(k,it,ichir1,ichir2)
4352             bthetk=bthet(k,it,ichir1,ichir2)
4353           if (it.eq.10) then
4354              athetk=athet(k,itype1,ichir11,ichir12)
4355              bthetk=bthet(k,itype2,ichir21,ichir22)
4356           endif
4357          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4358         enddo
4359         dthett=thet_pred_mean*ssd
4360         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4361 ! Derivatives of the "mean" values in gamma1 and gamma2.
4362         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4363                +athet(2,it,ichir1,ichir2)*y(1))*ss
4364         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4365                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4366          if (it.eq.10) then
4367         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4368              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4369         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4370                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4371          endif
4372         if (theta(i).gt.pi-delta) then
4373           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4374                E_tc0)
4375           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4376           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4377           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4378               E_theta)
4379           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4380               E_tc)
4381         else if (theta(i).lt.delta) then
4382           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4383           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4384           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4385               E_theta)
4386           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4387           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4388               E_tc)
4389         else
4390           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4391               E_theta,E_tc)
4392         endif
4393         etheta=etheta+ethetai
4394         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4395             'ebend',i,ethetai
4396         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4397         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4398         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4399       enddo
4400 ! Ufff.... We've done all this!!!
4401       return
4402       end subroutine ebend
4403 !-----------------------------------------------------------------------------
4404       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4405
4406       use comm_calcthet
4407 !      implicit real*8 (a-h,o-z)
4408 !      include 'DIMENSIONS'
4409 !      include 'COMMON.LOCAL'
4410 !      include 'COMMON.IOUNITS'
4411 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4412 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4413 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4414       integer :: i,j,k
4415       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4416 !el      integer :: it
4417 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4418 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4419 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4420 !el local variables
4421       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4422        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4423
4424 ! Calculate the contributions to both Gaussian lobes.
4425 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4426 ! The "polynomial part" of the "standard deviation" of this part of
4427 ! the distribution.
4428         sig=polthet(3,it)
4429         do j=2,0,-1
4430           sig=sig*thet_pred_mean+polthet(j,it)
4431         enddo
4432 ! Derivative of the "interior part" of the "standard deviation of the"
4433 ! gamma-dependent Gaussian lobe in t_c.
4434         sigtc=3*polthet(3,it)
4435         do j=2,1,-1
4436           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4437         enddo
4438         sigtc=sig*sigtc
4439 ! Set the parameters of both Gaussian lobes of the distribution.
4440 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4441         fac=sig*sig+sigc0(it)
4442         sigcsq=fac+fac
4443         sigc=1.0D0/sigcsq
4444 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4445         sigsqtc=-4.0D0*sigcsq*sigtc
4446 !       print *,i,sig,sigtc,sigsqtc
4447 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4448         sigtc=-sigtc/(fac*fac)
4449 ! Following variable is sigma(t_c)**(-2)
4450         sigcsq=sigcsq*sigcsq
4451         sig0i=sig0(it)
4452         sig0inv=1.0D0/sig0i**2
4453         delthec=thetai-thet_pred_mean
4454         delthe0=thetai-theta0i
4455         term1=-0.5D0*sigcsq*delthec*delthec
4456         term2=-0.5D0*sig0inv*delthe0*delthe0
4457 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4458 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4459 ! to the energy (this being the log of the distribution) at the end of energy
4460 ! term evaluation for this virtual-bond angle.
4461         if (term1.gt.term2) then
4462           termm=term1
4463           term2=dexp(term2-termm)
4464           term1=1.0d0
4465         else
4466           termm=term2
4467           term1=dexp(term1-termm)
4468           term2=1.0d0
4469         endif
4470 ! The ratio between the gamma-independent and gamma-dependent lobes of
4471 ! the distribution is a Gaussian function of thet_pred_mean too.
4472         diffak=gthet(2,it)-thet_pred_mean
4473         ratak=diffak/gthet(3,it)**2
4474         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4475 ! Let's differentiate it in thet_pred_mean NOW.
4476         aktc=ak*ratak
4477 ! Now put together the distribution terms to make complete distribution.
4478         termexp=term1+ak*term2
4479         termpre=sigc+ak*sig0i
4480 ! Contribution of the bending energy from this theta is just the -log of
4481 ! the sum of the contributions from the two lobes and the pre-exponential
4482 ! factor. Simple enough, isn't it?
4483         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4484 ! NOW the derivatives!!!
4485 ! 6/6/97 Take into account the deformation.
4486         E_theta=(delthec*sigcsq*term1 &
4487              +ak*delthe0*sig0inv*term2)/termexp
4488         E_tc=((sigtc+aktc*sig0i)/termpre &
4489             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4490              aktc*term2)/termexp)
4491       return
4492       end subroutine theteng
4493 #else
4494 !-----------------------------------------------------------------------------
4495       subroutine ebend(etheta)
4496 !
4497 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4498 ! angles gamma and its derivatives in consecutive thetas and gammas.
4499 ! ab initio-derived potentials from
4500 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4501 !
4502 !      implicit real*8 (a-h,o-z)
4503 !      include 'DIMENSIONS'
4504 !      include 'COMMON.LOCAL'
4505 !      include 'COMMON.GEO'
4506 !      include 'COMMON.INTERACT'
4507 !      include 'COMMON.DERIV'
4508 !      include 'COMMON.VAR'
4509 !      include 'COMMON.CHAIN'
4510 !      include 'COMMON.IOUNITS'
4511 !      include 'COMMON.NAMES'
4512 !      include 'COMMON.FFIELD'
4513 !      include 'COMMON.CONTROL'
4514       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4515       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4516       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4517       logical :: lprn=.false., lprn1=.false.
4518 !el local variables
4519       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4520       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4521       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4522
4523       etheta=0.0D0
4524       do i=ithet_start,ithet_end
4525         if (itype(i-1).eq.ntyp1) cycle
4526         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
4527         if (iabs(itype(i+1)).eq.20) iblock=2
4528         if (iabs(itype(i+1)).ne.20) iblock=1
4529         dethetai=0.0d0
4530         dephii=0.0d0
4531         dephii1=0.0d0
4532         theti2=0.5d0*theta(i)
4533         ityp2=ithetyp((itype(i-1)))
4534         do k=1,nntheterm
4535           coskt(k)=dcos(k*theti2)
4536           sinkt(k)=dsin(k*theti2)
4537         enddo
4538         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4539 #ifdef OSF
4540           phii=phi(i)
4541           if (phii.ne.phii) phii=150.0
4542 #else
4543           phii=phi(i)
4544 #endif
4545           ityp1=ithetyp((itype(i-2)))
4546 ! propagation of chirality for glycine type
4547           do k=1,nsingle
4548             cosph1(k)=dcos(k*phii)
4549             sinph1(k)=dsin(k*phii)
4550           enddo
4551         else
4552           phii=0.0d0
4553           ityp1=ithetyp(itype(i-2))
4554           do k=1,nsingle
4555             cosph1(k)=0.0d0
4556             sinph1(k)=0.0d0
4557           enddo
4558         endif
4559         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4560 #ifdef OSF
4561           phii1=phi(i+1)
4562           if (phii1.ne.phii1) phii1=150.0
4563           phii1=pinorm(phii1)
4564 #else
4565           phii1=phi(i+1)
4566 #endif
4567           ityp3=ithetyp((itype(i)))
4568           do k=1,nsingle
4569             cosph2(k)=dcos(k*phii1)
4570             sinph2(k)=dsin(k*phii1)
4571           enddo
4572         else
4573           phii1=0.0d0
4574           ityp3=ithetyp(itype(i))
4575           do k=1,nsingle
4576             cosph2(k)=0.0d0
4577             sinph2(k)=0.0d0
4578           enddo
4579         endif
4580         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4581         do k=1,ndouble
4582           do l=1,k-1
4583             ccl=cosph1(l)*cosph2(k-l)
4584             ssl=sinph1(l)*sinph2(k-l)
4585             scl=sinph1(l)*cosph2(k-l)
4586             csl=cosph1(l)*sinph2(k-l)
4587             cosph1ph2(l,k)=ccl-ssl
4588             cosph1ph2(k,l)=ccl+ssl
4589             sinph1ph2(l,k)=scl+csl
4590             sinph1ph2(k,l)=scl-csl
4591           enddo
4592         enddo
4593         if (lprn) then
4594         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4595           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4596         write (iout,*) "coskt and sinkt"
4597         do k=1,nntheterm
4598           write (iout,*) k,coskt(k),sinkt(k)
4599         enddo
4600         endif
4601         do k=1,ntheterm
4602           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4603           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4604             *coskt(k)
4605           if (lprn) &
4606           write (iout,*) "k",k,&
4607            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4608            " ethetai",ethetai
4609         enddo
4610         if (lprn) then
4611         write (iout,*) "cosph and sinph"
4612         do k=1,nsingle
4613           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4614         enddo
4615         write (iout,*) "cosph1ph2 and sinph2ph2"
4616         do k=2,ndouble
4617           do l=1,k-1
4618             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4619                sinph1ph2(l,k),sinph1ph2(k,l)
4620           enddo
4621         enddo
4622         write(iout,*) "ethetai",ethetai
4623         endif
4624         do m=1,ntheterm2
4625           do k=1,nsingle
4626             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4627                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4628                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4629                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4630             ethetai=ethetai+sinkt(m)*aux
4631             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4632             dephii=dephii+k*sinkt(m)* &
4633                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4634                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4635             dephii1=dephii1+k*sinkt(m)* &
4636                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4637                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4638             if (lprn) &
4639             write (iout,*) "m",m," k",k," bbthet", &
4640                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4641                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4642                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4643                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4644           enddo
4645         enddo
4646         if (lprn) &
4647         write(iout,*) "ethetai",ethetai
4648         do m=1,ntheterm3
4649           do k=2,ndouble
4650             do l=1,k-1
4651               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4652                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4653                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4654                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4655               ethetai=ethetai+sinkt(m)*aux
4656               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4657               dephii=dephii+l*sinkt(m)* &
4658                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4659                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4660                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4661                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4662               dephii1=dephii1+(k-l)*sinkt(m)* &
4663                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4664                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4665                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4666                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4667               if (lprn) then
4668               write (iout,*) "m",m," k",k," l",l," ffthet",&
4669                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4670                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4671                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4672                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4673                   " ethetai",ethetai
4674               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4675                   cosph1ph2(k,l)*sinkt(m),&
4676                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4677               endif
4678             enddo
4679           enddo
4680         enddo
4681 10      continue
4682 !        lprn1=.true.
4683         if (lprn1) &
4684           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4685          i,theta(i)*rad2deg,phii*rad2deg,&
4686          phii1*rad2deg,ethetai
4687 !        lprn1=.false.
4688         etheta=etheta+ethetai
4689         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4690                                     'ebend',i,ethetai
4691         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4692         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4693         gloc(nphi+i-2,icg)=wang*dethetai
4694       enddo
4695       return
4696       end subroutine ebend
4697 #endif
4698 #ifdef CRYST_SC
4699 !-----------------------------------------------------------------------------
4700       subroutine esc(escloc)
4701 ! Calculate the local energy of a side chain and its derivatives in the
4702 ! corresponding virtual-bond valence angles THETA and the spherical angles
4703 ! ALPHA and OMEGA.
4704 !
4705       use comm_sccalc
4706 !      implicit real*8 (a-h,o-z)
4707 !      include 'DIMENSIONS'
4708 !      include 'COMMON.GEO'
4709 !      include 'COMMON.LOCAL'
4710 !      include 'COMMON.VAR'
4711 !      include 'COMMON.INTERACT'
4712 !      include 'COMMON.DERIV'
4713 !      include 'COMMON.CHAIN'
4714 !      include 'COMMON.IOUNITS'
4715 !      include 'COMMON.NAMES'
4716 !      include 'COMMON.FFIELD'
4717 !      include 'COMMON.CONTROL'
4718       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4719          ddersc0,ddummy,xtemp,temp
4720 !el      real(kind=8) :: time11,time12,time112,theti
4721       real(kind=8) :: escloc,delta
4722 !el      integer :: it,nlobit
4723 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4724 !el local variables
4725       integer :: i,k
4726       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4727        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4728       delta=0.02d0*pi
4729       escloc=0.0D0
4730 !     write (iout,'(a)') 'ESC'
4731       do i=loc_start,loc_end
4732         it=itype(i)
4733         if (it.eq.ntyp1) cycle
4734         if (it.eq.10) goto 1
4735         nlobit=nlob(iabs(it))
4736 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4737 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4738         theti=theta(i+1)-pipol
4739         x(1)=dtan(theti)
4740         x(2)=alph(i)
4741         x(3)=omeg(i)
4742
4743         if (x(2).gt.pi-delta) then
4744           xtemp(1)=x(1)
4745           xtemp(2)=pi-delta
4746           xtemp(3)=x(3)
4747           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4748           xtemp(2)=pi
4749           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4750           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4751               escloci,dersc(2))
4752           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4753               ddersc0(1),dersc(1))
4754           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4755               ddersc0(3),dersc(3))
4756           xtemp(2)=pi-delta
4757           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4758           xtemp(2)=pi
4759           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4760           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4761                   dersc0(2),esclocbi,dersc02)
4762           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4763                   dersc12,dersc01)
4764           call splinthet(x(2),0.5d0*delta,ss,ssd)
4765           dersc0(1)=dersc01
4766           dersc0(2)=dersc02
4767           dersc0(3)=0.0d0
4768           do k=1,3
4769             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4770           enddo
4771           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4772 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4773 !    &             esclocbi,ss,ssd
4774           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4775 !         escloci=esclocbi
4776 !         write (iout,*) escloci
4777         else if (x(2).lt.delta) then
4778           xtemp(1)=x(1)
4779           xtemp(2)=delta
4780           xtemp(3)=x(3)
4781           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4782           xtemp(2)=0.0d0
4783           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4784           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4785               escloci,dersc(2))
4786           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4787               ddersc0(1),dersc(1))
4788           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4789               ddersc0(3),dersc(3))
4790           xtemp(2)=delta
4791           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4792           xtemp(2)=0.0d0
4793           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4794           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4795                   dersc0(2),esclocbi,dersc02)
4796           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4797                   dersc12,dersc01)
4798           dersc0(1)=dersc01
4799           dersc0(2)=dersc02
4800           dersc0(3)=0.0d0
4801           call splinthet(x(2),0.5d0*delta,ss,ssd)
4802           do k=1,3
4803             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4804           enddo
4805           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4806 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4807 !    &             esclocbi,ss,ssd
4808           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4809 !         write (iout,*) escloci
4810         else
4811           call enesc(x,escloci,dersc,ddummy,.false.)
4812         endif
4813
4814         escloc=escloc+escloci
4815         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4816            'escloc',i,escloci
4817 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4818
4819         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
4820          wscloc*dersc(1)
4821         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4822         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4823     1   continue
4824       enddo
4825       return
4826       end subroutine esc
4827 !-----------------------------------------------------------------------------
4828       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4829
4830       use comm_sccalc
4831 !      implicit real*8 (a-h,o-z)
4832 !      include 'DIMENSIONS'
4833 !      include 'COMMON.GEO'
4834 !      include 'COMMON.LOCAL'
4835 !      include 'COMMON.IOUNITS'
4836 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4837       real(kind=8),dimension(3) :: x,z,dersc,ddersc
4838       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
4839       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
4840       real(kind=8) :: escloci
4841       logical :: mixed
4842 !el local variables
4843       integer :: j,iii,l,k !el,it,nlobit
4844       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
4845 !el       time11,time12,time112
4846 !       write (iout,*) 'it=',it,' nlobit=',nlobit
4847         escloc_i=0.0D0
4848         do j=1,3
4849           dersc(j)=0.0D0
4850           if (mixed) ddersc(j)=0.0d0
4851         enddo
4852         x3=x(3)
4853
4854 ! Because of periodicity of the dependence of the SC energy in omega we have
4855 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4856 ! To avoid underflows, first compute & store the exponents.
4857
4858         do iii=-1,1
4859
4860           x(3)=x3+iii*dwapi
4861
4862           do j=1,nlobit
4863             do k=1,3
4864               z(k)=x(k)-censc(k,j,it)
4865             enddo
4866             do k=1,3
4867               Axk=0.0D0
4868               do l=1,3
4869                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4870               enddo
4871               Ax(k,j,iii)=Axk
4872             enddo
4873             expfac=0.0D0
4874             do k=1,3
4875               expfac=expfac+Ax(k,j,iii)*z(k)
4876             enddo
4877             contr(j,iii)=expfac
4878           enddo ! j
4879
4880         enddo ! iii
4881
4882         x(3)=x3
4883 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4884 ! subsequent NaNs and INFs in energy calculation.
4885 ! Find the largest exponent
4886         emin=contr(1,-1)
4887         do iii=-1,1
4888           do j=1,nlobit
4889             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4890           enddo
4891         enddo
4892         emin=0.5D0*emin
4893 !d      print *,'it=',it,' emin=',emin
4894
4895 ! Compute the contribution to SC energy and derivatives
4896         do iii=-1,1
4897
4898           do j=1,nlobit
4899 #ifdef OSF
4900             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4901             if(adexp.ne.adexp) adexp=1.0
4902             expfac=dexp(adexp)
4903 #else
4904             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4905 #endif
4906 !d          print *,'j=',j,' expfac=',expfac
4907             escloc_i=escloc_i+expfac
4908             do k=1,3
4909               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4910             enddo
4911             if (mixed) then
4912               do k=1,3,2
4913                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
4914                   +gaussc(k,2,j,it))*expfac
4915               enddo
4916             endif
4917           enddo
4918
4919         enddo ! iii
4920
4921         dersc(1)=dersc(1)/cos(theti)**2
4922         ddersc(1)=ddersc(1)/cos(theti)**2
4923         ddersc(3)=ddersc(3)
4924
4925         escloci=-(dlog(escloc_i)-emin)
4926         do j=1,3
4927           dersc(j)=dersc(j)/escloc_i
4928         enddo
4929         if (mixed) then
4930           do j=1,3,2
4931             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4932           enddo
4933         endif
4934       return
4935       end subroutine enesc
4936 !-----------------------------------------------------------------------------
4937       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4938
4939       use comm_sccalc
4940 !      implicit real*8 (a-h,o-z)
4941 !      include 'DIMENSIONS'
4942 !      include 'COMMON.GEO'
4943 !      include 'COMMON.LOCAL'
4944 !      include 'COMMON.IOUNITS'
4945 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4946       real(kind=8),dimension(3) :: x,z,dersc
4947       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
4948       real(kind=8),dimension(nlobit) :: contr !(maxlob)
4949       real(kind=8) :: escloci,dersc12,emin
4950       logical :: mixed
4951 !el local varables
4952       integer :: j,k,l !el,it,nlobit
4953       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
4954
4955       escloc_i=0.0D0
4956
4957       do j=1,3
4958         dersc(j)=0.0D0
4959       enddo
4960
4961       do j=1,nlobit
4962         do k=1,2
4963           z(k)=x(k)-censc(k,j,it)
4964         enddo
4965         z(3)=dwapi
4966         do k=1,3
4967           Axk=0.0D0
4968           do l=1,3
4969             Axk=Axk+gaussc(l,k,j,it)*z(l)
4970           enddo
4971           Ax(k,j)=Axk
4972         enddo
4973         expfac=0.0D0
4974         do k=1,3
4975           expfac=expfac+Ax(k,j)*z(k)
4976         enddo
4977         contr(j)=expfac
4978       enddo ! j
4979
4980 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4981 ! subsequent NaNs and INFs in energy calculation.
4982 ! Find the largest exponent
4983       emin=contr(1)
4984       do j=1,nlobit
4985         if (emin.gt.contr(j)) emin=contr(j)
4986       enddo
4987       emin=0.5D0*emin
4988
4989 ! Compute the contribution to SC energy and derivatives
4990
4991       dersc12=0.0d0
4992       do j=1,nlobit
4993         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4994         escloc_i=escloc_i+expfac
4995         do k=1,2
4996           dersc(k)=dersc(k)+Ax(k,j)*expfac
4997         enddo
4998         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
4999                   +gaussc(1,2,j,it))*expfac
5000         dersc(3)=0.0d0
5001       enddo
5002
5003       dersc(1)=dersc(1)/cos(theti)**2
5004       dersc12=dersc12/cos(theti)**2
5005       escloci=-(dlog(escloc_i)-emin)
5006       do j=1,2
5007         dersc(j)=dersc(j)/escloc_i
5008       enddo
5009       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5010       return
5011       end subroutine enesc_bound
5012 #else
5013 !-----------------------------------------------------------------------------
5014       subroutine esc(escloc)
5015 ! Calculate the local energy of a side chain and its derivatives in the
5016 ! corresponding virtual-bond valence angles THETA and the spherical angles
5017 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5018 ! added by Urszula Kozlowska. 07/11/2007
5019 !
5020       use comm_sccalc
5021 !      implicit real*8 (a-h,o-z)
5022 !      include 'DIMENSIONS'
5023 !      include 'COMMON.GEO'
5024 !      include 'COMMON.LOCAL'
5025 !      include 'COMMON.VAR'
5026 !      include 'COMMON.SCROT'
5027 !      include 'COMMON.INTERACT'
5028 !      include 'COMMON.DERIV'
5029 !      include 'COMMON.CHAIN'
5030 !      include 'COMMON.IOUNITS'
5031 !      include 'COMMON.NAMES'
5032 !      include 'COMMON.FFIELD'
5033 !      include 'COMMON.CONTROL'
5034 !      include 'COMMON.VECTORS'
5035       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5036       real(kind=8),dimension(65) :: x
5037       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5038          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5039       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5040       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5041          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5042 !el local variables
5043       integer :: i,j,k !el,it,nlobit
5044       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5045 !el      real(kind=8) :: time11,time12,time112,theti
5046 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5047       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5048                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5049                    sumene1x,sumene2x,sumene3x,sumene4x,&
5050                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5051                    cosfac2xx,sinfac2yy
5052 #ifdef DEBUG
5053       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5054                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5055                    de_dt_num
5056 #endif
5057 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5058
5059       delta=0.02d0*pi
5060       escloc=0.0D0
5061       do i=loc_start,loc_end
5062         if (itype(i).eq.ntyp1) cycle
5063         costtab(i+1) =dcos(theta(i+1))
5064         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5065         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5066         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5067         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5068         cosfac=dsqrt(cosfac2)
5069         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5070         sinfac=dsqrt(sinfac2)
5071         it=iabs(itype(i))
5072         if (it.eq.10) goto 1
5073 !
5074 !  Compute the axes of tghe local cartesian coordinates system; store in
5075 !   x_prime, y_prime and z_prime
5076 !
5077         do j=1,3
5078           x_prime(j) = 0.00
5079           y_prime(j) = 0.00
5080           z_prime(j) = 0.00
5081         enddo
5082 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5083 !     &   dc_norm(3,i+nres)
5084         do j = 1,3
5085           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5086           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5087         enddo
5088         do j = 1,3
5089           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5090         enddo
5091 !       write (2,*) "i",i
5092 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5093 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5094 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5095 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5096 !      & " xy",scalar(x_prime(1),y_prime(1)),
5097 !      & " xz",scalar(x_prime(1),z_prime(1)),
5098 !      & " yy",scalar(y_prime(1),y_prime(1)),
5099 !      & " yz",scalar(y_prime(1),z_prime(1)),
5100 !      & " zz",scalar(z_prime(1),z_prime(1))
5101 !
5102 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5103 ! to local coordinate system. Store in xx, yy, zz.
5104 !
5105         xx=0.0d0
5106         yy=0.0d0
5107         zz=0.0d0
5108         do j = 1,3
5109           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5110           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5111           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5112         enddo
5113
5114         xxtab(i)=xx
5115         yytab(i)=yy
5116         zztab(i)=zz
5117 !
5118 ! Compute the energy of the ith side cbain
5119 !
5120 !        write (2,*) "xx",xx," yy",yy," zz",zz
5121         it=iabs(itype(i))
5122         do j = 1,65
5123           x(j) = sc_parmin(j,it)
5124         enddo
5125 #ifdef CHECK_COORD
5126 !c diagnostics - remove later
5127         xx1 = dcos(alph(2))
5128         yy1 = dsin(alph(2))*dcos(omeg(2))
5129         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5130         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5131           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5132           xx1,yy1,zz1
5133 !,"  --- ", xx_w,yy_w,zz_w
5134 ! end diagnostics
5135 #endif
5136         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5137          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5138          + x(10)*yy*zz
5139         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5140          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5141          + x(20)*yy*zz
5142         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5143          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5144          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5145          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5146          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5147          +x(40)*xx*yy*zz
5148         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5149          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5150          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5151          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5152          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5153          +x(60)*xx*yy*zz
5154         dsc_i   = 0.743d0+x(61)
5155         dp2_i   = 1.9d0+x(62)
5156         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5157                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5158         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5159                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5160         s1=(1+x(63))/(0.1d0 + dscp1)
5161         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5162         s2=(1+x(65))/(0.1d0 + dscp2)
5163         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5164         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5165       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5166 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5167 !     &   sumene4,
5168 !     &   dscp1,dscp2,sumene
5169 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5170         escloc = escloc + sumene
5171 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5172 !     & ,zz,xx,yy
5173 !#define DEBUG
5174 #ifdef DEBUG
5175 !
5176 ! This section to check the numerical derivatives of the energy of ith side
5177 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5178 ! #define DEBUG in the code to turn it on.
5179 !
5180         write (2,*) "sumene               =",sumene
5181         aincr=1.0d-7
5182         xxsave=xx
5183         xx=xx+aincr
5184         write (2,*) xx,yy,zz
5185         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5186         de_dxx_num=(sumenep-sumene)/aincr
5187         xx=xxsave
5188         write (2,*) "xx+ sumene from enesc=",sumenep
5189         yysave=yy
5190         yy=yy+aincr
5191         write (2,*) xx,yy,zz
5192         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5193         de_dyy_num=(sumenep-sumene)/aincr
5194         yy=yysave
5195         write (2,*) "yy+ sumene from enesc=",sumenep
5196         zzsave=zz
5197         zz=zz+aincr
5198         write (2,*) xx,yy,zz
5199         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5200         de_dzz_num=(sumenep-sumene)/aincr
5201         zz=zzsave
5202         write (2,*) "zz+ sumene from enesc=",sumenep
5203         costsave=cost2tab(i+1)
5204         sintsave=sint2tab(i+1)
5205         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5206         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5207         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5208         de_dt_num=(sumenep-sumene)/aincr
5209         write (2,*) " t+ sumene from enesc=",sumenep
5210         cost2tab(i+1)=costsave
5211         sint2tab(i+1)=sintsave
5212 ! End of diagnostics section.
5213 #endif
5214 !
5215 ! Compute the gradient of esc
5216 !
5217 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5218         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5219         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5220         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5221         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5222         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5223         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5224         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5225         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5226         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5227            *(pom_s1/dscp1+pom_s16*dscp1**4)
5228         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5229            *(pom_s2/dscp2+pom_s26*dscp2**4)
5230         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5231         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5232         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5233         +x(40)*yy*zz
5234         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5235         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5236         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5237         +x(60)*yy*zz
5238         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5239               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5240               +(pom1+pom2)*pom_dx
5241 #ifdef DEBUG
5242         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5243 #endif
5244 !
5245         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5246         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5247         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5248         +x(40)*xx*zz
5249         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5250         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5251         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5252         +x(59)*zz**2 +x(60)*xx*zz
5253         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5254               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5255               +(pom1-pom2)*pom_dy
5256 #ifdef DEBUG
5257         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5258 #endif
5259 !
5260         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5261         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5262         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5263         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5264         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5265         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5266         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5267         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5268 #ifdef DEBUG
5269         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5270 #endif
5271 !
5272         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5273         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5274         +pom1*pom_dt1+pom2*pom_dt2
5275 #ifdef DEBUG
5276         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5277 #endif
5278 !
5279 !
5280        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5281        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5282        cosfac2xx=cosfac2*xx
5283        sinfac2yy=sinfac2*yy
5284        do k = 1,3
5285          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5286             vbld_inv(i+1)
5287          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5288             vbld_inv(i)
5289          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5290          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5291 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5292 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5293 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5294 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5295          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5296          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5297          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5298          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5299          dZZ_Ci1(k)=0.0d0
5300          dZZ_Ci(k)=0.0d0
5301          do j=1,3
5302            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5303            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5304            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5305            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5306          enddo
5307
5308          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5309          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5310          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5311          (z_prime(k)-zz*dC_norm(k,i+nres))
5312 !
5313          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5314          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5315        enddo
5316
5317        do k=1,3
5318          dXX_Ctab(k,i)=dXX_Ci(k)
5319          dXX_C1tab(k,i)=dXX_Ci1(k)
5320          dYY_Ctab(k,i)=dYY_Ci(k)
5321          dYY_C1tab(k,i)=dYY_Ci1(k)
5322          dZZ_Ctab(k,i)=dZZ_Ci(k)
5323          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5324          dXX_XYZtab(k,i)=dXX_XYZ(k)
5325          dYY_XYZtab(k,i)=dYY_XYZ(k)
5326          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5327        enddo
5328
5329        do k = 1,3
5330 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5331 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5332 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5333 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5334 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5335 !     &    dt_dci(k)
5336 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5337 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5338          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5339           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5340          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5341           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5342          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5343           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5344        enddo
5345 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5346 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5347
5348 ! to check gradient call subroutine check_grad
5349
5350     1 continue
5351       enddo
5352       return
5353       end subroutine esc
5354 !-----------------------------------------------------------------------------
5355       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5356 !      implicit none
5357       real(kind=8),dimension(65) :: x
5358       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5359         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5360
5361       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5362         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5363         + x(10)*yy*zz
5364       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5365         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5366         + x(20)*yy*zz
5367       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5368         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5369         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5370         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5371         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5372         +x(40)*xx*yy*zz
5373       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5374         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5375         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5376         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5377         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5378         +x(60)*xx*yy*zz
5379       dsc_i   = 0.743d0+x(61)
5380       dp2_i   = 1.9d0+x(62)
5381       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5382                 *(xx*cost2+yy*sint2))
5383       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5384                 *(xx*cost2-yy*sint2))
5385       s1=(1+x(63))/(0.1d0 + dscp1)
5386       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5387       s2=(1+x(65))/(0.1d0 + dscp2)
5388       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5389       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5390        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5391       enesc=sumene
5392       return
5393       end function enesc
5394 #endif
5395 !-----------------------------------------------------------------------------
5396       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5397 !
5398 ! This procedure calculates two-body contact function g(rij) and its derivative:
5399 !
5400 !           eps0ij                                     !       x < -1
5401 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5402 !            0                                         !       x > 1
5403 !
5404 ! where x=(rij-r0ij)/delta
5405 !
5406 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5407 !
5408 !      implicit none
5409       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5410       real(kind=8) :: x,x2,x4,delta
5411 !     delta=0.02D0*r0ij
5412 !      delta=0.2D0*r0ij
5413       x=(rij-r0ij)/delta
5414       if (x.lt.-1.0D0) then
5415         fcont=eps0ij
5416         fprimcont=0.0D0
5417       else if (x.le.1.0D0) then
5418         x2=x*x
5419         x4=x2*x2
5420         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5421         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5422       else
5423         fcont=0.0D0
5424         fprimcont=0.0D0
5425       endif
5426       return
5427       end subroutine gcont
5428 !-----------------------------------------------------------------------------
5429       subroutine splinthet(theti,delta,ss,ssder)
5430 !      implicit real*8 (a-h,o-z)
5431 !      include 'DIMENSIONS'
5432 !      include 'COMMON.VAR'
5433 !      include 'COMMON.GEO'
5434       real(kind=8) :: theti,delta,ss,ssder
5435       real(kind=8) :: thetup,thetlow
5436       thetup=pi-delta
5437       thetlow=delta
5438       if (theti.gt.pipol) then
5439         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5440       else
5441         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5442         ssder=-ssder
5443       endif
5444       return
5445       end subroutine splinthet
5446 !-----------------------------------------------------------------------------
5447       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5448 !      implicit none
5449       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5450       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5451       a1=fprim0*delta/(f1-f0)
5452       a2=3.0d0-2.0d0*a1
5453       a3=a1-2.0d0
5454       ksi=(x-x0)/delta
5455       ksi2=ksi*ksi
5456       ksi3=ksi2*ksi
5457       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5458       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5459       return
5460       end subroutine spline1
5461 !-----------------------------------------------------------------------------
5462       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5463 !      implicit none
5464       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5465       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5466       ksi=(x-x0)/delta
5467       ksi2=ksi*ksi
5468       ksi3=ksi2*ksi
5469       a1=fprim0x*delta
5470       a2=3*(f1x-f0x)-2*fprim0x*delta
5471       a3=fprim0x*delta-2*(f1x-f0x)
5472       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5473       return
5474       end subroutine spline2
5475 !-----------------------------------------------------------------------------
5476 #ifdef CRYST_TOR
5477 !-----------------------------------------------------------------------------
5478       subroutine etor(etors,edihcnstr)
5479 !      implicit real*8 (a-h,o-z)
5480 !      include 'DIMENSIONS'
5481 !      include 'COMMON.VAR'
5482 !      include 'COMMON.GEO'
5483 !      include 'COMMON.LOCAL'
5484 !      include 'COMMON.TORSION'
5485 !      include 'COMMON.INTERACT'
5486 !      include 'COMMON.DERIV'
5487 !      include 'COMMON.CHAIN'
5488 !      include 'COMMON.NAMES'
5489 !      include 'COMMON.IOUNITS'
5490 !      include 'COMMON.FFIELD'
5491 !      include 'COMMON.TORCNSTR'
5492 !      include 'COMMON.CONTROL'
5493       real(kind=8) :: etors,edihcnstr
5494       logical :: lprn
5495 !el local variables
5496       integer :: i,j,
5497       real(kind=8) :: phii,fac,etors_ii
5498
5499 ! Set lprn=.true. for debugging
5500       lprn=.false.
5501 !      lprn=.true.
5502       etors=0.0D0
5503       do i=iphi_start,iphi_end
5504       etors_ii=0.0D0
5505         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5506             .or. itype(i).eq.ntyp1) cycle
5507         itori=itortyp(itype(i-2))
5508         itori1=itortyp(itype(i-1))
5509         phii=phi(i)
5510         gloci=0.0D0
5511 ! Proline-Proline pair is a special case...
5512         if (itori.eq.3 .and. itori1.eq.3) then
5513           if (phii.gt.-dwapi3) then
5514             cosphi=dcos(3*phii)
5515             fac=1.0D0/(1.0D0-cosphi)
5516             etorsi=v1(1,3,3)*fac
5517             etorsi=etorsi+etorsi
5518             etors=etors+etorsi-v1(1,3,3)
5519             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5520             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5521           endif
5522           do j=1,3
5523             v1ij=v1(j+1,itori,itori1)
5524             v2ij=v2(j+1,itori,itori1)
5525             cosphi=dcos(j*phii)
5526             sinphi=dsin(j*phii)
5527             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5528             if (energy_dec) etors_ii=etors_ii+ &
5529                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5530             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5531           enddo
5532         else
5533           do j=1,nterm_old
5534             v1ij=v1(j,itori,itori1)
5535             v2ij=v2(j,itori,itori1)
5536             cosphi=dcos(j*phii)
5537             sinphi=dsin(j*phii)
5538             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5539             if (energy_dec) etors_ii=etors_ii+ &
5540                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5541             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5542           enddo
5543         endif
5544         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5545              'etor',i,etors_ii
5546         if (lprn) &
5547         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5548         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5549         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5550         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5551 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5552       enddo
5553 ! 6/20/98 - dihedral angle constraints
5554       edihcnstr=0.0d0
5555       do i=1,ndih_constr
5556         itori=idih_constr(i)
5557         phii=phi(itori)
5558         difi=phii-phi0(i)
5559         if (difi.gt.drange(i)) then
5560           difi=difi-drange(i)
5561           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5562           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5563         else if (difi.lt.-drange(i)) then
5564           difi=difi+drange(i)
5565           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5566           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5567         endif
5568 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5569 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5570       enddo
5571 !      write (iout,*) 'edihcnstr',edihcnstr
5572       return
5573       end subroutine etor
5574 !-----------------------------------------------------------------------------
5575       subroutine etor_d(etors_d)
5576       real(kind=8) :: etors_d
5577       etors_d=0.0d0
5578       return
5579       end subroutine etor_d
5580 #else
5581 !-----------------------------------------------------------------------------
5582       subroutine etor(etors,edihcnstr)
5583 !      implicit real*8 (a-h,o-z)
5584 !      include 'DIMENSIONS'
5585 !      include 'COMMON.VAR'
5586 !      include 'COMMON.GEO'
5587 !      include 'COMMON.LOCAL'
5588 !      include 'COMMON.TORSION'
5589 !      include 'COMMON.INTERACT'
5590 !      include 'COMMON.DERIV'
5591 !      include 'COMMON.CHAIN'
5592 !      include 'COMMON.NAMES'
5593 !      include 'COMMON.IOUNITS'
5594 !      include 'COMMON.FFIELD'
5595 !      include 'COMMON.TORCNSTR'
5596 !      include 'COMMON.CONTROL'
5597       real(kind=8) :: etors,edihcnstr
5598       logical :: lprn
5599 !el local variables
5600       integer :: i,j,iblock,itori,itori1
5601       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5602                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5603 ! Set lprn=.true. for debugging
5604       lprn=.false.
5605 !     lprn=.true.
5606       etors=0.0D0
5607       do i=iphi_start,iphi_end
5608         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5609              .or. itype(i-3).eq.ntyp1 &
5610              .or. itype(i).eq.ntyp1) cycle
5611         etors_ii=0.0D0
5612          if (iabs(itype(i)).eq.20) then
5613          iblock=2
5614          else
5615          iblock=1
5616          endif
5617         itori=itortyp(itype(i-2))
5618         itori1=itortyp(itype(i-1))
5619         phii=phi(i)
5620         gloci=0.0D0
5621 ! Regular cosine and sine terms
5622         do j=1,nterm(itori,itori1,iblock)
5623           v1ij=v1(j,itori,itori1,iblock)
5624           v2ij=v2(j,itori,itori1,iblock)
5625           cosphi=dcos(j*phii)
5626           sinphi=dsin(j*phii)
5627           etors=etors+v1ij*cosphi+v2ij*sinphi
5628           if (energy_dec) etors_ii=etors_ii+ &
5629                      v1ij*cosphi+v2ij*sinphi
5630           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5631         enddo
5632 ! Lorentz terms
5633 !                         v1
5634 !  E = SUM ----------------------------------- - v1
5635 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5636 !
5637         cosphi=dcos(0.5d0*phii)
5638         sinphi=dsin(0.5d0*phii)
5639         do j=1,nlor(itori,itori1,iblock)
5640           vl1ij=vlor1(j,itori,itori1)
5641           vl2ij=vlor2(j,itori,itori1)
5642           vl3ij=vlor3(j,itori,itori1)
5643           pom=vl2ij*cosphi+vl3ij*sinphi
5644           pom1=1.0d0/(pom*pom+1.0d0)
5645           etors=etors+vl1ij*pom1
5646           if (energy_dec) etors_ii=etors_ii+ &
5647                      vl1ij*pom1
5648           pom=-pom*pom1*pom1
5649           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5650         enddo
5651 ! Subtract the constant term
5652         etors=etors-v0(itori,itori1,iblock)
5653           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5654                'etor',i,etors_ii-v0(itori,itori1,iblock)
5655         if (lprn) &
5656         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5657         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5658         (v1(j,itori,itori1,iblock),j=1,6),&
5659         (v2(j,itori,itori1,iblock),j=1,6)
5660         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5661 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5662       enddo
5663 ! 6/20/98 - dihedral angle constraints
5664       edihcnstr=0.0d0
5665 !      do i=1,ndih_constr
5666       do i=idihconstr_start,idihconstr_end
5667         itori=idih_constr(i)
5668         phii=phi(itori)
5669         difi=pinorm(phii-phi0(i))
5670         if (difi.gt.drange(i)) then
5671           difi=difi-drange(i)
5672           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5673           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5674         else if (difi.lt.-drange(i)) then
5675           difi=difi+drange(i)
5676           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5677           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5678         else
5679           difi=0.0
5680         endif
5681 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5682 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5683 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5684       enddo
5685 !d       write (iout,*) 'edihcnstr',edihcnstr
5686       return
5687       end subroutine etor
5688 !-----------------------------------------------------------------------------
5689       subroutine etor_d(etors_d)
5690 ! 6/23/01 Compute double torsional energy
5691 !      implicit real*8 (a-h,o-z)
5692 !      include 'DIMENSIONS'
5693 !      include 'COMMON.VAR'
5694 !      include 'COMMON.GEO'
5695 !      include 'COMMON.LOCAL'
5696 !      include 'COMMON.TORSION'
5697 !      include 'COMMON.INTERACT'
5698 !      include 'COMMON.DERIV'
5699 !      include 'COMMON.CHAIN'
5700 !      include 'COMMON.NAMES'
5701 !      include 'COMMON.IOUNITS'
5702 !      include 'COMMON.FFIELD'
5703 !      include 'COMMON.TORCNSTR'
5704       real(kind=8) :: etors_d,etors_d_ii
5705       logical :: lprn
5706 !el local variables
5707       integer :: i,j,k,l,itori,itori1,itori2,iblock
5708       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5709                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5710                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5711                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5712 ! Set lprn=.true. for debugging
5713       lprn=.false.
5714 !     lprn=.true.
5715       etors_d=0.0D0
5716 !      write(iout,*) "a tu??"
5717       do i=iphid_start,iphid_end
5718         etors_d_ii=0.0D0
5719         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5720             .or. itype(i-3).eq.ntyp1 &
5721             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5722         itori=itortyp(itype(i-2))
5723         itori1=itortyp(itype(i-1))
5724         itori2=itortyp(itype(i))
5725         phii=phi(i)
5726         phii1=phi(i+1)
5727         gloci1=0.0D0
5728         gloci2=0.0D0
5729         iblock=1
5730         if (iabs(itype(i+1)).eq.20) iblock=2
5731
5732 ! Regular cosine and sine terms
5733         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5734           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5735           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5736           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5737           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5738           cosphi1=dcos(j*phii)
5739           sinphi1=dsin(j*phii)
5740           cosphi2=dcos(j*phii1)
5741           sinphi2=dsin(j*phii1)
5742           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5743            v2cij*cosphi2+v2sij*sinphi2
5744           if (energy_dec) etors_d_ii=etors_d_ii+ &
5745            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5746           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5747           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5748         enddo
5749         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5750           do l=1,k-1
5751             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5752             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5753             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5754             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5755             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5756             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5757             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5758             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5759             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5760               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5761             if (energy_dec) etors_d_ii=etors_d_ii+ &
5762               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5763               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5764             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5765               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5766             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5767               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5768           enddo
5769         enddo
5770         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5771                             'etor_d',i,etors_d_ii
5772         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5773         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5774       enddo
5775       return
5776       end subroutine etor_d
5777 #endif
5778 !-----------------------------------------------------------------------------
5779       subroutine eback_sc_corr(esccor)
5780 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5781 !        conformational states; temporarily implemented as differences
5782 !        between UNRES torsional potentials (dependent on three types of
5783 !        residues) and the torsional potentials dependent on all 20 types
5784 !        of residues computed from AM1  energy surfaces of terminally-blocked
5785 !        amino-acid residues.
5786 !      implicit real*8 (a-h,o-z)
5787 !      include 'DIMENSIONS'
5788 !      include 'COMMON.VAR'
5789 !      include 'COMMON.GEO'
5790 !      include 'COMMON.LOCAL'
5791 !      include 'COMMON.TORSION'
5792 !      include 'COMMON.SCCOR'
5793 !      include 'COMMON.INTERACT'
5794 !      include 'COMMON.DERIV'
5795 !      include 'COMMON.CHAIN'
5796 !      include 'COMMON.NAMES'
5797 !      include 'COMMON.IOUNITS'
5798 !      include 'COMMON.FFIELD'
5799 !      include 'COMMON.CONTROL'
5800       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5801                    cosphi,sinphi
5802       logical :: lprn
5803       integer :: i,interty,j,isccori,isccori1,intertyp
5804 ! Set lprn=.true. for debugging
5805       lprn=.false.
5806 !      lprn=.true.
5807 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5808       esccor=0.0D0
5809       do i=itau_start,itau_end
5810         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5811         esccor_ii=0.0D0
5812         isccori=isccortyp(itype(i-2))
5813         isccori1=isccortyp(itype(i-1))
5814
5815 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5816         phii=phi(i)
5817         do intertyp=1,3 !intertyp
5818          esccor_ii=0.0D0
5819 !c Added 09 May 2012 (Adasko)
5820 !c  Intertyp means interaction type of backbone mainchain correlation:
5821 !   1 = SC...Ca...Ca...Ca
5822 !   2 = Ca...Ca...Ca...SC
5823 !   3 = SC...Ca...Ca...SCi
5824         gloci=0.0D0
5825         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5826             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5827             (itype(i-1).eq.ntyp1))) &
5828           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5829            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5830            .or.(itype(i).eq.ntyp1))) &
5831           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5832             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5833             (itype(i-3).eq.ntyp1)))) cycle
5834         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5835         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5836        cycle
5837        do j=1,nterm_sccor(isccori,isccori1)
5838           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5839           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5840           cosphi=dcos(j*tauangle(intertyp,i))
5841           sinphi=dsin(j*tauangle(intertyp,i))
5842           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5843           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5844           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5845         enddo
5846         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
5847                                 'esccor',i,intertyp,esccor_ii
5848 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5849         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5850         if (lprn) &
5851         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5852         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5853         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5854         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5855         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5856        enddo !intertyp
5857       enddo
5858
5859       return
5860       end subroutine eback_sc_corr
5861 !-----------------------------------------------------------------------------
5862       subroutine multibody(ecorr)
5863 ! This subroutine calculates multi-body contributions to energy following
5864 ! the idea of Skolnick et al. If side chains I and J make a contact and
5865 ! at the same time side chains I+1 and J+1 make a contact, an extra
5866 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5867 !      implicit real*8 (a-h,o-z)
5868 !      include 'DIMENSIONS'
5869 !      include 'COMMON.IOUNITS'
5870 !      include 'COMMON.DERIV'
5871 !      include 'COMMON.INTERACT'
5872 !      include 'COMMON.CONTACTS'
5873       real(kind=8),dimension(3) :: gx,gx1
5874       logical :: lprn
5875       real(kind=8) :: ecorr
5876       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5877 ! Set lprn=.true. for debugging
5878       lprn=.false.
5879
5880       if (lprn) then
5881         write (iout,'(a)') 'Contact function values:'
5882         do i=nnt,nct-2
5883           write (iout,'(i2,20(1x,i2,f10.5))') &
5884               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5885         enddo
5886       endif
5887       ecorr=0.0D0
5888
5889 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
5890 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
5891       do i=nnt,nct
5892         do j=1,3
5893           gradcorr(j,i)=0.0D0
5894           gradxorr(j,i)=0.0D0
5895         enddo
5896       enddo
5897       do i=nnt,nct-2
5898
5899         DO ISHIFT = 3,4
5900
5901         i1=i+ishift
5902         num_conti=num_cont(i)
5903         num_conti1=num_cont(i1)
5904         do jj=1,num_conti
5905           j=jcont(jj,i)
5906           do kk=1,num_conti1
5907             j1=jcont(kk,i1)
5908             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5909 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5910 !d   &                   ' ishift=',ishift
5911 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5912 ! The system gains extra energy.
5913               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5914             endif   ! j1==j+-ishift
5915           enddo     ! kk
5916         enddo       ! jj
5917
5918         ENDDO ! ISHIFT
5919
5920       enddo         ! i
5921       return
5922       end subroutine multibody
5923 !-----------------------------------------------------------------------------
5924       real(kind=8) function esccorr(i,j,k,l,jj,kk)
5925 !      implicit real*8 (a-h,o-z)
5926 !      include 'DIMENSIONS'
5927 !      include 'COMMON.IOUNITS'
5928 !      include 'COMMON.DERIV'
5929 !      include 'COMMON.INTERACT'
5930 !      include 'COMMON.CONTACTS'
5931       real(kind=8),dimension(3) :: gx,gx1
5932       logical :: lprn
5933       integer :: i,j,k,l,jj,kk,m,ll
5934       real(kind=8) :: eij,ekl
5935       lprn=.false.
5936       eij=facont(jj,i)
5937       ekl=facont(kk,k)
5938 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5939 ! Calculate the multi-body contribution to energy.
5940 ! Calculate multi-body contributions to the gradient.
5941 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5942 !d   & k,l,(gacont(m,kk,k),m=1,3)
5943       do m=1,3
5944         gx(m) =ekl*gacont(m,jj,i)
5945         gx1(m)=eij*gacont(m,kk,k)
5946         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5947         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5948         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5949         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5950       enddo
5951       do m=i,j-1
5952         do ll=1,3
5953           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5954         enddo
5955       enddo
5956       do m=k,l-1
5957         do ll=1,3
5958           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5959         enddo
5960       enddo
5961       esccorr=-eij*ekl
5962       return
5963       end function esccorr
5964 !-----------------------------------------------------------------------------
5965       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5966 ! This subroutine calculates multi-body contributions to hydrogen-bonding
5967 !      implicit real*8 (a-h,o-z)
5968 !      include 'DIMENSIONS'
5969 !      include 'COMMON.IOUNITS'
5970 #ifdef MPI
5971       include "mpif.h"
5972 !      integer :: maxconts !max_cont=maxconts  =nres/4
5973       integer,parameter :: max_dim=26
5974       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5975       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
5976 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
5977 !el      common /przechowalnia/ zapas
5978       integer :: status(MPI_STATUS_SIZE)
5979       integer,dimension((nres/4)*2) :: req !maxconts*2
5980       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
5981 #endif
5982 !      include 'COMMON.SETUP'
5983 !      include 'COMMON.FFIELD'
5984 !      include 'COMMON.DERIV'
5985 !      include 'COMMON.INTERACT'
5986 !      include 'COMMON.CONTACTS'
5987 !      include 'COMMON.CONTROL'
5988 !      include 'COMMON.LOCAL'
5989       real(kind=8),dimension(3) :: gx,gx1
5990       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
5991       logical :: lprn,ldone
5992 !el local variables
5993       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
5994               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
5995
5996 ! Set lprn=.true. for debugging
5997       lprn=.false.
5998 #ifdef MPI
5999 !      maxconts=nres/4
6000       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6001       n_corr=0
6002       n_corr1=0
6003       if (nfgtasks.le.1) goto 30
6004       if (lprn) then
6005         write (iout,'(a)') 'Contact function values before RECEIVE:'
6006         do i=nnt,nct-2
6007           write (iout,'(2i3,50(1x,i2,f5.2))') &
6008           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6009           j=1,num_cont_hb(i))
6010         enddo
6011       endif
6012       call flush(iout)
6013       do i=1,ntask_cont_from
6014         ncont_recv(i)=0
6015       enddo
6016       do i=1,ntask_cont_to
6017         ncont_sent(i)=0
6018       enddo
6019 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6020 !     & ntask_cont_to
6021 ! Make the list of contacts to send to send to other procesors
6022 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6023 !      call flush(iout)
6024       do i=iturn3_start,iturn3_end
6025 !        write (iout,*) "make contact list turn3",i," num_cont",
6026 !     &    num_cont_hb(i)
6027         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6028       enddo
6029       do i=iturn4_start,iturn4_end
6030 !        write (iout,*) "make contact list turn4",i," num_cont",
6031 !     &   num_cont_hb(i)
6032         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6033       enddo
6034       do ii=1,nat_sent
6035         i=iat_sent(ii)
6036 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6037 !     &    num_cont_hb(i)
6038         do j=1,num_cont_hb(i)
6039         do k=1,4
6040           jjc=jcont_hb(j,i)
6041           iproc=iint_sent_local(k,jjc,ii)
6042 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6043           if (iproc.gt.0) then
6044             ncont_sent(iproc)=ncont_sent(iproc)+1
6045             nn=ncont_sent(iproc)
6046             zapas(1,nn,iproc)=i
6047             zapas(2,nn,iproc)=jjc
6048             zapas(3,nn,iproc)=facont_hb(j,i)
6049             zapas(4,nn,iproc)=ees0p(j,i)
6050             zapas(5,nn,iproc)=ees0m(j,i)
6051             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6052             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6053             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6054             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6055             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6056             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6057             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6058             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6059             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6060             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6061             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6062             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6063             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6064             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6065             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6066             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6067             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6068             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6069             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6070             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6071             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6072           endif
6073         enddo
6074         enddo
6075       enddo
6076       if (lprn) then
6077       write (iout,*) &
6078         "Numbers of contacts to be sent to other processors",&
6079         (ncont_sent(i),i=1,ntask_cont_to)
6080       write (iout,*) "Contacts sent"
6081       do ii=1,ntask_cont_to
6082         nn=ncont_sent(ii)
6083         iproc=itask_cont_to(ii)
6084         write (iout,*) nn," contacts to processor",iproc,&
6085          " of CONT_TO_COMM group"
6086         do i=1,nn
6087           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6088         enddo
6089       enddo
6090       call flush(iout)
6091       endif
6092       CorrelType=477
6093       CorrelID=fg_rank+1
6094       CorrelType1=478
6095       CorrelID1=nfgtasks+fg_rank+1
6096       ireq=0
6097 ! Receive the numbers of needed contacts from other processors
6098       do ii=1,ntask_cont_from
6099         iproc=itask_cont_from(ii)
6100         ireq=ireq+1
6101         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6102           FG_COMM,req(ireq),IERR)
6103       enddo
6104 !      write (iout,*) "IRECV ended"
6105 !      call flush(iout)
6106 ! Send the number of contacts needed by other processors
6107       do ii=1,ntask_cont_to
6108         iproc=itask_cont_to(ii)
6109         ireq=ireq+1
6110         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6111           FG_COMM,req(ireq),IERR)
6112       enddo
6113 !      write (iout,*) "ISEND ended"
6114 !      write (iout,*) "number of requests (nn)",ireq
6115       call flush(iout)
6116       if (ireq.gt.0) &
6117         call MPI_Waitall(ireq,req,status_array,ierr)
6118 !      write (iout,*)
6119 !     &  "Numbers of contacts to be received from other processors",
6120 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6121 !      call flush(iout)
6122 ! Receive contacts
6123       ireq=0
6124       do ii=1,ntask_cont_from
6125         iproc=itask_cont_from(ii)
6126         nn=ncont_recv(ii)
6127 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6128 !     &   " of CONT_TO_COMM group"
6129         call flush(iout)
6130         if (nn.gt.0) then
6131           ireq=ireq+1
6132           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6133           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6134 !          write (iout,*) "ireq,req",ireq,req(ireq)
6135         endif
6136       enddo
6137 ! Send the contacts to processors that need them
6138       do ii=1,ntask_cont_to
6139         iproc=itask_cont_to(ii)
6140         nn=ncont_sent(ii)
6141 !        write (iout,*) nn," contacts to processor",iproc,
6142 !     &   " of CONT_TO_COMM group"
6143         if (nn.gt.0) then
6144           ireq=ireq+1
6145           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6146             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6147 !          write (iout,*) "ireq,req",ireq,req(ireq)
6148 !          do i=1,nn
6149 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6150 !          enddo
6151         endif
6152       enddo
6153 !      write (iout,*) "number of requests (contacts)",ireq
6154 !      write (iout,*) "req",(req(i),i=1,4)
6155 !      call flush(iout)
6156       if (ireq.gt.0) &
6157        call MPI_Waitall(ireq,req,status_array,ierr)
6158       do iii=1,ntask_cont_from
6159         iproc=itask_cont_from(iii)
6160         nn=ncont_recv(iii)
6161         if (lprn) then
6162         write (iout,*) "Received",nn," contacts from processor",iproc,&
6163          " of CONT_FROM_COMM group"
6164         call flush(iout)
6165         do i=1,nn
6166           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6167         enddo
6168         call flush(iout)
6169         endif
6170         do i=1,nn
6171           ii=zapas_recv(1,i,iii)
6172 ! Flag the received contacts to prevent double-counting
6173           jj=-zapas_recv(2,i,iii)
6174 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6175 !          call flush(iout)
6176           nnn=num_cont_hb(ii)+1
6177           num_cont_hb(ii)=nnn
6178           jcont_hb(nnn,ii)=jj
6179           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6180           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6181           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6182           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6183           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6184           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6185           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6186           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6187           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6188           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6189           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6190           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6191           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6192           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6193           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6194           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6195           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6196           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6197           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6198           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6199           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6200           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6201           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6202           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6203         enddo
6204       enddo
6205       call flush(iout)
6206       if (lprn) then
6207         write (iout,'(a)') 'Contact function values after receive:'
6208         do i=nnt,nct-2
6209           write (iout,'(2i3,50(1x,i3,f5.2))') &
6210           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6211           j=1,num_cont_hb(i))
6212         enddo
6213         call flush(iout)
6214       endif
6215    30 continue
6216 #endif
6217       if (lprn) then
6218         write (iout,'(a)') 'Contact function values:'
6219         do i=nnt,nct-2
6220           write (iout,'(2i3,50(1x,i3,f5.2))') &
6221           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6222           j=1,num_cont_hb(i))
6223         enddo
6224       endif
6225       ecorr=0.0D0
6226
6227 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6228 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6229 ! Remove the loop below after debugging !!!
6230       do i=nnt,nct
6231         do j=1,3
6232           gradcorr(j,i)=0.0D0
6233           gradxorr(j,i)=0.0D0
6234         enddo
6235       enddo
6236 ! Calculate the local-electrostatic correlation terms
6237       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6238         i1=i+1
6239         num_conti=num_cont_hb(i)
6240         num_conti1=num_cont_hb(i+1)
6241         do jj=1,num_conti
6242           j=jcont_hb(jj,i)
6243           jp=iabs(j)
6244           do kk=1,num_conti1
6245             j1=jcont_hb(kk,i1)
6246             jp1=iabs(j1)
6247 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6248 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6249             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6250                 .or. j.lt.0 .and. j1.gt.0) .and. &
6251                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6252 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6253 ! The system gains extra energy.
6254               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6255               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6256                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6257               n_corr=n_corr+1
6258             else if (j1.eq.j) then
6259 ! Contacts I-J and I-(J+1) occur simultaneously.
6260 ! The system loses extra energy.
6261 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6262             endif
6263           enddo ! kk
6264           do kk=1,num_conti
6265             j1=jcont_hb(kk,i)
6266 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6267 !    &         ' jj=',jj,' kk=',kk
6268             if (j1.eq.j+1) then
6269 ! Contacts I-J and (I+1)-J occur simultaneously.
6270 ! The system loses extra energy.
6271 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6272             endif ! j1==j+1
6273           enddo ! kk
6274         enddo ! jj
6275       enddo ! i
6276       return
6277       end subroutine multibody_hb
6278 !-----------------------------------------------------------------------------
6279       subroutine add_hb_contact(ii,jj,itask)
6280 !      implicit real*8 (a-h,o-z)
6281 !      include "DIMENSIONS"
6282 !      include "COMMON.IOUNITS"
6283 !      include "COMMON.CONTACTS"
6284 !      integer,parameter :: maxconts=nres/4
6285       integer,parameter :: max_dim=26
6286       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6287 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6288 !      common /przechowalnia/ zapas
6289       integer :: i,j,ii,jj,iproc,nn,jjc
6290       integer,dimension(4) :: itask
6291 !      write (iout,*) "itask",itask
6292       do i=1,2
6293         iproc=itask(i)
6294         if (iproc.gt.0) then
6295           do j=1,num_cont_hb(ii)
6296             jjc=jcont_hb(j,ii)
6297 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6298             if (jjc.eq.jj) then
6299               ncont_sent(iproc)=ncont_sent(iproc)+1
6300               nn=ncont_sent(iproc)
6301               zapas(1,nn,iproc)=ii
6302               zapas(2,nn,iproc)=jjc
6303               zapas(3,nn,iproc)=facont_hb(j,ii)
6304               zapas(4,nn,iproc)=ees0p(j,ii)
6305               zapas(5,nn,iproc)=ees0m(j,ii)
6306               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6307               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6308               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6309               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6310               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6311               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6312               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6313               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6314               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6315               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6316               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6317               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6318               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6319               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6320               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6321               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6322               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6323               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6324               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6325               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6326               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6327               exit
6328             endif
6329           enddo
6330         endif
6331       enddo
6332       return
6333       end subroutine add_hb_contact
6334 !-----------------------------------------------------------------------------
6335       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6336 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6337 !      implicit real*8 (a-h,o-z)
6338 !      include 'DIMENSIONS'
6339 !      include 'COMMON.IOUNITS'
6340       integer,parameter :: max_dim=70
6341 #ifdef MPI
6342       include "mpif.h"
6343 !      integer :: maxconts !max_cont=maxconts=nres/4
6344       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6345       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6346 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6347 !      common /przechowalnia/ zapas
6348       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6349         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6350         ierr,iii,nnn
6351 #endif
6352 !      include 'COMMON.SETUP'
6353 !      include 'COMMON.FFIELD'
6354 !      include 'COMMON.DERIV'
6355 !      include 'COMMON.LOCAL'
6356 !      include 'COMMON.INTERACT'
6357 !      include 'COMMON.CONTACTS'
6358 !      include 'COMMON.CHAIN'
6359 !      include 'COMMON.CONTROL'
6360       real(kind=8),dimension(3) :: gx,gx1
6361       integer,dimension(nres) :: num_cont_hb_old
6362       logical :: lprn,ldone
6363 !EL      double precision eello4,eello5,eelo6,eello_turn6
6364 !EL      external eello4,eello5,eello6,eello_turn6
6365 !el local variables
6366       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6367               j1,jp1,i1,num_conti1
6368       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6369       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6370
6371 ! Set lprn=.true. for debugging
6372       lprn=.false.
6373       eturn6=0.0d0
6374 #ifdef MPI
6375 !      maxconts=nres/4
6376       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6377       do i=1,nres
6378         num_cont_hb_old(i)=num_cont_hb(i)
6379       enddo
6380       n_corr=0
6381       n_corr1=0
6382       if (nfgtasks.le.1) goto 30
6383       if (lprn) then
6384         write (iout,'(a)') 'Contact function values before RECEIVE:'
6385         do i=nnt,nct-2
6386           write (iout,'(2i3,50(1x,i2,f5.2))') &
6387           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6388           j=1,num_cont_hb(i))
6389         enddo
6390       endif
6391       call flush(iout)
6392       do i=1,ntask_cont_from
6393         ncont_recv(i)=0
6394       enddo
6395       do i=1,ntask_cont_to
6396         ncont_sent(i)=0
6397       enddo
6398 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6399 !     & ntask_cont_to
6400 ! Make the list of contacts to send to send to other procesors
6401       do i=iturn3_start,iturn3_end
6402 !        write (iout,*) "make contact list turn3",i," num_cont",
6403 !     &    num_cont_hb(i)
6404         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6405       enddo
6406       do i=iturn4_start,iturn4_end
6407 !        write (iout,*) "make contact list turn4",i," num_cont",
6408 !     &   num_cont_hb(i)
6409         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6410       enddo
6411       do ii=1,nat_sent
6412         i=iat_sent(ii)
6413 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6414 !     &    num_cont_hb(i)
6415         do j=1,num_cont_hb(i)
6416         do k=1,4
6417           jjc=jcont_hb(j,i)
6418           iproc=iint_sent_local(k,jjc,ii)
6419 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6420           if (iproc.ne.0) then
6421             ncont_sent(iproc)=ncont_sent(iproc)+1
6422             nn=ncont_sent(iproc)
6423             zapas(1,nn,iproc)=i
6424             zapas(2,nn,iproc)=jjc
6425             zapas(3,nn,iproc)=d_cont(j,i)
6426             ind=3
6427             do kk=1,3
6428               ind=ind+1
6429               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6430             enddo
6431             do kk=1,2
6432               do ll=1,2
6433                 ind=ind+1
6434                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6435               enddo
6436             enddo
6437             do jj=1,5
6438               do kk=1,3
6439                 do ll=1,2
6440                   do mm=1,2
6441                     ind=ind+1
6442                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6443                   enddo
6444                 enddo
6445               enddo
6446             enddo
6447           endif
6448         enddo
6449         enddo
6450       enddo
6451       if (lprn) then
6452       write (iout,*) &
6453         "Numbers of contacts to be sent to other processors",&
6454         (ncont_sent(i),i=1,ntask_cont_to)
6455       write (iout,*) "Contacts sent"
6456       do ii=1,ntask_cont_to
6457         nn=ncont_sent(ii)
6458         iproc=itask_cont_to(ii)
6459         write (iout,*) nn," contacts to processor",iproc,&
6460          " of CONT_TO_COMM group"
6461         do i=1,nn
6462           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6463         enddo
6464       enddo
6465       call flush(iout)
6466       endif
6467       CorrelType=477
6468       CorrelID=fg_rank+1
6469       CorrelType1=478
6470       CorrelID1=nfgtasks+fg_rank+1
6471       ireq=0
6472 ! Receive the numbers of needed contacts from other processors
6473       do ii=1,ntask_cont_from
6474         iproc=itask_cont_from(ii)
6475         ireq=ireq+1
6476         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6477           FG_COMM,req(ireq),IERR)
6478       enddo
6479 !      write (iout,*) "IRECV ended"
6480 !      call flush(iout)
6481 ! Send the number of contacts needed by other processors
6482       do ii=1,ntask_cont_to
6483         iproc=itask_cont_to(ii)
6484         ireq=ireq+1
6485         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6486           FG_COMM,req(ireq),IERR)
6487       enddo
6488 !      write (iout,*) "ISEND ended"
6489 !      write (iout,*) "number of requests (nn)",ireq
6490       call flush(iout)
6491       if (ireq.gt.0) &
6492         call MPI_Waitall(ireq,req,status_array,ierr)
6493 !      write (iout,*)
6494 !     &  "Numbers of contacts to be received from other processors",
6495 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6496 !      call flush(iout)
6497 ! Receive contacts
6498       ireq=0
6499       do ii=1,ntask_cont_from
6500         iproc=itask_cont_from(ii)
6501         nn=ncont_recv(ii)
6502 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6503 !     &   " of CONT_TO_COMM group"
6504         call flush(iout)
6505         if (nn.gt.0) then
6506           ireq=ireq+1
6507           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6508           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6509 !          write (iout,*) "ireq,req",ireq,req(ireq)
6510         endif
6511       enddo
6512 ! Send the contacts to processors that need them
6513       do ii=1,ntask_cont_to
6514         iproc=itask_cont_to(ii)
6515         nn=ncont_sent(ii)
6516 !        write (iout,*) nn," contacts to processor",iproc,
6517 !     &   " of CONT_TO_COMM group"
6518         if (nn.gt.0) then
6519           ireq=ireq+1
6520           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6521             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6522 !          write (iout,*) "ireq,req",ireq,req(ireq)
6523 !          do i=1,nn
6524 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6525 !          enddo
6526         endif
6527       enddo
6528 !      write (iout,*) "number of requests (contacts)",ireq
6529 !      write (iout,*) "req",(req(i),i=1,4)
6530 !      call flush(iout)
6531       if (ireq.gt.0) &
6532        call MPI_Waitall(ireq,req,status_array,ierr)
6533       do iii=1,ntask_cont_from
6534         iproc=itask_cont_from(iii)
6535         nn=ncont_recv(iii)
6536         if (lprn) then
6537         write (iout,*) "Received",nn," contacts from processor",iproc,&
6538          " of CONT_FROM_COMM group"
6539         call flush(iout)
6540         do i=1,nn
6541           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6542         enddo
6543         call flush(iout)
6544         endif
6545         do i=1,nn
6546           ii=zapas_recv(1,i,iii)
6547 ! Flag the received contacts to prevent double-counting
6548           jj=-zapas_recv(2,i,iii)
6549 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6550 !          call flush(iout)
6551           nnn=num_cont_hb(ii)+1
6552           num_cont_hb(ii)=nnn
6553           jcont_hb(nnn,ii)=jj
6554           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6555           ind=3
6556           do kk=1,3
6557             ind=ind+1
6558             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6559           enddo
6560           do kk=1,2
6561             do ll=1,2
6562               ind=ind+1
6563               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6564             enddo
6565           enddo
6566           do jj=1,5
6567             do kk=1,3
6568               do ll=1,2
6569                 do mm=1,2
6570                   ind=ind+1
6571                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6572                 enddo
6573               enddo
6574             enddo
6575           enddo
6576         enddo
6577       enddo
6578       call flush(iout)
6579       if (lprn) then
6580         write (iout,'(a)') 'Contact function values after receive:'
6581         do i=nnt,nct-2
6582           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6583           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6584           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6585         enddo
6586         call flush(iout)
6587       endif
6588    30 continue
6589 #endif
6590       if (lprn) then
6591         write (iout,'(a)') 'Contact function values:'
6592         do i=nnt,nct-2
6593           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6594           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6595           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6596         enddo
6597       endif
6598       ecorr=0.0D0
6599       ecorr5=0.0d0
6600       ecorr6=0.0d0
6601
6602 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6603 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6604 ! Remove the loop below after debugging !!!
6605       do i=nnt,nct
6606         do j=1,3
6607           gradcorr(j,i)=0.0D0
6608           gradxorr(j,i)=0.0D0
6609         enddo
6610       enddo
6611 ! Calculate the dipole-dipole interaction energies
6612       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6613       do i=iatel_s,iatel_e+1
6614         num_conti=num_cont_hb(i)
6615         do jj=1,num_conti
6616           j=jcont_hb(jj,i)
6617 #ifdef MOMENT
6618           call dipole(i,j,jj)
6619 #endif
6620         enddo
6621       enddo
6622       endif
6623 ! Calculate the local-electrostatic correlation terms
6624 !                write (iout,*) "gradcorr5 in eello5 before loop"
6625 !                do iii=1,nres
6626 !                  write (iout,'(i5,3f10.5)')
6627 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6628 !                enddo
6629       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6630 !        write (iout,*) "corr loop i",i
6631         i1=i+1
6632         num_conti=num_cont_hb(i)
6633         num_conti1=num_cont_hb(i+1)
6634         do jj=1,num_conti
6635           j=jcont_hb(jj,i)
6636           jp=iabs(j)
6637           do kk=1,num_conti1
6638             j1=jcont_hb(kk,i1)
6639             jp1=iabs(j1)
6640 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6641 !     &         ' jj=',jj,' kk=',kk
6642 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6643             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6644                 .or. j.lt.0 .and. j1.gt.0) .and. &
6645                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6646 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6647 ! The system gains extra energy.
6648               n_corr=n_corr+1
6649               sqd1=dsqrt(d_cont(jj,i))
6650               sqd2=dsqrt(d_cont(kk,i1))
6651               sred_geom = sqd1*sqd2
6652               IF (sred_geom.lt.cutoff_corr) THEN
6653                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6654                   ekont,fprimcont)
6655 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6656 !d     &         ' jj=',jj,' kk=',kk
6657                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6658                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6659                 do l=1,3
6660                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6661                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6662                 enddo
6663                 n_corr1=n_corr1+1
6664 !d               write (iout,*) 'sred_geom=',sred_geom,
6665 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6666 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6667 !d               write (iout,*) "g_contij",g_contij
6668 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6669 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6670                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6671                 if (wcorr4.gt.0.0d0) &
6672                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6673                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6674                        write (iout,'(a6,4i5,0pf7.3)') &
6675                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6676 !                write (iout,*) "gradcorr5 before eello5"
6677 !                do iii=1,nres
6678 !                  write (iout,'(i5,3f10.5)')
6679 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6680 !                enddo
6681                 if (wcorr5.gt.0.0d0) &
6682                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6683 !                write (iout,*) "gradcorr5 after eello5"
6684 !                do iii=1,nres
6685 !                  write (iout,'(i5,3f10.5)')
6686 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6687 !                enddo
6688                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6689                        write (iout,'(a6,4i5,0pf7.3)') &
6690                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6691 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6692 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6693                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6694                      .or. wturn6.eq.0.0d0))then
6695 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6696                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6697                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6698                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6699 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6700 !d     &            'ecorr6=',ecorr6
6701 !d                write (iout,'(4e15.5)') sred_geom,
6702 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6703 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6704 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6705                 else if (wturn6.gt.0.0d0 &
6706                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6707 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6708                   eturn6=eturn6+eello_turn6(i,jj,kk)
6709                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6710                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6711 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6712                 endif
6713               ENDIF
6714 1111          continue
6715             endif
6716           enddo ! kk
6717         enddo ! jj
6718       enddo ! i
6719       do i=1,nres
6720         num_cont_hb(i)=num_cont_hb_old(i)
6721       enddo
6722 !                write (iout,*) "gradcorr5 in eello5"
6723 !                do iii=1,nres
6724 !                  write (iout,'(i5,3f10.5)')
6725 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6726 !                enddo
6727       return
6728       end subroutine multibody_eello
6729 !-----------------------------------------------------------------------------
6730       subroutine add_hb_contact_eello(ii,jj,itask)
6731 !      implicit real*8 (a-h,o-z)
6732 !      include "DIMENSIONS"
6733 !      include "COMMON.IOUNITS"
6734 !      include "COMMON.CONTACTS"
6735 !      integer,parameter :: maxconts=nres/4
6736       integer,parameter :: max_dim=70
6737       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6738 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6739 !      common /przechowalnia/ zapas
6740
6741       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6742       integer,dimension(4) ::itask
6743 !      write (iout,*) "itask",itask
6744       do i=1,2
6745         iproc=itask(i)
6746         if (iproc.gt.0) then
6747           do j=1,num_cont_hb(ii)
6748             jjc=jcont_hb(j,ii)
6749 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6750             if (jjc.eq.jj) then
6751               ncont_sent(iproc)=ncont_sent(iproc)+1
6752               nn=ncont_sent(iproc)
6753               zapas(1,nn,iproc)=ii
6754               zapas(2,nn,iproc)=jjc
6755               zapas(3,nn,iproc)=d_cont(j,ii)
6756               ind=3
6757               do kk=1,3
6758                 ind=ind+1
6759                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6760               enddo
6761               do kk=1,2
6762                 do ll=1,2
6763                   ind=ind+1
6764                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6765                 enddo
6766               enddo
6767               do jj=1,5
6768                 do kk=1,3
6769                   do ll=1,2
6770                     do mm=1,2
6771                       ind=ind+1
6772                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6773                     enddo
6774                   enddo
6775                 enddo
6776               enddo
6777               exit
6778             endif
6779           enddo
6780         endif
6781       enddo
6782       return
6783       end subroutine add_hb_contact_eello
6784 !-----------------------------------------------------------------------------
6785       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6786 !      implicit real*8 (a-h,o-z)
6787 !      include 'DIMENSIONS'
6788 !      include 'COMMON.IOUNITS'
6789 !      include 'COMMON.DERIV'
6790 !      include 'COMMON.INTERACT'
6791 !      include 'COMMON.CONTACTS'
6792       real(kind=8),dimension(3) :: gx,gx1
6793       logical :: lprn
6794 !el local variables
6795       integer :: i,j,k,l,jj,kk,ll
6796       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6797                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6798                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6799
6800       lprn=.false.
6801       eij=facont_hb(jj,i)
6802       ekl=facont_hb(kk,k)
6803       ees0pij=ees0p(jj,i)
6804       ees0pkl=ees0p(kk,k)
6805       ees0mij=ees0m(jj,i)
6806       ees0mkl=ees0m(kk,k)
6807       ekont=eij*ekl
6808       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6809 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6810 ! Following 4 lines for diagnostics.
6811 !d    ees0pkl=0.0D0
6812 !d    ees0pij=1.0D0
6813 !d    ees0mkl=0.0D0
6814 !d    ees0mij=1.0D0
6815 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6816 !     & 'Contacts ',i,j,
6817 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6818 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6819 !     & 'gradcorr_long'
6820 ! Calculate the multi-body contribution to energy.
6821 !      ecorr=ecorr+ekont*ees
6822 ! Calculate multi-body contributions to the gradient.
6823       coeffpees0pij=coeffp*ees0pij
6824       coeffmees0mij=coeffm*ees0mij
6825       coeffpees0pkl=coeffp*ees0pkl
6826       coeffmees0mkl=coeffm*ees0mkl
6827       do ll=1,3
6828 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6829         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6830         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6831         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6832         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6833         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6834         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6835 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6836         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6837         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6838         coeffmees0mij*gacontm_hb1(ll,kk,k))
6839         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6840         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6841         coeffmees0mij*gacontm_hb2(ll,kk,k))
6842         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6843            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6844            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6845         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6846         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6847         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6848            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6849            coeffmees0mij*gacontm_hb3(ll,kk,k))
6850         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6851         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6852 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6853       enddo
6854 !      write (iout,*)
6855 !grad      do m=i+1,j-1
6856 !grad        do ll=1,3
6857 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6858 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6859 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6860 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6861 !grad        enddo
6862 !grad      enddo
6863 !grad      do m=k+1,l-1
6864 !grad        do ll=1,3
6865 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6866 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6867 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6868 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6869 !grad        enddo
6870 !grad      enddo
6871 !      write (iout,*) "ehbcorr",ekont*ees
6872       ehbcorr=ekont*ees
6873       return
6874       end function ehbcorr
6875 #ifdef MOMENT
6876 !-----------------------------------------------------------------------------
6877       subroutine dipole(i,j,jj)
6878 !      implicit real*8 (a-h,o-z)
6879 !      include 'DIMENSIONS'
6880 !      include 'COMMON.IOUNITS'
6881 !      include 'COMMON.CHAIN'
6882 !      include 'COMMON.FFIELD'
6883 !      include 'COMMON.DERIV'
6884 !      include 'COMMON.INTERACT'
6885 !      include 'COMMON.CONTACTS'
6886 !      include 'COMMON.TORSION'
6887 !      include 'COMMON.VAR'
6888 !      include 'COMMON.GEO'
6889       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
6890       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
6891       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
6892
6893       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
6894       allocate(dipderx(3,5,4,maxconts,nres))
6895 !
6896
6897       iti1 = itortyp(itype(i+1))
6898       if (j.lt.nres-1) then
6899         itj1 = itortyp(itype(j+1))
6900       else
6901         itj1=ntortyp+1
6902       endif
6903       do iii=1,2
6904         dipi(iii,1)=Ub2(iii,i)
6905         dipderi(iii)=Ub2der(iii,i)
6906         dipi(iii,2)=b1(iii,iti1)
6907         dipj(iii,1)=Ub2(iii,j)
6908         dipderj(iii)=Ub2der(iii,j)
6909         dipj(iii,2)=b1(iii,itj1)
6910       enddo
6911       kkk=0
6912       do iii=1,2
6913         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6914         do jjj=1,2
6915           kkk=kkk+1
6916           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6917         enddo
6918       enddo
6919       do kkk=1,5
6920         do lll=1,3
6921           mmm=0
6922           do iii=1,2
6923             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
6924               auxvec(1))
6925             do jjj=1,2
6926               mmm=mmm+1
6927               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6928             enddo
6929           enddo
6930         enddo
6931       enddo
6932       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6933       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6934       do iii=1,2
6935         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6936       enddo
6937       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6938       do iii=1,2
6939         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6940       enddo
6941       return
6942       end subroutine dipole
6943 #endif
6944 !-----------------------------------------------------------------------------
6945       subroutine calc_eello(i,j,k,l,jj,kk)
6946 !
6947 ! This subroutine computes matrices and vectors needed to calculate
6948 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
6949 !
6950       use comm_kut
6951 !      implicit real*8 (a-h,o-z)
6952 !      include 'DIMENSIONS'
6953 !      include 'COMMON.IOUNITS'
6954 !      include 'COMMON.CHAIN'
6955 !      include 'COMMON.DERIV'
6956 !      include 'COMMON.INTERACT'
6957 !      include 'COMMON.CONTACTS'
6958 !      include 'COMMON.TORSION'
6959 !      include 'COMMON.VAR'
6960 !      include 'COMMON.GEO'
6961 !      include 'COMMON.FFIELD'
6962       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
6963       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
6964       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
6965               itj1
6966 !el      logical :: lprn
6967 !el      common /kutas/ lprn
6968 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6969 !d     & ' jj=',jj,' kk=',kk
6970 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6971 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6972 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6973       do iii=1,2
6974         do jjj=1,2
6975           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6976           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6977         enddo
6978       enddo
6979       call transpose2(aa1(1,1),aa1t(1,1))
6980       call transpose2(aa2(1,1),aa2t(1,1))
6981       do kkk=1,5
6982         do lll=1,3
6983           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
6984             aa1tder(1,1,lll,kkk))
6985           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
6986             aa2tder(1,1,lll,kkk))
6987         enddo
6988       enddo
6989       if (l.eq.j+1) then
6990 ! parallel orientation of the two CA-CA-CA frames.
6991         if (i.gt.1) then
6992           iti=itortyp(itype(i))
6993         else
6994           iti=ntortyp+1
6995         endif
6996         itk1=itortyp(itype(k+1))
6997         itj=itortyp(itype(j))
6998         if (l.lt.nres-1) then
6999           itl1=itortyp(itype(l+1))
7000         else
7001           itl1=ntortyp+1
7002         endif
7003 ! A1 kernel(j+1) A2T
7004 !d        do iii=1,2
7005 !d          write (iout,'(3f10.5,5x,3f10.5)')
7006 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7007 !d        enddo
7008         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7009          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7010          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7011 ! Following matrices are needed only for 6-th order cumulants
7012         IF (wcorr6.gt.0.0d0) THEN
7013         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7014          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7015          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7016         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7017          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7018          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7019          ADtEAderx(1,1,1,1,1,1))
7020         lprn=.false.
7021         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7022          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7023          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7024          ADtEA1derx(1,1,1,1,1,1))
7025         ENDIF
7026 ! End 6-th order cumulants
7027 !d        lprn=.false.
7028 !d        if (lprn) then
7029 !d        write (2,*) 'In calc_eello6'
7030 !d        do iii=1,2
7031 !d          write (2,*) 'iii=',iii
7032 !d          do kkk=1,5
7033 !d            write (2,*) 'kkk=',kkk
7034 !d            do jjj=1,2
7035 !d              write (2,'(3(2f10.5),5x)')
7036 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7037 !d            enddo
7038 !d          enddo
7039 !d        enddo
7040 !d        endif
7041         call transpose2(EUgder(1,1,k),auxmat(1,1))
7042         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7043         call transpose2(EUg(1,1,k),auxmat(1,1))
7044         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7045         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7046         do iii=1,2
7047           do kkk=1,5
7048             do lll=1,3
7049               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7050                 EAEAderx(1,1,lll,kkk,iii,1))
7051             enddo
7052           enddo
7053         enddo
7054 ! A1T kernel(i+1) A2
7055         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7056          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7057          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7058 ! Following matrices are needed only for 6-th order cumulants
7059         IF (wcorr6.gt.0.0d0) THEN
7060         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7061          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7062          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7063         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7064          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7065          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7066          ADtEAderx(1,1,1,1,1,2))
7067         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7068          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7069          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7070          ADtEA1derx(1,1,1,1,1,2))
7071         ENDIF
7072 ! End 6-th order cumulants
7073         call transpose2(EUgder(1,1,l),auxmat(1,1))
7074         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7075         call transpose2(EUg(1,1,l),auxmat(1,1))
7076         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7077         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7078         do iii=1,2
7079           do kkk=1,5
7080             do lll=1,3
7081               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7082                 EAEAderx(1,1,lll,kkk,iii,2))
7083             enddo
7084           enddo
7085         enddo
7086 ! AEAb1 and AEAb2
7087 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7088 ! They are needed only when the fifth- or the sixth-order cumulants are
7089 ! indluded.
7090         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7091         call transpose2(AEA(1,1,1),auxmat(1,1))
7092         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7093         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7094         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7095         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7096         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7097         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7098         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7099         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7100         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7101         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7102         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7103         call transpose2(AEA(1,1,2),auxmat(1,1))
7104         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7105         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7106         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7107         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7108         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7109         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7110         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7111         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7112         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7113         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7114         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7115 ! Calculate the Cartesian derivatives of the vectors.
7116         do iii=1,2
7117           do kkk=1,5
7118             do lll=1,3
7119               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7120               call matvec2(auxmat(1,1),b1(1,iti),&
7121                 AEAb1derx(1,lll,kkk,iii,1,1))
7122               call matvec2(auxmat(1,1),Ub2(1,i),&
7123                 AEAb2derx(1,lll,kkk,iii,1,1))
7124               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7125                 AEAb1derx(1,lll,kkk,iii,2,1))
7126               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7127                 AEAb2derx(1,lll,kkk,iii,2,1))
7128               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7129               call matvec2(auxmat(1,1),b1(1,itj),&
7130                 AEAb1derx(1,lll,kkk,iii,1,2))
7131               call matvec2(auxmat(1,1),Ub2(1,j),&
7132                 AEAb2derx(1,lll,kkk,iii,1,2))
7133               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7134                 AEAb1derx(1,lll,kkk,iii,2,2))
7135               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7136                 AEAb2derx(1,lll,kkk,iii,2,2))
7137             enddo
7138           enddo
7139         enddo
7140         ENDIF
7141 ! End vectors
7142       else
7143 ! Antiparallel orientation of the two CA-CA-CA frames.
7144         if (i.gt.1) then
7145           iti=itortyp(itype(i))
7146         else
7147           iti=ntortyp+1
7148         endif
7149         itk1=itortyp(itype(k+1))
7150         itl=itortyp(itype(l))
7151         itj=itortyp(itype(j))
7152         if (j.lt.nres-1) then
7153           itj1=itortyp(itype(j+1))
7154         else
7155           itj1=ntortyp+1
7156         endif
7157 ! A2 kernel(j-1)T A1T
7158         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7159          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7160          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7161 ! Following matrices are needed only for 6-th order cumulants
7162         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7163            j.eq.i+4 .and. l.eq.i+3)) THEN
7164         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7165          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7166          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7167         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7168          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7169          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7170          ADtEAderx(1,1,1,1,1,1))
7171         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7172          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7173          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7174          ADtEA1derx(1,1,1,1,1,1))
7175         ENDIF
7176 ! End 6-th order cumulants
7177         call transpose2(EUgder(1,1,k),auxmat(1,1))
7178         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7179         call transpose2(EUg(1,1,k),auxmat(1,1))
7180         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7181         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7182         do iii=1,2
7183           do kkk=1,5
7184             do lll=1,3
7185               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7186                 EAEAderx(1,1,lll,kkk,iii,1))
7187             enddo
7188           enddo
7189         enddo
7190 ! A2T kernel(i+1)T A1
7191         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7192          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7193          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7194 ! Following matrices are needed only for 6-th order cumulants
7195         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7196            j.eq.i+4 .and. l.eq.i+3)) THEN
7197         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7198          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7199          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7200         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7201          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7202          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7203          ADtEAderx(1,1,1,1,1,2))
7204         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7205          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7206          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7207          ADtEA1derx(1,1,1,1,1,2))
7208         ENDIF
7209 ! End 6-th order cumulants
7210         call transpose2(EUgder(1,1,j),auxmat(1,1))
7211         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7212         call transpose2(EUg(1,1,j),auxmat(1,1))
7213         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7214         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7215         do iii=1,2
7216           do kkk=1,5
7217             do lll=1,3
7218               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7219                 EAEAderx(1,1,lll,kkk,iii,2))
7220             enddo
7221           enddo
7222         enddo
7223 ! AEAb1 and AEAb2
7224 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7225 ! They are needed only when the fifth- or the sixth-order cumulants are
7226 ! indluded.
7227         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7228           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7229         call transpose2(AEA(1,1,1),auxmat(1,1))
7230         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7231         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7232         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7233         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7234         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7235         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7236         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7237         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7238         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7239         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7240         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7241         call transpose2(AEA(1,1,2),auxmat(1,1))
7242         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7243         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7244         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7245         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7246         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7247         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7248         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7249         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7250         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7251         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7252         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7253 ! Calculate the Cartesian derivatives of the vectors.
7254         do iii=1,2
7255           do kkk=1,5
7256             do lll=1,3
7257               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7258               call matvec2(auxmat(1,1),b1(1,iti),&
7259                 AEAb1derx(1,lll,kkk,iii,1,1))
7260               call matvec2(auxmat(1,1),Ub2(1,i),&
7261                 AEAb2derx(1,lll,kkk,iii,1,1))
7262               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7263                 AEAb1derx(1,lll,kkk,iii,2,1))
7264               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7265                 AEAb2derx(1,lll,kkk,iii,2,1))
7266               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7267               call matvec2(auxmat(1,1),b1(1,itl),&
7268                 AEAb1derx(1,lll,kkk,iii,1,2))
7269               call matvec2(auxmat(1,1),Ub2(1,l),&
7270                 AEAb2derx(1,lll,kkk,iii,1,2))
7271               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7272                 AEAb1derx(1,lll,kkk,iii,2,2))
7273               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7274                 AEAb2derx(1,lll,kkk,iii,2,2))
7275             enddo
7276           enddo
7277         enddo
7278         ENDIF
7279 ! End vectors
7280       endif
7281       return
7282       end subroutine calc_eello
7283 !-----------------------------------------------------------------------------
7284       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7285       use comm_kut
7286       implicit none
7287       integer :: nderg
7288       logical :: transp
7289       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7290       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7291       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7292       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7293       integer :: iii,kkk,lll
7294       integer :: jjj,mmm
7295 !el      logical :: lprn
7296 !el      common /kutas/ lprn
7297       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7298       do iii=1,nderg
7299         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7300           AKAderg(1,1,iii))
7301       enddo
7302 !d      if (lprn) write (2,*) 'In kernel'
7303       do kkk=1,5
7304 !d        if (lprn) write (2,*) 'kkk=',kkk
7305         do lll=1,3
7306           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7307             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7308 !d          if (lprn) then
7309 !d            write (2,*) 'lll=',lll
7310 !d            write (2,*) 'iii=1'
7311 !d            do jjj=1,2
7312 !d              write (2,'(3(2f10.5),5x)')
7313 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7314 !d            enddo
7315 !d          endif
7316           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7317             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7318 !d          if (lprn) then
7319 !d            write (2,*) 'lll=',lll
7320 !d            write (2,*) 'iii=2'
7321 !d            do jjj=1,2
7322 !d              write (2,'(3(2f10.5),5x)')
7323 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7324 !d            enddo
7325 !d          endif
7326         enddo
7327       enddo
7328       return
7329       end subroutine kernel
7330 !-----------------------------------------------------------------------------
7331       real(kind=8) function eello4(i,j,k,l,jj,kk)
7332 !      implicit real*8 (a-h,o-z)
7333 !      include 'DIMENSIONS'
7334 !      include 'COMMON.IOUNITS'
7335 !      include 'COMMON.CHAIN'
7336 !      include 'COMMON.DERIV'
7337 !      include 'COMMON.INTERACT'
7338 !      include 'COMMON.CONTACTS'
7339 !      include 'COMMON.TORSION'
7340 !      include 'COMMON.VAR'
7341 !      include 'COMMON.GEO'
7342       real(kind=8),dimension(2,2) :: pizda
7343       real(kind=8),dimension(3) :: ggg1,ggg2
7344       real(kind=8) ::  eel4,glongij,glongkl
7345       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7346 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7347 !d        eello4=0.0d0
7348 !d        return
7349 !d      endif
7350 !d      print *,'eello4:',i,j,k,l,jj,kk
7351 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7352 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7353 !old      eij=facont_hb(jj,i)
7354 !old      ekl=facont_hb(kk,k)
7355 !old      ekont=eij*ekl
7356       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7357 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7358       gcorr_loc(k-1)=gcorr_loc(k-1) &
7359          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7360       if (l.eq.j+1) then
7361         gcorr_loc(l-1)=gcorr_loc(l-1) &
7362            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7363       else
7364         gcorr_loc(j-1)=gcorr_loc(j-1) &
7365            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7366       endif
7367       do iii=1,2
7368         do kkk=1,5
7369           do lll=1,3
7370             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7371                               -EAEAderx(2,2,lll,kkk,iii,1)
7372 !d            derx(lll,kkk,iii)=0.0d0
7373           enddo
7374         enddo
7375       enddo
7376 !d      gcorr_loc(l-1)=0.0d0
7377 !d      gcorr_loc(j-1)=0.0d0
7378 !d      gcorr_loc(k-1)=0.0d0
7379 !d      eel4=1.0d0
7380 !d      write (iout,*)'Contacts have occurred for peptide groups',
7381 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7382 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7383       if (j.lt.nres-1) then
7384         j1=j+1
7385         j2=j-1
7386       else
7387         j1=j-1
7388         j2=j-2
7389       endif
7390       if (l.lt.nres-1) then
7391         l1=l+1
7392         l2=l-1
7393       else
7394         l1=l-1
7395         l2=l-2
7396       endif
7397       do ll=1,3
7398 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7399 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7400         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7401         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7402 !grad        ghalf=0.5d0*ggg1(ll)
7403         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7404         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7405         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7406         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7407         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7408         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7409 !grad        ghalf=0.5d0*ggg2(ll)
7410         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7411         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7412         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7413         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7414         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7415         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7416       enddo
7417 !grad      do m=i+1,j-1
7418 !grad        do ll=1,3
7419 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7420 !grad        enddo
7421 !grad      enddo
7422 !grad      do m=k+1,l-1
7423 !grad        do ll=1,3
7424 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7425 !grad        enddo
7426 !grad      enddo
7427 !grad      do m=i+2,j2
7428 !grad        do ll=1,3
7429 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7430 !grad        enddo
7431 !grad      enddo
7432 !grad      do m=k+2,l2
7433 !grad        do ll=1,3
7434 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7435 !grad        enddo
7436 !grad      enddo
7437 !d      do iii=1,nres-3
7438 !d        write (2,*) iii,gcorr_loc(iii)
7439 !d      enddo
7440       eello4=ekont*eel4
7441 !d      write (2,*) 'ekont',ekont
7442 !d      write (iout,*) 'eello4',ekont*eel4
7443       return
7444       end function eello4
7445 !-----------------------------------------------------------------------------
7446       real(kind=8) function eello5(i,j,k,l,jj,kk)
7447 !      implicit real*8 (a-h,o-z)
7448 !      include 'DIMENSIONS'
7449 !      include 'COMMON.IOUNITS'
7450 !      include 'COMMON.CHAIN'
7451 !      include 'COMMON.DERIV'
7452 !      include 'COMMON.INTERACT'
7453 !      include 'COMMON.CONTACTS'
7454 !      include 'COMMON.TORSION'
7455 !      include 'COMMON.VAR'
7456 !      include 'COMMON.GEO'
7457       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7458       real(kind=8),dimension(2) :: vv
7459       real(kind=8),dimension(3) :: ggg1,ggg2
7460       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7461       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7462       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7463 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7464 !                                                                              C
7465 !                            Parallel chains                                   C
7466 !                                                                              C
7467 !          o             o                   o             o                   C
7468 !         /l\           / \             \   / \           / \   /              C
7469 !        /   \         /   \             \ /   \         /   \ /               C
7470 !       j| o |l1       | o |              o| o |         | o |o                C
7471 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7472 !      \i/   \         /   \ /             /   \         /   \                 C
7473 !       o    k1             o                                                  C
7474 !         (I)          (II)                (III)          (IV)                 C
7475 !                                                                              C
7476 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7477 !                                                                              C
7478 !                            Antiparallel chains                               C
7479 !                                                                              C
7480 !          o             o                   o             o                   C
7481 !         /j\           / \             \   / \           / \   /              C
7482 !        /   \         /   \             \ /   \         /   \ /               C
7483 !      j1| o |l        | o |              o| o |         | o |o                C
7484 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7485 !      \i/   \         /   \ /             /   \         /   \                 C
7486 !       o     k1            o                                                  C
7487 !         (I)          (II)                (III)          (IV)                 C
7488 !                                                                              C
7489 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7490 !                                                                              C
7491 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7492 !                                                                              C
7493 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7494 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7495 !d        eello5=0.0d0
7496 !d        return
7497 !d      endif
7498 !d      write (iout,*)
7499 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7500 !d     &   ' and',k,l
7501       itk=itortyp(itype(k))
7502       itl=itortyp(itype(l))
7503       itj=itortyp(itype(j))
7504       eello5_1=0.0d0
7505       eello5_2=0.0d0
7506       eello5_3=0.0d0
7507       eello5_4=0.0d0
7508 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7509 !d     &   eel5_3_num,eel5_4_num)
7510       do iii=1,2
7511         do kkk=1,5
7512           do lll=1,3
7513             derx(lll,kkk,iii)=0.0d0
7514           enddo
7515         enddo
7516       enddo
7517 !d      eij=facont_hb(jj,i)
7518 !d      ekl=facont_hb(kk,k)
7519 !d      ekont=eij*ekl
7520 !d      write (iout,*)'Contacts have occurred for peptide groups',
7521 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7522 !d      goto 1111
7523 ! Contribution from the graph I.
7524 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7525 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7526       call transpose2(EUg(1,1,k),auxmat(1,1))
7527       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7528       vv(1)=pizda(1,1)-pizda(2,2)
7529       vv(2)=pizda(1,2)+pizda(2,1)
7530       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7531        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7532 ! Explicit gradient in virtual-dihedral angles.
7533       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7534        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7535        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7536       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7537       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7538       vv(1)=pizda(1,1)-pizda(2,2)
7539       vv(2)=pizda(1,2)+pizda(2,1)
7540       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7541        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7542        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7543       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7544       vv(1)=pizda(1,1)-pizda(2,2)
7545       vv(2)=pizda(1,2)+pizda(2,1)
7546       if (l.eq.j+1) then
7547         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7548          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7549          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7550       else
7551         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7552          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7553          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7554       endif
7555 ! Cartesian gradient
7556       do iii=1,2
7557         do kkk=1,5
7558           do lll=1,3
7559             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7560               pizda(1,1))
7561             vv(1)=pizda(1,1)-pizda(2,2)
7562             vv(2)=pizda(1,2)+pizda(2,1)
7563             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7564              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7565              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7566           enddo
7567         enddo
7568       enddo
7569 !      goto 1112
7570 !1111  continue
7571 ! Contribution from graph II
7572       call transpose2(EE(1,1,itk),auxmat(1,1))
7573       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7574       vv(1)=pizda(1,1)+pizda(2,2)
7575       vv(2)=pizda(2,1)-pizda(1,2)
7576       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7577        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7578 ! Explicit gradient in virtual-dihedral angles.
7579       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7580        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7581       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7582       vv(1)=pizda(1,1)+pizda(2,2)
7583       vv(2)=pizda(2,1)-pizda(1,2)
7584       if (l.eq.j+1) then
7585         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7586          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7587          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7588       else
7589         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7590          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7591          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7592       endif
7593 ! Cartesian gradient
7594       do iii=1,2
7595         do kkk=1,5
7596           do lll=1,3
7597             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7598               pizda(1,1))
7599             vv(1)=pizda(1,1)+pizda(2,2)
7600             vv(2)=pizda(2,1)-pizda(1,2)
7601             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7602              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7603              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7604           enddo
7605         enddo
7606       enddo
7607 !d      goto 1112
7608 !d1111  continue
7609       if (l.eq.j+1) then
7610 !d        goto 1110
7611 ! Parallel orientation
7612 ! Contribution from graph III
7613         call transpose2(EUg(1,1,l),auxmat(1,1))
7614         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7615         vv(1)=pizda(1,1)-pizda(2,2)
7616         vv(2)=pizda(1,2)+pizda(2,1)
7617         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7618          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7619 ! Explicit gradient in virtual-dihedral angles.
7620         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7621          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7622          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7623         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7624         vv(1)=pizda(1,1)-pizda(2,2)
7625         vv(2)=pizda(1,2)+pizda(2,1)
7626         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7627          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7628          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7629         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7630         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7631         vv(1)=pizda(1,1)-pizda(2,2)
7632         vv(2)=pizda(1,2)+pizda(2,1)
7633         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7634          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7635          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7636 ! Cartesian gradient
7637         do iii=1,2
7638           do kkk=1,5
7639             do lll=1,3
7640               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7641                 pizda(1,1))
7642               vv(1)=pizda(1,1)-pizda(2,2)
7643               vv(2)=pizda(1,2)+pizda(2,1)
7644               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7645                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7646                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7647             enddo
7648           enddo
7649         enddo
7650 !d        goto 1112
7651 ! Contribution from graph IV
7652 !d1110    continue
7653         call transpose2(EE(1,1,itl),auxmat(1,1))
7654         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7655         vv(1)=pizda(1,1)+pizda(2,2)
7656         vv(2)=pizda(2,1)-pizda(1,2)
7657         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7658          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7659 ! Explicit gradient in virtual-dihedral angles.
7660         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7661          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7662         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7663         vv(1)=pizda(1,1)+pizda(2,2)
7664         vv(2)=pizda(2,1)-pizda(1,2)
7665         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7666          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7667          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7668 ! Cartesian gradient
7669         do iii=1,2
7670           do kkk=1,5
7671             do lll=1,3
7672               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7673                 pizda(1,1))
7674               vv(1)=pizda(1,1)+pizda(2,2)
7675               vv(2)=pizda(2,1)-pizda(1,2)
7676               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7677                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7678                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7679             enddo
7680           enddo
7681         enddo
7682       else
7683 ! Antiparallel orientation
7684 ! Contribution from graph III
7685 !        goto 1110
7686         call transpose2(EUg(1,1,j),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,j)) &
7691          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7692 ! Explicit gradient in virtual-dihedral angles.
7693         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7694          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7695          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
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,j)) &
7701          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7702         call transpose2(EUgder(1,1,j),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(j-1)=g_corr5_loc(j-1) &
7707          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7708          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
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,3-iii)=derx(lll,kkk,3-iii) &
7718                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7719                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7720             enddo
7721           enddo
7722         enddo
7723 !d        goto 1112
7724 ! Contribution from graph IV
7725 1110    continue
7726         call transpose2(EE(1,1,itj),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,itj)) &
7731          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7732 ! Explicit gradient in virtual-dihedral angles.
7733         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7734          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
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,itj)) &
7740          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
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,3-iii)=derx(lll,kkk,3-iii) &
7750                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7751                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7752             enddo
7753           enddo
7754         enddo
7755       endif
7756 1112  continue
7757       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7758 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7759 !d        write (2,*) 'ijkl',i,j,k,l
7760 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7761 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7762 !d      endif
7763 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7764 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7765 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7766 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7767       if (j.lt.nres-1) then
7768         j1=j+1
7769         j2=j-1
7770       else
7771         j1=j-1
7772         j2=j-2
7773       endif
7774       if (l.lt.nres-1) then
7775         l1=l+1
7776         l2=l-1
7777       else
7778         l1=l-1
7779         l2=l-2
7780       endif
7781 !d      eij=1.0d0
7782 !d      ekl=1.0d0
7783 !d      ekont=1.0d0
7784 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7785 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7786 !        summed up outside the subrouine as for the other subroutines
7787 !        handling long-range interactions. The old code is commented out
7788 !        with "cgrad" to keep track of changes.
7789       do ll=1,3
7790 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7791 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7792         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7793         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7794 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7795 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7796 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7797 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7798 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7799 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7800 !     &   gradcorr5ij,
7801 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7802 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7803 !grad        ghalf=0.5d0*ggg1(ll)
7804 !d        ghalf=0.0d0
7805         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7806         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7807         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7808         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7809         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7810         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7811 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7812 !grad        ghalf=0.5d0*ggg2(ll)
7813         ghalf=0.0d0
7814         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7815         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7816         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7817         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7818         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7819         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7820       enddo
7821 !d      goto 1112
7822 !grad      do m=i+1,j-1
7823 !grad        do ll=1,3
7824 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7825 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7826 !grad        enddo
7827 !grad      enddo
7828 !grad      do m=k+1,l-1
7829 !grad        do ll=1,3
7830 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7831 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7832 !grad        enddo
7833 !grad      enddo
7834 !1112  continue
7835 !grad      do m=i+2,j2
7836 !grad        do ll=1,3
7837 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7838 !grad        enddo
7839 !grad      enddo
7840 !grad      do m=k+2,l2
7841 !grad        do ll=1,3
7842 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7843 !grad        enddo
7844 !grad      enddo
7845 !d      do iii=1,nres-3
7846 !d        write (2,*) iii,g_corr5_loc(iii)
7847 !d      enddo
7848       eello5=ekont*eel5
7849 !d      write (2,*) 'ekont',ekont
7850 !d      write (iout,*) 'eello5',ekont*eel5
7851       return
7852       end function eello5
7853 !-----------------------------------------------------------------------------
7854       real(kind=8) function eello6(i,j,k,l,jj,kk)
7855 !      implicit real*8 (a-h,o-z)
7856 !      include 'DIMENSIONS'
7857 !      include 'COMMON.IOUNITS'
7858 !      include 'COMMON.CHAIN'
7859 !      include 'COMMON.DERIV'
7860 !      include 'COMMON.INTERACT'
7861 !      include 'COMMON.CONTACTS'
7862 !      include 'COMMON.TORSION'
7863 !      include 'COMMON.VAR'
7864 !      include 'COMMON.GEO'
7865 !      include 'COMMON.FFIELD'
7866       real(kind=8),dimension(3) :: ggg1,ggg2
7867       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7868                    eello6_6,eel6
7869       real(kind=8) :: gradcorr6ij,gradcorr6kl
7870       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7871 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7872 !d        eello6=0.0d0
7873 !d        return
7874 !d      endif
7875 !d      write (iout,*)
7876 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7877 !d     &   ' and',k,l
7878       eello6_1=0.0d0
7879       eello6_2=0.0d0
7880       eello6_3=0.0d0
7881       eello6_4=0.0d0
7882       eello6_5=0.0d0
7883       eello6_6=0.0d0
7884 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7885 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7886       do iii=1,2
7887         do kkk=1,5
7888           do lll=1,3
7889             derx(lll,kkk,iii)=0.0d0
7890           enddo
7891         enddo
7892       enddo
7893 !d      eij=facont_hb(jj,i)
7894 !d      ekl=facont_hb(kk,k)
7895 !d      ekont=eij*ekl
7896 !d      eij=1.0d0
7897 !d      ekl=1.0d0
7898 !d      ekont=1.0d0
7899       if (l.eq.j+1) then
7900         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7901         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7902         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7903         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7904         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7905         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7906       else
7907         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7908         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7909         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7910         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7911         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7912           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7913         else
7914           eello6_5=0.0d0
7915         endif
7916         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7917       endif
7918 ! If turn contributions are considered, they will be handled separately.
7919       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7920 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7921 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7922 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7923 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7924 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7925 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7926 !d      goto 1112
7927       if (j.lt.nres-1) then
7928         j1=j+1
7929         j2=j-1
7930       else
7931         j1=j-1
7932         j2=j-2
7933       endif
7934       if (l.lt.nres-1) then
7935         l1=l+1
7936         l2=l-1
7937       else
7938         l1=l-1
7939         l2=l-2
7940       endif
7941       do ll=1,3
7942 !grad        ggg1(ll)=eel6*g_contij(ll,1)
7943 !grad        ggg2(ll)=eel6*g_contij(ll,2)
7944 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7945 !grad        ghalf=0.5d0*ggg1(ll)
7946 !d        ghalf=0.0d0
7947         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7948         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7949         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7950         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7951         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7952         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7953         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7954         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7955 !grad        ghalf=0.5d0*ggg2(ll)
7956 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7957 !d        ghalf=0.0d0
7958         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7959         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7960         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7961         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7962         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7963         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7964       enddo
7965 !d      goto 1112
7966 !grad      do m=i+1,j-1
7967 !grad        do ll=1,3
7968 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7969 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7970 !grad        enddo
7971 !grad      enddo
7972 !grad      do m=k+1,l-1
7973 !grad        do ll=1,3
7974 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7975 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7976 !grad        enddo
7977 !grad      enddo
7978 !grad1112  continue
7979 !grad      do m=i+2,j2
7980 !grad        do ll=1,3
7981 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7982 !grad        enddo
7983 !grad      enddo
7984 !grad      do m=k+2,l2
7985 !grad        do ll=1,3
7986 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7987 !grad        enddo
7988 !grad      enddo
7989 !d      do iii=1,nres-3
7990 !d        write (2,*) iii,g_corr6_loc(iii)
7991 !d      enddo
7992       eello6=ekont*eel6
7993 !d      write (2,*) 'ekont',ekont
7994 !d      write (iout,*) 'eello6',ekont*eel6
7995       return
7996       end function eello6
7997 !-----------------------------------------------------------------------------
7998       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
7999       use comm_kut
8000 !      implicit real*8 (a-h,o-z)
8001 !      include 'DIMENSIONS'
8002 !      include 'COMMON.IOUNITS'
8003 !      include 'COMMON.CHAIN'
8004 !      include 'COMMON.DERIV'
8005 !      include 'COMMON.INTERACT'
8006 !      include 'COMMON.CONTACTS'
8007 !      include 'COMMON.TORSION'
8008 !      include 'COMMON.VAR'
8009 !      include 'COMMON.GEO'
8010       real(kind=8),dimension(2) :: vv,vv1
8011       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8012       logical :: swap
8013 !el      logical :: lprn
8014 !el      common /kutas/ lprn
8015       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8016       real(kind=8) :: s1,s2,s3,s4,s5
8017 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8018 !                                                                              C
8019 !      Parallel       Antiparallel                                             C
8020 !                                                                              C
8021 !          o             o                                                     C
8022 !         /l\           /j\                                                    C
8023 !        /   \         /   \                                                   C
8024 !       /| o |         | o |\                                                  C
8025 !     \ j|/k\|  /   \  |/k\|l /                                                C
8026 !      \ /   \ /     \ /   \ /                                                 C
8027 !       o     o       o     o                                                  C
8028 !       i             i                                                        C
8029 !                                                                              C
8030 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8031       itk=itortyp(itype(k))
8032       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8033       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8034       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8035       call transpose2(EUgC(1,1,k),auxmat(1,1))
8036       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8037       vv1(1)=pizda1(1,1)-pizda1(2,2)
8038       vv1(2)=pizda1(1,2)+pizda1(2,1)
8039       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8040       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8041       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8042       s5=scalar2(vv(1),Dtobr2(1,i))
8043 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8044       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8045       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8046        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8047        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8048        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8049        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8050        +scalar2(vv(1),Dtobr2der(1,i)))
8051       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8052       vv1(1)=pizda1(1,1)-pizda1(2,2)
8053       vv1(2)=pizda1(1,2)+pizda1(2,1)
8054       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8055       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8056       if (l.eq.j+1) then
8057         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8058        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8059        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8060        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8061        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8062       else
8063         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8064        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8065        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8066        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8067        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8068       endif
8069       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8070       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8071       vv1(1)=pizda1(1,1)-pizda1(2,2)
8072       vv1(2)=pizda1(1,2)+pizda1(2,1)
8073       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8074        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8075        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8076        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8077       do iii=1,2
8078         if (swap) then
8079           ind=3-iii
8080         else
8081           ind=iii
8082         endif
8083         do kkk=1,5
8084           do lll=1,3
8085             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8086             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8087             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8088             call transpose2(EUgC(1,1,k),auxmat(1,1))
8089             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8090               pizda1(1,1))
8091             vv1(1)=pizda1(1,1)-pizda1(2,2)
8092             vv1(2)=pizda1(1,2)+pizda1(2,1)
8093             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8094             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8095              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8096             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8097              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8098             s5=scalar2(vv(1),Dtobr2(1,i))
8099             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8100           enddo
8101         enddo
8102       enddo
8103       return
8104       end function eello6_graph1
8105 !-----------------------------------------------------------------------------
8106       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8107       use comm_kut
8108 !      implicit real*8 (a-h,o-z)
8109 !      include 'DIMENSIONS'
8110 !      include 'COMMON.IOUNITS'
8111 !      include 'COMMON.CHAIN'
8112 !      include 'COMMON.DERIV'
8113 !      include 'COMMON.INTERACT'
8114 !      include 'COMMON.CONTACTS'
8115 !      include 'COMMON.TORSION'
8116 !      include 'COMMON.VAR'
8117 !      include 'COMMON.GEO'
8118       logical :: swap
8119       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8120       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8121 !el      logical :: lprn
8122 !el      common /kutas/ lprn
8123       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8124       real(kind=8) :: s2,s3,s4
8125 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8126 !                                                                              C
8127 !      Parallel       Antiparallel                                             C
8128 !                                                                              C
8129 !          o             o                                                     C
8130 !     \   /l\           /j\   /                                                C
8131 !      \ /   \         /   \ /                                                 C
8132 !       o| o |         | o |o                                                  C
8133 !     \ j|/k\|      \  |/k\|l                                                  C
8134 !      \ /   \       \ /   \                                                   C
8135 !       o             o                                                        C
8136 !       i             i                                                        C
8137 !                                                                              C
8138 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8139 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8140 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8141 !           but not in a cluster cumulant
8142 #ifdef MOMENT
8143       s1=dip(1,jj,i)*dip(1,kk,k)
8144 #endif
8145       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8146       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8147       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8148       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8149       call transpose2(EUg(1,1,k),auxmat(1,1))
8150       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8151       vv(1)=pizda(1,1)-pizda(2,2)
8152       vv(2)=pizda(1,2)+pizda(2,1)
8153       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8154 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8155 #ifdef MOMENT
8156       eello6_graph2=-(s1+s2+s3+s4)
8157 #else
8158       eello6_graph2=-(s2+s3+s4)
8159 #endif
8160 !      eello6_graph2=-s3
8161 ! Derivatives in gamma(i-1)
8162       if (i.gt.1) then
8163 #ifdef MOMENT
8164         s1=dipderg(1,jj,i)*dip(1,kk,k)
8165 #endif
8166         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8167         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8168         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8169         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8170 #ifdef MOMENT
8171         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8172 #else
8173         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8174 #endif
8175 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8176       endif
8177 ! Derivatives in gamma(k-1)
8178 #ifdef MOMENT
8179       s1=dip(1,jj,i)*dipderg(1,kk,k)
8180 #endif
8181       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8182       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8183       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8184       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8185       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8186       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8187       vv(1)=pizda(1,1)-pizda(2,2)
8188       vv(2)=pizda(1,2)+pizda(2,1)
8189       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8190 #ifdef MOMENT
8191       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8192 #else
8193       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8194 #endif
8195 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8196 ! Derivatives in gamma(j-1) or gamma(l-1)
8197       if (j.gt.1) then
8198 #ifdef MOMENT
8199         s1=dipderg(3,jj,i)*dip(1,kk,k)
8200 #endif
8201         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8202         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8203         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8204         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8205         vv(1)=pizda(1,1)-pizda(2,2)
8206         vv(2)=pizda(1,2)+pizda(2,1)
8207         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8208 #ifdef MOMENT
8209         if (swap) then
8210           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8211         else
8212           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8213         endif
8214 #endif
8215         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8216 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8217       endif
8218 ! Derivatives in gamma(l-1) or gamma(j-1)
8219       if (l.gt.1) then
8220 #ifdef MOMENT
8221         s1=dip(1,jj,i)*dipderg(3,kk,k)
8222 #endif
8223         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8224         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8225         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8226         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8227         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8228         vv(1)=pizda(1,1)-pizda(2,2)
8229         vv(2)=pizda(1,2)+pizda(2,1)
8230         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8231 #ifdef MOMENT
8232         if (swap) then
8233           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8234         else
8235           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8236         endif
8237 #endif
8238         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8239 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8240       endif
8241 ! Cartesian derivatives.
8242       if (lprn) then
8243         write (2,*) 'In eello6_graph2'
8244         do iii=1,2
8245           write (2,*) 'iii=',iii
8246           do kkk=1,5
8247             write (2,*) 'kkk=',kkk
8248             do jjj=1,2
8249               write (2,'(3(2f10.5),5x)') &
8250               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8251             enddo
8252           enddo
8253         enddo
8254       endif
8255       do iii=1,2
8256         do kkk=1,5
8257           do lll=1,3
8258 #ifdef MOMENT
8259             if (iii.eq.1) then
8260               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8261             else
8262               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8263             endif
8264 #endif
8265             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8266               auxvec(1))
8267             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8268             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8269               auxvec(1))
8270             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8271             call transpose2(EUg(1,1,k),auxmat(1,1))
8272             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8273               pizda(1,1))
8274             vv(1)=pizda(1,1)-pizda(2,2)
8275             vv(2)=pizda(1,2)+pizda(2,1)
8276             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8277 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8278 #ifdef MOMENT
8279             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8280 #else
8281             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8282 #endif
8283             if (swap) then
8284               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8285             else
8286               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8287             endif
8288           enddo
8289         enddo
8290       enddo
8291       return
8292       end function eello6_graph2
8293 !-----------------------------------------------------------------------------
8294       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8295 !      implicit real*8 (a-h,o-z)
8296 !      include 'DIMENSIONS'
8297 !      include 'COMMON.IOUNITS'
8298 !      include 'COMMON.CHAIN'
8299 !      include 'COMMON.DERIV'
8300 !      include 'COMMON.INTERACT'
8301 !      include 'COMMON.CONTACTS'
8302 !      include 'COMMON.TORSION'
8303 !      include 'COMMON.VAR'
8304 !      include 'COMMON.GEO'
8305       real(kind=8),dimension(2) :: vv,auxvec
8306       real(kind=8),dimension(2,2) :: pizda,auxmat
8307       logical :: swap
8308       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8309       real(kind=8) :: s1,s2,s3,s4
8310 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8311 !                                                                              C
8312 !      Parallel       Antiparallel                                             C
8313 !                                                                              C
8314 !          o             o                                                     C
8315 !         /l\   /   \   /j\                                                    C
8316 !        /   \ /     \ /   \                                                   C
8317 !       /| o |o       o| o |\                                                  C
8318 !       j|/k\|  /      |/k\|l /                                                C
8319 !        /   \ /       /   \ /                                                 C
8320 !       /     o       /     o                                                  C
8321 !       i             i                                                        C
8322 !                                                                              C
8323 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8324 !
8325 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8326 !           energy moment and not to the cluster cumulant.
8327       iti=itortyp(itype(i))
8328       if (j.lt.nres-1) then
8329         itj1=itortyp(itype(j+1))
8330       else
8331         itj1=ntortyp+1
8332       endif
8333       itk=itortyp(itype(k))
8334       itk1=itortyp(itype(k+1))
8335       if (l.lt.nres-1) then
8336         itl1=itortyp(itype(l+1))
8337       else
8338         itl1=ntortyp+1
8339       endif
8340 #ifdef MOMENT
8341       s1=dip(4,jj,i)*dip(4,kk,k)
8342 #endif
8343       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8344       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8345       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8346       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8347       call transpose2(EE(1,1,itk),auxmat(1,1))
8348       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8349       vv(1)=pizda(1,1)+pizda(2,2)
8350       vv(2)=pizda(2,1)-pizda(1,2)
8351       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8352 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8353 !d     & "sum",-(s2+s3+s4)
8354 #ifdef MOMENT
8355       eello6_graph3=-(s1+s2+s3+s4)
8356 #else
8357       eello6_graph3=-(s2+s3+s4)
8358 #endif
8359 !      eello6_graph3=-s4
8360 ! Derivatives in gamma(k-1)
8361       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8362       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8363       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8364       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8365 ! Derivatives in gamma(l-1)
8366       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8367       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8368       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8369       vv(1)=pizda(1,1)+pizda(2,2)
8370       vv(2)=pizda(2,1)-pizda(1,2)
8371       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8372       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8373 ! Cartesian derivatives.
8374       do iii=1,2
8375         do kkk=1,5
8376           do lll=1,3
8377 #ifdef MOMENT
8378             if (iii.eq.1) then
8379               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8380             else
8381               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8382             endif
8383 #endif
8384             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8385               auxvec(1))
8386             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8387             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8388               auxvec(1))
8389             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8390             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8391               pizda(1,1))
8392             vv(1)=pizda(1,1)+pizda(2,2)
8393             vv(2)=pizda(2,1)-pizda(1,2)
8394             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8395 #ifdef MOMENT
8396             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8397 #else
8398             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8399 #endif
8400             if (swap) then
8401               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8402             else
8403               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8404             endif
8405 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8406           enddo
8407         enddo
8408       enddo
8409       return
8410       end function eello6_graph3
8411 !-----------------------------------------------------------------------------
8412       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8413 !      implicit real*8 (a-h,o-z)
8414 !      include 'DIMENSIONS'
8415 !      include 'COMMON.IOUNITS'
8416 !      include 'COMMON.CHAIN'
8417 !      include 'COMMON.DERIV'
8418 !      include 'COMMON.INTERACT'
8419 !      include 'COMMON.CONTACTS'
8420 !      include 'COMMON.TORSION'
8421 !      include 'COMMON.VAR'
8422 !      include 'COMMON.GEO'
8423 !      include 'COMMON.FFIELD'
8424       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8425       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8426       logical :: swap
8427       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8428               iii,kkk,lll
8429       real(kind=8) :: s1,s2,s3,s4
8430 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8431 !                                                                              C
8432 !      Parallel       Antiparallel                                             C
8433 !                                                                              C
8434 !          o             o                                                     C
8435 !         /l\   /   \   /j\                                                    C
8436 !        /   \ /     \ /   \                                                   C
8437 !       /| o |o       o| o |\                                                  C
8438 !     \ j|/k\|      \  |/k\|l                                                  C
8439 !      \ /   \       \ /   \                                                   C
8440 !       o     \       o     \                                                  C
8441 !       i             i                                                        C
8442 !                                                                              C
8443 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8444 !
8445 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8446 !           energy moment and not to the cluster cumulant.
8447 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8448       iti=itortyp(itype(i))
8449       itj=itortyp(itype(j))
8450       if (j.lt.nres-1) then
8451         itj1=itortyp(itype(j+1))
8452       else
8453         itj1=ntortyp+1
8454       endif
8455       itk=itortyp(itype(k))
8456       if (k.lt.nres-1) then
8457         itk1=itortyp(itype(k+1))
8458       else
8459         itk1=ntortyp+1
8460       endif
8461       itl=itortyp(itype(l))
8462       if (l.lt.nres-1) then
8463         itl1=itortyp(itype(l+1))
8464       else
8465         itl1=ntortyp+1
8466       endif
8467 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8468 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8469 !d     & ' itl',itl,' itl1',itl1
8470 #ifdef MOMENT
8471       if (imat.eq.1) then
8472         s1=dip(3,jj,i)*dip(3,kk,k)
8473       else
8474         s1=dip(2,jj,j)*dip(2,kk,l)
8475       endif
8476 #endif
8477       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8478       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8479       if (j.eq.l+1) then
8480         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8481         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8482       else
8483         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8484         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8485       endif
8486       call transpose2(EUg(1,1,k),auxmat(1,1))
8487       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8488       vv(1)=pizda(1,1)-pizda(2,2)
8489       vv(2)=pizda(2,1)+pizda(1,2)
8490       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8491 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8492 #ifdef MOMENT
8493       eello6_graph4=-(s1+s2+s3+s4)
8494 #else
8495       eello6_graph4=-(s2+s3+s4)
8496 #endif
8497 ! Derivatives in gamma(i-1)
8498       if (i.gt.1) then
8499 #ifdef MOMENT
8500         if (imat.eq.1) then
8501           s1=dipderg(2,jj,i)*dip(3,kk,k)
8502         else
8503           s1=dipderg(4,jj,j)*dip(2,kk,l)
8504         endif
8505 #endif
8506         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8507         if (j.eq.l+1) then
8508           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8509           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8510         else
8511           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8512           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8513         endif
8514         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8515         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8516 !d          write (2,*) 'turn6 derivatives'
8517 #ifdef MOMENT
8518           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8519 #else
8520           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8521 #endif
8522         else
8523 #ifdef MOMENT
8524           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8525 #else
8526           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8527 #endif
8528         endif
8529       endif
8530 ! Derivatives in gamma(k-1)
8531 #ifdef MOMENT
8532       if (imat.eq.1) then
8533         s1=dip(3,jj,i)*dipderg(2,kk,k)
8534       else
8535         s1=dip(2,jj,j)*dipderg(4,kk,l)
8536       endif
8537 #endif
8538       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8539       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8540       if (j.eq.l+1) then
8541         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8542         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8543       else
8544         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8545         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8546       endif
8547       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8548       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8549       vv(1)=pizda(1,1)-pizda(2,2)
8550       vv(2)=pizda(2,1)+pizda(1,2)
8551       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8552       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8553 #ifdef MOMENT
8554         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8555 #else
8556         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8557 #endif
8558       else
8559 #ifdef MOMENT
8560         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8561 #else
8562         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8563 #endif
8564       endif
8565 ! Derivatives in gamma(j-1) or gamma(l-1)
8566       if (l.eq.j+1 .and. l.gt.1) then
8567         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8568         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8569         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8570         vv(1)=pizda(1,1)-pizda(2,2)
8571         vv(2)=pizda(2,1)+pizda(1,2)
8572         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8573         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8574       else if (j.gt.1) then
8575         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8576         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8577         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8578         vv(1)=pizda(1,1)-pizda(2,2)
8579         vv(2)=pizda(2,1)+pizda(1,2)
8580         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8581         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8582           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8583         else
8584           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8585         endif
8586       endif
8587 ! Cartesian derivatives.
8588       do iii=1,2
8589         do kkk=1,5
8590           do lll=1,3
8591 #ifdef MOMENT
8592             if (iii.eq.1) then
8593               if (imat.eq.1) then
8594                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8595               else
8596                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8597               endif
8598             else
8599               if (imat.eq.1) then
8600                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8601               else
8602                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8603               endif
8604             endif
8605 #endif
8606             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8607               auxvec(1))
8608             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8609             if (j.eq.l+1) then
8610               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8611                 b1(1,itj1),auxvec(1))
8612               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8613             else
8614               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8615                 b1(1,itl1),auxvec(1))
8616               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8617             endif
8618             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8619               pizda(1,1))
8620             vv(1)=pizda(1,1)-pizda(2,2)
8621             vv(2)=pizda(2,1)+pizda(1,2)
8622             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8623             if (swap) then
8624               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8625 #ifdef MOMENT
8626                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8627                    -(s1+s2+s4)
8628 #else
8629                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8630                    -(s2+s4)
8631 #endif
8632                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8633               else
8634 #ifdef MOMENT
8635                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8636 #else
8637                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8638 #endif
8639                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8640               endif
8641             else
8642 #ifdef MOMENT
8643               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8644 #else
8645               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8646 #endif
8647               if (l.eq.j+1) then
8648                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8649               else
8650                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8651               endif
8652             endif
8653           enddo
8654         enddo
8655       enddo
8656       return
8657       end function eello6_graph4
8658 !-----------------------------------------------------------------------------
8659       real(kind=8) function eello_turn6(i,jj,kk)
8660 !      implicit real*8 (a-h,o-z)
8661 !      include 'DIMENSIONS'
8662 !      include 'COMMON.IOUNITS'
8663 !      include 'COMMON.CHAIN'
8664 !      include 'COMMON.DERIV'
8665 !      include 'COMMON.INTERACT'
8666 !      include 'COMMON.CONTACTS'
8667 !      include 'COMMON.TORSION'
8668 !      include 'COMMON.VAR'
8669 !      include 'COMMON.GEO'
8670       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8671       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8672       real(kind=8),dimension(3) :: ggg1,ggg2
8673       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8674       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8675 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8676 !           the respective energy moment and not to the cluster cumulant.
8677 !el local variables
8678       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8679       integer :: j1,j2,l1,l2,ll
8680       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8681       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8682       s1=0.0d0
8683       s8=0.0d0
8684       s13=0.0d0
8685 !
8686       eello_turn6=0.0d0
8687       j=i+4
8688       k=i+1
8689       l=i+3
8690       iti=itortyp(itype(i))
8691       itk=itortyp(itype(k))
8692       itk1=itortyp(itype(k+1))
8693       itl=itortyp(itype(l))
8694       itj=itortyp(itype(j))
8695 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8696 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8697 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8698 !d        eello6=0.0d0
8699 !d        return
8700 !d      endif
8701 !d      write (iout,*)
8702 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8703 !d     &   ' and',k,l
8704 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8705       do iii=1,2
8706         do kkk=1,5
8707           do lll=1,3
8708             derx_turn(lll,kkk,iii)=0.0d0
8709           enddo
8710         enddo
8711       enddo
8712 !d      eij=1.0d0
8713 !d      ekl=1.0d0
8714 !d      ekont=1.0d0
8715       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8716 !d      eello6_5=0.0d0
8717 !d      write (2,*) 'eello6_5',eello6_5
8718 #ifdef MOMENT
8719       call transpose2(AEA(1,1,1),auxmat(1,1))
8720       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8721       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8722       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8723 #endif
8724       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8725       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8726       s2 = scalar2(b1(1,itk),vtemp1(1))
8727 #ifdef MOMENT
8728       call transpose2(AEA(1,1,2),atemp(1,1))
8729       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8730       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8731       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8732 #endif
8733       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8734       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8735       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8736 #ifdef MOMENT
8737       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8738       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8739       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8740       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8741       ss13 = scalar2(b1(1,itk),vtemp4(1))
8742       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8743 #endif
8744 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8745 !      s1=0.0d0
8746 !      s2=0.0d0
8747 !      s8=0.0d0
8748 !      s12=0.0d0
8749 !      s13=0.0d0
8750       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8751 ! Derivatives in gamma(i+2)
8752       s1d =0.0d0
8753       s8d =0.0d0
8754 #ifdef MOMENT
8755       call transpose2(AEA(1,1,1),auxmatd(1,1))
8756       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8757       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8758       call transpose2(AEAderg(1,1,2),atempd(1,1))
8759       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8760       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8761 #endif
8762       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8763       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8764       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8765 !      s1d=0.0d0
8766 !      s2d=0.0d0
8767 !      s8d=0.0d0
8768 !      s12d=0.0d0
8769 !      s13d=0.0d0
8770       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8771 ! Derivatives in gamma(i+3)
8772 #ifdef MOMENT
8773       call transpose2(AEA(1,1,1),auxmatd(1,1))
8774       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8775       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8776       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8777 #endif
8778       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8779       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8780       s2d = scalar2(b1(1,itk),vtemp1d(1))
8781 #ifdef MOMENT
8782       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8783       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8784 #endif
8785       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8786 #ifdef MOMENT
8787       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8788       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8789       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8790 #endif
8791 !      s1d=0.0d0
8792 !      s2d=0.0d0
8793 !      s8d=0.0d0
8794 !      s12d=0.0d0
8795 !      s13d=0.0d0
8796 #ifdef MOMENT
8797       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8798                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8799 #else
8800       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8801                     -0.5d0*ekont*(s2d+s12d)
8802 #endif
8803 ! Derivatives in gamma(i+4)
8804       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8805       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8806       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8807 #ifdef MOMENT
8808       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8809       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8810       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8811 #endif
8812 !      s1d=0.0d0
8813 !      s2d=0.0d0
8814 !      s8d=0.0d0
8815 !      s12d=0.0d0
8816 !      s13d=0.0d0
8817 #ifdef MOMENT
8818       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8819 #else
8820       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8821 #endif
8822 ! Derivatives in gamma(i+5)
8823 #ifdef MOMENT
8824       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8825       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8826       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8827 #endif
8828       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8829       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8830       s2d = scalar2(b1(1,itk),vtemp1d(1))
8831 #ifdef MOMENT
8832       call transpose2(AEA(1,1,2),atempd(1,1))
8833       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8834       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8835 #endif
8836       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8837       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8838 #ifdef MOMENT
8839       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8840       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8841       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8842 #endif
8843 !      s1d=0.0d0
8844 !      s2d=0.0d0
8845 !      s8d=0.0d0
8846 !      s12d=0.0d0
8847 !      s13d=0.0d0
8848 #ifdef MOMENT
8849       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8850                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8851 #else
8852       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8853                     -0.5d0*ekont*(s2d+s12d)
8854 #endif
8855 ! Cartesian derivatives
8856       do iii=1,2
8857         do kkk=1,5
8858           do lll=1,3
8859 #ifdef MOMENT
8860             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8861             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8862             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8863 #endif
8864             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8865             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8866                 vtemp1d(1))
8867             s2d = scalar2(b1(1,itk),vtemp1d(1))
8868 #ifdef MOMENT
8869             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8870             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8871             s8d = -(atempd(1,1)+atempd(2,2))* &
8872                  scalar2(cc(1,1,itl),vtemp2(1))
8873 #endif
8874             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8875                  auxmatd(1,1))
8876             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8877             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8878 !      s1d=0.0d0
8879 !      s2d=0.0d0
8880 !      s8d=0.0d0
8881 !      s12d=0.0d0
8882 !      s13d=0.0d0
8883 #ifdef MOMENT
8884             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8885               - 0.5d0*(s1d+s2d)
8886 #else
8887             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8888               - 0.5d0*s2d
8889 #endif
8890 #ifdef MOMENT
8891             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8892               - 0.5d0*(s8d+s12d)
8893 #else
8894             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8895               - 0.5d0*s12d
8896 #endif
8897           enddo
8898         enddo
8899       enddo
8900 #ifdef MOMENT
8901       do kkk=1,5
8902         do lll=1,3
8903           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
8904             achuj_tempd(1,1))
8905           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8906           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8907           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8908           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8909           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
8910             vtemp4d(1))
8911           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8912           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8913           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8914         enddo
8915       enddo
8916 #endif
8917 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8918 !d     &  16*eel_turn6_num
8919 !d      goto 1112
8920       if (j.lt.nres-1) then
8921         j1=j+1
8922         j2=j-1
8923       else
8924         j1=j-1
8925         j2=j-2
8926       endif
8927       if (l.lt.nres-1) then
8928         l1=l+1
8929         l2=l-1
8930       else
8931         l1=l-1
8932         l2=l-2
8933       endif
8934       do ll=1,3
8935 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8936 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8937 !grad        ghalf=0.5d0*ggg1(ll)
8938 !d        ghalf=0.0d0
8939         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8940         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8941         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
8942           +ekont*derx_turn(ll,2,1)
8943         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8944         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
8945           +ekont*derx_turn(ll,4,1)
8946         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8947         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8948         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8949 !grad        ghalf=0.5d0*ggg2(ll)
8950 !d        ghalf=0.0d0
8951         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
8952           +ekont*derx_turn(ll,2,2)
8953         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8954         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
8955           +ekont*derx_turn(ll,4,2)
8956         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8957         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8958         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8959       enddo
8960 !d      goto 1112
8961 !grad      do m=i+1,j-1
8962 !grad        do ll=1,3
8963 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8964 !grad        enddo
8965 !grad      enddo
8966 !grad      do m=k+1,l-1
8967 !grad        do ll=1,3
8968 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8969 !grad        enddo
8970 !grad      enddo
8971 !grad1112  continue
8972 !grad      do m=i+2,j2
8973 !grad        do ll=1,3
8974 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8975 !grad        enddo
8976 !grad      enddo
8977 !grad      do m=k+2,l2
8978 !grad        do ll=1,3
8979 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8980 !grad        enddo
8981 !grad      enddo
8982 !d      do iii=1,nres-3
8983 !d        write (2,*) iii,g_corr6_loc(iii)
8984 !d      enddo
8985       eello_turn6=ekont*eel_turn6
8986 !d      write (2,*) 'ekont',ekont
8987 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
8988       return
8989       end function eello_turn6
8990 !-----------------------------------------------------------------------------
8991       subroutine MATVEC2(A1,V1,V2)
8992 !DIR$ INLINEALWAYS MATVEC2
8993 #ifndef OSF
8994 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8995 #endif
8996 !      implicit real*8 (a-h,o-z)
8997 !      include 'DIMENSIONS'
8998       real(kind=8),dimension(2) :: V1,V2
8999       real(kind=8),dimension(2,2) :: A1
9000       real(kind=8) :: vaux1,vaux2
9001 !      DO 1 I=1,2
9002 !        VI=0.0
9003 !        DO 3 K=1,2
9004 !    3     VI=VI+A1(I,K)*V1(K)
9005 !        Vaux(I)=VI
9006 !    1 CONTINUE
9007
9008       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9009       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9010
9011       v2(1)=vaux1
9012       v2(2)=vaux2
9013       end subroutine MATVEC2
9014 !-----------------------------------------------------------------------------
9015       subroutine MATMAT2(A1,A2,A3)
9016 #ifndef OSF
9017 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9018 #endif
9019 !      implicit real*8 (a-h,o-z)
9020 !      include 'DIMENSIONS'
9021       real(kind=8),dimension(2,2) :: A1,A2,A3
9022       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9023 !      DIMENSION AI3(2,2)
9024 !        DO  J=1,2
9025 !          A3IJ=0.0
9026 !          DO K=1,2
9027 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9028 !          enddo
9029 !          A3(I,J)=A3IJ
9030 !       enddo
9031 !      enddo
9032
9033       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9034       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9035       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9036       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9037
9038       A3(1,1)=AI3_11
9039       A3(2,1)=AI3_21
9040       A3(1,2)=AI3_12
9041       A3(2,2)=AI3_22
9042       end subroutine MATMAT2
9043 !-----------------------------------------------------------------------------
9044       real(kind=8) function scalar2(u,v)
9045 !DIR$ INLINEALWAYS scalar2
9046       implicit none
9047       real(kind=8),dimension(2) :: u,v
9048       real(kind=8) :: sc
9049       integer :: i
9050       scalar2=u(1)*v(1)+u(2)*v(2)
9051       return
9052       end function scalar2
9053 !-----------------------------------------------------------------------------
9054       subroutine transpose2(a,at)
9055 !DIR$ INLINEALWAYS transpose2
9056 #ifndef OSF
9057 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9058 #endif
9059       implicit none
9060       real(kind=8),dimension(2,2) :: a,at
9061       at(1,1)=a(1,1)
9062       at(1,2)=a(2,1)
9063       at(2,1)=a(1,2)
9064       at(2,2)=a(2,2)
9065       return
9066       end subroutine transpose2
9067 !-----------------------------------------------------------------------------
9068       subroutine transpose(n,a,at)
9069       implicit none
9070       integer :: n,i,j
9071       real(kind=8),dimension(n,n) :: a,at
9072       do i=1,n
9073         do j=1,n
9074           at(j,i)=a(i,j)
9075         enddo
9076       enddo
9077       return
9078       end subroutine transpose
9079 !-----------------------------------------------------------------------------
9080       subroutine prodmat3(a1,a2,kk,transp,prod)
9081 !DIR$ INLINEALWAYS prodmat3
9082 #ifndef OSF
9083 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9084 #endif
9085       implicit none
9086       integer :: i,j
9087       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9088       logical :: transp
9089 !rc      double precision auxmat(2,2),prod_(2,2)
9090
9091       if (transp) then
9092 !rc        call transpose2(kk(1,1),auxmat(1,1))
9093 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9094 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9095
9096            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9097        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9098            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9099        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9100            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9101        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9102            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9103        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9104
9105       else
9106 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9107 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9108
9109            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9110         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9111            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9112         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9113            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9114         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9115            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9116         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9117
9118       endif
9119 !      call transpose2(a2(1,1),a2t(1,1))
9120
9121 !rc      print *,transp
9122 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9123 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9124
9125       return
9126       end subroutine prodmat3
9127 !-----------------------------------------------------------------------------
9128 ! energy_p_new_barrier.F
9129 !-----------------------------------------------------------------------------
9130       subroutine sum_gradient
9131 !      implicit real*8 (a-h,o-z)
9132       use io_base, only: pdbout
9133 !      include 'DIMENSIONS'
9134 #ifndef ISNAN
9135       external proc_proc
9136 #ifdef WINPGI
9137 !MS$ATTRIBUTES C ::  proc_proc
9138 #endif
9139 #endif
9140 #ifdef MPI
9141       include 'mpif.h'
9142 #endif
9143       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9144                    gloc_scbuf !(3,maxres)
9145
9146       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9147 !#endif
9148 !el local variables
9149       integer :: i,j,k,ierror,ierr
9150       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9151                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9152                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9153                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9154                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9155                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9156                    gsccorr_max,gsccorrx_max,time00
9157
9158 !      include 'COMMON.SETUP'
9159 !      include 'COMMON.IOUNITS'
9160 !      include 'COMMON.FFIELD'
9161 !      include 'COMMON.DERIV'
9162 !      include 'COMMON.INTERACT'
9163 !      include 'COMMON.SBRIDGE'
9164 !      include 'COMMON.CHAIN'
9165 !      include 'COMMON.VAR'
9166 !      include 'COMMON.CONTROL'
9167 !      include 'COMMON.TIME1'
9168 !      include 'COMMON.MAXGRAD'
9169 !      include 'COMMON.SCCOR'
9170 #ifdef TIMING
9171       time01=MPI_Wtime()
9172 #endif
9173 #ifdef DEBUG
9174       write (iout,*) "sum_gradient gvdwc, gvdwx"
9175       do i=1,nres
9176         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9177          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9178       enddo
9179       call flush(iout)
9180 #endif
9181 #ifdef MPI
9182         gradbufc=0.0d0
9183         gradbufx=0.0d0
9184         gradbufc_sum=0.0d0
9185         gloc_scbuf=0.0d0
9186         glocbuf=0.0d0
9187 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9188         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9189           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9190 #endif
9191 !
9192 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9193 !            in virtual-bond-vector coordinates
9194 !
9195 #ifdef DEBUG
9196 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9197 !      do i=1,nres-1
9198 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9199 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9200 !      enddo
9201 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9202 !      do i=1,nres-1
9203 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9204 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9205 !      enddo
9206       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9207       do i=1,nres
9208         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9209          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9210          (gvdwc_scpp(j,i),j=1,3)
9211       enddo
9212       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9213       do i=1,nres
9214         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9215          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9216          (gelc_loc_long(j,i),j=1,3)
9217       enddo
9218       call flush(iout)
9219 #endif
9220 #ifdef SPLITELE
9221       do i=1,nct
9222         do j=1,3
9223           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9224                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9225                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9226                       wel_loc*gel_loc_long(j,i)+ &
9227                       wcorr*gradcorr_long(j,i)+ &
9228                       wcorr5*gradcorr5_long(j,i)+ &
9229                       wcorr6*gradcorr6_long(j,i)+ &
9230                       wturn6*gcorr6_turn_long(j,i)+ &
9231                       wstrain*ghpbc(j,i)
9232         enddo
9233       enddo
9234 #else
9235       do i=1,nct
9236         do j=1,3
9237           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9238                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9239                       welec*gelc_long(j,i)+ &
9240                       wbond*gradb(j,i)+ &
9241                       wel_loc*gel_loc_long(j,i)+ &
9242                       wcorr*gradcorr_long(j,i)+ &
9243                       wcorr5*gradcorr5_long(j,i)+ &
9244                       wcorr6*gradcorr6_long(j,i)+ &
9245                       wturn6*gcorr6_turn_long(j,i)+ &
9246                       wstrain*ghpbc(j,i)
9247         enddo
9248       enddo
9249 #endif
9250 #ifdef MPI
9251       if (nfgtasks.gt.1) then
9252       time00=MPI_Wtime()
9253 #ifdef DEBUG
9254       write (iout,*) "gradbufc before allreduce"
9255       do i=1,nres
9256         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9257       enddo
9258       call flush(iout)
9259 #endif
9260       do i=1,nres
9261         do j=1,3
9262           gradbufc_sum(j,i)=gradbufc(j,i)
9263         enddo
9264       enddo
9265 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9266 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9267 !      time_reduce=time_reduce+MPI_Wtime()-time00
9268 #ifdef DEBUG
9269 !      write (iout,*) "gradbufc_sum after allreduce"
9270 !      do i=1,nres
9271 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9272 !      enddo
9273 !      call flush(iout)
9274 #endif
9275 #ifdef TIMING
9276 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9277 #endif
9278       do i=nnt,nres
9279         do k=1,3
9280           gradbufc(k,i)=0.0d0
9281         enddo
9282       enddo
9283 #ifdef DEBUG
9284       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9285       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9286                         " jgrad_end  ",jgrad_end(i),&
9287                         i=igrad_start,igrad_end)
9288 #endif
9289 !
9290 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9291 ! do not parallelize this part.
9292 !
9293 !      do i=igrad_start,igrad_end
9294 !        do j=jgrad_start(i),jgrad_end(i)
9295 !          do k=1,3
9296 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9297 !          enddo
9298 !        enddo
9299 !      enddo
9300       do j=1,3
9301         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9302       enddo
9303       do i=nres-2,nnt,-1
9304         do j=1,3
9305           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9306         enddo
9307       enddo
9308 #ifdef DEBUG
9309       write (iout,*) "gradbufc after summing"
9310       do i=1,nres
9311         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9312       enddo
9313       call flush(iout)
9314 #endif
9315       else
9316 #endif
9317 !el#define DEBUG
9318 #ifdef DEBUG
9319       write (iout,*) "gradbufc"
9320       do i=1,nres
9321         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9322       enddo
9323       call flush(iout)
9324 #endif
9325 !el#undef DEBUG
9326       do i=1,nres
9327         do j=1,3
9328           gradbufc_sum(j,i)=gradbufc(j,i)
9329           gradbufc(j,i)=0.0d0
9330         enddo
9331       enddo
9332       do j=1,3
9333         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9334       enddo
9335       do i=nres-2,nnt,-1
9336         do j=1,3
9337           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9338         enddo
9339       enddo
9340 !      do i=nnt,nres-1
9341 !        do k=1,3
9342 !          gradbufc(k,i)=0.0d0
9343 !        enddo
9344 !        do j=i+1,nres
9345 !          do k=1,3
9346 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9347 !          enddo
9348 !        enddo
9349 !      enddo
9350 !el#define DEBUG
9351 #ifdef DEBUG
9352       write (iout,*) "gradbufc after summing"
9353       do i=1,nres
9354         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9355       enddo
9356       call flush(iout)
9357 #endif
9358 !el#undef DEBUG
9359 #ifdef MPI
9360       endif
9361 #endif
9362       do k=1,3
9363         gradbufc(k,nres)=0.0d0
9364       enddo
9365 !el----------------
9366 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9367 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9368 !el-----------------
9369       do i=1,nct
9370         do j=1,3
9371 #ifdef SPLITELE
9372           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9373                       wel_loc*gel_loc(j,i)+ &
9374                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9375                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9376                       wel_loc*gel_loc_long(j,i)+ &
9377                       wcorr*gradcorr_long(j,i)+ &
9378                       wcorr5*gradcorr5_long(j,i)+ &
9379                       wcorr6*gradcorr6_long(j,i)+ &
9380                       wturn6*gcorr6_turn_long(j,i))+ &
9381                       wbond*gradb(j,i)+ &
9382                       wcorr*gradcorr(j,i)+ &
9383                       wturn3*gcorr3_turn(j,i)+ &
9384                       wturn4*gcorr4_turn(j,i)+ &
9385                       wcorr5*gradcorr5(j,i)+ &
9386                       wcorr6*gradcorr6(j,i)+ &
9387                       wturn6*gcorr6_turn(j,i)+ &
9388                       wsccor*gsccorc(j,i) &
9389                      +wscloc*gscloc(j,i)
9390 #else
9391           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9392                       wel_loc*gel_loc(j,i)+ &
9393                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9394                       welec*gelc_long(j,i)+ &
9395                       wel_loc*gel_loc_long(j,i)+ &
9396 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9397                       wcorr5*gradcorr5_long(j,i)+ &
9398                       wcorr6*gradcorr6_long(j,i)+ &
9399                       wturn6*gcorr6_turn_long(j,i))+ &
9400                       wbond*gradb(j,i)+ &
9401                       wcorr*gradcorr(j,i)+ &
9402                       wturn3*gcorr3_turn(j,i)+ &
9403                       wturn4*gcorr4_turn(j,i)+ &
9404                       wcorr5*gradcorr5(j,i)+ &
9405                       wcorr6*gradcorr6(j,i)+ &
9406                       wturn6*gcorr6_turn(j,i)+ &
9407                       wsccor*gsccorc(j,i) &
9408                      +wscloc*gscloc(j,i)
9409 #endif
9410           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9411                         wbond*gradbx(j,i)+ &
9412                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9413                         wsccor*gsccorx(j,i) &
9414                        +wscloc*gsclocx(j,i)
9415         enddo
9416       enddo
9417 #ifdef DEBUG
9418       write (iout,*) "gloc before adding corr"
9419       do i=1,4*nres
9420         write (iout,*) i,gloc(i,icg)
9421       enddo
9422 #endif
9423       do i=1,nres-3
9424         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9425          +wcorr5*g_corr5_loc(i) &
9426          +wcorr6*g_corr6_loc(i) &
9427          +wturn4*gel_loc_turn4(i) &
9428          +wturn3*gel_loc_turn3(i) &
9429          +wturn6*gel_loc_turn6(i) &
9430          +wel_loc*gel_loc_loc(i)
9431       enddo
9432 #ifdef DEBUG
9433       write (iout,*) "gloc after adding corr"
9434       do i=1,4*nres
9435         write (iout,*) i,gloc(i,icg)
9436       enddo
9437 #endif
9438 #ifdef MPI
9439       if (nfgtasks.gt.1) then
9440         do j=1,3
9441           do i=1,nres
9442             gradbufc(j,i)=gradc(j,i,icg)
9443             gradbufx(j,i)=gradx(j,i,icg)
9444           enddo
9445         enddo
9446         do i=1,4*nres
9447           glocbuf(i)=gloc(i,icg)
9448         enddo
9449 !#define DEBUG
9450 #ifdef DEBUG
9451       write (iout,*) "gloc_sc before reduce"
9452       do i=1,nres
9453        do j=1,1
9454         write (iout,*) i,j,gloc_sc(j,i,icg)
9455        enddo
9456       enddo
9457 #endif
9458 !#undef DEBUG
9459         do i=1,nres
9460          do j=1,3
9461           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9462          enddo
9463         enddo
9464         time00=MPI_Wtime()
9465         call MPI_Barrier(FG_COMM,IERR)
9466         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9467         time00=MPI_Wtime()
9468         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9469           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9470         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9471           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9472         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9473           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9474         time_reduce=time_reduce+MPI_Wtime()-time00
9475         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9476           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9477         time_reduce=time_reduce+MPI_Wtime()-time00
9478 !#define DEBUG
9479 #ifdef DEBUG
9480       write (iout,*) "gloc_sc after reduce"
9481       do i=1,nres
9482        do j=1,1
9483         write (iout,*) i,j,gloc_sc(j,i,icg)
9484        enddo
9485       enddo
9486 #endif
9487 !#undef DEBUG
9488 #ifdef DEBUG
9489       write (iout,*) "gloc after reduce"
9490       do i=1,4*nres
9491         write (iout,*) i,gloc(i,icg)
9492       enddo
9493 #endif
9494       endif
9495 #endif
9496       if (gnorm_check) then
9497 !
9498 ! Compute the maximum elements of the gradient
9499 !
9500       gvdwc_max=0.0d0
9501       gvdwc_scp_max=0.0d0
9502       gelc_max=0.0d0
9503       gvdwpp_max=0.0d0
9504       gradb_max=0.0d0
9505       ghpbc_max=0.0d0
9506       gradcorr_max=0.0d0
9507       gel_loc_max=0.0d0
9508       gcorr3_turn_max=0.0d0
9509       gcorr4_turn_max=0.0d0
9510       gradcorr5_max=0.0d0
9511       gradcorr6_max=0.0d0
9512       gcorr6_turn_max=0.0d0
9513       gsccorc_max=0.0d0
9514       gscloc_max=0.0d0
9515       gvdwx_max=0.0d0
9516       gradx_scp_max=0.0d0
9517       ghpbx_max=0.0d0
9518       gradxorr_max=0.0d0
9519       gsccorx_max=0.0d0
9520       gsclocx_max=0.0d0
9521       do i=1,nct
9522         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9523         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9524         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9525         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9526          gvdwc_scp_max=gvdwc_scp_norm
9527         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9528         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9529         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9530         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9531         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9532         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9533         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9534         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9535         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9536         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9537         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9538         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9539         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9540           gcorr3_turn(1,i)))
9541         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9542           gcorr3_turn_max=gcorr3_turn_norm
9543         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9544           gcorr4_turn(1,i)))
9545         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9546           gcorr4_turn_max=gcorr4_turn_norm
9547         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9548         if (gradcorr5_norm.gt.gradcorr5_max) &
9549           gradcorr5_max=gradcorr5_norm
9550         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9551         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9552         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9553           gcorr6_turn(1,i)))
9554         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9555           gcorr6_turn_max=gcorr6_turn_norm
9556         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9557         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9558         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9559         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9560         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9561         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9562         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9563         if (gradx_scp_norm.gt.gradx_scp_max) &
9564           gradx_scp_max=gradx_scp_norm
9565         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9566         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9567         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9568         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9569         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9570         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9571         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9572         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9573       enddo
9574       if (gradout) then
9575 #ifdef AIX
9576         open(istat,file=statname,position="append")
9577 #else
9578         open(istat,file=statname,access="append")
9579 #endif
9580         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9581            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9582            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9583            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9584            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9585            gsccorx_max,gsclocx_max
9586         close(istat)
9587         if (gvdwc_max.gt.1.0d4) then
9588           write (iout,*) "gvdwc gvdwx gradb gradbx"
9589           do i=nnt,nct
9590             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9591               gradb(j,i),gradbx(j,i),j=1,3)
9592           enddo
9593           call pdbout(0.0d0,'cipiszcze',iout)
9594           call flush(iout)
9595         endif
9596       endif
9597       endif
9598 !el#define DEBUG
9599 #ifdef DEBUG
9600       write (iout,*) "gradc gradx gloc"
9601       do i=1,nres
9602         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9603          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9604       enddo
9605 #endif
9606 !el#undef DEBUG
9607 #ifdef TIMING
9608       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9609 #endif
9610       return
9611       end subroutine sum_gradient
9612 !-----------------------------------------------------------------------------
9613       subroutine sc_grad
9614 !      implicit real*8 (a-h,o-z)
9615       use calc_data
9616 !      include 'DIMENSIONS'
9617 !      include 'COMMON.CHAIN'
9618 !      include 'COMMON.DERIV'
9619 !      include 'COMMON.CALC'
9620 !      include 'COMMON.IOUNITS'
9621       real(kind=8), dimension(3) :: dcosom1,dcosom2
9622
9623       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9624       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9625       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9626            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9627 ! diagnostics only
9628 !      eom1=0.0d0
9629 !      eom2=0.0d0
9630 !      eom12=evdwij*eps1_om12
9631 ! end diagnostics
9632 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9633 !       " sigder",sigder
9634 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9635 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9636 !C      print *,sss_ele_cut,'in sc_grad'
9637       do k=1,3
9638         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9639         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9640       enddo
9641       do k=1,3
9642         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
9643 !C      print *,'gg',k,gg(k)
9644       enddo
9645 !      write (iout,*) "gg",(gg(k),k=1,3)
9646       do k=1,3
9647         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9648                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9649                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
9650                   *sss_ele_cut
9651
9652         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9653                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9654                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
9655                   *sss_ele_cut
9656
9657 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9658 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9659 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9660 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9661       enddo
9662 !
9663 ! Calculate the components of the gradient in DC and X
9664 !
9665 !grad      do k=i,j-1
9666 !grad        do l=1,3
9667 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9668 !grad        enddo
9669 !grad      enddo
9670       do l=1,3
9671         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9672         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9673       enddo
9674       return
9675       end subroutine sc_grad
9676 #ifdef CRYST_THETA
9677 !-----------------------------------------------------------------------------
9678       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9679
9680       use comm_calcthet
9681 !      implicit real*8 (a-h,o-z)
9682 !      include 'DIMENSIONS'
9683 !      include 'COMMON.LOCAL'
9684 !      include 'COMMON.IOUNITS'
9685 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9686 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9687 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9688       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9689       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9690 !el      integer :: it
9691 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9692 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9693 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9694 !el local variables
9695
9696       delthec=thetai-thet_pred_mean
9697       delthe0=thetai-theta0i
9698 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9699       t3 = thetai-thet_pred_mean
9700       t6 = t3**2
9701       t9 = term1
9702       t12 = t3*sigcsq
9703       t14 = t12+t6*sigsqtc
9704       t16 = 1.0d0
9705       t21 = thetai-theta0i
9706       t23 = t21**2
9707       t26 = term2
9708       t27 = t21*t26
9709       t32 = termexp
9710       t40 = t32**2
9711       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9712        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9713        *(-t12*t9-ak*sig0inv*t27)
9714       return
9715       end subroutine mixder
9716 #endif
9717 !-----------------------------------------------------------------------------
9718 ! cartder.F
9719 !-----------------------------------------------------------------------------
9720       subroutine cartder
9721 !-----------------------------------------------------------------------------
9722 ! This subroutine calculates the derivatives of the consecutive virtual
9723 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9724 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9725 ! in the angles alpha and omega, describing the location of a side chain
9726 ! in its local coordinate system.
9727 !
9728 ! The derivatives are stored in the following arrays:
9729 !
9730 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9731 ! The structure is as follows:
9732 !
9733 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9734 ! 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)
9735 !         . . . . . . . . . . . .  . . . . . .
9736 ! 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)
9737 !                          .
9738 !                          .
9739 !                          .
9740 ! 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)
9741 !
9742 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9743 ! The structure is same as above.
9744 !
9745 ! DCDS - the derivatives of the side chain vectors in the local spherical
9746 ! andgles alph and omega:
9747 !
9748 ! 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)
9749 ! 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)
9750 !                          .
9751 !                          .
9752 !                          .
9753 ! 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)
9754 !
9755 ! Version of March '95, based on an early version of November '91.
9756 !
9757 !**********************************************************************
9758 !      implicit real*8 (a-h,o-z)
9759 !      include 'DIMENSIONS'
9760 !      include 'COMMON.VAR'
9761 !      include 'COMMON.CHAIN'
9762 !      include 'COMMON.DERIV'
9763 !      include 'COMMON.GEO'
9764 !      include 'COMMON.LOCAL'
9765 !      include 'COMMON.INTERACT'
9766       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9767       real(kind=8),dimension(3,3) :: dp,temp
9768 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9769       real(kind=8),dimension(3) :: xx,xx1
9770 !el local variables
9771       integer :: i,k,l,j,m,ind,ind1,jjj
9772       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9773                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9774                  sint2,xp,yp,xxp,yyp,zzp,dj
9775
9776 !      common /przechowalnia/ fromto
9777       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9778 ! get the position of the jth ijth fragment of the chain coordinate system
9779 ! in the fromto array.
9780 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9781 !
9782 !      maxdim=(nres-1)*(nres-2)/2
9783 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9784 ! calculate the derivatives of transformation matrix elements in theta
9785 !
9786
9787 !el      call flush(iout) !el
9788       do i=1,nres-2
9789         rdt(1,1,i)=-rt(1,2,i)
9790         rdt(1,2,i)= rt(1,1,i)
9791         rdt(1,3,i)= 0.0d0
9792         rdt(2,1,i)=-rt(2,2,i)
9793         rdt(2,2,i)= rt(2,1,i)
9794         rdt(2,3,i)= 0.0d0
9795         rdt(3,1,i)=-rt(3,2,i)
9796         rdt(3,2,i)= rt(3,1,i)
9797         rdt(3,3,i)= 0.0d0
9798       enddo
9799 !
9800 ! derivatives in phi
9801 !
9802       do i=2,nres-2
9803         drt(1,1,i)= 0.0d0
9804         drt(1,2,i)= 0.0d0
9805         drt(1,3,i)= 0.0d0
9806         drt(2,1,i)= rt(3,1,i)
9807         drt(2,2,i)= rt(3,2,i)
9808         drt(2,3,i)= rt(3,3,i)
9809         drt(3,1,i)=-rt(2,1,i)
9810         drt(3,2,i)=-rt(2,2,i)
9811         drt(3,3,i)=-rt(2,3,i)
9812       enddo
9813 !
9814 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9815 !
9816       do i=2,nres-2
9817         ind=indmat(i,i+1)
9818         do k=1,3
9819           do l=1,3
9820             temp(k,l)=rt(k,l,i)
9821           enddo
9822         enddo
9823         do k=1,3
9824           do l=1,3
9825             fromto(k,l,ind)=temp(k,l)
9826           enddo
9827         enddo
9828         do j=i+1,nres-2
9829           ind=indmat(i,j+1)
9830           do k=1,3
9831             do l=1,3
9832               dpkl=0.0d0
9833               do m=1,3
9834                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9835               enddo
9836               dp(k,l)=dpkl
9837               fromto(k,l,ind)=dpkl
9838             enddo
9839           enddo
9840           do k=1,3
9841             do l=1,3
9842               temp(k,l)=dp(k,l)
9843             enddo
9844           enddo
9845         enddo
9846       enddo
9847 !
9848 ! Calculate derivatives.
9849 !
9850       ind1=0
9851       do i=1,nres-2
9852         ind1=ind1+1
9853 !
9854 ! Derivatives of DC(i+1) in theta(i+2)
9855 !
9856         do j=1,3
9857           do k=1,2
9858             dpjk=0.0D0
9859             do l=1,3
9860               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9861             enddo
9862             dp(j,k)=dpjk
9863             prordt(j,k,i)=dp(j,k)
9864           enddo
9865           dp(j,3)=0.0D0
9866           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9867         enddo
9868 !
9869 ! Derivatives of SC(i+1) in theta(i+2)
9870 !
9871         xx1(1)=-0.5D0*xloc(2,i+1)
9872         xx1(2)= 0.5D0*xloc(1,i+1)
9873         do j=1,3
9874           xj=0.0D0
9875           do k=1,2
9876             xj=xj+r(j,k,i)*xx1(k)
9877           enddo
9878           xx(j)=xj
9879         enddo
9880         do j=1,3
9881           rj=0.0D0
9882           do k=1,3
9883             rj=rj+prod(j,k,i)*xx(k)
9884           enddo
9885           dxdv(j,ind1)=rj
9886         enddo
9887 !
9888 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
9889 ! than the other off-diagonal derivatives.
9890 !
9891         do j=1,3
9892           dxoiij=0.0D0
9893           do k=1,3
9894             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9895           enddo
9896           dxdv(j,ind1+1)=dxoiij
9897         enddo
9898 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
9899 !
9900 ! Derivatives of DC(i+1) in phi(i+2)
9901 !
9902         do j=1,3
9903           do k=1,3
9904             dpjk=0.0
9905             do l=2,3
9906               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
9907             enddo
9908             dp(j,k)=dpjk
9909             prodrt(j,k,i)=dp(j,k)
9910           enddo
9911           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
9912         enddo
9913 !
9914 ! Derivatives of SC(i+1) in phi(i+2)
9915 !
9916         xx(1)= 0.0D0
9917         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
9918         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
9919         do j=1,3
9920           rj=0.0D0
9921           do k=2,3
9922             rj=rj+prod(j,k,i)*xx(k)
9923           enddo
9924           dxdv(j+3,ind1)=-rj
9925         enddo
9926 !
9927 ! Derivatives of SC(i+1) in phi(i+3).
9928 !
9929         do j=1,3
9930           dxoiij=0.0D0
9931           do k=1,3
9932             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9933           enddo
9934           dxdv(j+3,ind1+1)=dxoiij
9935         enddo
9936 !
9937 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
9938 ! theta(nres) and phi(i+3) thru phi(nres).
9939 !
9940         do j=i+1,nres-2
9941           ind1=ind1+1
9942           ind=indmat(i+1,j+1)
9943 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
9944           do k=1,3
9945             do l=1,3
9946               tempkl=0.0D0
9947               do m=1,2
9948                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
9949               enddo
9950               temp(k,l)=tempkl
9951             enddo
9952           enddo
9953 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
9954 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
9955 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
9956 ! Derivatives of virtual-bond vectors in theta
9957           do k=1,3
9958             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
9959           enddo
9960 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
9961 ! Derivatives of SC vectors in theta
9962           do k=1,3
9963             dxoijk=0.0D0
9964             do l=1,3
9965               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9966             enddo
9967             dxdv(k,ind1+1)=dxoijk
9968           enddo
9969 !
9970 !--- Calculate the derivatives in phi
9971 !
9972           do k=1,3
9973             do l=1,3
9974               tempkl=0.0D0
9975               do m=1,3
9976                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
9977               enddo
9978               temp(k,l)=tempkl
9979             enddo
9980           enddo
9981           do k=1,3
9982             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
9983           enddo
9984           do k=1,3
9985             dxoijk=0.0D0
9986             do l=1,3
9987               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9988             enddo
9989             dxdv(k+3,ind1+1)=dxoijk
9990           enddo
9991         enddo
9992       enddo
9993 !
9994 ! Derivatives in alpha and omega:
9995 !
9996       do i=2,nres-1
9997 !       dsci=dsc(itype(i))
9998         dsci=vbld(i+nres)
9999 #ifdef OSF
10000         alphi=alph(i)
10001         omegi=omeg(i)
10002         if(alphi.ne.alphi) alphi=100.0
10003         if(omegi.ne.omegi) omegi=-100.0
10004 #else
10005         alphi=alph(i)
10006         omegi=omeg(i)
10007 #endif
10008 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10009         cosalphi=dcos(alphi)
10010         sinalphi=dsin(alphi)
10011         cosomegi=dcos(omegi)
10012         sinomegi=dsin(omegi)
10013         temp(1,1)=-dsci*sinalphi
10014         temp(2,1)= dsci*cosalphi*cosomegi
10015         temp(3,1)=-dsci*cosalphi*sinomegi
10016         temp(1,2)=0.0D0
10017         temp(2,2)=-dsci*sinalphi*sinomegi
10018         temp(3,2)=-dsci*sinalphi*cosomegi
10019         theta2=pi-0.5D0*theta(i+1)
10020         cost2=dcos(theta2)
10021         sint2=dsin(theta2)
10022         jjj=0
10023 !d      print *,((temp(l,k),l=1,3),k=1,2)
10024         do j=1,2
10025           xp=temp(1,j)
10026           yp=temp(2,j)
10027           xxp= xp*cost2+yp*sint2
10028           yyp=-xp*sint2+yp*cost2
10029           zzp=temp(3,j)
10030           xx(1)=xxp
10031           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
10032           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
10033           do k=1,3
10034             dj=0.0D0
10035             do l=1,3
10036               dj=dj+prod(k,l,i-1)*xx(l)
10037             enddo
10038             dxds(jjj+k,i)=dj
10039           enddo
10040           jjj=jjj+3
10041         enddo
10042       enddo
10043       return
10044       end subroutine cartder
10045 !-----------------------------------------------------------------------------
10046 ! checkder_p.F
10047 !-----------------------------------------------------------------------------
10048       subroutine check_cartgrad
10049 ! Check the gradient of Cartesian coordinates in internal coordinates.
10050 !      implicit real*8 (a-h,o-z)
10051 !      include 'DIMENSIONS'
10052 !      include 'COMMON.IOUNITS'
10053 !      include 'COMMON.VAR'
10054 !      include 'COMMON.CHAIN'
10055 !      include 'COMMON.GEO'
10056 !      include 'COMMON.LOCAL'
10057 !      include 'COMMON.DERIV'
10058       real(kind=8),dimension(6,nres) :: temp
10059       real(kind=8),dimension(3) :: xx,gg
10060       integer :: i,k,j,ii
10061       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
10062 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10063 !
10064 ! Check the gradient of the virtual-bond and SC vectors in the internal
10065 ! coordinates.
10066 !
10067       aincr=1.0d-7
10068       aincr2=5.0d-8
10069       call cartder
10070       write (iout,'(a)') '**************** dx/dalpha'
10071       write (iout,'(a)')
10072       do i=2,nres-1
10073         alphi=alph(i)
10074         alph(i)=alph(i)+aincr
10075         do k=1,3
10076           temp(k,i)=dc(k,nres+i)
10077         enddo
10078         call chainbuild
10079         do k=1,3
10080           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10081           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10082         enddo
10083         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10084         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10085         write (iout,'(a)')
10086         alph(i)=alphi
10087         call chainbuild
10088       enddo
10089       write (iout,'(a)')
10090       write (iout,'(a)') '**************** dx/domega'
10091       write (iout,'(a)')
10092       do i=2,nres-1
10093         omegi=omeg(i)
10094         omeg(i)=omeg(i)+aincr
10095         do k=1,3
10096           temp(k,i)=dc(k,nres+i)
10097         enddo
10098         call chainbuild
10099         do k=1,3
10100           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10101           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10102                 (aincr*dabs(dxds(k+3,i))+aincr))
10103         enddo
10104         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10105             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10106         write (iout,'(a)')
10107         omeg(i)=omegi
10108         call chainbuild
10109       enddo
10110       write (iout,'(a)')
10111       write (iout,'(a)') '**************** dx/dtheta'
10112       write (iout,'(a)')
10113       do i=3,nres
10114         theti=theta(i)
10115         theta(i)=theta(i)+aincr
10116         do j=i-1,nres-1
10117           do k=1,3
10118             temp(k,j)=dc(k,nres+j)
10119           enddo
10120         enddo
10121         call chainbuild
10122         do j=i-1,nres-1
10123           ii = indmat(i-2,j)
10124 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10125           do k=1,3
10126             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10127             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10128                   (aincr*dabs(dxdv(k,ii))+aincr))
10129           enddo
10130           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10131               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10132           write(iout,'(a)')
10133         enddo
10134         write (iout,'(a)')
10135         theta(i)=theti
10136         call chainbuild
10137       enddo
10138       write (iout,'(a)') '***************** dx/dphi'
10139       write (iout,'(a)')
10140       do i=4,nres
10141         phi(i)=phi(i)+aincr
10142         do j=i-1,nres-1
10143           do k=1,3
10144             temp(k,j)=dc(k,nres+j)
10145           enddo
10146         enddo
10147         call chainbuild
10148         do j=i-1,nres-1
10149           ii = indmat(i-2,j)
10150 !         print *,'ii=',ii
10151           do k=1,3
10152             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10153             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10154                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10155           enddo
10156           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10157               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10158           write(iout,'(a)')
10159         enddo
10160         phi(i)=phi(i)-aincr
10161         call chainbuild
10162       enddo
10163       write (iout,'(a)') '****************** ddc/dtheta'
10164       do i=1,nres-2
10165         thet=theta(i+2)
10166         theta(i+2)=thet+aincr
10167         do j=i,nres
10168           do k=1,3
10169             temp(k,j)=dc(k,j)
10170           enddo
10171         enddo
10172         call chainbuild
10173         do j=i+1,nres-1
10174           ii = indmat(i,j)
10175 !         print *,'ii=',ii
10176           do k=1,3
10177             gg(k)=(dc(k,j)-temp(k,j))/aincr
10178             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10179                  (aincr*dabs(dcdv(k,ii))+aincr))
10180           enddo
10181           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10182                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10183           write (iout,'(a)')
10184         enddo
10185         do j=1,nres
10186           do k=1,3
10187             dc(k,j)=temp(k,j)
10188           enddo
10189         enddo
10190         theta(i+2)=thet
10191       enddo
10192       write (iout,'(a)') '******************* ddc/dphi'
10193       do i=1,nres-3
10194         phii=phi(i+3)
10195         phi(i+3)=phii+aincr
10196         do j=1,nres
10197           do k=1,3
10198             temp(k,j)=dc(k,j)
10199           enddo
10200         enddo
10201         call chainbuild
10202         do j=i+2,nres-1
10203           ii = indmat(i+1,j)
10204 !         print *,'ii=',ii
10205           do k=1,3
10206             gg(k)=(dc(k,j)-temp(k,j))/aincr
10207             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10208                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10209           enddo
10210           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10211                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10212           write (iout,'(a)')
10213         enddo
10214         do j=1,nres
10215           do k=1,3
10216             dc(k,j)=temp(k,j)
10217           enddo
10218         enddo
10219         phi(i+3)=phii
10220       enddo
10221       return
10222       end subroutine check_cartgrad
10223 !-----------------------------------------------------------------------------
10224       subroutine check_ecart
10225 ! Check the gradient of the energy in Cartesian coordinates.
10226 !     implicit real*8 (a-h,o-z)
10227 !     include 'DIMENSIONS'
10228 !     include 'COMMON.CHAIN'
10229 !     include 'COMMON.DERIV'
10230 !     include 'COMMON.IOUNITS'
10231 !     include 'COMMON.VAR'
10232 !     include 'COMMON.CONTACTS'
10233       use comm_srutu
10234 !el      integer :: icall
10235 !el      common /srutu/ icall
10236       real(kind=8),dimension(6) :: ggg
10237       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10238       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10239       real(kind=8),dimension(6,nres) :: grad_s
10240       real(kind=8),dimension(0:n_ene) :: energia,energia1
10241       integer :: uiparm(1)
10242       real(kind=8) :: urparm(1)
10243 !EL      external fdum
10244       integer :: nf,i,j,k
10245       real(kind=8) :: aincr,etot,etot1
10246       icg=1
10247       nf=0
10248       nfl=0
10249       call zerograd
10250       aincr=1.0D-7
10251       print '(a)','CG processor',me,' calling CHECK_CART.'
10252       nf=0
10253       icall=0
10254       call geom_to_var(nvar,x)
10255       call etotal(energia)
10256       etot=energia(0)
10257 !el      call enerprint(energia)
10258       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10259       icall =1
10260       do i=1,nres
10261         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10262       enddo
10263       do i=1,nres
10264         do j=1,3
10265           grad_s(j,i)=gradc(j,i,icg)
10266           grad_s(j+3,i)=gradx(j,i,icg)
10267         enddo
10268       enddo
10269       call flush(iout)
10270       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10271       do i=1,nres
10272         do j=1,3
10273           xx(j)=c(j,i+nres)
10274           ddc(j)=dc(j,i)
10275           ddx(j)=dc(j,i+nres)
10276         enddo
10277         do j=1,3
10278           dc(j,i)=dc(j,i)+aincr
10279           do k=i+1,nres
10280             c(j,k)=c(j,k)+aincr
10281             c(j,k+nres)=c(j,k+nres)+aincr
10282           enddo
10283           call etotal(energia1)
10284           etot1=energia1(0)
10285           ggg(j)=(etot1-etot)/aincr
10286           dc(j,i)=ddc(j)
10287           do k=i+1,nres
10288             c(j,k)=c(j,k)-aincr
10289             c(j,k+nres)=c(j,k+nres)-aincr
10290           enddo
10291         enddo
10292         do j=1,3
10293           c(j,i+nres)=c(j,i+nres)+aincr
10294           dc(j,i+nres)=dc(j,i+nres)+aincr
10295           call etotal(energia1)
10296           etot1=energia1(0)
10297           ggg(j+3)=(etot1-etot)/aincr
10298           c(j,i+nres)=xx(j)
10299           dc(j,i+nres)=ddx(j)
10300         enddo
10301         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10302          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10303       enddo
10304       return
10305       end subroutine check_ecart
10306 #ifdef CARGRAD
10307 !-----------------------------------------------------------------------------
10308       subroutine check_ecartint
10309 ! Check the gradient of the energy in Cartesian coordinates.
10310       use io_base, only: intout
10311 !      implicit real*8 (a-h,o-z)
10312 !      include 'DIMENSIONS'
10313 !      include 'COMMON.CONTROL'
10314 !      include 'COMMON.CHAIN'
10315 !      include 'COMMON.DERIV'
10316 !      include 'COMMON.IOUNITS'
10317 !      include 'COMMON.VAR'
10318 !      include 'COMMON.CONTACTS'
10319 !      include 'COMMON.MD'
10320 !      include 'COMMON.LOCAL'
10321 !      include 'COMMON.SPLITELE'
10322       use comm_srutu
10323 !el      integer :: icall
10324 !el      common /srutu/ icall
10325       real(kind=8),dimension(6) :: ggg,ggg1
10326       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
10327       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10328       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
10329       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10330       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10331       real(kind=8),dimension(0:n_ene) :: energia,energia1
10332       integer :: uiparm(1)
10333       real(kind=8) :: urparm(1)
10334 !EL      external fdum
10335       integer :: i,j,k,nf
10336       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10337                    etot21,etot22
10338       r_cut=2.0d0
10339       rlambd=0.3d0
10340       icg=1
10341       nf=0
10342       nfl=0
10343       call intout
10344 !      call intcartderiv
10345 !      call checkintcartgrad
10346       call zerograd
10347       aincr=1.0D-5
10348       write(iout,*) 'Calling CHECK_ECARTINT.'
10349       nf=0
10350       icall=0
10351       write (iout,*) "Before geom_to_var"
10352       call geom_to_var(nvar,x)
10353       write (iout,*) "after geom_to_var"
10354       write (iout,*) "split_ene ",split_ene
10355       call flush(iout)
10356       if (.not.split_ene) then
10357         write(iout,*) 'Calling CHECK_ECARTINT if'
10358         call etotal(energia)
10359 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10360         etot=energia(0)
10361         write (iout,*) "etot",etot
10362         call flush(iout)
10363 !el        call enerprint(energia)
10364 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10365         call flush(iout)
10366         write (iout,*) "enter cartgrad"
10367         call flush(iout)
10368         call cartgrad
10369 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10370         write (iout,*) "exit cartgrad"
10371         call flush(iout)
10372         icall =1
10373         do i=1,nres
10374           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10375         enddo
10376         do j=1,3
10377           grad_s(j,0)=gcart(j,0)
10378         enddo
10379 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10380         do i=1,nres
10381           do j=1,3
10382             grad_s(j,i)=gcart(j,i)
10383             grad_s(j+3,i)=gxcart(j,i)
10384           enddo
10385         enddo
10386       else
10387 write(iout,*) 'Calling CHECK_ECARTIN else.'
10388 !- split gradient check
10389         call zerograd
10390         call etotal_long(energia)
10391 !el        call enerprint(energia)
10392         call flush(iout)
10393         write (iout,*) "enter cartgrad"
10394         call flush(iout)
10395         call cartgrad
10396         write (iout,*) "exit cartgrad"
10397         call flush(iout)
10398         icall =1
10399         write (iout,*) "longrange grad"
10400         do i=1,nres
10401           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10402           (gxcart(j,i),j=1,3)
10403         enddo
10404         do j=1,3
10405           grad_s(j,0)=gcart(j,0)
10406         enddo
10407         do i=1,nres
10408           do j=1,3
10409             grad_s(j,i)=gcart(j,i)
10410             grad_s(j+3,i)=gxcart(j,i)
10411           enddo
10412         enddo
10413         call zerograd
10414         call etotal_short(energia)
10415 !el        call enerprint(energia)
10416         call flush(iout)
10417         write (iout,*) "enter cartgrad"
10418         call flush(iout)
10419         call cartgrad
10420         write (iout,*) "exit cartgrad"
10421         call flush(iout)
10422         icall =1
10423         write (iout,*) "shortrange grad"
10424         do i=1,nres
10425           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10426           (gxcart(j,i),j=1,3)
10427         enddo
10428         do j=1,3
10429           grad_s1(j,0)=gcart(j,0)
10430         enddo
10431         do i=1,nres
10432           do j=1,3
10433             grad_s1(j,i)=gcart(j,i)
10434             grad_s1(j+3,i)=gxcart(j,i)
10435           enddo
10436         enddo
10437       endif
10438       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10439 !      do i=1,nres
10440       do i=nnt,nct
10441         do j=1,3
10442           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
10443           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
10444           ddc(j)=c(j,i)
10445           ddx(j)=c(j,i+nres)
10446           dcnorm_safe1(j)=dc_norm(j,i-1)
10447           dcnorm_safe2(j)=dc_norm(j,i)
10448           dxnorm_safe(j)=dc_norm(j,i+nres)
10449         enddo
10450         do j=1,3
10451           c(j,i)=ddc(j)+aincr
10452           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
10453           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
10454           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10455           dc(j,i)=c(j,i+1)-c(j,i)
10456           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10457           call int_from_cart1(.false.)
10458           if (.not.split_ene) then
10459             call etotal(energia1)
10460             etot1=energia1(0)
10461             write (iout,*) "ij",i,j," etot1",etot1
10462           else
10463 !- split gradient
10464             call etotal_long(energia1)
10465             etot11=energia1(0)
10466             call etotal_short(energia1)
10467             etot12=energia1(0)
10468           endif
10469 !- end split gradient
10470 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10471           c(j,i)=ddc(j)-aincr
10472           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
10473           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
10474           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10475           dc(j,i)=c(j,i+1)-c(j,i)
10476           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10477           call int_from_cart1(.false.)
10478           if (.not.split_ene) then
10479             call etotal(energia1)
10480             etot2=energia1(0)
10481             write (iout,*) "ij",i,j," etot2",etot2
10482             ggg(j)=(etot1-etot2)/(2*aincr)
10483           else
10484 !- split gradient
10485             call etotal_long(energia1)
10486             etot21=energia1(0)
10487             ggg(j)=(etot11-etot21)/(2*aincr)
10488             call etotal_short(energia1)
10489             etot22=energia1(0)
10490             ggg1(j)=(etot12-etot22)/(2*aincr)
10491 !- end split gradient
10492 !            write (iout,*) "etot21",etot21," etot22",etot22
10493           endif
10494 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10495           c(j,i)=ddc(j)
10496           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
10497           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
10498           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10499           dc(j,i)=c(j,i+1)-c(j,i)
10500           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10501           dc_norm(j,i-1)=dcnorm_safe1(j)
10502           dc_norm(j,i)=dcnorm_safe2(j)
10503           dc_norm(j,i+nres)=dxnorm_safe(j)
10504         enddo
10505         do j=1,3
10506           c(j,i+nres)=ddx(j)+aincr
10507           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10508           call int_from_cart1(.false.)
10509           if (.not.split_ene) then
10510             call etotal(energia1)
10511             etot1=energia1(0)
10512           else
10513 !- split gradient
10514             call etotal_long(energia1)
10515             etot11=energia1(0)
10516             call etotal_short(energia1)
10517             etot12=energia1(0)
10518           endif
10519 !- end split gradient
10520           c(j,i+nres)=ddx(j)-aincr
10521           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10522           call int_from_cart1(.false.)
10523           if (.not.split_ene) then
10524             call etotal(energia1)
10525             etot2=energia1(0)
10526             ggg(j+3)=(etot1-etot2)/(2*aincr)
10527           else
10528 !- split gradient
10529             call etotal_long(energia1)
10530             etot21=energia1(0)
10531             ggg(j+3)=(etot11-etot21)/(2*aincr)
10532             call etotal_short(energia1)
10533             etot22=energia1(0)
10534             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10535 !- end split gradient
10536           endif
10537 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10538           c(j,i+nres)=ddx(j)
10539           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10540           dc_norm(j,i+nres)=dxnorm_safe(j)
10541           call int_from_cart1(.false.)
10542         enddo
10543         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10544          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10545         if (split_ene) then
10546           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10547          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10548          k=1,6)
10549          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10550          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10551          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10552         endif
10553       enddo
10554       return
10555       end subroutine check_ecartint
10556 #else
10557 !-----------------------------------------------------------------------------
10558       subroutine check_ecartint
10559 ! Check the gradient of the energy in Cartesian coordinates.
10560       use io_base, only: intout
10561 !      implicit real*8 (a-h,o-z)
10562 !      include 'DIMENSIONS'
10563 !      include 'COMMON.CONTROL'
10564 !      include 'COMMON.CHAIN'
10565 !      include 'COMMON.DERIV'
10566 !      include 'COMMON.IOUNITS'
10567 !      include 'COMMON.VAR'
10568 !      include 'COMMON.CONTACTS'
10569 !      include 'COMMON.MD'
10570 !      include 'COMMON.LOCAL'
10571 !      include 'COMMON.SPLITELE'
10572       use comm_srutu
10573 !el      integer :: icall
10574 !el      common /srutu/ icall
10575       real(kind=8),dimension(6) :: ggg,ggg1
10576       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10577       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10578       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10579       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10580       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10581       real(kind=8),dimension(0:n_ene) :: energia,energia1
10582       integer :: uiparm(1)
10583       real(kind=8) :: urparm(1)
10584 !EL      external fdum
10585       integer :: i,j,k,nf
10586       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10587                    etot21,etot22
10588       r_cut=2.0d0
10589       rlambd=0.3d0
10590       icg=1
10591       nf=0
10592       nfl=0
10593       call intout
10594 !      call intcartderiv
10595 !      call checkintcartgrad
10596       call zerograd
10597       aincr=1.0D-6
10598       write(iout,*) 'Calling CHECK_ECARTINT.'
10599       nf=0
10600       icall=0
10601       call geom_to_var(nvar,x)
10602       if (.not.split_ene) then
10603         call etotal(energia)
10604         etot=energia(0)
10605 !el        call enerprint(energia)
10606         call flush(iout)
10607         write (iout,*) "enter cartgrad"
10608         call flush(iout)
10609         call cartgrad
10610         write (iout,*) "exit cartgrad"
10611         call flush(iout)
10612         icall =1
10613         do i=1,nres
10614           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10615         enddo
10616         do j=1,3
10617           grad_s(j,0)=gcart(j,0)
10618         enddo
10619         do i=1,nres
10620           do j=1,3
10621             grad_s(j,i)=gcart(j,i)
10622             grad_s(j+3,i)=gxcart(j,i)
10623           enddo
10624         enddo
10625       else
10626 !- split gradient check
10627         call zerograd
10628         call etotal_long(energia)
10629 !el        call enerprint(energia)
10630         call flush(iout)
10631         write (iout,*) "enter cartgrad"
10632         call flush(iout)
10633         call cartgrad
10634         write (iout,*) "exit cartgrad"
10635         call flush(iout)
10636         icall =1
10637         write (iout,*) "longrange grad"
10638         do i=1,nres
10639           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10640           (gxcart(j,i),j=1,3)
10641         enddo
10642         do j=1,3
10643           grad_s(j,0)=gcart(j,0)
10644         enddo
10645         do i=1,nres
10646           do j=1,3
10647             grad_s(j,i)=gcart(j,i)
10648             grad_s(j+3,i)=gxcart(j,i)
10649           enddo
10650         enddo
10651         call zerograd
10652         call etotal_short(energia)
10653 !el        call enerprint(energia)
10654         call flush(iout)
10655         write (iout,*) "enter cartgrad"
10656         call flush(iout)
10657         call cartgrad
10658         write (iout,*) "exit cartgrad"
10659         call flush(iout)
10660         icall =1
10661         write (iout,*) "shortrange grad"
10662         do i=1,nres
10663           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10664           (gxcart(j,i),j=1,3)
10665         enddo
10666         do j=1,3
10667           grad_s1(j,0)=gcart(j,0)
10668         enddo
10669         do i=1,nres
10670           do j=1,3
10671             grad_s1(j,i)=gcart(j,i)
10672             grad_s1(j+3,i)=gxcart(j,i)
10673           enddo
10674         enddo
10675       endif
10676       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10677       do i=0,nres
10678         do j=1,3
10679           xx(j)=c(j,i+nres)
10680           ddc(j)=dc(j,i)
10681           ddx(j)=dc(j,i+nres)
10682           do k=1,3
10683             dcnorm_safe(k)=dc_norm(k,i)
10684             dxnorm_safe(k)=dc_norm(k,i+nres)
10685           enddo
10686         enddo
10687         do j=1,3
10688           dc(j,i)=ddc(j)+aincr
10689           call chainbuild_cart
10690 #ifdef MPI
10691 ! Broadcast the order to compute internal coordinates to the slaves.
10692 !          if (nfgtasks.gt.1)
10693 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10694 #endif
10695 !          call int_from_cart1(.false.)
10696           if (.not.split_ene) then
10697             call etotal(energia1)
10698             etot1=energia1(0)
10699           else
10700 !- split gradient
10701             call etotal_long(energia1)
10702             etot11=energia1(0)
10703             call etotal_short(energia1)
10704             etot12=energia1(0)
10705 !            write (iout,*) "etot11",etot11," etot12",etot12
10706           endif
10707 !- end split gradient
10708 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10709           dc(j,i)=ddc(j)-aincr
10710           call chainbuild_cart
10711 !          call int_from_cart1(.false.)
10712           if (.not.split_ene) then
10713             call etotal(energia1)
10714             etot2=energia1(0)
10715             ggg(j)=(etot1-etot2)/(2*aincr)
10716           else
10717 !- split gradient
10718             call etotal_long(energia1)
10719             etot21=energia1(0)
10720             ggg(j)=(etot11-etot21)/(2*aincr)
10721             call etotal_short(energia1)
10722             etot22=energia1(0)
10723             ggg1(j)=(etot12-etot22)/(2*aincr)
10724 !- end split gradient
10725 !            write (iout,*) "etot21",etot21," etot22",etot22
10726           endif
10727 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10728           dc(j,i)=ddc(j)
10729           call chainbuild_cart
10730         enddo
10731         do j=1,3
10732           dc(j,i+nres)=ddx(j)+aincr
10733           call chainbuild_cart
10734 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10735 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10736 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10737 !          write (iout,*) "dxnormnorm",dsqrt(
10738 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10739 !          write (iout,*) "dxnormnormsafe",dsqrt(
10740 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10741 !          write (iout,*)
10742           if (.not.split_ene) then
10743             call etotal(energia1)
10744             etot1=energia1(0)
10745           else
10746 !- split gradient
10747             call etotal_long(energia1)
10748             etot11=energia1(0)
10749             call etotal_short(energia1)
10750             etot12=energia1(0)
10751           endif
10752 !- end split gradient
10753 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10754           dc(j,i+nres)=ddx(j)-aincr
10755           call chainbuild_cart
10756 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10757 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10758 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10759 !          write (iout,*)
10760 !          write (iout,*) "dxnormnorm",dsqrt(
10761 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10762 !          write (iout,*) "dxnormnormsafe",dsqrt(
10763 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10764           if (.not.split_ene) then
10765             call etotal(energia1)
10766             etot2=energia1(0)
10767             ggg(j+3)=(etot1-etot2)/(2*aincr)
10768           else
10769 !- split gradient
10770             call etotal_long(energia1)
10771             etot21=energia1(0)
10772             ggg(j+3)=(etot11-etot21)/(2*aincr)
10773             call etotal_short(energia1)
10774             etot22=energia1(0)
10775             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10776 !- end split gradient
10777           endif
10778 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10779           dc(j,i+nres)=ddx(j)
10780           call chainbuild_cart
10781         enddo
10782         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10783          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10784         if (split_ene) then
10785           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10786          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10787          k=1,6)
10788          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10789          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10790          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10791         endif
10792       enddo
10793       return
10794       end subroutine check_ecartint
10795 #endif
10796 !-----------------------------------------------------------------------------
10797       subroutine check_eint
10798 ! Check the gradient of energy in internal coordinates.
10799 !      implicit real*8 (a-h,o-z)
10800 !      include 'DIMENSIONS'
10801 !      include 'COMMON.CHAIN'
10802 !      include 'COMMON.DERIV'
10803 !      include 'COMMON.IOUNITS'
10804 !      include 'COMMON.VAR'
10805 !      include 'COMMON.GEO'
10806       use comm_srutu
10807 !el      integer :: icall
10808 !el      common /srutu/ icall
10809       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10810       integer :: uiparm(1)
10811       real(kind=8) :: urparm(1)
10812       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10813       character(len=6) :: key
10814 !EL      external fdum
10815       integer :: i,ii,nf
10816       real(kind=8) :: xi,aincr,etot,etot1,etot2
10817       call zerograd
10818       aincr=1.0D-7
10819       print '(a)','Calling CHECK_INT.'
10820       nf=0
10821       nfl=0
10822       icg=1
10823       call geom_to_var(nvar,x)
10824       call var_to_geom(nvar,x)
10825       call chainbuild
10826       icall=1
10827       print *,'ICG=',ICG
10828       call etotal(energia)
10829       etot = energia(0)
10830 !el      call enerprint(energia)
10831       print *,'ICG=',ICG
10832 #ifdef MPL
10833       if (MyID.ne.BossID) then
10834         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10835         nf=x(nvar+1)
10836         nfl=x(nvar+2)
10837         icg=x(nvar+3)
10838       endif
10839 #endif
10840       nf=1
10841       nfl=3
10842 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10843       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10844 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10845       icall=1
10846       do i=1,nvar
10847         xi=x(i)
10848         x(i)=xi-0.5D0*aincr
10849         call var_to_geom(nvar,x)
10850         call chainbuild
10851         call etotal(energia1)
10852         etot1=energia1(0)
10853         x(i)=xi+0.5D0*aincr
10854         call var_to_geom(nvar,x)
10855         call chainbuild
10856         call etotal(energia2)
10857         etot2=energia2(0)
10858         gg(i)=(etot2-etot1)/aincr
10859         write (iout,*) i,etot1,etot2
10860         x(i)=xi
10861       enddo
10862       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10863           '     RelDiff*100% '
10864       do i=1,nvar
10865         if (i.le.nphi) then
10866           ii=i
10867           key = ' phi'
10868         else if (i.le.nphi+ntheta) then
10869           ii=i-nphi
10870           key=' theta'
10871         else if (i.le.nphi+ntheta+nside) then
10872            ii=i-(nphi+ntheta)
10873            key=' alpha'
10874         else
10875            ii=i-(nphi+ntheta+nside)
10876            key=' omega'
10877         endif
10878         write (iout,'(i3,a,i3,3(1pd16.6))') &
10879        i,key,ii,gg(i),gana(i),&
10880        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10881       enddo
10882       return
10883       end subroutine check_eint
10884 !-----------------------------------------------------------------------------
10885 ! econstr_local.F
10886 !-----------------------------------------------------------------------------
10887       subroutine Econstr_back
10888 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
10889 !      implicit real*8 (a-h,o-z)
10890 !      include 'DIMENSIONS'
10891 !      include 'COMMON.CONTROL'
10892 !      include 'COMMON.VAR'
10893 !      include 'COMMON.MD'
10894       use MD_data
10895 !#ifndef LANG0
10896 !      include 'COMMON.LANGEVIN'
10897 !#else
10898 !      include 'COMMON.LANGEVIN.lang0'
10899 !#endif
10900 !      include 'COMMON.CHAIN'
10901 !      include 'COMMON.DERIV'
10902 !      include 'COMMON.GEO'
10903 !      include 'COMMON.LOCAL'
10904 !      include 'COMMON.INTERACT'
10905 !      include 'COMMON.IOUNITS'
10906 !      include 'COMMON.NAMES'
10907 !      include 'COMMON.TIME1'
10908       integer :: i,j,ii,k
10909       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
10910
10911       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
10912       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
10913       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
10914
10915       Uconst_back=0.0d0
10916       do i=1,nres
10917         dutheta(i)=0.0d0
10918         dugamma(i)=0.0d0
10919         do j=1,3
10920           duscdiff(j,i)=0.0d0
10921           duscdiffx(j,i)=0.0d0
10922         enddo
10923       enddo
10924       do i=1,nfrag_back
10925         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10926 !
10927 ! Deviations from theta angles
10928 !
10929         utheta_i=0.0d0
10930         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
10931           dtheta_i=theta(j)-thetaref(j)
10932           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
10933           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10934         enddo
10935         utheta(i)=utheta_i/(ii-1)
10936 !
10937 ! Deviations from gamma angles
10938 !
10939         ugamma_i=0.0d0
10940         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
10941           dgamma_i=pinorm(phi(j)-phiref(j))
10942 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
10943           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
10944           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
10945 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
10946         enddo
10947         ugamma(i)=ugamma_i/(ii-2)
10948 !
10949 ! Deviations from local SC geometry
10950 !
10951         uscdiff(i)=0.0d0
10952         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
10953           dxx=xxtab(j)-xxref(j)
10954           dyy=yytab(j)-yyref(j)
10955           dzz=zztab(j)-zzref(j)
10956           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
10957           do k=1,3
10958             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
10959              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
10960              (ii-1)
10961             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
10962              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
10963              (ii-1)
10964             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
10965            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
10966             /(ii-1)
10967           enddo
10968 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10969 !     &      xxref(j),yyref(j),zzref(j)
10970         enddo
10971         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
10972 !        write (iout,*) i," uscdiff",uscdiff(i)
10973 !
10974 ! Put together deviations from local geometry
10975 !
10976         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
10977           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
10978 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
10979 !     &   " uconst_back",uconst_back
10980         utheta(i)=dsqrt(utheta(i))
10981         ugamma(i)=dsqrt(ugamma(i))
10982         uscdiff(i)=dsqrt(uscdiff(i))
10983       enddo
10984       return
10985       end subroutine Econstr_back
10986 !-----------------------------------------------------------------------------
10987 ! energy_p_new-sep_barrier.F
10988 !-----------------------------------------------------------------------------
10989       real(kind=8) function sscale(r)
10990 !      include "COMMON.SPLITELE"
10991       real(kind=8) :: r,gamm
10992       if(r.lt.r_cut-rlamb) then
10993         sscale=1.0d0
10994       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10995         gamm=(r-(r_cut-rlamb))/rlamb
10996         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10997       else
10998         sscale=0d0
10999       endif
11000       return
11001       end function sscale
11002 !!!!!!!!!! PBCSCALE
11003       real(kind=8) function sscale_ele(r)
11004 !      include "COMMON.SPLITELE"
11005       real(kind=8) :: r,gamm
11006       if(r.lt.r_cut_ele-rlamb_ele) then
11007         sscale_ele=1.0d0
11008       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11009         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11010         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11011       else
11012         sscale_ele=0d0
11013       endif
11014       return
11015       end function sscale_ele
11016
11017       real(kind=8)  function sscagrad_ele(r)
11018       real(kind=8) :: r,gamm
11019 !      include "COMMON.SPLITELE"
11020       if(r.lt.r_cut_ele-rlamb_ele) then
11021         sscagrad_ele=0.0d0
11022       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11023         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11024         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
11025       else
11026         sscagrad_ele=0.0d0
11027       endif
11028       return
11029       end function sscagrad_ele
11030 !!!!!!!!!!!!!!!
11031 !-----------------------------------------------------------------------------
11032       subroutine elj_long(evdw)
11033 !
11034 ! This subroutine calculates the interaction energy of nonbonded side chains
11035 ! assuming the LJ potential of interaction.
11036 !
11037 !      implicit real*8 (a-h,o-z)
11038 !      include 'DIMENSIONS'
11039 !      include 'COMMON.GEO'
11040 !      include 'COMMON.VAR'
11041 !      include 'COMMON.LOCAL'
11042 !      include 'COMMON.CHAIN'
11043 !      include 'COMMON.DERIV'
11044 !      include 'COMMON.INTERACT'
11045 !      include 'COMMON.TORSION'
11046 !      include 'COMMON.SBRIDGE'
11047 !      include 'COMMON.NAMES'
11048 !      include 'COMMON.IOUNITS'
11049 !      include 'COMMON.CONTACTS'
11050       real(kind=8),parameter :: accur=1.0d-10
11051       real(kind=8),dimension(3) :: gg
11052 !el local variables
11053       integer :: i,iint,j,k,itypi,itypi1,itypj
11054       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11055       real(kind=8) :: e1,e2,evdwij,evdw
11056 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11057       evdw=0.0D0
11058       do i=iatsc_s,iatsc_e
11059         itypi=itype(i)
11060         if (itypi.eq.ntyp1) cycle
11061         itypi1=itype(i+1)
11062         xi=c(1,nres+i)
11063         yi=c(2,nres+i)
11064         zi=c(3,nres+i)
11065 !
11066 ! Calculate SC interaction energy.
11067 !
11068         do iint=1,nint_gr(i)
11069 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11070 !d   &                  'iend=',iend(i,iint)
11071           do j=istart(i,iint),iend(i,iint)
11072             itypj=itype(j)
11073             if (itypj.eq.ntyp1) cycle
11074             xj=c(1,nres+j)-xi
11075             yj=c(2,nres+j)-yi
11076             zj=c(3,nres+j)-zi
11077             rij=xj*xj+yj*yj+zj*zj
11078             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11079             if (sss.lt.1.0d0) then
11080               rrij=1.0D0/rij
11081               eps0ij=eps(itypi,itypj)
11082               fac=rrij**expon2
11083               e1=fac*fac*aa(itypi,itypj)
11084               e2=fac*bb(itypi,itypj)
11085               evdwij=e1+e2
11086               evdw=evdw+(1.0d0-sss)*evdwij
11087 !
11088 ! Calculate the components of the gradient in DC and X
11089 !
11090               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
11091               gg(1)=xj*fac
11092               gg(2)=yj*fac
11093               gg(3)=zj*fac
11094               do k=1,3
11095                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11096                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11097                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11098                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11099               enddo
11100             endif
11101           enddo      ! j
11102         enddo        ! iint
11103       enddo          ! i
11104       do i=1,nct
11105         do j=1,3
11106           gvdwc(j,i)=expon*gvdwc(j,i)
11107           gvdwx(j,i)=expon*gvdwx(j,i)
11108         enddo
11109       enddo
11110 !******************************************************************************
11111 !
11112 !                              N O T E !!!
11113 !
11114 ! To save time, the factor of EXPON has been extracted from ALL components
11115 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11116 ! use!
11117 !
11118 !******************************************************************************
11119       return
11120       end subroutine elj_long
11121 !-----------------------------------------------------------------------------
11122       subroutine elj_short(evdw)
11123 !
11124 ! This subroutine calculates the interaction energy of nonbonded side chains
11125 ! assuming the LJ potential of interaction.
11126 !
11127 !      implicit real*8 (a-h,o-z)
11128 !      include 'DIMENSIONS'
11129 !      include 'COMMON.GEO'
11130 !      include 'COMMON.VAR'
11131 !      include 'COMMON.LOCAL'
11132 !      include 'COMMON.CHAIN'
11133 !      include 'COMMON.DERIV'
11134 !      include 'COMMON.INTERACT'
11135 !      include 'COMMON.TORSION'
11136 !      include 'COMMON.SBRIDGE'
11137 !      include 'COMMON.NAMES'
11138 !      include 'COMMON.IOUNITS'
11139 !      include 'COMMON.CONTACTS'
11140       real(kind=8),parameter :: accur=1.0d-10
11141       real(kind=8),dimension(3) :: gg
11142 !el local variables
11143       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
11144       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11145       real(kind=8) :: e1,e2,evdwij,evdw
11146 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11147       evdw=0.0D0
11148       do i=iatsc_s,iatsc_e
11149         itypi=itype(i)
11150         if (itypi.eq.ntyp1) cycle
11151         itypi1=itype(i+1)
11152         xi=c(1,nres+i)
11153         yi=c(2,nres+i)
11154         zi=c(3,nres+i)
11155 ! Change 12/1/95
11156         num_conti=0
11157 !
11158 ! Calculate SC interaction energy.
11159 !
11160         do iint=1,nint_gr(i)
11161 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11162 !d   &                  'iend=',iend(i,iint)
11163           do j=istart(i,iint),iend(i,iint)
11164             itypj=itype(j)
11165             if (itypj.eq.ntyp1) cycle
11166             xj=c(1,nres+j)-xi
11167             yj=c(2,nres+j)-yi
11168             zj=c(3,nres+j)-zi
11169 ! Change 12/1/95 to calculate four-body interactions
11170             rij=xj*xj+yj*yj+zj*zj
11171             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11172             if (sss.gt.0.0d0) then
11173               rrij=1.0D0/rij
11174               eps0ij=eps(itypi,itypj)
11175               fac=rrij**expon2
11176               e1=fac*fac*aa(itypi,itypj)
11177               e2=fac*bb(itypi,itypj)
11178               evdwij=e1+e2
11179               evdw=evdw+sss*evdwij
11180 !
11181 ! Calculate the components of the gradient in DC and X
11182 !
11183               fac=-rrij*(e1+evdwij)*sss
11184               gg(1)=xj*fac
11185               gg(2)=yj*fac
11186               gg(3)=zj*fac
11187               do k=1,3
11188                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11189                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11190                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11191                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11192               enddo
11193             endif
11194           enddo      ! j
11195         enddo        ! iint
11196       enddo          ! i
11197       do i=1,nct
11198         do j=1,3
11199           gvdwc(j,i)=expon*gvdwc(j,i)
11200           gvdwx(j,i)=expon*gvdwx(j,i)
11201         enddo
11202       enddo
11203 !******************************************************************************
11204 !
11205 !                              N O T E !!!
11206 !
11207 ! To save time, the factor of EXPON has been extracted from ALL components
11208 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11209 ! use!
11210 !
11211 !******************************************************************************
11212       return
11213       end subroutine elj_short
11214 !-----------------------------------------------------------------------------
11215       subroutine eljk_long(evdw)
11216 !
11217 ! This subroutine calculates the interaction energy of nonbonded side chains
11218 ! assuming the LJK potential of interaction.
11219 !
11220 !      implicit real*8 (a-h,o-z)
11221 !      include 'DIMENSIONS'
11222 !      include 'COMMON.GEO'
11223 !      include 'COMMON.VAR'
11224 !      include 'COMMON.LOCAL'
11225 !      include 'COMMON.CHAIN'
11226 !      include 'COMMON.DERIV'
11227 !      include 'COMMON.INTERACT'
11228 !      include 'COMMON.IOUNITS'
11229 !      include 'COMMON.NAMES'
11230       real(kind=8),dimension(3) :: gg
11231       logical :: scheck
11232 !el local variables
11233       integer :: i,iint,j,k,itypi,itypi1,itypj
11234       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11235                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11236 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11237       evdw=0.0D0
11238       do i=iatsc_s,iatsc_e
11239         itypi=itype(i)
11240         if (itypi.eq.ntyp1) cycle
11241         itypi1=itype(i+1)
11242         xi=c(1,nres+i)
11243         yi=c(2,nres+i)
11244         zi=c(3,nres+i)
11245 !
11246 ! Calculate SC interaction energy.
11247 !
11248         do iint=1,nint_gr(i)
11249           do j=istart(i,iint),iend(i,iint)
11250             itypj=itype(j)
11251             if (itypj.eq.ntyp1) cycle
11252             xj=c(1,nres+j)-xi
11253             yj=c(2,nres+j)-yi
11254             zj=c(3,nres+j)-zi
11255             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11256             fac_augm=rrij**expon
11257             e_augm=augm(itypi,itypj)*fac_augm
11258             r_inv_ij=dsqrt(rrij)
11259             rij=1.0D0/r_inv_ij
11260             sss=sscale(rij/sigma(itypi,itypj))
11261             if (sss.lt.1.0d0) then
11262               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11263               fac=r_shift_inv**expon
11264               e1=fac*fac*aa(itypi,itypj)
11265               e2=fac*bb(itypi,itypj)
11266               evdwij=e_augm+e1+e2
11267 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11268 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11269 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11270 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11271 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11272 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11273 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11274               evdw=evdw+(1.0d0-sss)*evdwij
11275 !
11276 ! Calculate the components of the gradient in DC and X
11277 !
11278               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11279               fac=fac*(1.0d0-sss)
11280               gg(1)=xj*fac
11281               gg(2)=yj*fac
11282               gg(3)=zj*fac
11283               do k=1,3
11284                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11285                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11286                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11287                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11288               enddo
11289             endif
11290           enddo      ! j
11291         enddo        ! iint
11292       enddo          ! i
11293       do i=1,nct
11294         do j=1,3
11295           gvdwc(j,i)=expon*gvdwc(j,i)
11296           gvdwx(j,i)=expon*gvdwx(j,i)
11297         enddo
11298       enddo
11299       return
11300       end subroutine eljk_long
11301 !-----------------------------------------------------------------------------
11302       subroutine eljk_short(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.gt.0.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+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*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_short
11388 !-----------------------------------------------------------------------------
11389       subroutine ebp_long(evdw)
11390 !
11391 ! This subroutine calculates the interaction energy of nonbonded side chains
11392 ! assuming the Berne-Pechukas potential of interaction.
11393 !
11394       use calc_data
11395 !      implicit real*8 (a-h,o-z)
11396 !      include 'DIMENSIONS'
11397 !      include 'COMMON.GEO'
11398 !      include 'COMMON.VAR'
11399 !      include 'COMMON.LOCAL'
11400 !      include 'COMMON.CHAIN'
11401 !      include 'COMMON.DERIV'
11402 !      include 'COMMON.NAMES'
11403 !      include 'COMMON.INTERACT'
11404 !      include 'COMMON.IOUNITS'
11405 !      include 'COMMON.CALC'
11406       use comm_srutu
11407 !el      integer :: icall
11408 !el      common /srutu/ icall
11409 !     double precision rrsave(maxdim)
11410       logical :: lprn
11411 !el local variables
11412       integer :: iint,itypi,itypi1,itypj
11413       real(kind=8) :: rrij,xi,yi,zi,fac
11414       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11415       evdw=0.0D0
11416 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11417       evdw=0.0D0
11418 !     if (icall.eq.0) then
11419 !       lprn=.true.
11420 !     else
11421         lprn=.false.
11422 !     endif
11423 !el      ind=0
11424       do i=iatsc_s,iatsc_e
11425         itypi=itype(i)
11426         if (itypi.eq.ntyp1) cycle
11427         itypi1=itype(i+1)
11428         xi=c(1,nres+i)
11429         yi=c(2,nres+i)
11430         zi=c(3,nres+i)
11431         dxi=dc_norm(1,nres+i)
11432         dyi=dc_norm(2,nres+i)
11433         dzi=dc_norm(3,nres+i)
11434 !        dsci_inv=dsc_inv(itypi)
11435         dsci_inv=vbld_inv(i+nres)
11436 !
11437 ! Calculate SC interaction energy.
11438 !
11439         do iint=1,nint_gr(i)
11440           do j=istart(i,iint),iend(i,iint)
11441 !el            ind=ind+1
11442             itypj=itype(j)
11443             if (itypj.eq.ntyp1) cycle
11444 !            dscj_inv=dsc_inv(itypj)
11445             dscj_inv=vbld_inv(j+nres)
11446             chi1=chi(itypi,itypj)
11447             chi2=chi(itypj,itypi)
11448             chi12=chi1*chi2
11449             chip1=chip(itypi)
11450             chip2=chip(itypj)
11451             chip12=chip1*chip2
11452             alf1=alp(itypi)
11453             alf2=alp(itypj)
11454             alf12=0.5D0*(alf1+alf2)
11455             xj=c(1,nres+j)-xi
11456             yj=c(2,nres+j)-yi
11457             zj=c(3,nres+j)-zi
11458             dxj=dc_norm(1,nres+j)
11459             dyj=dc_norm(2,nres+j)
11460             dzj=dc_norm(3,nres+j)
11461             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11462             rij=dsqrt(rrij)
11463             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11464
11465             if (sss.lt.1.0d0) then
11466
11467 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11468               call sc_angular
11469 ! Calculate whole angle-dependent part of epsilon and contributions
11470 ! to its derivatives
11471               fac=(rrij*sigsq)**expon2
11472               e1=fac*fac*aa(itypi,itypj)
11473               e2=fac*bb(itypi,itypj)
11474               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11475               eps2der=evdwij*eps3rt
11476               eps3der=evdwij*eps2rt
11477               evdwij=evdwij*eps2rt*eps3rt
11478               evdw=evdw+evdwij*(1.0d0-sss)
11479               if (lprn) then
11480               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11481               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11482 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11483 !d     &          restyp(itypi),i,restyp(itypj),j,
11484 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11485 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11486 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11487 !d     &          evdwij
11488               endif
11489 ! Calculate gradient components.
11490               e1=e1*eps1*eps2rt**2*eps3rt**2
11491               fac=-expon*(e1+evdwij)
11492               sigder=fac/sigsq
11493               fac=rrij*fac
11494 ! Calculate radial part of the gradient
11495               gg(1)=xj*fac
11496               gg(2)=yj*fac
11497               gg(3)=zj*fac
11498 ! Calculate the angular part of the gradient and sum add the contributions
11499 ! to the appropriate components of the Cartesian gradient.
11500               call sc_grad_scale(1.0d0-sss)
11501             endif
11502           enddo      ! j
11503         enddo        ! iint
11504       enddo          ! i
11505 !     stop
11506       return
11507       end subroutine ebp_long
11508 !-----------------------------------------------------------------------------
11509       subroutine ebp_short(evdw)
11510 !
11511 ! This subroutine calculates the interaction energy of nonbonded side chains
11512 ! assuming the Berne-Pechukas potential of interaction.
11513 !
11514       use calc_data
11515 !      implicit real*8 (a-h,o-z)
11516 !      include 'DIMENSIONS'
11517 !      include 'COMMON.GEO'
11518 !      include 'COMMON.VAR'
11519 !      include 'COMMON.LOCAL'
11520 !      include 'COMMON.CHAIN'
11521 !      include 'COMMON.DERIV'
11522 !      include 'COMMON.NAMES'
11523 !      include 'COMMON.INTERACT'
11524 !      include 'COMMON.IOUNITS'
11525 !      include 'COMMON.CALC'
11526       use comm_srutu
11527 !el      integer :: icall
11528 !el      common /srutu/ icall
11529 !     double precision rrsave(maxdim)
11530       logical :: lprn
11531 !el local variables
11532       integer :: iint,itypi,itypi1,itypj
11533       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11534       real(kind=8) :: sss,e1,e2,evdw
11535       evdw=0.0D0
11536 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11537       evdw=0.0D0
11538 !     if (icall.eq.0) then
11539 !       lprn=.true.
11540 !     else
11541         lprn=.false.
11542 !     endif
11543 !el      ind=0
11544       do i=iatsc_s,iatsc_e
11545         itypi=itype(i)
11546         if (itypi.eq.ntyp1) cycle
11547         itypi1=itype(i+1)
11548         xi=c(1,nres+i)
11549         yi=c(2,nres+i)
11550         zi=c(3,nres+i)
11551         dxi=dc_norm(1,nres+i)
11552         dyi=dc_norm(2,nres+i)
11553         dzi=dc_norm(3,nres+i)
11554 !        dsci_inv=dsc_inv(itypi)
11555         dsci_inv=vbld_inv(i+nres)
11556 !
11557 ! Calculate SC interaction energy.
11558 !
11559         do iint=1,nint_gr(i)
11560           do j=istart(i,iint),iend(i,iint)
11561 !el            ind=ind+1
11562             itypj=itype(j)
11563             if (itypj.eq.ntyp1) cycle
11564 !            dscj_inv=dsc_inv(itypj)
11565             dscj_inv=vbld_inv(j+nres)
11566             chi1=chi(itypi,itypj)
11567             chi2=chi(itypj,itypi)
11568             chi12=chi1*chi2
11569             chip1=chip(itypi)
11570             chip2=chip(itypj)
11571             chip12=chip1*chip2
11572             alf1=alp(itypi)
11573             alf2=alp(itypj)
11574             alf12=0.5D0*(alf1+alf2)
11575             xj=c(1,nres+j)-xi
11576             yj=c(2,nres+j)-yi
11577             zj=c(3,nres+j)-zi
11578             dxj=dc_norm(1,nres+j)
11579             dyj=dc_norm(2,nres+j)
11580             dzj=dc_norm(3,nres+j)
11581             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11582             rij=dsqrt(rrij)
11583             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11584
11585             if (sss.gt.0.0d0) then
11586
11587 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11588               call sc_angular
11589 ! Calculate whole angle-dependent part of epsilon and contributions
11590 ! to its derivatives
11591               fac=(rrij*sigsq)**expon2
11592               e1=fac*fac*aa(itypi,itypj)
11593               e2=fac*bb(itypi,itypj)
11594               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11595               eps2der=evdwij*eps3rt
11596               eps3der=evdwij*eps2rt
11597               evdwij=evdwij*eps2rt*eps3rt
11598               evdw=evdw+evdwij*sss
11599               if (lprn) then
11600               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11601               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11602 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11603 !d     &          restyp(itypi),i,restyp(itypj),j,
11604 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11605 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11606 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11607 !d     &          evdwij
11608               endif
11609 ! Calculate gradient components.
11610               e1=e1*eps1*eps2rt**2*eps3rt**2
11611               fac=-expon*(e1+evdwij)
11612               sigder=fac/sigsq
11613               fac=rrij*fac
11614 ! Calculate radial part of the gradient
11615               gg(1)=xj*fac
11616               gg(2)=yj*fac
11617               gg(3)=zj*fac
11618 ! Calculate the angular part of the gradient and sum add the contributions
11619 ! to the appropriate components of the Cartesian gradient.
11620               call sc_grad_scale(sss)
11621             endif
11622           enddo      ! j
11623         enddo        ! iint
11624       enddo          ! i
11625 !     stop
11626       return
11627       end subroutine ebp_short
11628 !-----------------------------------------------------------------------------
11629       subroutine egb_long(evdw)
11630 !
11631 ! This subroutine calculates the interaction energy of nonbonded side chains
11632 ! assuming the Gay-Berne potential of interaction.
11633 !
11634       use calc_data
11635 !      implicit real*8 (a-h,o-z)
11636 !      include 'DIMENSIONS'
11637 !      include 'COMMON.GEO'
11638 !      include 'COMMON.VAR'
11639 !      include 'COMMON.LOCAL'
11640 !      include 'COMMON.CHAIN'
11641 !      include 'COMMON.DERIV'
11642 !      include 'COMMON.NAMES'
11643 !      include 'COMMON.INTERACT'
11644 !      include 'COMMON.IOUNITS'
11645 !      include 'COMMON.CALC'
11646 !      include 'COMMON.CONTROL'
11647       logical :: lprn
11648 !el local variables
11649       integer :: iint,itypi,itypi1,itypj,subchap
11650       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11651       real(kind=8) :: sss,e1,e2,evdw
11652       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11653                     dist_temp, dist_init
11654
11655       evdw=0.0D0
11656 !cccc      energy_dec=.false.
11657 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11658       evdw=0.0D0
11659       lprn=.false.
11660 !     if (icall.eq.0) lprn=.false.
11661 !el      ind=0
11662       do i=iatsc_s,iatsc_e
11663         itypi=itype(i)
11664         if (itypi.eq.ntyp1) cycle
11665         itypi1=itype(i+1)
11666         xi=c(1,nres+i)
11667         yi=c(2,nres+i)
11668         zi=c(3,nres+i)
11669           xi=mod(xi,boxxsize)
11670           if (xi.lt.0) xi=xi+boxxsize
11671           yi=mod(yi,boxysize)
11672           if (yi.lt.0) yi=yi+boxysize
11673           zi=mod(zi,boxzsize)
11674           if (zi.lt.0) zi=zi+boxzsize
11675         dxi=dc_norm(1,nres+i)
11676         dyi=dc_norm(2,nres+i)
11677         dzi=dc_norm(3,nres+i)
11678 !        dsci_inv=dsc_inv(itypi)
11679         dsci_inv=vbld_inv(i+nres)
11680 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11681 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11682 !
11683 ! Calculate SC interaction energy.
11684 !
11685         do iint=1,nint_gr(i)
11686           do j=istart(i,iint),iend(i,iint)
11687 !el            ind=ind+1
11688             itypj=itype(j)
11689             if (itypj.eq.ntyp1) cycle
11690 !            dscj_inv=dsc_inv(itypj)
11691             dscj_inv=vbld_inv(j+nres)
11692 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11693 !     &       1.0d0/vbld(j+nres)
11694 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11695             sig0ij=sigma(itypi,itypj)
11696             chi1=chi(itypi,itypj)
11697             chi2=chi(itypj,itypi)
11698             chi12=chi1*chi2
11699             chip1=chip(itypi)
11700             chip2=chip(itypj)
11701             chip12=chip1*chip2
11702             alf1=alp(itypi)
11703             alf2=alp(itypj)
11704             alf12=0.5D0*(alf1+alf2)
11705             xj=c(1,nres+j)
11706             yj=c(2,nres+j)
11707             zj=c(3,nres+j)
11708 ! Searching for nearest neighbour
11709           xj=mod(xj,boxxsize)
11710           if (xj.lt.0) xj=xj+boxxsize
11711           yj=mod(yj,boxysize)
11712           if (yj.lt.0) yj=yj+boxysize
11713           zj=mod(zj,boxzsize)
11714           if (zj.lt.0) zj=zj+boxzsize
11715           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11716           xj_safe=xj
11717           yj_safe=yj
11718           zj_safe=zj
11719           subchap=0
11720           do xshift=-1,1
11721           do yshift=-1,1
11722           do zshift=-1,1
11723           xj=xj_safe+xshift*boxxsize
11724           yj=yj_safe+yshift*boxysize
11725           zj=zj_safe+zshift*boxzsize
11726           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11727           if(dist_temp.lt.dist_init) then
11728             dist_init=dist_temp
11729             xj_temp=xj
11730             yj_temp=yj
11731             zj_temp=zj
11732             subchap=1
11733           endif
11734           enddo
11735           enddo
11736           enddo
11737           if (subchap.eq.1) then
11738           xj=xj_temp-xi
11739           yj=yj_temp-yi
11740           zj=zj_temp-zi
11741           else
11742           xj=xj_safe-xi
11743           yj=yj_safe-yi
11744           zj=zj_safe-zi
11745           endif
11746
11747             dxj=dc_norm(1,nres+j)
11748             dyj=dc_norm(2,nres+j)
11749             dzj=dc_norm(3,nres+j)
11750             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11751             rij=dsqrt(rrij)
11752             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11753             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
11754             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
11755             if (sss_ele_cut.le.0.0) cycle
11756             if (sss.lt.1.0d0) then
11757
11758 ! Calculate angle-dependent terms of energy and contributions to their
11759 ! derivatives.
11760               call sc_angular
11761               sigsq=1.0D0/sigsq
11762               sig=sig0ij*dsqrt(sigsq)
11763               rij_shift=1.0D0/rij-sig+sig0ij
11764 ! for diagnostics; uncomment
11765 !              rij_shift=1.2*sig0ij
11766 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11767               if (rij_shift.le.0.0D0) then
11768                 evdw=1.0D20
11769 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11770 !d     &          restyp(itypi),i,restyp(itypj),j,
11771 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11772                 return
11773               endif
11774               sigder=-sig*sigsq
11775 !---------------------------------------------------------------
11776               rij_shift=1.0D0/rij_shift
11777               fac=rij_shift**expon
11778               e1=fac*fac*aa(itypi,itypj)
11779               e2=fac*bb(itypi,itypj)
11780               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11781               eps2der=evdwij*eps3rt
11782               eps3der=evdwij*eps2rt
11783 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11784 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11785               evdwij=evdwij*eps2rt*eps3rt
11786               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
11787               if (lprn) then
11788               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11789               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11790               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11791                 restyp(itypi),i,restyp(itypj),j,&
11792                 epsi,sigm,chi1,chi2,chip1,chip2,&
11793                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11794                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11795                 evdwij
11796               endif
11797
11798               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11799                               'evdw',i,j,evdwij
11800 !              if (energy_dec) write (iout,*) &
11801 !                              'evdw',i,j,evdwij,"egb_long"
11802
11803 ! Calculate gradient components.
11804               e1=e1*eps1*eps2rt**2*eps3rt**2
11805               fac=-expon*(e1+evdwij)*rij_shift
11806               sigder=fac*sigder
11807               fac=rij*fac
11808               fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
11809             /sigma(itypi,itypj)*rij
11810 !              fac=0.0d0
11811 ! Calculate the radial part of the gradient
11812               gg(1)=xj*fac
11813               gg(2)=yj*fac
11814               gg(3)=zj*fac
11815 ! Calculate angular part of the gradient.
11816               call sc_grad_scale(1.0d0-sss)
11817             endif
11818           enddo      ! j
11819         enddo        ! iint
11820       enddo          ! i
11821 !      write (iout,*) "Number of loop steps in EGB:",ind
11822 !ccc      energy_dec=.false.
11823       return
11824       end subroutine egb_long
11825 !-----------------------------------------------------------------------------
11826       subroutine egb_short(evdw)
11827 !
11828 ! This subroutine calculates the interaction energy of nonbonded side chains
11829 ! assuming the Gay-Berne potential of interaction.
11830 !
11831       use calc_data
11832 !      implicit real*8 (a-h,o-z)
11833 !      include 'DIMENSIONS'
11834 !      include 'COMMON.GEO'
11835 !      include 'COMMON.VAR'
11836 !      include 'COMMON.LOCAL'
11837 !      include 'COMMON.CHAIN'
11838 !      include 'COMMON.DERIV'
11839 !      include 'COMMON.NAMES'
11840 !      include 'COMMON.INTERACT'
11841 !      include 'COMMON.IOUNITS'
11842 !      include 'COMMON.CALC'
11843 !      include 'COMMON.CONTROL'
11844       logical :: lprn
11845 !el local variables
11846       integer :: iint,itypi,itypi1,itypj,subchap
11847       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11848       real(kind=8) :: sss,e1,e2,evdw,rij_shift
11849       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11850                     dist_temp, dist_init
11851       evdw=0.0D0
11852 !cccc      energy_dec=.false.
11853 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11854       evdw=0.0D0
11855       lprn=.false.
11856 !     if (icall.eq.0) lprn=.false.
11857 !el      ind=0
11858       do i=iatsc_s,iatsc_e
11859         itypi=itype(i)
11860         if (itypi.eq.ntyp1) cycle
11861         itypi1=itype(i+1)
11862         xi=c(1,nres+i)
11863         yi=c(2,nres+i)
11864         zi=c(3,nres+i)
11865           xi=mod(xi,boxxsize)
11866           if (xi.lt.0) xi=xi+boxxsize
11867           yi=mod(yi,boxysize)
11868           if (yi.lt.0) yi=yi+boxysize
11869           zi=mod(zi,boxzsize)
11870           if (zi.lt.0) zi=zi+boxzsize
11871         dxi=dc_norm(1,nres+i)
11872         dyi=dc_norm(2,nres+i)
11873         dzi=dc_norm(3,nres+i)
11874 !        dsci_inv=dsc_inv(itypi)
11875         dsci_inv=vbld_inv(i+nres)
11876
11877         dxi=dc_norm(1,nres+i)
11878         dyi=dc_norm(2,nres+i)
11879         dzi=dc_norm(3,nres+i)
11880 !        dsci_inv=dsc_inv(itypi)
11881         dsci_inv=vbld_inv(i+nres)
11882 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11883 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11884 !
11885 ! Calculate SC interaction energy.
11886 !
11887         do iint=1,nint_gr(i)
11888           do j=istart(i,iint),iend(i,iint)
11889 !el            ind=ind+1
11890             itypj=itype(j)
11891             if (itypj.eq.ntyp1) cycle
11892 !            dscj_inv=dsc_inv(itypj)
11893             dscj_inv=vbld_inv(j+nres)
11894 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11895 !     &       1.0d0/vbld(j+nres)
11896 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11897             sig0ij=sigma(itypi,itypj)
11898             chi1=chi(itypi,itypj)
11899             chi2=chi(itypj,itypi)
11900             chi12=chi1*chi2
11901             chip1=chip(itypi)
11902             chip2=chip(itypj)
11903             chip12=chip1*chip2
11904             alf1=alp(itypi)
11905             alf2=alp(itypj)
11906             alf12=0.5D0*(alf1+alf2)
11907 !            xj=c(1,nres+j)-xi
11908 !            yj=c(2,nres+j)-yi
11909 !            zj=c(3,nres+j)-zi
11910             xj=c(1,nres+j)
11911             yj=c(2,nres+j)
11912             zj=c(3,nres+j)
11913 ! Searching for nearest neighbour
11914           xj=mod(xj,boxxsize)
11915           if (xj.lt.0) xj=xj+boxxsize
11916           yj=mod(yj,boxysize)
11917           if (yj.lt.0) yj=yj+boxysize
11918           zj=mod(zj,boxzsize)
11919           if (zj.lt.0) zj=zj+boxzsize
11920           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11921           xj_safe=xj
11922           yj_safe=yj
11923           zj_safe=zj
11924           subchap=0
11925           do xshift=-1,1
11926           do yshift=-1,1
11927           do zshift=-1,1
11928           xj=xj_safe+xshift*boxxsize
11929           yj=yj_safe+yshift*boxysize
11930           zj=zj_safe+zshift*boxzsize
11931           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11932           if(dist_temp.lt.dist_init) then
11933             dist_init=dist_temp
11934             xj_temp=xj
11935             yj_temp=yj
11936             zj_temp=zj
11937             subchap=1
11938           endif
11939           enddo
11940           enddo
11941           enddo
11942           if (subchap.eq.1) then
11943           xj=xj_temp-xi
11944           yj=yj_temp-yi
11945           zj=zj_temp-zi
11946           else
11947           xj=xj_safe-xi
11948           yj=yj_safe-yi
11949           zj=zj_safe-zi
11950           endif
11951
11952             dxj=dc_norm(1,nres+j)
11953             dyj=dc_norm(2,nres+j)
11954             dzj=dc_norm(3,nres+j)
11955             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11956             rij=dsqrt(rrij)
11957             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11958             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
11959             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
11960             if (sss_ele_cut.le.0.0) cycle
11961
11962             if (sss.gt.0.0d0) then
11963
11964 ! Calculate angle-dependent terms of energy and contributions to their
11965 ! derivatives.
11966               call sc_angular
11967               sigsq=1.0D0/sigsq
11968               sig=sig0ij*dsqrt(sigsq)
11969               rij_shift=1.0D0/rij-sig+sig0ij
11970 ! for diagnostics; uncomment
11971 !              rij_shift=1.2*sig0ij
11972 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11973               if (rij_shift.le.0.0D0) then
11974                 evdw=1.0D20
11975 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11976 !d     &          restyp(itypi),i,restyp(itypj),j,
11977 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11978                 return
11979               endif
11980               sigder=-sig*sigsq
11981 !---------------------------------------------------------------
11982               rij_shift=1.0D0/rij_shift
11983               fac=rij_shift**expon
11984               e1=fac*fac*aa(itypi,itypj)
11985               e2=fac*bb(itypi,itypj)
11986               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11987               eps2der=evdwij*eps3rt
11988               eps3der=evdwij*eps2rt
11989 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11990 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11991               evdwij=evdwij*eps2rt*eps3rt
11992               evdw=evdw+evdwij*sss
11993               if (lprn) then
11994               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11995               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11996               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11997                 restyp(itypi),i,restyp(itypj),j,&
11998                 epsi,sigm,chi1,chi2,chip1,chip2,&
11999                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12000                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12001                 evdwij
12002               endif
12003
12004               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12005                               'evdw',i,j,evdwij
12006 !              if (energy_dec) write (iout,*) &
12007 !                              'evdw',i,j,evdwij,"egb_short"
12008
12009 ! Calculate gradient components.
12010               e1=e1*eps1*eps2rt**2*eps3rt**2
12011               fac=-expon*(e1+evdwij)*rij_shift
12012               sigder=fac*sigder
12013               fac=rij*fac
12014               fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
12015             /sigma(itypi,itypj)*rij
12016
12017 !              fac=0.0d0
12018 ! Calculate the radial part of the gradient
12019               gg(1)=xj*fac
12020               gg(2)=yj*fac
12021               gg(3)=zj*fac
12022 ! Calculate angular part of the gradient.
12023               call sc_grad_scale(sss)
12024             endif
12025           enddo      ! j
12026         enddo        ! iint
12027       enddo          ! i
12028 !      write (iout,*) "Number of loop steps in EGB:",ind
12029 !ccc      energy_dec=.false.
12030       return
12031       end subroutine egb_short
12032 !-----------------------------------------------------------------------------
12033       subroutine egbv_long(evdw)
12034 !
12035 ! This subroutine calculates the interaction energy of nonbonded side chains
12036 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12037 !
12038       use calc_data
12039 !      implicit real*8 (a-h,o-z)
12040 !      include 'DIMENSIONS'
12041 !      include 'COMMON.GEO'
12042 !      include 'COMMON.VAR'
12043 !      include 'COMMON.LOCAL'
12044 !      include 'COMMON.CHAIN'
12045 !      include 'COMMON.DERIV'
12046 !      include 'COMMON.NAMES'
12047 !      include 'COMMON.INTERACT'
12048 !      include 'COMMON.IOUNITS'
12049 !      include 'COMMON.CALC'
12050       use comm_srutu
12051 !el      integer :: icall
12052 !el      common /srutu/ icall
12053       logical :: lprn
12054 !el local variables
12055       integer :: iint,itypi,itypi1,itypj
12056       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
12057       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
12058       evdw=0.0D0
12059 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12060       evdw=0.0D0
12061       lprn=.false.
12062 !     if (icall.eq.0) lprn=.true.
12063 !el      ind=0
12064       do i=iatsc_s,iatsc_e
12065         itypi=itype(i)
12066         if (itypi.eq.ntyp1) cycle
12067         itypi1=itype(i+1)
12068         xi=c(1,nres+i)
12069         yi=c(2,nres+i)
12070         zi=c(3,nres+i)
12071         dxi=dc_norm(1,nres+i)
12072         dyi=dc_norm(2,nres+i)
12073         dzi=dc_norm(3,nres+i)
12074 !        dsci_inv=dsc_inv(itypi)
12075         dsci_inv=vbld_inv(i+nres)
12076 !
12077 ! Calculate SC interaction energy.
12078 !
12079         do iint=1,nint_gr(i)
12080           do j=istart(i,iint),iend(i,iint)
12081 !el            ind=ind+1
12082             itypj=itype(j)
12083             if (itypj.eq.ntyp1) cycle
12084 !            dscj_inv=dsc_inv(itypj)
12085             dscj_inv=vbld_inv(j+nres)
12086             sig0ij=sigma(itypi,itypj)
12087             r0ij=r0(itypi,itypj)
12088             chi1=chi(itypi,itypj)
12089             chi2=chi(itypj,itypi)
12090             chi12=chi1*chi2
12091             chip1=chip(itypi)
12092             chip2=chip(itypj)
12093             chip12=chip1*chip2
12094             alf1=alp(itypi)
12095             alf2=alp(itypj)
12096             alf12=0.5D0*(alf1+alf2)
12097             xj=c(1,nres+j)-xi
12098             yj=c(2,nres+j)-yi
12099             zj=c(3,nres+j)-zi
12100             dxj=dc_norm(1,nres+j)
12101             dyj=dc_norm(2,nres+j)
12102             dzj=dc_norm(3,nres+j)
12103             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12104             rij=dsqrt(rrij)
12105
12106             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12107
12108             if (sss.lt.1.0d0) then
12109
12110 ! Calculate angle-dependent terms of energy and contributions to their
12111 ! derivatives.
12112               call sc_angular
12113               sigsq=1.0D0/sigsq
12114               sig=sig0ij*dsqrt(sigsq)
12115               rij_shift=1.0D0/rij-sig+r0ij
12116 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12117               if (rij_shift.le.0.0D0) then
12118                 evdw=1.0D20
12119                 return
12120               endif
12121               sigder=-sig*sigsq
12122 !---------------------------------------------------------------
12123               rij_shift=1.0D0/rij_shift
12124               fac=rij_shift**expon
12125               e1=fac*fac*aa(itypi,itypj)
12126               e2=fac*bb(itypi,itypj)
12127               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12128               eps2der=evdwij*eps3rt
12129               eps3der=evdwij*eps2rt
12130               fac_augm=rrij**expon
12131               e_augm=augm(itypi,itypj)*fac_augm
12132               evdwij=evdwij*eps2rt*eps3rt
12133               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
12134               if (lprn) then
12135               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12136               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12137               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12138                 restyp(itypi),i,restyp(itypj),j,&
12139                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12140                 chi1,chi2,chip1,chip2,&
12141                 eps1,eps2rt**2,eps3rt**2,&
12142                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12143                 evdwij+e_augm
12144               endif
12145 ! Calculate gradient components.
12146               e1=e1*eps1*eps2rt**2*eps3rt**2
12147               fac=-expon*(e1+evdwij)*rij_shift
12148               sigder=fac*sigder
12149               fac=rij*fac-2*expon*rrij*e_augm
12150 ! Calculate the radial part of the gradient
12151               gg(1)=xj*fac
12152               gg(2)=yj*fac
12153               gg(3)=zj*fac
12154 ! Calculate angular part of the gradient.
12155               call sc_grad_scale(1.0d0-sss)
12156             endif
12157           enddo      ! j
12158         enddo        ! iint
12159       enddo          ! i
12160       end subroutine egbv_long
12161 !-----------------------------------------------------------------------------
12162       subroutine egbv_short(evdw)
12163 !
12164 ! This subroutine calculates the interaction energy of nonbonded side chains
12165 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12166 !
12167       use calc_data
12168 !      implicit real*8 (a-h,o-z)
12169 !      include 'DIMENSIONS'
12170 !      include 'COMMON.GEO'
12171 !      include 'COMMON.VAR'
12172 !      include 'COMMON.LOCAL'
12173 !      include 'COMMON.CHAIN'
12174 !      include 'COMMON.DERIV'
12175 !      include 'COMMON.NAMES'
12176 !      include 'COMMON.INTERACT'
12177 !      include 'COMMON.IOUNITS'
12178 !      include 'COMMON.CALC'
12179       use comm_srutu
12180 !el      integer :: icall
12181 !el      common /srutu/ icall
12182       logical :: lprn
12183 !el local variables
12184       integer :: iint,itypi,itypi1,itypj
12185       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
12186       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
12187       evdw=0.0D0
12188 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12189       evdw=0.0D0
12190       lprn=.false.
12191 !     if (icall.eq.0) lprn=.true.
12192 !el      ind=0
12193       do i=iatsc_s,iatsc_e
12194         itypi=itype(i)
12195         if (itypi.eq.ntyp1) cycle
12196         itypi1=itype(i+1)
12197         xi=c(1,nres+i)
12198         yi=c(2,nres+i)
12199         zi=c(3,nres+i)
12200         dxi=dc_norm(1,nres+i)
12201         dyi=dc_norm(2,nres+i)
12202         dzi=dc_norm(3,nres+i)
12203 !        dsci_inv=dsc_inv(itypi)
12204         dsci_inv=vbld_inv(i+nres)
12205 !
12206 ! Calculate SC interaction energy.
12207 !
12208         do iint=1,nint_gr(i)
12209           do j=istart(i,iint),iend(i,iint)
12210 !el            ind=ind+1
12211             itypj=itype(j)
12212             if (itypj.eq.ntyp1) cycle
12213 !            dscj_inv=dsc_inv(itypj)
12214             dscj_inv=vbld_inv(j+nres)
12215             sig0ij=sigma(itypi,itypj)
12216             r0ij=r0(itypi,itypj)
12217             chi1=chi(itypi,itypj)
12218             chi2=chi(itypj,itypi)
12219             chi12=chi1*chi2
12220             chip1=chip(itypi)
12221             chip2=chip(itypj)
12222             chip12=chip1*chip2
12223             alf1=alp(itypi)
12224             alf2=alp(itypj)
12225             alf12=0.5D0*(alf1+alf2)
12226             xj=c(1,nres+j)-xi
12227             yj=c(2,nres+j)-yi
12228             zj=c(3,nres+j)-zi
12229             dxj=dc_norm(1,nres+j)
12230             dyj=dc_norm(2,nres+j)
12231             dzj=dc_norm(3,nres+j)
12232             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12233             rij=dsqrt(rrij)
12234
12235             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12236
12237             if (sss.gt.0.0d0) then
12238
12239 ! Calculate angle-dependent terms of energy and contributions to their
12240 ! derivatives.
12241               call sc_angular
12242               sigsq=1.0D0/sigsq
12243               sig=sig0ij*dsqrt(sigsq)
12244               rij_shift=1.0D0/rij-sig+r0ij
12245 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12246               if (rij_shift.le.0.0D0) then
12247                 evdw=1.0D20
12248                 return
12249               endif
12250               sigder=-sig*sigsq
12251 !---------------------------------------------------------------
12252               rij_shift=1.0D0/rij_shift
12253               fac=rij_shift**expon
12254               e1=fac*fac*aa(itypi,itypj)
12255               e2=fac*bb(itypi,itypj)
12256               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12257               eps2der=evdwij*eps3rt
12258               eps3der=evdwij*eps2rt
12259               fac_augm=rrij**expon
12260               e_augm=augm(itypi,itypj)*fac_augm
12261               evdwij=evdwij*eps2rt*eps3rt
12262               evdw=evdw+(evdwij+e_augm)*sss
12263               if (lprn) then
12264               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12265               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12266               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12267                 restyp(itypi),i,restyp(itypj),j,&
12268                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12269                 chi1,chi2,chip1,chip2,&
12270                 eps1,eps2rt**2,eps3rt**2,&
12271                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12272                 evdwij+e_augm
12273               endif
12274 ! Calculate gradient components.
12275               e1=e1*eps1*eps2rt**2*eps3rt**2
12276               fac=-expon*(e1+evdwij)*rij_shift
12277               sigder=fac*sigder
12278               fac=rij*fac-2*expon*rrij*e_augm
12279 ! Calculate the radial part of the gradient
12280               gg(1)=xj*fac
12281               gg(2)=yj*fac
12282               gg(3)=zj*fac
12283 ! Calculate angular part of the gradient.
12284               call sc_grad_scale(sss)
12285             endif
12286           enddo      ! j
12287         enddo        ! iint
12288       enddo          ! i
12289       end subroutine egbv_short
12290 !-----------------------------------------------------------------------------
12291       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
12292 !
12293 ! This subroutine calculates the average interaction energy and its gradient
12294 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
12295 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
12296 ! The potential depends both on the distance of peptide-group centers and on
12297 ! the orientation of the CA-CA virtual bonds.
12298 !
12299 !      implicit real*8 (a-h,o-z)
12300
12301       use comm_locel
12302 #ifdef MPI
12303       include 'mpif.h'
12304 #endif
12305 !      include 'DIMENSIONS'
12306 !      include 'COMMON.CONTROL'
12307 !      include 'COMMON.SETUP'
12308 !      include 'COMMON.IOUNITS'
12309 !      include 'COMMON.GEO'
12310 !      include 'COMMON.VAR'
12311 !      include 'COMMON.LOCAL'
12312 !      include 'COMMON.CHAIN'
12313 !      include 'COMMON.DERIV'
12314 !      include 'COMMON.INTERACT'
12315 !      include 'COMMON.CONTACTS'
12316 !      include 'COMMON.TORSION'
12317 !      include 'COMMON.VECTORS'
12318 !      include 'COMMON.FFIELD'
12319 !      include 'COMMON.TIME1'
12320       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
12321       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
12322       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12323 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12324       real(kind=8),dimension(4) :: muij
12325 !el      integer :: num_conti,j1,j2
12326 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12327 !el                   dz_normi,xmedi,ymedi,zmedi
12328 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12329 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12330 !el          num_conti,j1,j2
12331 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12332 #ifdef MOMENT
12333       real(kind=8) :: scal_el=1.0d0
12334 #else
12335       real(kind=8) :: scal_el=0.5d0
12336 #endif
12337 ! 12/13/98
12338 ! 13-go grudnia roku pamietnego...
12339       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12340                                              0.0d0,1.0d0,0.0d0,&
12341                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12342 !el local variables
12343       integer :: i,j,k
12344       real(kind=8) :: fac
12345       real(kind=8) :: dxj,dyj,dzj
12346       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
12347
12348 !      allocate(num_cont_hb(nres)) !(maxres)
12349 !d      write(iout,*) 'In EELEC'
12350 !d      do i=1,nloctyp
12351 !d        write(iout,*) 'Type',i
12352 !d        write(iout,*) 'B1',B1(:,i)
12353 !d        write(iout,*) 'B2',B2(:,i)
12354 !d        write(iout,*) 'CC',CC(:,:,i)
12355 !d        write(iout,*) 'DD',DD(:,:,i)
12356 !d        write(iout,*) 'EE',EE(:,:,i)
12357 !d      enddo
12358 !d      call check_vecgrad
12359 !d      stop
12360       if (icheckgrad.eq.1) then
12361         do i=1,nres-1
12362           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
12363           do k=1,3
12364             dc_norm(k,i)=dc(k,i)*fac
12365           enddo
12366 !          write (iout,*) 'i',i,' fac',fac
12367         enddo
12368       endif
12369       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12370           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
12371           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
12372 !        call vec_and_deriv
12373 #ifdef TIMING
12374         time01=MPI_Wtime()
12375 #endif
12376         call set_matrices
12377 #ifdef TIMING
12378         time_mat=time_mat+MPI_Wtime()-time01
12379 #endif
12380       endif
12381 !d      do i=1,nres-1
12382 !d        write (iout,*) 'i=',i
12383 !d        do k=1,3
12384 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
12385 !d        enddo
12386 !d        do k=1,3
12387 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
12388 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
12389 !d        enddo
12390 !d      enddo
12391       t_eelecij=0.0d0
12392       ees=0.0D0
12393       evdw1=0.0D0
12394       eel_loc=0.0d0
12395       eello_turn3=0.0d0
12396       eello_turn4=0.0d0
12397 !el      ind=0
12398       do i=1,nres
12399         num_cont_hb(i)=0
12400       enddo
12401 !d      print '(a)','Enter EELEC'
12402 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
12403 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
12404 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
12405       do i=1,nres
12406         gel_loc_loc(i)=0.0d0
12407         gcorr_loc(i)=0.0d0
12408       enddo
12409 !
12410 !
12411 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
12412 !
12413 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
12414 !
12415       do i=iturn3_start,iturn3_end
12416         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
12417         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
12418         dxi=dc(1,i)
12419         dyi=dc(2,i)
12420         dzi=dc(3,i)
12421         dx_normi=dc_norm(1,i)
12422         dy_normi=dc_norm(2,i)
12423         dz_normi=dc_norm(3,i)
12424         xmedi=c(1,i)+0.5d0*dxi
12425         ymedi=c(2,i)+0.5d0*dyi
12426         zmedi=c(3,i)+0.5d0*dzi
12427         num_conti=0
12428         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
12429         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
12430         num_cont_hb(i)=num_conti
12431       enddo
12432       do i=iturn4_start,iturn4_end
12433         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
12434           .or. itype(i+3).eq.ntyp1 &
12435           .or. itype(i+4).eq.ntyp1) cycle
12436         dxi=dc(1,i)
12437         dyi=dc(2,i)
12438         dzi=dc(3,i)
12439         dx_normi=dc_norm(1,i)
12440         dy_normi=dc_norm(2,i)
12441         dz_normi=dc_norm(3,i)
12442         xmedi=c(1,i)+0.5d0*dxi
12443         ymedi=c(2,i)+0.5d0*dyi
12444         zmedi=c(3,i)+0.5d0*dzi
12445         num_conti=num_cont_hb(i)
12446         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
12447         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
12448           call eturn4(i,eello_turn4)
12449         num_cont_hb(i)=num_conti
12450       enddo   ! i
12451 !
12452 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
12453 !
12454       do i=iatel_s,iatel_e
12455         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12456         dxi=dc(1,i)
12457         dyi=dc(2,i)
12458         dzi=dc(3,i)
12459         dx_normi=dc_norm(1,i)
12460         dy_normi=dc_norm(2,i)
12461         dz_normi=dc_norm(3,i)
12462         xmedi=c(1,i)+0.5d0*dxi
12463         ymedi=c(2,i)+0.5d0*dyi
12464         zmedi=c(3,i)+0.5d0*dzi
12465 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
12466         num_conti=num_cont_hb(i)
12467         do j=ielstart(i),ielend(i)
12468           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12469           call eelecij_scale(i,j,ees,evdw1,eel_loc)
12470         enddo ! j
12471         num_cont_hb(i)=num_conti
12472       enddo   ! i
12473 !      write (iout,*) "Number of loop steps in EELEC:",ind
12474 !d      do i=1,nres
12475 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12476 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12477 !d      enddo
12478 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12479 !cc      eel_loc=eel_loc+eello_turn3
12480 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12481       return
12482       end subroutine eelec_scale
12483 !-----------------------------------------------------------------------------
12484       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12485 !      implicit real*8 (a-h,o-z)
12486
12487       use comm_locel
12488 !      include 'DIMENSIONS'
12489 #ifdef MPI
12490       include "mpif.h"
12491 #endif
12492 !      include 'COMMON.CONTROL'
12493 !      include 'COMMON.IOUNITS'
12494 !      include 'COMMON.GEO'
12495 !      include 'COMMON.VAR'
12496 !      include 'COMMON.LOCAL'
12497 !      include 'COMMON.CHAIN'
12498 !      include 'COMMON.DERIV'
12499 !      include 'COMMON.INTERACT'
12500 !      include 'COMMON.CONTACTS'
12501 !      include 'COMMON.TORSION'
12502 !      include 'COMMON.VECTORS'
12503 !      include 'COMMON.FFIELD'
12504 !      include 'COMMON.TIME1'
12505       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12506       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12507       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12508 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12509       real(kind=8),dimension(4) :: muij
12510 !el      integer :: num_conti,j1,j2
12511 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12512 !el                   dz_normi,xmedi,ymedi,zmedi
12513 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12514 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12515 !el          num_conti,j1,j2
12516 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12517 #ifdef MOMENT
12518       real(kind=8) :: scal_el=1.0d0
12519 #else
12520       real(kind=8) :: scal_el=0.5d0
12521 #endif
12522 ! 12/13/98
12523 ! 13-go grudnia roku pamietnego...
12524       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12525                                              0.0d0,1.0d0,0.0d0,&
12526                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12527 !el local variables
12528       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12529       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12530       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12531       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12532       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12533       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12534       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12535                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12536                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12537                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12538                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12539                   ecosam,ecosbm,ecosgm,ghalf,time00
12540 !      integer :: maxconts
12541 !      maxconts = nres/4
12542 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12543 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12544 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12545 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12546 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12547 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12548 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12549 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12550 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12551 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12552 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12553 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12554 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12555
12556 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12557 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12558
12559 #ifdef MPI
12560           time00=MPI_Wtime()
12561 #endif
12562 !d      write (iout,*) "eelecij",i,j
12563 !el          ind=ind+1
12564           iteli=itel(i)
12565           itelj=itel(j)
12566           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12567           aaa=app(iteli,itelj)
12568           bbb=bpp(iteli,itelj)
12569           ael6i=ael6(iteli,itelj)
12570           ael3i=ael3(iteli,itelj)
12571           dxj=dc(1,j)
12572           dyj=dc(2,j)
12573           dzj=dc(3,j)
12574           dx_normj=dc_norm(1,j)
12575           dy_normj=dc_norm(2,j)
12576           dz_normj=dc_norm(3,j)
12577           xj=c(1,j)+0.5D0*dxj-xmedi
12578           yj=c(2,j)+0.5D0*dyj-ymedi
12579           zj=c(3,j)+0.5D0*dzj-zmedi
12580           rij=xj*xj+yj*yj+zj*zj
12581           rrmij=1.0D0/rij
12582           rij=dsqrt(rij)
12583           rmij=1.0D0/rij
12584 ! For extracting the short-range part of Evdwpp
12585           sss=sscale(rij/rpp(iteli,itelj))
12586
12587           r3ij=rrmij*rmij
12588           r6ij=r3ij*r3ij
12589           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12590           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12591           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12592           fac=cosa-3.0D0*cosb*cosg
12593           ev1=aaa*r6ij*r6ij
12594 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12595           if (j.eq.i+2) ev1=scal_el*ev1
12596           ev2=bbb*r6ij
12597           fac3=ael6i*r6ij
12598           fac4=ael3i*r3ij
12599           evdwij=ev1+ev2
12600           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12601           el2=fac4*fac
12602           eesij=el1+el2
12603 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12604           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12605           ees=ees+eesij
12606           evdw1=evdw1+evdwij*(1.0d0-sss)
12607 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12608 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12609 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12610 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12611
12612           if (energy_dec) then
12613               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12614               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12615           endif
12616
12617 !
12618 ! Calculate contributions to the Cartesian gradient.
12619 !
12620 #ifdef SPLITELE
12621           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12622           facel=-3*rrmij*(el1+eesij)
12623           fac1=fac
12624           erij(1)=xj*rmij
12625           erij(2)=yj*rmij
12626           erij(3)=zj*rmij
12627 !
12628 ! Radial derivatives. First process both termini of the fragment (i,j)
12629 !
12630           ggg(1)=facel*xj
12631           ggg(2)=facel*yj
12632           ggg(3)=facel*zj
12633 !          do k=1,3
12634 !            ghalf=0.5D0*ggg(k)
12635 !            gelc(k,i)=gelc(k,i)+ghalf
12636 !            gelc(k,j)=gelc(k,j)+ghalf
12637 !          enddo
12638 ! 9/28/08 AL Gradient compotents will be summed only at the end
12639           do k=1,3
12640             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12641             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12642           enddo
12643 !
12644 ! Loop over residues i+1 thru j-1.
12645 !
12646 !grad          do k=i+1,j-1
12647 !grad            do l=1,3
12648 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12649 !grad            enddo
12650 !grad          enddo
12651           ggg(1)=facvdw*xj
12652           ggg(2)=facvdw*yj
12653           ggg(3)=facvdw*zj
12654 !          do k=1,3
12655 !            ghalf=0.5D0*ggg(k)
12656 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12657 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12658 !          enddo
12659 ! 9/28/08 AL Gradient compotents will be summed only at the end
12660           do k=1,3
12661             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12662             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12663           enddo
12664 !
12665 ! Loop over residues i+1 thru j-1.
12666 !
12667 !grad          do k=i+1,j-1
12668 !grad            do l=1,3
12669 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12670 !grad            enddo
12671 !grad          enddo
12672 #else
12673           facvdw=ev1+evdwij*(1.0d0-sss)
12674           facel=el1+eesij
12675           fac1=fac
12676           fac=-3*rrmij*(facvdw+facvdw+facel)
12677           erij(1)=xj*rmij
12678           erij(2)=yj*rmij
12679           erij(3)=zj*rmij
12680 !
12681 ! Radial derivatives. First process both termini of the fragment (i,j)
12682 !
12683           ggg(1)=fac*xj
12684           ggg(2)=fac*yj
12685           ggg(3)=fac*zj
12686 !          do k=1,3
12687 !            ghalf=0.5D0*ggg(k)
12688 !            gelc(k,i)=gelc(k,i)+ghalf
12689 !            gelc(k,j)=gelc(k,j)+ghalf
12690 !          enddo
12691 ! 9/28/08 AL Gradient compotents will be summed only at the end
12692           do k=1,3
12693             gelc_long(k,j)=gelc(k,j)+ggg(k)
12694             gelc_long(k,i)=gelc(k,i)-ggg(k)
12695           enddo
12696 !
12697 ! Loop over residues i+1 thru j-1.
12698 !
12699 !grad          do k=i+1,j-1
12700 !grad            do l=1,3
12701 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12702 !grad            enddo
12703 !grad          enddo
12704 ! 9/28/08 AL Gradient compotents will be summed only at the end
12705           ggg(1)=facvdw*xj
12706           ggg(2)=facvdw*yj
12707           ggg(3)=facvdw*zj
12708           do k=1,3
12709             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12710             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12711           enddo
12712 #endif
12713 !
12714 ! Angular part
12715 !
12716           ecosa=2.0D0*fac3*fac1+fac4
12717           fac4=-3.0D0*fac4
12718           fac3=-6.0D0*fac3
12719           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12720           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12721           do k=1,3
12722             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12723             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12724           enddo
12725 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12726 !d   &          (dcosg(k),k=1,3)
12727           do k=1,3
12728             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12729           enddo
12730 !          do k=1,3
12731 !            ghalf=0.5D0*ggg(k)
12732 !            gelc(k,i)=gelc(k,i)+ghalf
12733 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12734 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12735 !            gelc(k,j)=gelc(k,j)+ghalf
12736 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12737 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12738 !          enddo
12739 !grad          do k=i+1,j-1
12740 !grad            do l=1,3
12741 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12742 !grad            enddo
12743 !grad          enddo
12744           do k=1,3
12745             gelc(k,i)=gelc(k,i) &
12746                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12747                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12748             gelc(k,j)=gelc(k,j) &
12749                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12750                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12751             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12752             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12753           enddo
12754           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12755               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12756               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12757 !
12758 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12759 !   energy of a peptide unit is assumed in the form of a second-order
12760 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12761 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12762 !   are computed for EVERY pair of non-contiguous peptide groups.
12763 !
12764           if (j.lt.nres-1) then
12765             j1=j+1
12766             j2=j-1
12767           else
12768             j1=j-1
12769             j2=j-2
12770           endif
12771           kkk=0
12772           do k=1,2
12773             do l=1,2
12774               kkk=kkk+1
12775               muij(kkk)=mu(k,i)*mu(l,j)
12776             enddo
12777           enddo
12778 !d         write (iout,*) 'EELEC: i',i,' j',j
12779 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12780 !d          write(iout,*) 'muij',muij
12781           ury=scalar(uy(1,i),erij)
12782           urz=scalar(uz(1,i),erij)
12783           vry=scalar(uy(1,j),erij)
12784           vrz=scalar(uz(1,j),erij)
12785           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12786           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12787           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12788           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12789           fac=dsqrt(-ael6i)*r3ij
12790           a22=a22*fac
12791           a23=a23*fac
12792           a32=a32*fac
12793           a33=a33*fac
12794 !d          write (iout,'(4i5,4f10.5)')
12795 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12796 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12797 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12798 !d     &      uy(:,j),uz(:,j)
12799 !d          write (iout,'(4f10.5)')
12800 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12801 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12802 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12803 !d           write (iout,'(9f10.5/)')
12804 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12805 ! Derivatives of the elements of A in virtual-bond vectors
12806           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12807           do k=1,3
12808             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12809             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12810             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12811             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12812             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12813             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12814             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12815             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12816             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12817             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12818             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12819             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12820           enddo
12821 ! Compute radial contributions to the gradient
12822           facr=-3.0d0*rrmij
12823           a22der=a22*facr
12824           a23der=a23*facr
12825           a32der=a32*facr
12826           a33der=a33*facr
12827           agg(1,1)=a22der*xj
12828           agg(2,1)=a22der*yj
12829           agg(3,1)=a22der*zj
12830           agg(1,2)=a23der*xj
12831           agg(2,2)=a23der*yj
12832           agg(3,2)=a23der*zj
12833           agg(1,3)=a32der*xj
12834           agg(2,3)=a32der*yj
12835           agg(3,3)=a32der*zj
12836           agg(1,4)=a33der*xj
12837           agg(2,4)=a33der*yj
12838           agg(3,4)=a33der*zj
12839 ! Add the contributions coming from er
12840           fac3=-3.0d0*fac
12841           do k=1,3
12842             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12843             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12844             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12845             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12846           enddo
12847           do k=1,3
12848 ! Derivatives in DC(i)
12849 !grad            ghalf1=0.5d0*agg(k,1)
12850 !grad            ghalf2=0.5d0*agg(k,2)
12851 !grad            ghalf3=0.5d0*agg(k,3)
12852 !grad            ghalf4=0.5d0*agg(k,4)
12853             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12854             -3.0d0*uryg(k,2)*vry)!+ghalf1
12855             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12856             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12857             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12858             -3.0d0*urzg(k,2)*vry)!+ghalf3
12859             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12860             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12861 ! Derivatives in DC(i+1)
12862             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12863             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12864             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12865             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12866             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
12867             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
12868             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
12869             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
12870 ! Derivatives in DC(j)
12871             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
12872             -3.0d0*vryg(k,2)*ury)!+ghalf1
12873             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
12874             -3.0d0*vrzg(k,2)*ury)!+ghalf2
12875             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
12876             -3.0d0*vryg(k,2)*urz)!+ghalf3
12877             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
12878             -3.0d0*vrzg(k,2)*urz)!+ghalf4
12879 ! Derivatives in DC(j+1) or DC(nres-1)
12880             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
12881             -3.0d0*vryg(k,3)*ury)
12882             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
12883             -3.0d0*vrzg(k,3)*ury)
12884             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
12885             -3.0d0*vryg(k,3)*urz)
12886             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
12887             -3.0d0*vrzg(k,3)*urz)
12888 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
12889 !grad              do l=1,4
12890 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
12891 !grad              enddo
12892 !grad            endif
12893           enddo
12894           acipa(1,1)=a22
12895           acipa(1,2)=a23
12896           acipa(2,1)=a32
12897           acipa(2,2)=a33
12898           a22=-a22
12899           a23=-a23
12900           do l=1,2
12901             do k=1,3
12902               agg(k,l)=-agg(k,l)
12903               aggi(k,l)=-aggi(k,l)
12904               aggi1(k,l)=-aggi1(k,l)
12905               aggj(k,l)=-aggj(k,l)
12906               aggj1(k,l)=-aggj1(k,l)
12907             enddo
12908           enddo
12909           if (j.lt.nres-1) then
12910             a22=-a22
12911             a32=-a32
12912             do l=1,3,2
12913               do k=1,3
12914                 agg(k,l)=-agg(k,l)
12915                 aggi(k,l)=-aggi(k,l)
12916                 aggi1(k,l)=-aggi1(k,l)
12917                 aggj(k,l)=-aggj(k,l)
12918                 aggj1(k,l)=-aggj1(k,l)
12919               enddo
12920             enddo
12921           else
12922             a22=-a22
12923             a23=-a23
12924             a32=-a32
12925             a33=-a33
12926             do l=1,4
12927               do k=1,3
12928                 agg(k,l)=-agg(k,l)
12929                 aggi(k,l)=-aggi(k,l)
12930                 aggi1(k,l)=-aggi1(k,l)
12931                 aggj(k,l)=-aggj(k,l)
12932                 aggj1(k,l)=-aggj1(k,l)
12933               enddo
12934             enddo
12935           endif
12936           ENDIF ! WCORR
12937           IF (wel_loc.gt.0.0d0) THEN
12938 ! Contribution to the local-electrostatic energy coming from the i-j pair
12939           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
12940            +a33*muij(4)
12941 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
12942
12943           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12944                   'eelloc',i,j,eel_loc_ij
12945 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
12946
12947           eel_loc=eel_loc+eel_loc_ij
12948 ! Partial derivatives in virtual-bond dihedral angles gamma
12949           if (i.gt.1) &
12950           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
12951                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
12952                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
12953           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
12954                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
12955                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
12956 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
12957           do l=1,3
12958             ggg(l)=agg(l,1)*muij(1)+ &
12959                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
12960             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
12961             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
12962 !grad            ghalf=0.5d0*ggg(l)
12963 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
12964 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
12965           enddo
12966 !grad          do k=i+1,j2
12967 !grad            do l=1,3
12968 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
12969 !grad            enddo
12970 !grad          enddo
12971 ! Remaining derivatives of eello
12972           do l=1,3
12973             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
12974                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
12975             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
12976                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
12977             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
12978                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
12979             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
12980                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
12981           enddo
12982           ENDIF
12983 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
12984 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
12985           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
12986              .and. num_conti.le.maxconts) then
12987 !            write (iout,*) i,j," entered corr"
12988 !
12989 ! Calculate the contact function. The ith column of the array JCONT will
12990 ! contain the numbers of atoms that make contacts with the atom I (of numbers
12991 ! greater than I). The arrays FACONT and GACONT will contain the values of
12992 ! the contact function and its derivative.
12993 !           r0ij=1.02D0*rpp(iteli,itelj)
12994 !           r0ij=1.11D0*rpp(iteli,itelj)
12995             r0ij=2.20D0*rpp(iteli,itelj)
12996 !           r0ij=1.55D0*rpp(iteli,itelj)
12997             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
12998 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12999             if (fcont.gt.0.0D0) then
13000               num_conti=num_conti+1
13001               if (num_conti.gt.maxconts) then
13002 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13003                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
13004                                ' will skip next contacts for this conf.',num_conti
13005               else
13006                 jcont_hb(num_conti,i)=j
13007 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
13008 !d     &           " jcont_hb",jcont_hb(num_conti,i)
13009                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
13010                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13011 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
13012 !  terms.
13013                 d_cont(num_conti,i)=rij
13014 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
13015 !     --- Electrostatic-interaction matrix ---
13016                 a_chuj(1,1,num_conti,i)=a22
13017                 a_chuj(1,2,num_conti,i)=a23
13018                 a_chuj(2,1,num_conti,i)=a32
13019                 a_chuj(2,2,num_conti,i)=a33
13020 !     --- Gradient of rij
13021                 do kkk=1,3
13022                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
13023                 enddo
13024                 kkll=0
13025                 do k=1,2
13026                   do l=1,2
13027                     kkll=kkll+1
13028                     do m=1,3
13029                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
13030                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
13031                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
13032                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
13033                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
13034                     enddo
13035                   enddo
13036                 enddo
13037                 ENDIF
13038                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
13039 ! Calculate contact energies
13040                 cosa4=4.0D0*cosa
13041                 wij=cosa-3.0D0*cosb*cosg
13042                 cosbg1=cosb+cosg
13043                 cosbg2=cosb-cosg
13044 !               fac3=dsqrt(-ael6i)/r0ij**3
13045                 fac3=dsqrt(-ael6i)*r3ij
13046 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
13047                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
13048                 if (ees0tmp.gt.0) then
13049                   ees0pij=dsqrt(ees0tmp)
13050                 else
13051                   ees0pij=0
13052                 endif
13053 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
13054                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
13055                 if (ees0tmp.gt.0) then
13056                   ees0mij=dsqrt(ees0tmp)
13057                 else
13058                   ees0mij=0
13059                 endif
13060 !               ees0mij=0.0D0
13061                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
13062                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
13063 ! Diagnostics. Comment out or remove after debugging!
13064 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
13065 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
13066 !               ees0m(num_conti,i)=0.0D0
13067 ! End diagnostics.
13068 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
13069 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
13070 ! Angular derivatives of the contact function
13071                 ees0pij1=fac3/ees0pij
13072                 ees0mij1=fac3/ees0mij
13073                 fac3p=-3.0D0*fac3*rrmij
13074                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
13075                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
13076 !               ees0mij1=0.0D0
13077                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
13078                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
13079                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
13080                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
13081                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
13082                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
13083                 ecosap=ecosa1+ecosa2
13084                 ecosbp=ecosb1+ecosb2
13085                 ecosgp=ecosg1+ecosg2
13086                 ecosam=ecosa1-ecosa2
13087                 ecosbm=ecosb1-ecosb2
13088                 ecosgm=ecosg1-ecosg2
13089 ! Diagnostics
13090 !               ecosap=ecosa1
13091 !               ecosbp=ecosb1
13092 !               ecosgp=ecosg1
13093 !               ecosam=0.0D0
13094 !               ecosbm=0.0D0
13095 !               ecosgm=0.0D0
13096 ! End diagnostics
13097                 facont_hb(num_conti,i)=fcont
13098                 fprimcont=fprimcont/rij
13099 !d              facont_hb(num_conti,i)=1.0D0
13100 ! Following line is for diagnostics.
13101 !d              fprimcont=0.0D0
13102                 do k=1,3
13103                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13104                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13105                 enddo
13106                 do k=1,3
13107                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
13108                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
13109                 enddo
13110                 gggp(1)=gggp(1)+ees0pijp*xj
13111                 gggp(2)=gggp(2)+ees0pijp*yj
13112                 gggp(3)=gggp(3)+ees0pijp*zj
13113                 gggm(1)=gggm(1)+ees0mijp*xj
13114                 gggm(2)=gggm(2)+ees0mijp*yj
13115                 gggm(3)=gggm(3)+ees0mijp*zj
13116 ! Derivatives due to the contact function
13117                 gacont_hbr(1,num_conti,i)=fprimcont*xj
13118                 gacont_hbr(2,num_conti,i)=fprimcont*yj
13119                 gacont_hbr(3,num_conti,i)=fprimcont*zj
13120                 do k=1,3
13121 !
13122 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
13123 !          following the change of gradient-summation algorithm.
13124 !
13125 !grad                  ghalfp=0.5D0*gggp(k)
13126 !grad                  ghalfm=0.5D0*gggm(k)
13127                   gacontp_hb1(k,num_conti,i)= & !ghalfp
13128                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13129                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13130                   gacontp_hb2(k,num_conti,i)= & !ghalfp
13131                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13132                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13133                   gacontp_hb3(k,num_conti,i)=gggp(k)
13134                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
13135                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13136                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13137                   gacontm_hb2(k,num_conti,i)= & !ghalfm
13138                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13139                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13140                   gacontm_hb3(k,num_conti,i)=gggm(k)
13141                 enddo
13142               ENDIF ! wcorr
13143               endif  ! num_conti.le.maxconts
13144             endif  ! fcont.gt.0
13145           endif    ! j.gt.i+1
13146           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
13147             do k=1,4
13148               do l=1,3
13149                 ghalf=0.5d0*agg(l,k)
13150                 aggi(l,k)=aggi(l,k)+ghalf
13151                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
13152                 aggj(l,k)=aggj(l,k)+ghalf
13153               enddo
13154             enddo
13155             if (j.eq.nres-1 .and. i.lt.j-2) then
13156               do k=1,4
13157                 do l=1,3
13158                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
13159                 enddo
13160               enddo
13161             endif
13162           endif
13163 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
13164       return
13165       end subroutine eelecij_scale
13166 !-----------------------------------------------------------------------------
13167       subroutine evdwpp_short(evdw1)
13168 !
13169 ! Compute Evdwpp
13170 !
13171 !      implicit real*8 (a-h,o-z)
13172 !      include 'DIMENSIONS'
13173 !      include 'COMMON.CONTROL'
13174 !      include 'COMMON.IOUNITS'
13175 !      include 'COMMON.GEO'
13176 !      include 'COMMON.VAR'
13177 !      include 'COMMON.LOCAL'
13178 !      include 'COMMON.CHAIN'
13179 !      include 'COMMON.DERIV'
13180 !      include 'COMMON.INTERACT'
13181 !      include 'COMMON.CONTACTS'
13182 !      include 'COMMON.TORSION'
13183 !      include 'COMMON.VECTORS'
13184 !      include 'COMMON.FFIELD'
13185       real(kind=8),dimension(3) :: ggg
13186 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13187 #ifdef MOMENT
13188       real(kind=8) :: scal_el=1.0d0
13189 #else
13190       real(kind=8) :: scal_el=0.5d0
13191 #endif
13192 !el local variables
13193       integer :: i,j,k,iteli,itelj,num_conti
13194       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
13195       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
13196                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13197                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
13198
13199       evdw1=0.0D0
13200 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
13201 !     & " iatel_e_vdw",iatel_e_vdw
13202       call flush(iout)
13203       do i=iatel_s_vdw,iatel_e_vdw
13204         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
13205         dxi=dc(1,i)
13206         dyi=dc(2,i)
13207         dzi=dc(3,i)
13208         dx_normi=dc_norm(1,i)
13209         dy_normi=dc_norm(2,i)
13210         dz_normi=dc_norm(3,i)
13211         xmedi=c(1,i)+0.5d0*dxi
13212         ymedi=c(2,i)+0.5d0*dyi
13213         zmedi=c(3,i)+0.5d0*dzi
13214         num_conti=0
13215 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
13216 !     &   ' ielend',ielend_vdw(i)
13217         call flush(iout)
13218         do j=ielstart_vdw(i),ielend_vdw(i)
13219           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13220 !el          ind=ind+1
13221           iteli=itel(i)
13222           itelj=itel(j)
13223           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13224           aaa=app(iteli,itelj)
13225           bbb=bpp(iteli,itelj)
13226           dxj=dc(1,j)
13227           dyj=dc(2,j)
13228           dzj=dc(3,j)
13229           dx_normj=dc_norm(1,j)
13230           dy_normj=dc_norm(2,j)
13231           dz_normj=dc_norm(3,j)
13232           xj=c(1,j)+0.5D0*dxj-xmedi
13233           yj=c(2,j)+0.5D0*dyj-ymedi
13234           zj=c(3,j)+0.5D0*dzj-zmedi
13235           rij=xj*xj+yj*yj+zj*zj
13236           rrmij=1.0D0/rij
13237           rij=dsqrt(rij)
13238           sss=sscale(rij/rpp(iteli,itelj))
13239           if (sss.gt.0.0d0) then
13240             rmij=1.0D0/rij
13241             r3ij=rrmij*rmij
13242             r6ij=r3ij*r3ij
13243             ev1=aaa*r6ij*r6ij
13244 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13245             if (j.eq.i+2) ev1=scal_el*ev1
13246             ev2=bbb*r6ij
13247             evdwij=ev1+ev2
13248             if (energy_dec) then
13249               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13250             endif
13251             evdw1=evdw1+evdwij*sss
13252 !
13253 ! Calculate contributions to the Cartesian gradient.
13254 !
13255             facvdw=-6*rrmij*(ev1+evdwij)*sss
13256             ggg(1)=facvdw*xj
13257             ggg(2)=facvdw*yj
13258             ggg(3)=facvdw*zj
13259             do k=1,3
13260               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13261               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13262             enddo
13263           endif
13264         enddo ! j
13265       enddo   ! i
13266       return
13267       end subroutine evdwpp_short
13268 !-----------------------------------------------------------------------------
13269       subroutine escp_long(evdw2,evdw2_14)
13270 !
13271 ! This subroutine calculates the excluded-volume interaction energy between
13272 ! peptide-group centers and side chains and its gradient in virtual-bond and
13273 ! side-chain vectors.
13274 !
13275 !      implicit real*8 (a-h,o-z)
13276 !      include 'DIMENSIONS'
13277 !      include 'COMMON.GEO'
13278 !      include 'COMMON.VAR'
13279 !      include 'COMMON.LOCAL'
13280 !      include 'COMMON.CHAIN'
13281 !      include 'COMMON.DERIV'
13282 !      include 'COMMON.INTERACT'
13283 !      include 'COMMON.FFIELD'
13284 !      include 'COMMON.IOUNITS'
13285 !      include 'COMMON.CONTROL'
13286       real(kind=8),dimension(3) :: ggg
13287 !el local variables
13288       integer :: i,iint,j,k,iteli,itypj
13289       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13290       real(kind=8) :: evdw2,evdw2_14,evdwij
13291       evdw2=0.0D0
13292       evdw2_14=0.0d0
13293 !d    print '(a)','Enter ESCP'
13294 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13295       do i=iatscp_s,iatscp_e
13296         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13297         iteli=itel(i)
13298         xi=0.5D0*(c(1,i)+c(1,i+1))
13299         yi=0.5D0*(c(2,i)+c(2,i+1))
13300         zi=0.5D0*(c(3,i)+c(3,i+1))
13301
13302         do iint=1,nscp_gr(i)
13303
13304         do j=iscpstart(i,iint),iscpend(i,iint)
13305           itypj=itype(j)
13306           if (itypj.eq.ntyp1) cycle
13307 ! Uncomment following three lines for SC-p interactions
13308 !         xj=c(1,nres+j)-xi
13309 !         yj=c(2,nres+j)-yi
13310 !         zj=c(3,nres+j)-zi
13311 ! Uncomment following three lines for Ca-p interactions
13312           xj=c(1,j)-xi
13313           yj=c(2,j)-yi
13314           zj=c(3,j)-zi
13315           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13316
13317           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13318
13319           if (sss.lt.1.0d0) then
13320
13321             fac=rrij**expon2
13322             e1=fac*fac*aad(itypj,iteli)
13323             e2=fac*bad(itypj,iteli)
13324             if (iabs(j-i) .le. 2) then
13325               e1=scal14*e1
13326               e2=scal14*e2
13327               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
13328             endif
13329             evdwij=e1+e2
13330             evdw2=evdw2+evdwij*(1.0d0-sss)
13331             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13332                 'evdw2',i,j,sss,evdwij
13333 !
13334 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13335 !
13336             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
13337             ggg(1)=xj*fac
13338             ggg(2)=yj*fac
13339             ggg(3)=zj*fac
13340 ! Uncomment following three lines for SC-p interactions
13341 !           do k=1,3
13342 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13343 !           enddo
13344 ! Uncomment following line for SC-p interactions
13345 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13346             do k=1,3
13347               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13348               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13349             enddo
13350           endif
13351         enddo
13352
13353         enddo ! iint
13354       enddo ! i
13355       do i=1,nct
13356         do j=1,3
13357           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13358           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13359           gradx_scp(j,i)=expon*gradx_scp(j,i)
13360         enddo
13361       enddo
13362 !******************************************************************************
13363 !
13364 !                              N O T E !!!
13365 !
13366 ! To save time the factor EXPON has been extracted from ALL components
13367 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13368 ! use!
13369 !
13370 !******************************************************************************
13371       return
13372       end subroutine escp_long
13373 !-----------------------------------------------------------------------------
13374       subroutine escp_short(evdw2,evdw2_14)
13375 !
13376 ! This subroutine calculates the excluded-volume interaction energy between
13377 ! peptide-group centers and side chains and its gradient in virtual-bond and
13378 ! side-chain vectors.
13379 !
13380 !      implicit real*8 (a-h,o-z)
13381 !      include 'DIMENSIONS'
13382 !      include 'COMMON.GEO'
13383 !      include 'COMMON.VAR'
13384 !      include 'COMMON.LOCAL'
13385 !      include 'COMMON.CHAIN'
13386 !      include 'COMMON.DERIV'
13387 !      include 'COMMON.INTERACT'
13388 !      include 'COMMON.FFIELD'
13389 !      include 'COMMON.IOUNITS'
13390 !      include 'COMMON.CONTROL'
13391       real(kind=8),dimension(3) :: ggg
13392 !el local variables
13393       integer :: i,iint,j,k,iteli,itypj
13394       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13395       real(kind=8) :: evdw2,evdw2_14,evdwij
13396       evdw2=0.0D0
13397       evdw2_14=0.0d0
13398 !d    print '(a)','Enter ESCP'
13399 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13400       do i=iatscp_s,iatscp_e
13401         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13402         iteli=itel(i)
13403         xi=0.5D0*(c(1,i)+c(1,i+1))
13404         yi=0.5D0*(c(2,i)+c(2,i+1))
13405         zi=0.5D0*(c(3,i)+c(3,i+1))
13406
13407         do iint=1,nscp_gr(i)
13408
13409         do j=iscpstart(i,iint),iscpend(i,iint)
13410           itypj=itype(j)
13411           if (itypj.eq.ntyp1) cycle
13412 ! Uncomment following three lines for SC-p interactions
13413 !         xj=c(1,nres+j)-xi
13414 !         yj=c(2,nres+j)-yi
13415 !         zj=c(3,nres+j)-zi
13416 ! Uncomment following three lines for Ca-p interactions
13417           xj=c(1,j)-xi
13418           yj=c(2,j)-yi
13419           zj=c(3,j)-zi
13420           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13421
13422           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13423
13424           if (sss.gt.0.0d0) then
13425
13426             fac=rrij**expon2
13427             e1=fac*fac*aad(itypj,iteli)
13428             e2=fac*bad(itypj,iteli)
13429             if (iabs(j-i) .le. 2) then
13430               e1=scal14*e1
13431               e2=scal14*e2
13432               evdw2_14=evdw2_14+(e1+e2)*sss
13433             endif
13434             evdwij=e1+e2
13435             evdw2=evdw2+evdwij*sss
13436             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13437                 'evdw2',i,j,sss,evdwij
13438 !
13439 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13440 !
13441             fac=-(evdwij+e1)*rrij*sss
13442             ggg(1)=xj*fac
13443             ggg(2)=yj*fac
13444             ggg(3)=zj*fac
13445 ! Uncomment following three lines for SC-p interactions
13446 !           do k=1,3
13447 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13448 !           enddo
13449 ! Uncomment following line for SC-p interactions
13450 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13451             do k=1,3
13452               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13453               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13454             enddo
13455           endif
13456         enddo
13457
13458         enddo ! iint
13459       enddo ! i
13460       do i=1,nct
13461         do j=1,3
13462           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13463           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13464           gradx_scp(j,i)=expon*gradx_scp(j,i)
13465         enddo
13466       enddo
13467 !******************************************************************************
13468 !
13469 !                              N O T E !!!
13470 !
13471 ! To save time the factor EXPON has been extracted from ALL components
13472 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13473 ! use!
13474 !
13475 !******************************************************************************
13476       return
13477       end subroutine escp_short
13478 !-----------------------------------------------------------------------------
13479 ! energy_p_new-sep_barrier.F
13480 !-----------------------------------------------------------------------------
13481       subroutine sc_grad_scale(scalfac)
13482 !      implicit real*8 (a-h,o-z)
13483       use calc_data
13484 !      include 'DIMENSIONS'
13485 !      include 'COMMON.CHAIN'
13486 !      include 'COMMON.DERIV'
13487 !      include 'COMMON.CALC'
13488 !      include 'COMMON.IOUNITS'
13489       real(kind=8),dimension(3) :: dcosom1,dcosom2
13490       real(kind=8) :: scalfac
13491 !el local variables
13492 !      integer :: i,j,k,l
13493
13494       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13495       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13496       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13497            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13498 ! diagnostics only
13499 !      eom1=0.0d0
13500 !      eom2=0.0d0
13501 !      eom12=evdwij*eps1_om12
13502 ! end diagnostics
13503 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13504 !     &  " sigder",sigder
13505 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13506 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13507       do k=1,3
13508         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13509         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13510       enddo
13511       do k=1,3
13512         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
13513          *sss_ele_cut
13514       enddo
13515 !      write (iout,*) "gg",(gg(k),k=1,3)
13516       do k=1,3
13517         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13518                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13519                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
13520                  *sss_ele_cut
13521         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13522                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13523                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
13524          *sss_ele_cut
13525 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13526 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13527 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13528 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13529       enddo
13530 !
13531 ! Calculate the components of the gradient in DC and X
13532 !
13533       do l=1,3
13534         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13535         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13536       enddo
13537       return
13538       end subroutine sc_grad_scale
13539 !-----------------------------------------------------------------------------
13540 ! energy_split-sep.F
13541 !-----------------------------------------------------------------------------
13542       subroutine etotal_long(energia)
13543 !
13544 ! Compute the long-range slow-varying contributions to the energy
13545 !
13546 !      implicit real*8 (a-h,o-z)
13547 !      include 'DIMENSIONS'
13548       use MD_data, only: totT,usampl,eq_time
13549 #ifndef ISNAN
13550       external proc_proc
13551 #ifdef WINPGI
13552 !MS$ATTRIBUTES C ::  proc_proc
13553 #endif
13554 #endif
13555 #ifdef MPI
13556       include "mpif.h"
13557       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13558 #endif
13559 !      include 'COMMON.SETUP'
13560 !      include 'COMMON.IOUNITS'
13561 !      include 'COMMON.FFIELD'
13562 !      include 'COMMON.DERIV'
13563 !      include 'COMMON.INTERACT'
13564 !      include 'COMMON.SBRIDGE'
13565 !      include 'COMMON.CHAIN'
13566 !      include 'COMMON.VAR'
13567 !      include 'COMMON.LOCAL'
13568 !      include 'COMMON.MD'
13569       real(kind=8),dimension(0:n_ene) :: energia
13570 !el local variables
13571       integer :: i,n_corr,n_corr1,ierror,ierr
13572       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13573                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13574                   ecorr,ecorr5,ecorr6,eturn6,time00
13575 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13576 !elwrite(iout,*)"in etotal long"
13577
13578       if (modecalc.eq.12.or.modecalc.eq.14) then
13579 #ifdef MPI
13580 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13581 #else
13582         call int_from_cart1(.false.)
13583 #endif
13584       endif
13585 !elwrite(iout,*)"in etotal long"
13586
13587 #ifdef MPI
13588 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13589 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13590       call flush(iout)
13591       if (nfgtasks.gt.1) then
13592         time00=MPI_Wtime()
13593 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13594         if (fg_rank.eq.0) then
13595           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13596 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13597 !          call flush(iout)
13598 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13599 ! FG slaves as WEIGHTS array.
13600           weights_(1)=wsc
13601           weights_(2)=wscp
13602           weights_(3)=welec
13603           weights_(4)=wcorr
13604           weights_(5)=wcorr5
13605           weights_(6)=wcorr6
13606           weights_(7)=wel_loc
13607           weights_(8)=wturn3
13608           weights_(9)=wturn4
13609           weights_(10)=wturn6
13610           weights_(11)=wang
13611           weights_(12)=wscloc
13612           weights_(13)=wtor
13613           weights_(14)=wtor_d
13614           weights_(15)=wstrain
13615           weights_(16)=wvdwpp
13616           weights_(17)=wbond
13617           weights_(18)=scal14
13618           weights_(21)=wsccor
13619 ! FG Master broadcasts the WEIGHTS_ array
13620           call MPI_Bcast(weights_(1),n_ene,&
13621               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13622         else
13623 ! FG slaves receive the WEIGHTS array
13624           call MPI_Bcast(weights(1),n_ene,&
13625               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13626           wsc=weights(1)
13627           wscp=weights(2)
13628           welec=weights(3)
13629           wcorr=weights(4)
13630           wcorr5=weights(5)
13631           wcorr6=weights(6)
13632           wel_loc=weights(7)
13633           wturn3=weights(8)
13634           wturn4=weights(9)
13635           wturn6=weights(10)
13636           wang=weights(11)
13637           wscloc=weights(12)
13638           wtor=weights(13)
13639           wtor_d=weights(14)
13640           wstrain=weights(15)
13641           wvdwpp=weights(16)
13642           wbond=weights(17)
13643           scal14=weights(18)
13644           wsccor=weights(21)
13645         endif
13646         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13647           king,FG_COMM,IERR)
13648          time_Bcast=time_Bcast+MPI_Wtime()-time00
13649          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13650 !        call chainbuild_cart
13651 !        call int_from_cart1(.false.)
13652       endif
13653 !      write (iout,*) 'Processor',myrank,
13654 !     &  ' calling etotal_short ipot=',ipot
13655 !      call flush(iout)
13656 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13657 #endif
13658 !d    print *,'nnt=',nnt,' nct=',nct
13659 !
13660 !elwrite(iout,*)"in etotal long"
13661 ! Compute the side-chain and electrostatic interaction energy
13662 !
13663       goto (101,102,103,104,105,106) ipot
13664 ! Lennard-Jones potential.
13665   101 call elj_long(evdw)
13666 !d    print '(a)','Exit ELJ'
13667       goto 107
13668 ! Lennard-Jones-Kihara potential (shifted).
13669   102 call eljk_long(evdw)
13670       goto 107
13671 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13672   103 call ebp_long(evdw)
13673       goto 107
13674 ! Gay-Berne potential (shifted LJ, angular dependence).
13675   104 call egb_long(evdw)
13676       goto 107
13677 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13678   105 call egbv_long(evdw)
13679       goto 107
13680 ! Soft-sphere potential
13681   106 call e_softsphere(evdw)
13682 !
13683 ! Calculate electrostatic (H-bonding) energy of the main chain.
13684 !
13685   107 continue
13686       call vec_and_deriv
13687       if (ipot.lt.6) then
13688 #ifdef SPLITELE
13689          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13690              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13691              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13692              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13693 #else
13694          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13695              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13696              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13697              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13698 #endif
13699            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13700          else
13701             ees=0
13702             evdw1=0
13703             eel_loc=0
13704             eello_turn3=0
13705             eello_turn4=0
13706          endif
13707       else
13708 !        write (iout,*) "Soft-spheer ELEC potential"
13709         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13710          eello_turn4)
13711       endif
13712 !
13713 ! Calculate excluded-volume interaction energy between peptide groups
13714 ! and side chains.
13715 !
13716       if (ipot.lt.6) then
13717        if(wscp.gt.0d0) then
13718         call escp_long(evdw2,evdw2_14)
13719        else
13720         evdw2=0
13721         evdw2_14=0
13722        endif
13723       else
13724         call escp_soft_sphere(evdw2,evdw2_14)
13725       endif
13726 !
13727 ! 12/1/95 Multi-body terms
13728 !
13729       n_corr=0
13730       n_corr1=0
13731       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13732           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13733          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13734 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13735 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13736       else
13737          ecorr=0.0d0
13738          ecorr5=0.0d0
13739          ecorr6=0.0d0
13740          eturn6=0.0d0
13741       endif
13742       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13743          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13744       endif
13745 !
13746 ! If performing constraint dynamics, call the constraint energy
13747 !  after the equilibration time
13748       if(usampl.and.totT.gt.eq_time) then
13749          call EconstrQ
13750          call Econstr_back
13751       else
13752          Uconst=0.0d0
13753          Uconst_back=0.0d0
13754       endif
13755 !
13756 ! Sum the energies
13757 !
13758       do i=1,n_ene
13759         energia(i)=0.0d0
13760       enddo
13761       energia(1)=evdw
13762 #ifdef SCP14
13763       energia(2)=evdw2-evdw2_14
13764       energia(18)=evdw2_14
13765 #else
13766       energia(2)=evdw2
13767       energia(18)=0.0d0
13768 #endif
13769 #ifdef SPLITELE
13770       energia(3)=ees
13771       energia(16)=evdw1
13772 #else
13773       energia(3)=ees+evdw1
13774       energia(16)=0.0d0
13775 #endif
13776       energia(4)=ecorr
13777       energia(5)=ecorr5
13778       energia(6)=ecorr6
13779       energia(7)=eel_loc
13780       energia(8)=eello_turn3
13781       energia(9)=eello_turn4
13782       energia(10)=eturn6
13783       energia(20)=Uconst+Uconst_back
13784       call sum_energy(energia,.true.)
13785 !      write (iout,*) "Exit ETOTAL_LONG"
13786       call flush(iout)
13787       return
13788       end subroutine etotal_long
13789 !-----------------------------------------------------------------------------
13790       subroutine etotal_short(energia)
13791 !
13792 ! Compute the short-range fast-varying contributions to the energy
13793 !
13794 !      implicit real*8 (a-h,o-z)
13795 !      include 'DIMENSIONS'
13796 #ifndef ISNAN
13797       external proc_proc
13798 #ifdef WINPGI
13799 !MS$ATTRIBUTES C ::  proc_proc
13800 #endif
13801 #endif
13802 #ifdef MPI
13803       include "mpif.h"
13804       integer :: ierror,ierr
13805       real(kind=8),dimension(n_ene) :: weights_
13806       real(kind=8) :: time00
13807 #endif
13808 !      include 'COMMON.SETUP'
13809 !      include 'COMMON.IOUNITS'
13810 !      include 'COMMON.FFIELD'
13811 !      include 'COMMON.DERIV'
13812 !      include 'COMMON.INTERACT'
13813 !      include 'COMMON.SBRIDGE'
13814 !      include 'COMMON.CHAIN'
13815 !      include 'COMMON.VAR'
13816 !      include 'COMMON.LOCAL'
13817       real(kind=8),dimension(0:n_ene) :: energia
13818 !el local variables
13819       integer :: i,nres6
13820       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13821       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13822       nres6=6*nres
13823
13824 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13825 !      call flush(iout)
13826       if (modecalc.eq.12.or.modecalc.eq.14) then
13827 #ifdef MPI
13828         if (fg_rank.eq.0) call int_from_cart1(.false.)
13829 #else
13830         call int_from_cart1(.false.)
13831 #endif
13832       endif
13833 #ifdef MPI
13834 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13835 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13836 !      call flush(iout)
13837       if (nfgtasks.gt.1) then
13838         time00=MPI_Wtime()
13839 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13840         if (fg_rank.eq.0) then
13841           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13842 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13843 !          call flush(iout)
13844 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13845 ! FG slaves as WEIGHTS array.
13846           weights_(1)=wsc
13847           weights_(2)=wscp
13848           weights_(3)=welec
13849           weights_(4)=wcorr
13850           weights_(5)=wcorr5
13851           weights_(6)=wcorr6
13852           weights_(7)=wel_loc
13853           weights_(8)=wturn3
13854           weights_(9)=wturn4
13855           weights_(10)=wturn6
13856           weights_(11)=wang
13857           weights_(12)=wscloc
13858           weights_(13)=wtor
13859           weights_(14)=wtor_d
13860           weights_(15)=wstrain
13861           weights_(16)=wvdwpp
13862           weights_(17)=wbond
13863           weights_(18)=scal14
13864           weights_(21)=wsccor
13865 ! FG Master broadcasts the WEIGHTS_ array
13866           call MPI_Bcast(weights_(1),n_ene,&
13867               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13868         else
13869 ! FG slaves receive the WEIGHTS array
13870           call MPI_Bcast(weights(1),n_ene,&
13871               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13872           wsc=weights(1)
13873           wscp=weights(2)
13874           welec=weights(3)
13875           wcorr=weights(4)
13876           wcorr5=weights(5)
13877           wcorr6=weights(6)
13878           wel_loc=weights(7)
13879           wturn3=weights(8)
13880           wturn4=weights(9)
13881           wturn6=weights(10)
13882           wang=weights(11)
13883           wscloc=weights(12)
13884           wtor=weights(13)
13885           wtor_d=weights(14)
13886           wstrain=weights(15)
13887           wvdwpp=weights(16)
13888           wbond=weights(17)
13889           scal14=weights(18)
13890           wsccor=weights(21)
13891         endif
13892 !        write (iout,*),"Processor",myrank," BROADCAST weights"
13893         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
13894           king,FG_COMM,IERR)
13895 !        write (iout,*) "Processor",myrank," BROADCAST c"
13896         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
13897           king,FG_COMM,IERR)
13898 !        write (iout,*) "Processor",myrank," BROADCAST dc"
13899         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
13900           king,FG_COMM,IERR)
13901 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
13902         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
13903           king,FG_COMM,IERR)
13904 !        write (iout,*) "Processor",myrank," BROADCAST theta"
13905         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
13906           king,FG_COMM,IERR)
13907 !        write (iout,*) "Processor",myrank," BROADCAST phi"
13908         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
13909           king,FG_COMM,IERR)
13910 !        write (iout,*) "Processor",myrank," BROADCAST alph"
13911         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
13912           king,FG_COMM,IERR)
13913 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
13914         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
13915           king,FG_COMM,IERR)
13916 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
13917         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
13918           king,FG_COMM,IERR)
13919          time_Bcast=time_Bcast+MPI_Wtime()-time00
13920 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
13921       endif
13922 !      write (iout,*) 'Processor',myrank,
13923 !     &  ' calling etotal_short ipot=',ipot
13924 !      call flush(iout)
13925 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13926 #endif
13927 !      call int_from_cart1(.false.)
13928 !
13929 ! Compute the side-chain and electrostatic interaction energy
13930 !
13931       goto (101,102,103,104,105,106) ipot
13932 ! Lennard-Jones potential.
13933   101 call elj_short(evdw)
13934 !d    print '(a)','Exit ELJ'
13935       goto 107
13936 ! Lennard-Jones-Kihara potential (shifted).
13937   102 call eljk_short(evdw)
13938       goto 107
13939 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13940   103 call ebp_short(evdw)
13941       goto 107
13942 ! Gay-Berne potential (shifted LJ, angular dependence).
13943   104 call egb_short(evdw)
13944       goto 107
13945 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13946   105 call egbv_short(evdw)
13947       goto 107
13948 ! Soft-sphere potential - already dealt with in the long-range part
13949   106 evdw=0.0d0
13950 !  106 call e_softsphere_short(evdw)
13951 !
13952 ! Calculate electrostatic (H-bonding) energy of the main chain.
13953 !
13954   107 continue
13955 !
13956 ! Calculate the short-range part of Evdwpp
13957 !
13958       call evdwpp_short(evdw1)
13959 !
13960 ! Calculate the short-range part of ESCp
13961 !
13962       if (ipot.lt.6) then
13963         call escp_short(evdw2,evdw2_14)
13964       endif
13965 !
13966 ! Calculate the bond-stretching energy
13967 !
13968       call ebond(estr)
13969 !
13970 ! Calculate the disulfide-bridge and other energy and the contributions
13971 ! from other distance constraints.
13972       call edis(ehpb)
13973 !
13974 ! Calculate the virtual-bond-angle energy.
13975 !
13976       call ebend(ebe)
13977 !
13978 ! Calculate the SC local energy.
13979 !
13980       call vec_and_deriv
13981       call esc(escloc)
13982 !
13983 ! Calculate the virtual-bond torsional energy.
13984 !
13985       call etor(etors,edihcnstr)
13986 !
13987 ! 6/23/01 Calculate double-torsional energy
13988 !
13989       call etor_d(etors_d)
13990 !
13991 ! 21/5/07 Calculate local sicdechain correlation energy
13992 !
13993       if (wsccor.gt.0.0d0) then
13994         call eback_sc_corr(esccor)
13995       else
13996         esccor=0.0d0
13997       endif
13998 !
13999 ! Put energy components into an array
14000 !
14001       do i=1,n_ene
14002         energia(i)=0.0d0
14003       enddo
14004       energia(1)=evdw
14005 #ifdef SCP14
14006       energia(2)=evdw2-evdw2_14
14007       energia(18)=evdw2_14
14008 #else
14009       energia(2)=evdw2
14010       energia(18)=0.0d0
14011 #endif
14012 #ifdef SPLITELE
14013       energia(16)=evdw1
14014 #else
14015       energia(3)=evdw1
14016 #endif
14017       energia(11)=ebe
14018       energia(12)=escloc
14019       energia(13)=etors
14020       energia(14)=etors_d
14021       energia(15)=ehpb
14022       energia(17)=estr
14023       energia(19)=edihcnstr
14024       energia(21)=esccor
14025 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
14026       call flush(iout)
14027       call sum_energy(energia,.true.)
14028 !      write (iout,*) "Exit ETOTAL_SHORT"
14029       call flush(iout)
14030       return
14031       end subroutine etotal_short
14032 !-----------------------------------------------------------------------------
14033 ! gnmr1.f
14034 !-----------------------------------------------------------------------------
14035       real(kind=8) function gnmr1(y,ymin,ymax)
14036 !      implicit none
14037       real(kind=8) :: y,ymin,ymax
14038       real(kind=8) :: wykl=4.0d0
14039       if (y.lt.ymin) then
14040         gnmr1=(ymin-y)**wykl/wykl
14041       else if (y.gt.ymax) then
14042         gnmr1=(y-ymax)**wykl/wykl
14043       else
14044         gnmr1=0.0d0
14045       endif
14046       return
14047       end function gnmr1
14048 !-----------------------------------------------------------------------------
14049       real(kind=8) function gnmr1prim(y,ymin,ymax)
14050 !      implicit none
14051       real(kind=8) :: y,ymin,ymax
14052       real(kind=8) :: wykl=4.0d0
14053       if (y.lt.ymin) then
14054         gnmr1prim=-(ymin-y)**(wykl-1)
14055       else if (y.gt.ymax) then
14056         gnmr1prim=(y-ymax)**(wykl-1)
14057       else
14058         gnmr1prim=0.0d0
14059       endif
14060       return
14061       end function gnmr1prim
14062 !-----------------------------------------------------------------------------
14063       real(kind=8) function harmonic(y,ymax)
14064 !      implicit none
14065       real(kind=8) :: y,ymax
14066       real(kind=8) :: wykl=2.0d0
14067       harmonic=(y-ymax)**wykl
14068       return
14069       end function harmonic
14070 !-----------------------------------------------------------------------------
14071       real(kind=8) function harmonicprim(y,ymax)
14072       real(kind=8) :: y,ymin,ymax
14073       real(kind=8) :: wykl=2.0d0
14074       harmonicprim=(y-ymax)*wykl
14075       return
14076       end function harmonicprim
14077 !-----------------------------------------------------------------------------
14078 ! gradient_p.F
14079 !-----------------------------------------------------------------------------
14080       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
14081
14082       use io_base, only:intout,briefout
14083 !      implicit real*8 (a-h,o-z)
14084 !      include 'DIMENSIONS'
14085 !      include 'COMMON.CHAIN'
14086 !      include 'COMMON.DERIV'
14087 !      include 'COMMON.VAR'
14088 !      include 'COMMON.INTERACT'
14089 !      include 'COMMON.FFIELD'
14090 !      include 'COMMON.MD'
14091 !      include 'COMMON.IOUNITS'
14092       real(kind=8),external :: ufparm
14093       integer :: uiparm(1)
14094       real(kind=8) :: urparm(1)
14095       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
14096       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
14097       integer :: n,nf,ind,ind1,i,k,j
14098 !
14099 ! This subroutine calculates total internal coordinate gradient.
14100 ! Depending on the number of function evaluations, either whole energy
14101 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
14102 ! internal coordinates are reevaluated or only the cartesian-in-internal
14103 ! coordinate derivatives are evaluated. The subroutine was designed to work
14104 ! with SUMSL.
14105 !
14106 !
14107       icg=mod(nf,2)+1
14108
14109 !d      print *,'grad',nf,icg
14110       if (nf-nfl+1) 20,30,40
14111    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
14112 !    write (iout,*) 'grad 20'
14113       if (nf.eq.0) return
14114       goto 40
14115    30 call var_to_geom(n,x)
14116       call chainbuild
14117 !    write (iout,*) 'grad 30'
14118 !
14119 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
14120 !
14121    40 call cartder
14122 !     write (iout,*) 'grad 40'
14123 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
14124 !
14125 ! Convert the Cartesian gradient into internal-coordinate gradient.
14126 !
14127       ind=0
14128       ind1=0
14129       do i=1,nres-2
14130         gthetai=0.0D0
14131         gphii=0.0D0
14132         do j=i+1,nres-1
14133           ind=ind+1
14134 !         ind=indmat(i,j)
14135 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
14136           do k=1,3
14137             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
14138           enddo
14139           do k=1,3
14140             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
14141           enddo
14142         enddo
14143         do j=i+1,nres-1
14144           ind1=ind1+1
14145 !         ind1=indmat(i,j)
14146 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
14147           do k=1,3
14148             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
14149             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
14150           enddo
14151         enddo
14152         if (i.gt.1) g(i-1)=gphii
14153         if (n.gt.nphi) g(nphi+i)=gthetai
14154       enddo
14155       if (n.le.nphi+ntheta) goto 10
14156       do i=2,nres-1
14157         if (itype(i).ne.10) then
14158           galphai=0.0D0
14159           gomegai=0.0D0
14160           do k=1,3
14161             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
14162           enddo
14163           do k=1,3
14164             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
14165           enddo
14166           g(ialph(i,1))=galphai
14167           g(ialph(i,1)+nside)=gomegai
14168         endif
14169       enddo
14170 !
14171 ! Add the components corresponding to local energy terms.
14172 !
14173    10 continue
14174       do i=1,nvar
14175 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
14176         g(i)=g(i)+gloc(i,icg)
14177       enddo
14178 ! Uncomment following three lines for diagnostics.
14179 !d    call intout
14180 !elwrite(iout,*) "in gradient after calling intout"
14181 !d    call briefout(0,0.0d0)
14182 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
14183       return
14184       end subroutine gradient
14185 !-----------------------------------------------------------------------------
14186       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
14187
14188       use comm_chu
14189 !      implicit real*8 (a-h,o-z)
14190 !      include 'DIMENSIONS'
14191 !      include 'COMMON.DERIV'
14192 !      include 'COMMON.IOUNITS'
14193 !      include 'COMMON.GEO'
14194       integer :: n,nf
14195 !el      integer :: jjj
14196 !el      common /chuju/ jjj
14197       real(kind=8) :: energia(0:n_ene)
14198       integer :: uiparm(1)
14199       real(kind=8) :: urparm(1)
14200       real(kind=8) :: f
14201       real(kind=8),external :: ufparm
14202       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
14203 !     if (jjj.gt.0) then
14204 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14205 !     endif
14206       nfl=nf
14207       icg=mod(nf,2)+1
14208 !d      print *,'func',nf,nfl,icg
14209       call var_to_geom(n,x)
14210       call zerograd
14211       call chainbuild
14212 !d    write (iout,*) 'ETOTAL called from FUNC'
14213       call etotal(energia)
14214       call sum_gradient
14215       f=energia(0)
14216 !     if (jjj.gt.0) then
14217 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14218 !       write (iout,*) 'f=',etot
14219 !       jjj=0
14220 !     endif
14221       return
14222       end subroutine func
14223 !-----------------------------------------------------------------------------
14224       subroutine cartgrad
14225 !      implicit real*8 (a-h,o-z)
14226 !      include 'DIMENSIONS'
14227       use energy_data
14228       use MD_data, only: totT,usampl,eq_time
14229 #ifdef MPI
14230       include 'mpif.h'
14231 #endif
14232 !      include 'COMMON.CHAIN'
14233 !      include 'COMMON.DERIV'
14234 !      include 'COMMON.VAR'
14235 !      include 'COMMON.INTERACT'
14236 !      include 'COMMON.FFIELD'
14237 !      include 'COMMON.MD'
14238 !      include 'COMMON.IOUNITS'
14239 !      include 'COMMON.TIME1'
14240 !
14241       integer :: i,j
14242
14243 ! This subrouting calculates total Cartesian coordinate gradient.
14244 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
14245 !
14246 !el#define DEBUG
14247 #ifdef TIMING
14248       time00=MPI_Wtime()
14249 #endif
14250       icg=1
14251       call sum_gradient
14252 #ifdef TIMING
14253 #endif
14254 !el      write (iout,*) "After sum_gradient"
14255 #ifdef DEBUG
14256 !el      write (iout,*) "After sum_gradient"
14257       do i=1,nres-1
14258         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
14259         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
14260       enddo
14261 #endif
14262 ! If performing constraint dynamics, add the gradients of the constraint energy
14263       if(usampl.and.totT.gt.eq_time) then
14264          do i=1,nct
14265            do j=1,3
14266              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
14267              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
14268            enddo
14269          enddo
14270          do i=1,nres-3
14271            gloc(i,icg)=gloc(i,icg)+dugamma(i)
14272          enddo
14273          do i=1,nres-2
14274            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
14275          enddo
14276       endif
14277 !elwrite (iout,*) "After sum_gradient"
14278 #ifdef TIMING
14279       time01=MPI_Wtime()
14280 #endif
14281       call intcartderiv
14282 !elwrite (iout,*) "After sum_gradient"
14283 #ifdef TIMING
14284       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
14285 #endif
14286 !     call checkintcartgrad
14287 !     write(iout,*) 'calling int_to_cart'
14288 #ifdef DEBUG
14289       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
14290 #endif
14291       do i=1,nct
14292         do j=1,3
14293           gcart(j,i)=gradc(j,i,icg)
14294           gxcart(j,i)=gradx(j,i,icg)
14295         enddo
14296 #ifdef DEBUG
14297         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
14298           (gxcart(j,i),j=1,3),gloc(i,icg)
14299 #endif
14300       enddo
14301 #ifdef TIMING
14302       time01=MPI_Wtime()
14303 #endif
14304       call int_to_cart
14305 #ifdef TIMING
14306       time_inttocart=time_inttocart+MPI_Wtime()-time01
14307 #endif
14308 #ifdef DEBUG
14309       write (iout,*) "gcart and gxcart after int_to_cart"
14310       do i=0,nres-1
14311         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
14312             (gxcart(j,i),j=1,3)
14313       enddo
14314 #endif
14315 #ifdef CARGRAD
14316 #ifdef DEBUG
14317       write (iout,*) "CARGRAD"
14318 #endif
14319       do i=nres,1,-1
14320         do j=1,3
14321           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14322 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14323         enddo
14324 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
14325 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
14326       enddo
14327 ! Correction: dummy residues
14328         if (nnt.gt.1) then
14329           do j=1,3
14330 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
14331             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
14332           enddo
14333         endif
14334         if (nct.lt.nres) then
14335           do j=1,3
14336 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
14337             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
14338           enddo
14339         endif
14340 #endif
14341 #ifdef TIMING
14342       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
14343 #endif
14344 !el#undef DEBUG
14345       return
14346       end subroutine cartgrad
14347 !-----------------------------------------------------------------------------
14348       subroutine zerograd
14349 !      implicit real*8 (a-h,o-z)
14350 !      include 'DIMENSIONS'
14351 !      include 'COMMON.DERIV'
14352 !      include 'COMMON.CHAIN'
14353 !      include 'COMMON.VAR'
14354 !      include 'COMMON.MD'
14355 !      include 'COMMON.SCCOR'
14356 !
14357 !el local variables
14358       integer :: i,j,intertyp
14359 ! Initialize Cartesian-coordinate gradient
14360 !
14361 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
14362 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
14363
14364 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
14365 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
14366 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
14367 !      allocate(gradcorr_long(3,nres))
14368 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
14369 !      allocate(gcorr6_turn_long(3,nres))
14370 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
14371
14372 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
14373
14374 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
14375 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
14376
14377 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
14378 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
14379
14380 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
14381 !      allocate(gscloc(3,nres)) !(3,maxres)
14382 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
14383
14384
14385
14386 !      common /deriv_scloc/
14387 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
14388 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
14389 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
14390 !      common /mpgrad/
14391 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
14392
14393
14394
14395 !          gradc(j,i,icg)=0.0d0
14396 !          gradx(j,i,icg)=0.0d0
14397
14398 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
14399 !elwrite(iout,*) "icg",icg
14400       do i=1,nres
14401         do j=1,3
14402           gvdwx(j,i)=0.0D0
14403           gradx_scp(j,i)=0.0D0
14404           gvdwc(j,i)=0.0D0
14405           gvdwc_scp(j,i)=0.0D0
14406           gvdwc_scpp(j,i)=0.0d0
14407           gelc(j,i)=0.0D0
14408           gelc_long(j,i)=0.0D0
14409           gradb(j,i)=0.0d0
14410           gradbx(j,i)=0.0d0
14411           gvdwpp(j,i)=0.0d0
14412           gel_loc(j,i)=0.0d0
14413           gel_loc_long(j,i)=0.0d0
14414           ghpbc(j,i)=0.0D0
14415           ghpbx(j,i)=0.0D0
14416           gcorr3_turn(j,i)=0.0d0
14417           gcorr4_turn(j,i)=0.0d0
14418           gradcorr(j,i)=0.0d0
14419           gradcorr_long(j,i)=0.0d0
14420           gradcorr5_long(j,i)=0.0d0
14421           gradcorr6_long(j,i)=0.0d0
14422           gcorr6_turn_long(j,i)=0.0d0
14423           gradcorr5(j,i)=0.0d0
14424           gradcorr6(j,i)=0.0d0
14425           gcorr6_turn(j,i)=0.0d0
14426           gsccorc(j,i)=0.0d0
14427           gsccorx(j,i)=0.0d0
14428           gradc(j,i,icg)=0.0d0
14429           gradx(j,i,icg)=0.0d0
14430           gscloc(j,i)=0.0d0
14431           gsclocx(j,i)=0.0d0
14432           do intertyp=1,3
14433            gloc_sc(intertyp,i,icg)=0.0d0
14434           enddo
14435         enddo
14436       enddo
14437 !
14438 ! Initialize the gradient of local energy terms.
14439 !
14440 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
14441 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14442 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14443 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
14444 !      allocate(gel_loc_turn3(nres))
14445 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
14446 !      allocate(gsccor_loc(nres))       !(maxres)
14447
14448       do i=1,4*nres
14449         gloc(i,icg)=0.0D0
14450       enddo
14451       do i=1,nres
14452         gel_loc_loc(i)=0.0d0
14453         gcorr_loc(i)=0.0d0
14454         g_corr5_loc(i)=0.0d0
14455         g_corr6_loc(i)=0.0d0
14456         gel_loc_turn3(i)=0.0d0
14457         gel_loc_turn4(i)=0.0d0
14458         gel_loc_turn6(i)=0.0d0
14459         gsccor_loc(i)=0.0d0
14460       enddo
14461 ! initialize gcart and gxcart
14462 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
14463       do i=0,nres
14464         do j=1,3
14465           gcart(j,i)=0.0d0
14466           gxcart(j,i)=0.0d0
14467         enddo
14468       enddo
14469       return
14470       end subroutine zerograd
14471 !-----------------------------------------------------------------------------
14472       real(kind=8) function fdum()
14473       fdum=0.0D0
14474       return
14475       end function fdum
14476 !-----------------------------------------------------------------------------
14477 ! intcartderiv.F
14478 !-----------------------------------------------------------------------------
14479       subroutine intcartderiv
14480 !      implicit real*8 (a-h,o-z)
14481 !      include 'DIMENSIONS'
14482 #ifdef MPI
14483       include 'mpif.h'
14484 #endif
14485 !      include 'COMMON.SETUP'
14486 !      include 'COMMON.CHAIN'
14487 !      include 'COMMON.VAR'
14488 !      include 'COMMON.GEO'
14489 !      include 'COMMON.INTERACT'
14490 !      include 'COMMON.DERIV'
14491 !      include 'COMMON.IOUNITS'
14492 !      include 'COMMON.LOCAL'
14493 !      include 'COMMON.SCCOR'
14494       real(kind=8) :: pi4,pi34
14495       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
14496       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
14497                     dcosomega,dsinomega !(3,3,maxres)
14498       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
14499
14500       integer :: i,j,k
14501       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
14502                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
14503                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
14504                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
14505       integer :: nres2
14506       nres2=2*nres
14507
14508 !el from module energy-------------
14509 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
14510 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
14511 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
14512
14513 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
14514 !el      allocate(dsintau(3,3,3,0:nres2))
14515 !el      allocate(dtauangle(3,3,3,0:nres2))
14516 !el      allocate(domicron(3,2,2,0:nres2))
14517 !el      allocate(dcosomicron(3,2,2,0:nres2))
14518
14519
14520
14521 #if defined(MPI) && defined(PARINTDER)
14522       if (nfgtasks.gt.1 .and. me.eq.king) &
14523         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14524 #endif
14525       pi4 = 0.5d0*pipol
14526       pi34 = 3*pi4
14527
14528 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14529 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14530
14531 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14532       do i=1,nres
14533         do j=1,3
14534           dtheta(j,1,i)=0.0d0
14535           dtheta(j,2,i)=0.0d0
14536           dphi(j,1,i)=0.0d0
14537           dphi(j,2,i)=0.0d0
14538           dphi(j,3,i)=0.0d0
14539         enddo
14540       enddo
14541 ! Derivatives of theta's
14542 #if defined(MPI) && defined(PARINTDER)
14543 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14544       do i=max0(ithet_start-1,3),ithet_end
14545 #else
14546       do i=3,nres
14547 #endif
14548         cost=dcos(theta(i))
14549         sint=sqrt(1-cost*cost)
14550         do j=1,3
14551           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14552           vbld(i-1)
14553           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14554           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14555           vbld(i)
14556           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14557         enddo
14558       enddo
14559 #if defined(MPI) && defined(PARINTDER)
14560 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14561       do i=max0(ithet_start-1,3),ithet_end
14562 #else
14563       do i=3,nres
14564 #endif
14565       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14566         cost1=dcos(omicron(1,i))
14567         sint1=sqrt(1-cost1*cost1)
14568         cost2=dcos(omicron(2,i))
14569         sint2=sqrt(1-cost2*cost2)
14570        do j=1,3
14571 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14572           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14573           cost1*dc_norm(j,i-2))/ &
14574           vbld(i-1)
14575           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14576           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14577           +cost1*(dc_norm(j,i-1+nres)))/ &
14578           vbld(i-1+nres)
14579           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14580 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14581 !C Looks messy but better than if in loop
14582           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14583           +cost2*dc_norm(j,i-1))/ &
14584           vbld(i)
14585           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14586           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14587            +cost2*(-dc_norm(j,i-1+nres)))/ &
14588           vbld(i-1+nres)
14589 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14590           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14591         enddo
14592        endif
14593       enddo
14594 !elwrite(iout,*) "after vbld write"
14595 ! Derivatives of phi:
14596 ! If phi is 0 or 180 degrees, then the formulas
14597 ! have to be derived by power series expansion of the
14598 ! conventional formulas around 0 and 180.
14599 #ifdef PARINTDER
14600       do i=iphi1_start,iphi1_end
14601 #else
14602       do i=4,nres
14603 #endif
14604 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14605 ! the conventional case
14606         sint=dsin(theta(i))
14607         sint1=dsin(theta(i-1))
14608         sing=dsin(phi(i))
14609         cost=dcos(theta(i))
14610         cost1=dcos(theta(i-1))
14611         cosg=dcos(phi(i))
14612         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14613         fac0=1.0d0/(sint1*sint)
14614         fac1=cost*fac0
14615         fac2=cost1*fac0
14616         fac3=cosg*cost1/(sint1*sint1)
14617         fac4=cosg*cost/(sint*sint)
14618 !    Obtaining the gamma derivatives from sine derivative
14619        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14620            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14621            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14622          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14623          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14624          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14625          do j=1,3
14626             ctgt=cost/sint
14627             ctgt1=cost1/sint1
14628             cosg_inv=1.0d0/cosg
14629             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14630             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14631               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14632             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14633             dsinphi(j,2,i)= &
14634               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14635               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14636             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14637             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14638               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14639 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14640             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14641             endif
14642 ! Bug fixed 3/24/05 (AL)
14643          enddo
14644 !   Obtaining the gamma derivatives from cosine derivative
14645         else
14646            do j=1,3
14647            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14648            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14649            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14650            dc_norm(j,i-3))/vbld(i-2)
14651            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14652            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14653            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14654            dcostheta(j,1,i)
14655            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14656            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14657            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14658            dc_norm(j,i-1))/vbld(i)
14659            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14660            endif
14661          enddo
14662         endif
14663       enddo
14664 !alculate derivative of Tauangle
14665 #ifdef PARINTDER
14666       do i=itau_start,itau_end
14667 #else
14668       do i=3,nres
14669 !elwrite(iout,*) " vecpr",i,nres
14670 #endif
14671        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14672 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14673 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14674 !c dtauangle(j,intertyp,dervityp,residue number)
14675 !c INTERTYP=1 SC...Ca...Ca..Ca
14676 ! the conventional case
14677         sint=dsin(theta(i))
14678         sint1=dsin(omicron(2,i-1))
14679         sing=dsin(tauangle(1,i))
14680         cost=dcos(theta(i))
14681         cost1=dcos(omicron(2,i-1))
14682         cosg=dcos(tauangle(1,i))
14683 !elwrite(iout,*) " vecpr5",i,nres
14684         do j=1,3
14685 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14686 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14687         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14688 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14689         enddo
14690         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14691         fac0=1.0d0/(sint1*sint)
14692         fac1=cost*fac0
14693         fac2=cost1*fac0
14694         fac3=cosg*cost1/(sint1*sint1)
14695         fac4=cosg*cost/(sint*sint)
14696 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14697 !    Obtaining the gamma derivatives from sine derivative
14698        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14699            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14700            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14701          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14702          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14703          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14704         do j=1,3
14705             ctgt=cost/sint
14706             ctgt1=cost1/sint1
14707             cosg_inv=1.0d0/cosg
14708             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14709        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14710        *vbld_inv(i-2+nres)
14711             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14712             dsintau(j,1,2,i)= &
14713               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14714               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14715 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14716             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14717 ! Bug fixed 3/24/05 (AL)
14718             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14719               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14720 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14721             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14722          enddo
14723 !   Obtaining the gamma derivatives from cosine derivative
14724         else
14725            do j=1,3
14726            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14727            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14728            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14729            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14730            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14731            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14732            dcostheta(j,1,i)
14733            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14734            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14735            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14736            dc_norm(j,i-1))/vbld(i)
14737            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14738 !         write (iout,*) "else",i
14739          enddo
14740         endif
14741 !        do k=1,3
14742 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14743 !        enddo
14744       enddo
14745 !C Second case Ca...Ca...Ca...SC
14746 #ifdef PARINTDER
14747       do i=itau_start,itau_end
14748 #else
14749       do i=4,nres
14750 #endif
14751        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14752           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14753 ! the conventional case
14754         sint=dsin(omicron(1,i))
14755         sint1=dsin(theta(i-1))
14756         sing=dsin(tauangle(2,i))
14757         cost=dcos(omicron(1,i))
14758         cost1=dcos(theta(i-1))
14759         cosg=dcos(tauangle(2,i))
14760 !        do j=1,3
14761 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14762 !        enddo
14763         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14764         fac0=1.0d0/(sint1*sint)
14765         fac1=cost*fac0
14766         fac2=cost1*fac0
14767         fac3=cosg*cost1/(sint1*sint1)
14768         fac4=cosg*cost/(sint*sint)
14769 !    Obtaining the gamma derivatives from sine derivative
14770        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14771            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14772            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14773          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14774          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14775          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14776         do j=1,3
14777             ctgt=cost/sint
14778             ctgt1=cost1/sint1
14779             cosg_inv=1.0d0/cosg
14780             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14781               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14782 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14783 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14784             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14785             dsintau(j,2,2,i)= &
14786               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14787               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14788 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14789 !     & sing*ctgt*domicron(j,1,2,i),
14790 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14791             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14792 ! Bug fixed 3/24/05 (AL)
14793             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14794              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14795 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14796             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14797          enddo
14798 !   Obtaining the gamma derivatives from cosine derivative
14799         else
14800            do j=1,3
14801            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14802            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14803            dc_norm(j,i-3))/vbld(i-2)
14804            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14805            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14806            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14807            dcosomicron(j,1,1,i)
14808            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14809            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14810            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14811            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14812            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14813 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14814          enddo
14815         endif
14816       enddo
14817
14818 !CC third case SC...Ca...Ca...SC
14819 #ifdef PARINTDER
14820
14821       do i=itau_start,itau_end
14822 #else
14823       do i=3,nres
14824 #endif
14825 ! the conventional case
14826       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14827       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14828         sint=dsin(omicron(1,i))
14829         sint1=dsin(omicron(2,i-1))
14830         sing=dsin(tauangle(3,i))
14831         cost=dcos(omicron(1,i))
14832         cost1=dcos(omicron(2,i-1))
14833         cosg=dcos(tauangle(3,i))
14834         do j=1,3
14835         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14836 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14837         enddo
14838         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14839         fac0=1.0d0/(sint1*sint)
14840         fac1=cost*fac0
14841         fac2=cost1*fac0
14842         fac3=cosg*cost1/(sint1*sint1)
14843         fac4=cosg*cost/(sint*sint)
14844 !    Obtaining the gamma derivatives from sine derivative
14845        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14846            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14847            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14848          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14849          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14850          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14851         do j=1,3
14852             ctgt=cost/sint
14853             ctgt1=cost1/sint1
14854             cosg_inv=1.0d0/cosg
14855             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14856               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14857               *vbld_inv(i-2+nres)
14858             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14859             dsintau(j,3,2,i)= &
14860               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14861               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14862             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14863 ! Bug fixed 3/24/05 (AL)
14864             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14865               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14866               *vbld_inv(i-1+nres)
14867 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14868             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
14869          enddo
14870 !   Obtaining the gamma derivatives from cosine derivative
14871         else
14872            do j=1,3
14873            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14874            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14875            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
14876            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
14877            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14878            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14879            dcosomicron(j,1,1,i)
14880            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
14881            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14882            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
14883            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14884            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
14885 !          write(iout,*) "else",i
14886          enddo
14887         endif
14888       enddo
14889
14890 #ifdef CRYST_SC
14891 !   Derivatives of side-chain angles alpha and omega
14892 #if defined(MPI) && defined(PARINTDER)
14893         do i=ibond_start,ibond_end
14894 #else
14895         do i=2,nres-1
14896 #endif
14897           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
14898              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
14899              fac6=fac5/vbld(i)
14900              fac7=fac5*fac5
14901              fac8=fac5/vbld(i+1)
14902              fac9=fac5/vbld(i+nres)
14903              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
14904              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
14905              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
14906              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
14907              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
14908              sina=sqrt(1-cosa*cosa)
14909              sino=dsin(omeg(i))
14910 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
14911              do j=1,3
14912                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
14913                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
14914                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
14915                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
14916                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
14917                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
14918                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
14919                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
14920                 vbld(i+nres))
14921                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
14922             enddo
14923 ! obtaining the derivatives of omega from sines
14924             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
14925                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
14926                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
14927                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
14928                dsin(theta(i+1)))
14929                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
14930                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
14931                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
14932                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
14933                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
14934                coso_inv=1.0d0/dcos(omeg(i))
14935                do j=1,3
14936                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
14937                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
14938                  (sino*dc_norm(j,i-1))/vbld(i)
14939                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
14940                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
14941                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
14942                  -sino*dc_norm(j,i)/vbld(i+1)
14943                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
14944                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
14945                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
14946                  vbld(i+nres)
14947                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
14948               enddo
14949            else
14950 !   obtaining the derivatives of omega from cosines
14951              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
14952              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
14953              fac12=fac10*sina
14954              fac13=fac12*fac12
14955              fac14=sina*sina
14956              do j=1,3
14957                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
14958                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
14959                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
14960                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
14961                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
14962                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
14963                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
14964                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
14965                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
14966                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
14967                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
14968                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
14969                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
14970                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
14971                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
14972             enddo
14973           endif
14974          else
14975            do j=1,3
14976              do k=1,3
14977                dalpha(k,j,i)=0.0d0
14978                domega(k,j,i)=0.0d0
14979              enddo
14980            enddo
14981          endif
14982        enddo
14983 #endif
14984 #if defined(MPI) && defined(PARINTDER)
14985       if (nfgtasks.gt.1) then
14986 #ifdef DEBUG
14987 !d      write (iout,*) "Gather dtheta"
14988 !d      call flush(iout)
14989       write (iout,*) "dtheta before gather"
14990       do i=1,nres
14991         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
14992       enddo
14993 #endif
14994       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
14995         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
14996         king,FG_COMM,IERROR)
14997 #ifdef DEBUG
14998 !d      write (iout,*) "Gather dphi"
14999 !d      call flush(iout)
15000       write (iout,*) "dphi before gather"
15001       do i=1,nres
15002         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
15003       enddo
15004 #endif
15005       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
15006         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
15007         king,FG_COMM,IERROR)
15008 !d      write (iout,*) "Gather dalpha"
15009 !d      call flush(iout)
15010 #ifdef CRYST_SC
15011       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
15012         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15013         king,FG_COMM,IERROR)
15014 !d      write (iout,*) "Gather domega"
15015 !d      call flush(iout)
15016       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
15017         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15018         king,FG_COMM,IERROR)
15019 #endif
15020       endif
15021 #endif
15022 #ifdef DEBUG
15023       write (iout,*) "dtheta after gather"
15024       do i=1,nres
15025         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
15026       enddo
15027       write (iout,*) "dphi after gather"
15028       do i=1,nres
15029         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
15030       enddo
15031       write (iout,*) "dalpha after gather"
15032       do i=1,nres
15033         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
15034       enddo
15035       write (iout,*) "domega after gather"
15036       do i=1,nres
15037         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
15038       enddo
15039 #endif
15040       return
15041       end subroutine intcartderiv
15042 !-----------------------------------------------------------------------------
15043       subroutine checkintcartgrad
15044 !      implicit real*8 (a-h,o-z)
15045 !      include 'DIMENSIONS'
15046 #ifdef MPI
15047       include 'mpif.h'
15048 #endif
15049 !      include 'COMMON.CHAIN'
15050 !      include 'COMMON.VAR'
15051 !      include 'COMMON.GEO'
15052 !      include 'COMMON.INTERACT'
15053 !      include 'COMMON.DERIV'
15054 !      include 'COMMON.IOUNITS'
15055 !      include 'COMMON.SETUP'
15056       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
15057       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
15058       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
15059       real(kind=8),dimension(3) :: dc_norm_s
15060       real(kind=8) :: aincr=1.0d-5
15061       integer :: i,j
15062       real(kind=8) :: dcji
15063       do i=1,nres
15064         phi_s(i)=phi(i)
15065         theta_s(i)=theta(i)
15066         alph_s(i)=alph(i)
15067         omeg_s(i)=omeg(i)
15068       enddo
15069 ! Check theta gradient
15070       write (iout,*) &
15071        "Analytical (upper) and numerical (lower) gradient of theta"
15072       write (iout,*)
15073       do i=3,nres
15074         do j=1,3
15075           dcji=dc(j,i-2)
15076           dc(j,i-2)=dcji+aincr
15077           call chainbuild_cart
15078           call int_from_cart1(.false.)
15079           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
15080           dc(j,i-2)=dcji
15081           dcji=dc(j,i-1)
15082           dc(j,i-1)=dc(j,i-1)+aincr
15083           call chainbuild_cart
15084           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
15085           dc(j,i-1)=dcji
15086         enddo
15087 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
15088 !el          (dtheta(j,2,i),j=1,3)
15089 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
15090 !el          (dthetanum(j,2,i),j=1,3)
15091 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
15092 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
15093 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
15094 !el        write (iout,*)
15095       enddo
15096 ! Check gamma gradient
15097       write (iout,*) &
15098        "Analytical (upper) and numerical (lower) gradient of gamma"
15099       do i=4,nres
15100         do j=1,3
15101           dcji=dc(j,i-3)
15102           dc(j,i-3)=dcji+aincr
15103           call chainbuild_cart
15104           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
15105           dc(j,i-3)=dcji
15106           dcji=dc(j,i-2)
15107           dc(j,i-2)=dcji+aincr
15108           call chainbuild_cart
15109           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
15110           dc(j,i-2)=dcji
15111           dcji=dc(j,i-1)
15112           dc(j,i-1)=dc(j,i-1)+aincr
15113           call chainbuild_cart
15114           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
15115           dc(j,i-1)=dcji
15116         enddo
15117 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
15118 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
15119 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
15120 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
15121 !el        write (iout,'(5x,3(3f10.5,5x))') &
15122 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
15123 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
15124 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
15125 !el        write (iout,*)
15126       enddo
15127 ! Check alpha gradient
15128       write (iout,*) &
15129        "Analytical (upper) and numerical (lower) gradient of alpha"
15130       do i=2,nres-1
15131        if(itype(i).ne.10) then
15132             do j=1,3
15133               dcji=dc(j,i-1)
15134               dc(j,i-1)=dcji+aincr
15135               call chainbuild_cart
15136               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
15137               /aincr
15138               dc(j,i-1)=dcji
15139               dcji=dc(j,i)
15140               dc(j,i)=dcji+aincr
15141               call chainbuild_cart
15142               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
15143               /aincr
15144               dc(j,i)=dcji
15145               dcji=dc(j,i+nres)
15146               dc(j,i+nres)=dc(j,i+nres)+aincr
15147               call chainbuild_cart
15148               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
15149               /aincr
15150              dc(j,i+nres)=dcji
15151             enddo
15152           endif
15153 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
15154 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
15155 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
15156 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
15157 !el        write (iout,'(5x,3(3f10.5,5x))') &
15158 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
15159 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
15160 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
15161 !el        write (iout,*)
15162       enddo
15163 !     Check omega gradient
15164       write (iout,*) &
15165        "Analytical (upper) and numerical (lower) gradient of omega"
15166       do i=2,nres-1
15167        if(itype(i).ne.10) then
15168             do j=1,3
15169               dcji=dc(j,i-1)
15170               dc(j,i-1)=dcji+aincr
15171               call chainbuild_cart
15172               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
15173               /aincr
15174               dc(j,i-1)=dcji
15175               dcji=dc(j,i)
15176               dc(j,i)=dcji+aincr
15177               call chainbuild_cart
15178               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
15179               /aincr
15180               dc(j,i)=dcji
15181               dcji=dc(j,i+nres)
15182               dc(j,i+nres)=dc(j,i+nres)+aincr
15183               call chainbuild_cart
15184               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
15185               /aincr
15186              dc(j,i+nres)=dcji
15187             enddo
15188           endif
15189 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
15190 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
15191 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
15192 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
15193 !el        write (iout,'(5x,3(3f10.5,5x))') &
15194 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
15195 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
15196 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
15197 !el        write (iout,*)
15198       enddo
15199       return
15200       end subroutine checkintcartgrad
15201 !-----------------------------------------------------------------------------
15202 ! q_measure.F
15203 !-----------------------------------------------------------------------------
15204       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
15205 !      implicit real*8 (a-h,o-z)
15206 !      include 'DIMENSIONS'
15207 !      include 'COMMON.IOUNITS'
15208 !      include 'COMMON.CHAIN'
15209 !      include 'COMMON.INTERACT'
15210 !      include 'COMMON.VAR'
15211       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
15212       integer :: kkk,nsep=3
15213       real(kind=8) :: qm        !dist,
15214       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
15215       logical :: lprn=.false.
15216       logical :: flag
15217 !      real(kind=8) :: sigm,x
15218
15219 !el      sigm(x)=0.25d0*x     ! local function
15220       qqmax=1.0d10
15221       do kkk=1,nperm
15222       qq = 0.0d0
15223       nl=0
15224        if(flag) then
15225         do il=seg1+nsep,seg2
15226           do jl=seg1,il-nsep
15227             nl=nl+1
15228             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
15229                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
15230                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15231             dij=dist(il,jl)
15232             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15233             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15234               nl=nl+1
15235               d0ijCM=dsqrt( &
15236                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15237                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15238                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15239               dijCM=dist(il+nres,jl+nres)
15240               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15241             endif
15242             qq = qq+qqij+qqijCM
15243           enddo
15244         enddo
15245         qq = qq/nl
15246       else
15247       do il=seg1,seg2
15248         if((seg3-il).lt.3) then
15249              secseg=il+3
15250         else
15251              secseg=seg3
15252         endif
15253           do jl=secseg,seg4
15254             nl=nl+1
15255             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15256                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15257                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15258             dij=dist(il,jl)
15259             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15260             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15261               nl=nl+1
15262               d0ijCM=dsqrt( &
15263                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15264                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15265                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15266               dijCM=dist(il+nres,jl+nres)
15267               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15268             endif
15269             qq = qq+qqij+qqijCM
15270           enddo
15271         enddo
15272       qq = qq/nl
15273       endif
15274       if (qqmax.le.qq) qqmax=qq
15275       enddo
15276       qwolynes=1.0d0-qqmax
15277       return
15278       end function qwolynes
15279 !-----------------------------------------------------------------------------
15280       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
15281 !      implicit real*8 (a-h,o-z)
15282 !      include 'DIMENSIONS'
15283 !      include 'COMMON.IOUNITS'
15284 !      include 'COMMON.CHAIN'
15285 !      include 'COMMON.INTERACT'
15286 !      include 'COMMON.VAR'
15287 !      include 'COMMON.MD'
15288       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
15289       integer :: nsep=3, kkk
15290 !el      real(kind=8) :: dist
15291       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
15292       logical :: lprn=.false.
15293       logical :: flag
15294       real(kind=8) :: sim,dd0,fac,ddqij
15295 !el      sigm(x)=0.25d0*x            ! local function
15296       do kkk=1,nperm
15297       do i=0,nres
15298         do j=1,3
15299           dqwol(j,i)=0.0d0
15300           dxqwol(j,i)=0.0d0
15301         enddo
15302       enddo
15303       nl=0
15304        if(flag) then
15305         do il=seg1+nsep,seg2
15306           do jl=seg1,il-nsep
15307             nl=nl+1
15308             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15309                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15310                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15311             dij=dist(il,jl)
15312             sim = 1.0d0/sigm(d0ij)
15313             sim = sim*sim
15314             dd0 = dij-d0ij
15315             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15316             do k=1,3
15317               ddqij = (c(k,il)-c(k,jl))*fac
15318               dqwol(k,il)=dqwol(k,il)+ddqij
15319               dqwol(k,jl)=dqwol(k,jl)-ddqij
15320             enddo
15321
15322             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15323               nl=nl+1
15324               d0ijCM=dsqrt( &
15325                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15326                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15327                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15328               dijCM=dist(il+nres,jl+nres)
15329               sim = 1.0d0/sigm(d0ijCM)
15330               sim = sim*sim
15331               dd0=dijCM-d0ijCM
15332               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15333               do k=1,3
15334                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15335                 dxqwol(k,il)=dxqwol(k,il)+ddqij
15336                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15337               enddo
15338             endif
15339           enddo
15340         enddo
15341        else
15342         do il=seg1,seg2
15343         if((seg3-il).lt.3) then
15344              secseg=il+3
15345         else
15346              secseg=seg3
15347         endif
15348           do jl=secseg,seg4
15349             nl=nl+1
15350             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15351                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15352                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15353             dij=dist(il,jl)
15354             sim = 1.0d0/sigm(d0ij)
15355             sim = sim*sim
15356             dd0 = dij-d0ij
15357             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15358             do k=1,3
15359               ddqij = (c(k,il)-c(k,jl))*fac
15360               dqwol(k,il)=dqwol(k,il)+ddqij
15361               dqwol(k,jl)=dqwol(k,jl)-ddqij
15362             enddo
15363             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15364               nl=nl+1
15365               d0ijCM=dsqrt( &
15366                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15367                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15368                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15369               dijCM=dist(il+nres,jl+nres)
15370               sim = 1.0d0/sigm(d0ijCM)
15371               sim=sim*sim
15372               dd0 = dijCM-d0ijCM
15373               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15374               do k=1,3
15375                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15376                dxqwol(k,il)=dxqwol(k,il)+ddqij
15377                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15378               enddo
15379             endif
15380           enddo
15381         enddo
15382       endif
15383       enddo
15384        do i=0,nres
15385          do j=1,3
15386            dqwol(j,i)=dqwol(j,i)/nl
15387            dxqwol(j,i)=dxqwol(j,i)/nl
15388          enddo
15389        enddo
15390       return
15391       end subroutine qwolynes_prim
15392 !-----------------------------------------------------------------------------
15393       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
15394 !      implicit real*8 (a-h,o-z)
15395 !      include 'DIMENSIONS'
15396 !      include 'COMMON.IOUNITS'
15397 !      include 'COMMON.CHAIN'
15398 !      include 'COMMON.INTERACT'
15399 !      include 'COMMON.VAR'
15400       integer :: seg1,seg2,seg3,seg4
15401       logical :: flag
15402       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
15403       real(kind=8),dimension(3,0:2*nres) :: cdummy
15404       real(kind=8) :: q1,q2
15405       real(kind=8) :: delta=1.0d-10
15406       integer :: i,j
15407
15408       do i=0,nres
15409         do j=1,3
15410           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15411           cdummy(j,i)=c(j,i)
15412           c(j,i)=c(j,i)+delta
15413           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15414           qwolan(j,i)=(q2-q1)/delta
15415           c(j,i)=cdummy(j,i)
15416         enddo
15417       enddo
15418       do i=0,nres
15419         do j=1,3
15420           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15421           cdummy(j,i+nres)=c(j,i+nres)
15422           c(j,i+nres)=c(j,i+nres)+delta
15423           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15424           qwolxan(j,i)=(q2-q1)/delta
15425           c(j,i+nres)=cdummy(j,i+nres)
15426         enddo
15427       enddo
15428 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
15429 !      do i=0,nct
15430 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
15431 !      enddo
15432 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
15433 !      do i=0,nct
15434 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
15435 !      enddo
15436       return
15437       end subroutine qwol_num
15438 !-----------------------------------------------------------------------------
15439       subroutine EconstrQ
15440 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
15441 !      implicit real*8 (a-h,o-z)
15442 !      include 'DIMENSIONS'
15443 !      include 'COMMON.CONTROL'
15444 !      include 'COMMON.VAR'
15445 !      include 'COMMON.MD'
15446       use MD_data
15447 !#ifndef LANG0
15448 !      include 'COMMON.LANGEVIN'
15449 !#else
15450 !      include 'COMMON.LANGEVIN.lang0'
15451 !#endif
15452 !      include 'COMMON.CHAIN'
15453 !      include 'COMMON.DERIV'
15454 !      include 'COMMON.GEO'
15455 !      include 'COMMON.LOCAL'
15456 !      include 'COMMON.INTERACT'
15457 !      include 'COMMON.IOUNITS'
15458 !      include 'COMMON.NAMES'
15459 !      include 'COMMON.TIME1'
15460       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
15461       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
15462                    duconst,duxconst
15463       integer :: kstart,kend,lstart,lend,idummy
15464       real(kind=8) :: delta=1.0d-7
15465       integer :: i,j,k,ii
15466       do i=0,nres
15467          do j=1,3
15468             duconst(j,i)=0.0d0
15469             dudconst(j,i)=0.0d0
15470             duxconst(j,i)=0.0d0
15471             dudxconst(j,i)=0.0d0
15472          enddo
15473       enddo
15474       Uconst=0.0d0
15475       do i=1,nfrag
15476          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15477            idummy,idummy)
15478          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
15479 ! Calculating the derivatives of Constraint energy with respect to Q
15480          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
15481            qinfrag(i,iset))
15482 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
15483 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
15484 !         hmnum=(hm2-hm1)/delta
15485 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
15486 !     &   qinfrag(i,iset))
15487 !         write(iout,*) "harmonicnum frag", hmnum
15488 ! Calculating the derivatives of Q with respect to cartesian coordinates
15489          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15490           idummy,idummy)
15491 !         write(iout,*) "dqwol "
15492 !         do ii=1,nres
15493 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15494 !         enddo
15495 !         write(iout,*) "dxqwol "
15496 !         do ii=1,nres
15497 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15498 !         enddo
15499 ! Calculating numerical gradients of dU/dQi and dQi/dxi
15500 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
15501 !     &  ,idummy,idummy)
15502 !  The gradients of Uconst in Cs
15503          do ii=0,nres
15504             do j=1,3
15505                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
15506                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
15507             enddo
15508          enddo
15509       enddo
15510       do i=1,npair
15511          kstart=ifrag(1,ipair(1,i,iset),iset)
15512          kend=ifrag(2,ipair(1,i,iset),iset)
15513          lstart=ifrag(1,ipair(2,i,iset),iset)
15514          lend=ifrag(2,ipair(2,i,iset),iset)
15515          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
15516          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
15517 !  Calculating dU/dQ
15518          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15519 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15520 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15521 !         hmnum=(hm2-hm1)/delta
15522 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15523 !     &   qinpair(i,iset))
15524 !         write(iout,*) "harmonicnum pair ", hmnum
15525 ! Calculating dQ/dXi
15526          call qwolynes_prim(kstart,kend,.false.,&
15527           lstart,lend)
15528 !         write(iout,*) "dqwol "
15529 !         do ii=1,nres
15530 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15531 !         enddo
15532 !         write(iout,*) "dxqwol "
15533 !         do ii=1,nres
15534 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15535 !        enddo
15536 ! Calculating numerical gradients
15537 !        call qwol_num(kstart,kend,.false.
15538 !     &  ,lstart,lend)
15539 ! The gradients of Uconst in Cs
15540          do ii=0,nres
15541             do j=1,3
15542                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15543                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15544             enddo
15545          enddo
15546       enddo
15547 !      write(iout,*) "Uconst inside subroutine ", Uconst
15548 ! Transforming the gradients from Cs to dCs for the backbone
15549       do i=0,nres
15550          do j=i+1,nres
15551            do k=1,3
15552              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15553            enddo
15554          enddo
15555       enddo
15556 !  Transforming the gradients from Cs to dCs for the side chains
15557       do i=1,nres
15558          do j=1,3
15559            dudxconst(j,i)=duxconst(j,i)
15560          enddo
15561       enddo
15562 !      write(iout,*) "dU/ddc backbone "
15563 !       do ii=0,nres
15564 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15565 !      enddo
15566 !      write(iout,*) "dU/ddX side chain "
15567 !      do ii=1,nres
15568 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15569 !      enddo
15570 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15571 !      call dEconstrQ_num
15572       return
15573       end subroutine EconstrQ
15574 !-----------------------------------------------------------------------------
15575       subroutine dEconstrQ_num
15576 ! Calculating numerical dUconst/ddc and dUconst/ddx
15577 !      implicit real*8 (a-h,o-z)
15578 !      include 'DIMENSIONS'
15579 !      include 'COMMON.CONTROL'
15580 !      include 'COMMON.VAR'
15581 !      include 'COMMON.MD'
15582       use MD_data
15583 !#ifndef LANG0
15584 !      include 'COMMON.LANGEVIN'
15585 !#else
15586 !      include 'COMMON.LANGEVIN.lang0'
15587 !#endif
15588 !      include 'COMMON.CHAIN'
15589 !      include 'COMMON.DERIV'
15590 !      include 'COMMON.GEO'
15591 !      include 'COMMON.LOCAL'
15592 !      include 'COMMON.INTERACT'
15593 !      include 'COMMON.IOUNITS'
15594 !      include 'COMMON.NAMES'
15595 !      include 'COMMON.TIME1'
15596       real(kind=8) :: uzap1,uzap2
15597       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15598       integer :: kstart,kend,lstart,lend,idummy
15599       real(kind=8) :: delta=1.0d-7
15600 !el local variables
15601       integer :: i,ii,j
15602 !     real(kind=8) ::
15603 !     For the backbone
15604       do i=0,nres-1
15605          do j=1,3
15606             dUcartan(j,i)=0.0d0
15607             cdummy(j,i)=dc(j,i)
15608             dc(j,i)=dc(j,i)+delta
15609             call chainbuild_cart
15610             uzap2=0.0d0
15611             do ii=1,nfrag
15612              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15613                 idummy,idummy)
15614                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15615                 qinfrag(ii,iset))
15616             enddo
15617             do ii=1,npair
15618                kstart=ifrag(1,ipair(1,ii,iset),iset)
15619                kend=ifrag(2,ipair(1,ii,iset),iset)
15620                lstart=ifrag(1,ipair(2,ii,iset),iset)
15621                lend=ifrag(2,ipair(2,ii,iset),iset)
15622                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15623                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15624                  qinpair(ii,iset))
15625             enddo
15626             dc(j,i)=cdummy(j,i)
15627             call chainbuild_cart
15628             uzap1=0.0d0
15629              do ii=1,nfrag
15630              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15631                 idummy,idummy)
15632                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15633                 qinfrag(ii,iset))
15634             enddo
15635             do ii=1,npair
15636                kstart=ifrag(1,ipair(1,ii,iset),iset)
15637                kend=ifrag(2,ipair(1,ii,iset),iset)
15638                lstart=ifrag(1,ipair(2,ii,iset),iset)
15639                lend=ifrag(2,ipair(2,ii,iset),iset)
15640                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15641                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15642                 qinpair(ii,iset))
15643             enddo
15644             ducartan(j,i)=(uzap2-uzap1)/(delta)
15645          enddo
15646       enddo
15647 ! Calculating numerical gradients for dU/ddx
15648       do i=0,nres-1
15649          duxcartan(j,i)=0.0d0
15650          do j=1,3
15651             cdummy(j,i)=dc(j,i+nres)
15652             dc(j,i+nres)=dc(j,i+nres)+delta
15653             call chainbuild_cart
15654             uzap2=0.0d0
15655             do ii=1,nfrag
15656              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15657                 idummy,idummy)
15658                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15659                 qinfrag(ii,iset))
15660             enddo
15661             do ii=1,npair
15662                kstart=ifrag(1,ipair(1,ii,iset),iset)
15663                kend=ifrag(2,ipair(1,ii,iset),iset)
15664                lstart=ifrag(1,ipair(2,ii,iset),iset)
15665                lend=ifrag(2,ipair(2,ii,iset),iset)
15666                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15667                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15668                 qinpair(ii,iset))
15669             enddo
15670             dc(j,i+nres)=cdummy(j,i)
15671             call chainbuild_cart
15672             uzap1=0.0d0
15673              do ii=1,nfrag
15674                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15675                 ifrag(2,ii,iset),.true.,idummy,idummy)
15676                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15677                 qinfrag(ii,iset))
15678             enddo
15679             do ii=1,npair
15680                kstart=ifrag(1,ipair(1,ii,iset),iset)
15681                kend=ifrag(2,ipair(1,ii,iset),iset)
15682                lstart=ifrag(1,ipair(2,ii,iset),iset)
15683                lend=ifrag(2,ipair(2,ii,iset),iset)
15684                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15685                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15686                 qinpair(ii,iset))
15687             enddo
15688             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15689          enddo
15690       enddo
15691       write(iout,*) "Numerical dUconst/ddc backbone "
15692       do ii=0,nres
15693         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15694       enddo
15695 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15696 !      do ii=1,nres
15697 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15698 !      enddo
15699       return
15700       end subroutine dEconstrQ_num
15701 !-----------------------------------------------------------------------------
15702 ! ssMD.F
15703 !-----------------------------------------------------------------------------
15704       subroutine check_energies
15705
15706 !      use random, only: ran_number
15707
15708 !      implicit none
15709 !     Includes
15710 !      include 'DIMENSIONS'
15711 !      include 'COMMON.CHAIN'
15712 !      include 'COMMON.VAR'
15713 !      include 'COMMON.IOUNITS'
15714 !      include 'COMMON.SBRIDGE'
15715 !      include 'COMMON.LOCAL'
15716 !      include 'COMMON.GEO'
15717
15718 !     External functions
15719 !EL      double precision ran_number
15720 !EL      external ran_number
15721
15722 !     Local variables
15723       integer :: i,j,k,l,lmax,p,pmax
15724       real(kind=8) :: rmin,rmax
15725       real(kind=8) :: eij
15726
15727       real(kind=8) :: d
15728       real(kind=8) :: wi,rij,tj,pj
15729 !      return
15730
15731       i=5
15732       j=14
15733
15734       d=dsc(1)
15735       rmin=2.0D0
15736       rmax=12.0D0
15737
15738       lmax=10000
15739       pmax=1
15740
15741       do k=1,3
15742         c(k,i)=0.0D0
15743         c(k,j)=0.0D0
15744         c(k,nres+i)=0.0D0
15745         c(k,nres+j)=0.0D0
15746       enddo
15747
15748       do l=1,lmax
15749
15750 !t        wi=ran_number(0.0D0,pi)
15751 !        wi=ran_number(0.0D0,pi/6.0D0)
15752 !        wi=0.0D0
15753 !t        tj=ran_number(0.0D0,pi)
15754 !t        pj=ran_number(0.0D0,pi)
15755 !        pj=ran_number(0.0D0,pi/6.0D0)
15756 !        pj=0.0D0
15757
15758         do p=1,pmax
15759 !t           rij=ran_number(rmin,rmax)
15760
15761            c(1,j)=d*sin(pj)*cos(tj)
15762            c(2,j)=d*sin(pj)*sin(tj)
15763            c(3,j)=d*cos(pj)
15764
15765            c(3,nres+i)=-rij
15766
15767            c(1,i)=d*sin(wi)
15768            c(3,i)=-rij-d*cos(wi)
15769
15770            do k=1,3
15771               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15772               dc_norm(k,nres+i)=dc(k,nres+i)/d
15773               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15774               dc_norm(k,nres+j)=dc(k,nres+j)/d
15775            enddo
15776
15777            call dyn_ssbond_ene(i,j,eij)
15778         enddo
15779       enddo
15780       call exit(1)
15781       return
15782       end subroutine check_energies
15783 !-----------------------------------------------------------------------------
15784       subroutine dyn_ssbond_ene(resi,resj,eij)
15785 !      implicit none
15786 !      Includes
15787       use calc_data
15788       use comm_sschecks
15789 !      include 'DIMENSIONS'
15790 !      include 'COMMON.SBRIDGE'
15791 !      include 'COMMON.CHAIN'
15792 !      include 'COMMON.DERIV'
15793 !      include 'COMMON.LOCAL'
15794 !      include 'COMMON.INTERACT'
15795 !      include 'COMMON.VAR'
15796 !      include 'COMMON.IOUNITS'
15797 !      include 'COMMON.CALC'
15798 #ifndef CLUST
15799 #ifndef WHAM
15800        use MD_data
15801 !      include 'COMMON.MD'
15802 !      use MD, only: totT,t_bath
15803 #endif
15804 #endif
15805 !     External functions
15806 !EL      double precision h_base
15807 !EL      external h_base
15808
15809 !     Input arguments
15810       integer :: resi,resj
15811
15812 !     Output arguments
15813       real(kind=8) :: eij
15814
15815 !     Local variables
15816       logical :: havebond
15817       integer itypi,itypj
15818       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15819       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15820       real(kind=8),dimension(3) :: dcosom1,dcosom2
15821       real(kind=8) :: ed
15822       real(kind=8) :: pom1,pom2
15823       real(kind=8) :: ljA,ljB,ljXs
15824       real(kind=8),dimension(1:3) :: d_ljB
15825       real(kind=8) :: ssA,ssB,ssC,ssXs
15826       real(kind=8) :: ssxm,ljxm,ssm,ljm
15827       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15828       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15829       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15830 !-------FIRST METHOD
15831       real(kind=8) :: xm
15832       real(kind=8),dimension(1:3) :: d_xm
15833 !-------END FIRST METHOD
15834 !-------SECOND METHOD
15835 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15836 !-------END SECOND METHOD
15837
15838 !-------TESTING CODE
15839 !el      logical :: checkstop,transgrad
15840 !el      common /sschecks/ checkstop,transgrad
15841
15842       integer :: icheck,nicheck,jcheck,njcheck
15843       real(kind=8),dimension(-1:1) :: echeck
15844       real(kind=8) :: deps,ssx0,ljx0
15845 !-------END TESTING CODE
15846
15847       eij=0.0d0
15848       i=resi
15849       j=resj
15850
15851 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15852 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15853
15854       itypi=itype(i)
15855       dxi=dc_norm(1,nres+i)
15856       dyi=dc_norm(2,nres+i)
15857       dzi=dc_norm(3,nres+i)
15858       dsci_inv=vbld_inv(i+nres)
15859
15860       itypj=itype(j)
15861       xj=c(1,nres+j)-c(1,nres+i)
15862       yj=c(2,nres+j)-c(2,nres+i)
15863       zj=c(3,nres+j)-c(3,nres+i)
15864       dxj=dc_norm(1,nres+j)
15865       dyj=dc_norm(2,nres+j)
15866       dzj=dc_norm(3,nres+j)
15867       dscj_inv=vbld_inv(j+nres)
15868
15869       chi1=chi(itypi,itypj)
15870       chi2=chi(itypj,itypi)
15871       chi12=chi1*chi2
15872       chip1=chip(itypi)
15873       chip2=chip(itypj)
15874       chip12=chip1*chip2
15875       alf1=alp(itypi)
15876       alf2=alp(itypj)
15877       alf12=0.5D0*(alf1+alf2)
15878
15879       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15880       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
15881 !     The following are set in sc_angular
15882 !      erij(1)=xj*rij
15883 !      erij(2)=yj*rij
15884 !      erij(3)=zj*rij
15885 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
15886 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
15887 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
15888       call sc_angular
15889       rij=1.0D0/rij  ! Reset this so it makes sense
15890
15891       sig0ij=sigma(itypi,itypj)
15892       sig=sig0ij*dsqrt(1.0D0/sigsq)
15893
15894       ljXs=sig-sig0ij
15895       ljA=eps1*eps2rt**2*eps3rt**2
15896       ljB=ljA*bb(itypi,itypj)
15897       ljA=ljA*aa(itypi,itypj)
15898       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15899
15900       ssXs=d0cm
15901       deltat1=1.0d0-om1
15902       deltat2=1.0d0+om2
15903       deltat12=om2-om1+2.0d0
15904       cosphi=om12-om1*om2
15905       ssA=akcm
15906       ssB=akct*deltat12
15907       ssC=ss_depth &
15908            +akth*(deltat1*deltat1+deltat2*deltat2) &
15909            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
15910       ssxm=ssXs-0.5D0*ssB/ssA
15911
15912 !-------TESTING CODE
15913 !$$$c     Some extra output
15914 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
15915 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15916 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
15917 !$$$      if (ssx0.gt.0.0d0) then
15918 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
15919 !$$$      else
15920 !$$$        ssx0=ssxm
15921 !$$$      endif
15922 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15923 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
15924 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
15925 !$$$      return
15926 !-------END TESTING CODE
15927
15928 !-------TESTING CODE
15929 !     Stop and plot energy and derivative as a function of distance
15930       if (checkstop) then
15931         ssm=ssC-0.25D0*ssB*ssB/ssA
15932         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15933         if (ssm.lt.ljm .and. &
15934              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
15935           nicheck=1000
15936           njcheck=1
15937           deps=0.5d-7
15938         else
15939           checkstop=.false.
15940         endif
15941       endif
15942       if (.not.checkstop) then
15943         nicheck=0
15944         njcheck=-1
15945       endif
15946
15947       do icheck=0,nicheck
15948       do jcheck=-1,njcheck
15949       if (checkstop) rij=(ssxm-1.0d0)+ &
15950              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
15951 !-------END TESTING CODE
15952
15953       if (rij.gt.ljxm) then
15954         havebond=.false.
15955         ljd=rij-ljXs
15956         fac=(1.0D0/ljd)**expon
15957         e1=fac*fac*aa(itypi,itypj)
15958         e2=fac*bb(itypi,itypj)
15959         eij=eps1*eps2rt*eps3rt*(e1+e2)
15960         eps2der=eij*eps3rt
15961         eps3der=eij*eps2rt
15962         eij=eij*eps2rt*eps3rt
15963
15964         sigder=-sig/sigsq
15965         e1=e1*eps1*eps2rt**2*eps3rt**2
15966         ed=-expon*(e1+eij)/ljd
15967         sigder=ed*sigder
15968         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15969         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15970         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
15971              -2.0D0*alf12*eps3der+sigder*sigsq_om12
15972       else if (rij.lt.ssxm) then
15973         havebond=.true.
15974         ssd=rij-ssXs
15975         eij=ssA*ssd*ssd+ssB*ssd+ssC
15976
15977         ed=2*akcm*ssd+akct*deltat12
15978         pom1=akct*ssd
15979         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
15980         eom1=-2*akth*deltat1-pom1-om2*pom2
15981         eom2= 2*akth*deltat2+pom1-om1*pom2
15982         eom12=pom2
15983       else
15984         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
15985
15986         d_ssxm(1)=0.5D0*akct/ssA
15987         d_ssxm(2)=-d_ssxm(1)
15988         d_ssxm(3)=0.0D0
15989
15990         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
15991         d_ljxm(2)=d_ljxm(1)*sigsq_om2
15992         d_ljxm(3)=d_ljxm(1)*sigsq_om12
15993         d_ljxm(1)=d_ljxm(1)*sigsq_om1
15994
15995 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15996         xm=0.5d0*(ssxm+ljxm)
15997         do k=1,3
15998           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
15999         enddo
16000         if (rij.lt.xm) then
16001           havebond=.true.
16002           ssm=ssC-0.25D0*ssB*ssB/ssA
16003           d_ssm(1)=0.5D0*akct*ssB/ssA
16004           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16005           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16006           d_ssm(3)=omega
16007           f1=(rij-xm)/(ssxm-xm)
16008           f2=(rij-ssxm)/(xm-ssxm)
16009           h1=h_base(f1,hd1)
16010           h2=h_base(f2,hd2)
16011           eij=ssm*h1+Ht*h2
16012           delta_inv=1.0d0/(xm-ssxm)
16013           deltasq_inv=delta_inv*delta_inv
16014           fac=ssm*hd1-Ht*hd2
16015           fac1=deltasq_inv*fac*(xm-rij)
16016           fac2=deltasq_inv*fac*(rij-ssxm)
16017           ed=delta_inv*(Ht*hd2-ssm*hd1)
16018           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
16019           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
16020           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
16021         else
16022           havebond=.false.
16023           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16024           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
16025           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
16026           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
16027                alf12/eps3rt)
16028           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
16029           f1=(rij-ljxm)/(xm-ljxm)
16030           f2=(rij-xm)/(ljxm-xm)
16031           h1=h_base(f1,hd1)
16032           h2=h_base(f2,hd2)
16033           eij=Ht*h1+ljm*h2
16034           delta_inv=1.0d0/(ljxm-xm)
16035           deltasq_inv=delta_inv*delta_inv
16036           fac=Ht*hd1-ljm*hd2
16037           fac1=deltasq_inv*fac*(ljxm-rij)
16038           fac2=deltasq_inv*fac*(rij-xm)
16039           ed=delta_inv*(ljm*hd2-Ht*hd1)
16040           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
16041           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
16042           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
16043         endif
16044 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16045
16046 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16047 !$$$        ssd=rij-ssXs
16048 !$$$        ljd=rij-ljXs
16049 !$$$        fac1=rij-ljxm
16050 !$$$        fac2=rij-ssxm
16051 !$$$
16052 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
16053 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
16054 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
16055 !$$$
16056 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
16057 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
16058 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16059 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16060 !$$$        d_ssm(3)=omega
16061 !$$$
16062 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
16063 !$$$        do k=1,3
16064 !$$$          d_ljm(k)=ljm*d_ljB(k)
16065 !$$$        enddo
16066 !$$$        ljm=ljm*ljB
16067 !$$$
16068 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
16069 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
16070 !$$$        d_ss(2)=akct*ssd
16071 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
16072 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
16073 !$$$        d_ss(3)=omega
16074 !$$$
16075 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
16076 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
16077 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
16078 !$$$        do k=1,3
16079 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
16080 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
16081 !$$$        enddo
16082 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
16083 !$$$
16084 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
16085 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
16086 !$$$        h1=h_base(f1,hd1)
16087 !$$$        h2=h_base(f2,hd2)
16088 !$$$        eij=ss*h1+ljf*h2
16089 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
16090 !$$$        deltasq_inv=delta_inv*delta_inv
16091 !$$$        fac=ljf*hd2-ss*hd1
16092 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
16093 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
16094 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
16095 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
16096 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
16097 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
16098 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
16099 !$$$
16100 !$$$        havebond=.false.
16101 !$$$        if (ed.gt.0.0d0) havebond=.true.
16102 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16103
16104       endif
16105
16106       if (havebond) then
16107 !#ifndef CLUST
16108 !#ifndef WHAM
16109 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
16110 !          write(iout,'(a15,f12.2,f8.1,2i5)')
16111 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
16112 !        endif
16113 !#endif
16114 !#endif
16115         dyn_ssbond_ij(i,j)=eij
16116       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
16117         dyn_ssbond_ij(i,j)=1.0d300
16118 !#ifndef CLUST
16119 !#ifndef WHAM
16120 !        write(iout,'(a15,f12.2,f8.1,2i5)')
16121 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
16122 !#endif
16123 !#endif
16124       endif
16125
16126 !-------TESTING CODE
16127 !el      if (checkstop) then
16128         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
16129              "CHECKSTOP",rij,eij,ed
16130         echeck(jcheck)=eij
16131 !el      endif
16132       enddo
16133       if (checkstop) then
16134         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
16135       endif
16136       enddo
16137       if (checkstop) then
16138         transgrad=.true.
16139         checkstop=.false.
16140       endif
16141 !-------END TESTING CODE
16142
16143       do k=1,3
16144         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
16145         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
16146       enddo
16147       do k=1,3
16148         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
16149       enddo
16150       do k=1,3
16151         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16152              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16153              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16154         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16155              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16156              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16157       enddo
16158 !grad      do k=i,j-1
16159 !grad        do l=1,3
16160 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
16161 !grad        enddo
16162 !grad      enddo
16163
16164       do l=1,3
16165         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16166         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16167       enddo
16168
16169       return
16170       end subroutine dyn_ssbond_ene
16171 !-----------------------------------------------------------------------------
16172       real(kind=8) function h_base(x,deriv)
16173 !     A smooth function going 0->1 in range [0,1]
16174 !     It should NOT be called outside range [0,1], it will not work there.
16175       implicit none
16176
16177 !     Input arguments
16178       real(kind=8) :: x
16179
16180 !     Output arguments
16181       real(kind=8) :: deriv
16182
16183 !     Local variables
16184       real(kind=8) :: xsq
16185
16186
16187 !     Two parabolas put together.  First derivative zero at extrema
16188 !$$$      if (x.lt.0.5D0) then
16189 !$$$        h_base=2.0D0*x*x
16190 !$$$        deriv=4.0D0*x
16191 !$$$      else
16192 !$$$        deriv=1.0D0-x
16193 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
16194 !$$$        deriv=4.0D0*deriv
16195 !$$$      endif
16196
16197 !     Third degree polynomial.  First derivative zero at extrema
16198       h_base=x*x*(3.0d0-2.0d0*x)
16199       deriv=6.0d0*x*(1.0d0-x)
16200
16201 !     Fifth degree polynomial.  First and second derivatives zero at extrema
16202 !$$$      xsq=x*x
16203 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
16204 !$$$      deriv=x-1.0d0
16205 !$$$      deriv=deriv*deriv
16206 !$$$      deriv=30.0d0*xsq*deriv
16207
16208       return
16209       end function h_base
16210 !-----------------------------------------------------------------------------
16211       subroutine dyn_set_nss
16212 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
16213 !      implicit none
16214       use MD_data, only: totT,t_bath
16215 !     Includes
16216 !      include 'DIMENSIONS'
16217 #ifdef MPI
16218       include "mpif.h"
16219 #endif
16220 !      include 'COMMON.SBRIDGE'
16221 !      include 'COMMON.CHAIN'
16222 !      include 'COMMON.IOUNITS'
16223 !      include 'COMMON.SETUP'
16224 !      include 'COMMON.MD'
16225 !     Local variables
16226       real(kind=8) :: emin
16227       integer :: i,j,imin,ierr
16228       integer :: diff,allnss,newnss
16229       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16230                 newihpb,newjhpb
16231       logical :: found
16232       integer,dimension(0:nfgtasks) :: i_newnss
16233       integer,dimension(0:nfgtasks) :: displ
16234       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16235       integer :: g_newnss
16236
16237       allnss=0
16238       do i=1,nres-1
16239         do j=i+1,nres
16240           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
16241             allnss=allnss+1
16242             allflag(allnss)=0
16243             allihpb(allnss)=i
16244             alljhpb(allnss)=j
16245           endif
16246         enddo
16247       enddo
16248
16249 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16250
16251  1    emin=1.0d300
16252       do i=1,allnss
16253         if (allflag(i).eq.0 .and. &
16254              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
16255           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
16256           imin=i
16257         endif
16258       enddo
16259       if (emin.lt.1.0d300) then
16260         allflag(imin)=1
16261         do i=1,allnss
16262           if (allflag(i).eq.0 .and. &
16263                (allihpb(i).eq.allihpb(imin) .or. &
16264                alljhpb(i).eq.allihpb(imin) .or. &
16265                allihpb(i).eq.alljhpb(imin) .or. &
16266                alljhpb(i).eq.alljhpb(imin))) then
16267             allflag(i)=-1
16268           endif
16269         enddo
16270         goto 1
16271       endif
16272
16273 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16274
16275       newnss=0
16276       do i=1,allnss
16277         if (allflag(i).eq.1) then
16278           newnss=newnss+1
16279           newihpb(newnss)=allihpb(i)
16280           newjhpb(newnss)=alljhpb(i)
16281         endif
16282       enddo
16283
16284 #ifdef MPI
16285       if (nfgtasks.gt.1)then
16286
16287         call MPI_Reduce(newnss,g_newnss,1,&
16288           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
16289         call MPI_Gather(newnss,1,MPI_INTEGER,&
16290                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
16291         displ(0)=0
16292         do i=1,nfgtasks-1,1
16293           displ(i)=i_newnss(i-1)+displ(i-1)
16294         enddo
16295         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
16296                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
16297                          king,FG_COMM,IERR)
16298         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
16299                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
16300                          king,FG_COMM,IERR)
16301         if(fg_rank.eq.0) then
16302 !         print *,'g_newnss',g_newnss
16303 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
16304 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
16305          newnss=g_newnss
16306          do i=1,newnss
16307           newihpb(i)=g_newihpb(i)
16308           newjhpb(i)=g_newjhpb(i)
16309          enddo
16310         endif
16311       endif
16312 #endif
16313
16314       diff=newnss-nss
16315
16316 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
16317
16318       do i=1,nss
16319         found=.false.
16320         do j=1,newnss
16321           if (idssb(i).eq.newihpb(j) .and. &
16322                jdssb(i).eq.newjhpb(j)) found=.true.
16323         enddo
16324 #ifndef CLUST
16325 #ifndef WHAM
16326         if (.not.found.and.fg_rank.eq.0) &
16327             write(iout,'(a15,f12.2,f8.1,2i5)') &
16328              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
16329 #endif
16330 #endif
16331       enddo
16332
16333       do i=1,newnss
16334         found=.false.
16335         do j=1,nss
16336           if (newihpb(i).eq.idssb(j) .and. &
16337                newjhpb(i).eq.jdssb(j)) found=.true.
16338         enddo
16339 #ifndef CLUST
16340 #ifndef WHAM
16341         if (.not.found.and.fg_rank.eq.0) &
16342             write(iout,'(a15,f12.2,f8.1,2i5)') &
16343              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
16344 #endif
16345 #endif
16346       enddo
16347
16348       nss=newnss
16349       do i=1,nss
16350         idssb(i)=newihpb(i)
16351         jdssb(i)=newjhpb(i)
16352       enddo
16353
16354       return
16355       end subroutine dyn_set_nss
16356 !-----------------------------------------------------------------------------
16357 #ifdef WHAM
16358       subroutine read_ssHist
16359 !      implicit none
16360 !      Includes
16361 !      include 'DIMENSIONS'
16362 !      include "DIMENSIONS.FREE"
16363 !      include 'COMMON.FREE'
16364 !     Local variables
16365       integer :: i,j
16366       character(len=80) :: controlcard
16367
16368       do i=1,dyn_nssHist
16369         call card_concat(controlcard,.true.)
16370         read(controlcard,*) &
16371              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
16372       enddo
16373
16374       return
16375       end subroutine read_ssHist
16376 #endif
16377 !-----------------------------------------------------------------------------
16378       integer function indmat(i,j)
16379 !el
16380 ! get the position of the jth ijth fragment of the chain coordinate system
16381 ! in the fromto array.
16382         integer :: i,j
16383
16384         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
16385       return
16386       end function indmat
16387 !-----------------------------------------------------------------------------
16388       real(kind=8) function sigm(x)
16389 !el
16390        real(kind=8) :: x
16391         sigm=0.25d0*x
16392       return
16393       end function sigm
16394 !-----------------------------------------------------------------------------
16395 !-----------------------------------------------------------------------------
16396       subroutine alloc_ener_arrays
16397 !EL Allocation of arrays used by module energy
16398       use MD_data, only: mset
16399 !el local variables
16400       integer :: i,j
16401
16402       if(nres.lt.100) then
16403         maxconts=nres
16404       elseif(nres.lt.200) then
16405         maxconts=0.8*nres       ! Max. number of contacts per residue
16406       else
16407         maxconts=0.6*nres ! (maxconts=maxres/4)
16408       endif
16409       maxcont=12*nres   ! Max. number of SC contacts
16410       maxvar=6*nres     ! Max. number of variables
16411 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16412       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16413 !----------------------
16414 ! arrays in subroutine init_int_table
16415 !el#ifdef MPI
16416 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
16417 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
16418 !el#endif
16419       allocate(nint_gr(nres))
16420       allocate(nscp_gr(nres))
16421       allocate(ielstart(nres))
16422       allocate(ielend(nres))
16423 !(maxres)
16424       allocate(istart(nres,maxint_gr))
16425       allocate(iend(nres,maxint_gr))
16426 !(maxres,maxint_gr)
16427       allocate(iscpstart(nres,maxint_gr))
16428       allocate(iscpend(nres,maxint_gr))
16429 !(maxres,maxint_gr)
16430       allocate(ielstart_vdw(nres))
16431       allocate(ielend_vdw(nres))
16432 !(maxres)
16433
16434       allocate(lentyp(0:nfgtasks-1))
16435 !(0:maxprocs-1)
16436 !----------------------
16437 ! commom.contacts
16438 !      common /contacts/
16439       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
16440       allocate(icont(2,maxcont))
16441 !(2,maxcont)
16442 !      common /contacts1/
16443       allocate(num_cont(0:nres+4))
16444 !(maxres)
16445       allocate(jcont(maxconts,nres))
16446 !(maxconts,maxres)
16447       allocate(facont(maxconts,nres))
16448 !(maxconts,maxres)
16449       allocate(gacont(3,maxconts,nres))
16450 !(3,maxconts,maxres)
16451 !      common /contacts_hb/
16452       allocate(gacontp_hb1(3,maxconts,nres))
16453       allocate(gacontp_hb2(3,maxconts,nres))
16454       allocate(gacontp_hb3(3,maxconts,nres))
16455       allocate(gacontm_hb1(3,maxconts,nres))
16456       allocate(gacontm_hb2(3,maxconts,nres))
16457       allocate(gacontm_hb3(3,maxconts,nres))
16458       allocate(gacont_hbr(3,maxconts,nres))
16459       allocate(grij_hb_cont(3,maxconts,nres))
16460 !(3,maxconts,maxres)
16461       allocate(facont_hb(maxconts,nres))
16462       allocate(ees0p(maxconts,nres))
16463       allocate(ees0m(maxconts,nres))
16464       allocate(d_cont(maxconts,nres))
16465 !(maxconts,maxres)
16466       allocate(num_cont_hb(nres))
16467 !(maxres)
16468       allocate(jcont_hb(maxconts,nres))
16469 !(maxconts,maxres)
16470 !      common /rotat/
16471       allocate(Ug(2,2,nres))
16472       allocate(Ugder(2,2,nres))
16473       allocate(Ug2(2,2,nres))
16474       allocate(Ug2der(2,2,nres))
16475 !(2,2,maxres)
16476       allocate(obrot(2,nres))
16477       allocate(obrot2(2,nres))
16478       allocate(obrot_der(2,nres))
16479       allocate(obrot2_der(2,nres))
16480 !(2,maxres)
16481 !      common /precomp1/
16482       allocate(mu(2,nres))
16483       allocate(muder(2,nres))
16484       allocate(Ub2(2,nres))
16485       Ub2(1,:)=0.0d0
16486       Ub2(2,:)=0.0d0
16487       allocate(Ub2der(2,nres))
16488       allocate(Ctobr(2,nres))
16489       allocate(Ctobrder(2,nres))
16490       allocate(Dtobr2(2,nres))
16491       allocate(Dtobr2der(2,nres))
16492 !(2,maxres)
16493       allocate(EUg(2,2,nres))
16494       allocate(EUgder(2,2,nres))
16495       allocate(CUg(2,2,nres))
16496       allocate(CUgder(2,2,nres))
16497       allocate(DUg(2,2,nres))
16498       allocate(Dugder(2,2,nres))
16499       allocate(DtUg2(2,2,nres))
16500       allocate(DtUg2der(2,2,nres))
16501 !(2,2,maxres)
16502 !      common /precomp2/
16503       allocate(Ug2Db1t(2,nres))
16504       allocate(Ug2Db1tder(2,nres))
16505       allocate(CUgb2(2,nres))
16506       allocate(CUgb2der(2,nres))
16507 !(2,maxres)
16508       allocate(EUgC(2,2,nres))
16509       allocate(EUgCder(2,2,nres))
16510       allocate(EUgD(2,2,nres))
16511       allocate(EUgDder(2,2,nres))
16512       allocate(DtUg2EUg(2,2,nres))
16513       allocate(Ug2DtEUg(2,2,nres))
16514 !(2,2,maxres)
16515       allocate(Ug2DtEUgder(2,2,2,nres))
16516       allocate(DtUg2EUgder(2,2,2,nres))
16517 !(2,2,2,maxres)
16518 !      common /rotat_old/
16519       allocate(costab(nres))
16520       allocate(sintab(nres))
16521       allocate(costab2(nres))
16522       allocate(sintab2(nres))
16523 !(maxres)
16524 !      common /dipmat/
16525       allocate(a_chuj(2,2,maxconts,nres))
16526 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16527       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16528 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16529 !      common /contdistrib/
16530       allocate(ncont_sent(nres))
16531       allocate(ncont_recv(nres))
16532
16533       allocate(iat_sent(nres))
16534 !(maxres)
16535       allocate(iint_sent(4,nres,nres))
16536       allocate(iint_sent_local(4,nres,nres))
16537 !(4,maxres,maxres)
16538       allocate(iturn3_sent(4,0:nres+4))
16539       allocate(iturn4_sent(4,0:nres+4))
16540       allocate(iturn3_sent_local(4,nres))
16541       allocate(iturn4_sent_local(4,nres))
16542 !(4,maxres)
16543       allocate(itask_cont_from(0:nfgtasks-1))
16544       allocate(itask_cont_to(0:nfgtasks-1))
16545 !(0:max_fg_procs-1)
16546
16547
16548
16549 !----------------------
16550 ! commom.deriv;
16551 !      common /derivat/
16552       allocate(dcdv(6,maxdim))
16553       allocate(dxdv(6,maxdim))
16554 !(6,maxdim)
16555       allocate(dxds(6,nres))
16556 !(6,maxres)
16557       allocate(gradx(3,nres,0:2))
16558       allocate(gradc(3,nres,0:2))
16559 !(3,maxres,2)
16560       allocate(gvdwx(3,nres))
16561       allocate(gvdwc(3,nres))
16562       allocate(gelc(3,nres))
16563       allocate(gelc_long(3,nres))
16564       allocate(gvdwpp(3,nres))
16565       allocate(gvdwc_scpp(3,nres))
16566       allocate(gradx_scp(3,nres))
16567       allocate(gvdwc_scp(3,nres))
16568       allocate(ghpbx(3,nres))
16569       allocate(ghpbc(3,nres))
16570       allocate(gradcorr(3,nres))
16571       allocate(gradcorr_long(3,nres))
16572       allocate(gradcorr5_long(3,nres))
16573       allocate(gradcorr6_long(3,nres))
16574       allocate(gcorr6_turn_long(3,nres))
16575       allocate(gradxorr(3,nres))
16576       allocate(gradcorr5(3,nres))
16577       allocate(gradcorr6(3,nres))
16578 !(3,maxres)
16579       allocate(gloc(0:maxvar,0:2))
16580       allocate(gloc_x(0:maxvar,2))
16581 !(maxvar,2)
16582       allocate(gel_loc(3,nres))
16583       allocate(gel_loc_long(3,nres))
16584       allocate(gcorr3_turn(3,nres))
16585       allocate(gcorr4_turn(3,nres))
16586       allocate(gcorr6_turn(3,nres))
16587       allocate(gradb(3,nres))
16588       allocate(gradbx(3,nres))
16589 !(3,maxres)
16590       allocate(gel_loc_loc(maxvar))
16591       allocate(gel_loc_turn3(maxvar))
16592       allocate(gel_loc_turn4(maxvar))
16593       allocate(gel_loc_turn6(maxvar))
16594       allocate(gcorr_loc(maxvar))
16595       allocate(g_corr5_loc(maxvar))
16596       allocate(g_corr6_loc(maxvar))
16597 !(maxvar)
16598       allocate(gsccorc(3,nres))
16599       allocate(gsccorx(3,nres))
16600 !(3,maxres)
16601       allocate(gsccor_loc(nres))
16602 !(maxres)
16603       allocate(dtheta(3,2,nres))
16604 !(3,2,maxres)
16605       allocate(gscloc(3,nres))
16606       allocate(gsclocx(3,nres))
16607 !(3,maxres)
16608       allocate(dphi(3,3,nres))
16609       allocate(dalpha(3,3,nres))
16610       allocate(domega(3,3,nres))
16611 !(3,3,maxres)
16612 !      common /deriv_scloc/
16613       allocate(dXX_C1tab(3,nres))
16614       allocate(dYY_C1tab(3,nres))
16615       allocate(dZZ_C1tab(3,nres))
16616       allocate(dXX_Ctab(3,nres))
16617       allocate(dYY_Ctab(3,nres))
16618       allocate(dZZ_Ctab(3,nres))
16619       allocate(dXX_XYZtab(3,nres))
16620       allocate(dYY_XYZtab(3,nres))
16621       allocate(dZZ_XYZtab(3,nres))
16622 !(3,maxres)
16623 !      common /mpgrad/
16624       allocate(jgrad_start(nres))
16625       allocate(jgrad_end(nres))
16626 !(maxres)
16627 !----------------------
16628
16629 !      common /indices/
16630       allocate(ibond_displ(0:nfgtasks-1))
16631       allocate(ibond_count(0:nfgtasks-1))
16632       allocate(ithet_displ(0:nfgtasks-1))
16633       allocate(ithet_count(0:nfgtasks-1))
16634       allocate(iphi_displ(0:nfgtasks-1))
16635       allocate(iphi_count(0:nfgtasks-1))
16636       allocate(iphi1_displ(0:nfgtasks-1))
16637       allocate(iphi1_count(0:nfgtasks-1))
16638       allocate(ivec_displ(0:nfgtasks-1))
16639       allocate(ivec_count(0:nfgtasks-1))
16640       allocate(iset_displ(0:nfgtasks-1))
16641       allocate(iset_count(0:nfgtasks-1))
16642       allocate(iint_count(0:nfgtasks-1))
16643       allocate(iint_displ(0:nfgtasks-1))
16644 !(0:max_fg_procs-1)
16645 !----------------------
16646 ! common.MD
16647 !      common /mdgrad/
16648       allocate(gcart(3,0:nres))
16649       allocate(gxcart(3,0:nres))
16650 !(3,0:MAXRES)
16651       allocate(gradcag(3,nres))
16652       allocate(gradxag(3,nres))
16653 !(3,MAXRES)
16654 !      common /back_constr/
16655 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16656       allocate(dutheta(nres))
16657       allocate(dugamma(nres))
16658 !(maxres)
16659       allocate(duscdiff(3,nres))
16660       allocate(duscdiffx(3,nres))
16661 !(3,maxres)
16662 !el i io:read_fragments
16663 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16664 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16665 !      common /qmeas/
16666 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16667 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16668       allocate(mset(0:nprocs))  !(maxprocs/20)
16669       mset(:)=0
16670 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16671 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16672       allocate(dUdconst(3,0:nres))
16673       allocate(dUdxconst(3,0:nres))
16674       allocate(dqwol(3,0:nres))
16675       allocate(dxqwol(3,0:nres))
16676 !(3,0:MAXRES)
16677 !----------------------
16678 ! common.sbridge
16679 !      common /sbridge/ in io_common: read_bridge
16680 !el    allocate((:),allocatable :: iss  !(maxss)
16681 !      common /links/  in io_common: read_bridge
16682 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16683 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16684 !      common /dyn_ssbond/
16685 ! and side-chain vectors in theta or phi.
16686       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16687 !(maxres,maxres)
16688 !      do i=1,nres
16689 !        do j=i+1,nres
16690       dyn_ssbond_ij(:,:)=1.0d300
16691 !        enddo
16692 !      enddo
16693
16694       if (nss.gt.0) then
16695         allocate(idssb(nss),jdssb(nss))
16696 !(maxdim)
16697       endif
16698       allocate(dyn_ss_mask(nres))
16699 !(maxres)
16700       dyn_ss_mask(:)=.false.
16701 !----------------------
16702 ! common.sccor
16703 ! Parameters of the SCCOR term
16704 !      common/sccor/
16705 !el in io_conf: parmread
16706 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16707 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16708 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16709 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16710 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16711 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16712 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16713 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16714 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16715 !----------------
16716       allocate(gloc_sc(3,0:2*nres,0:10))
16717 !(3,0:maxres2,10)maxres2=2*maxres
16718       allocate(dcostau(3,3,3,2*nres))
16719       allocate(dsintau(3,3,3,2*nres))
16720       allocate(dtauangle(3,3,3,2*nres))
16721       allocate(dcosomicron(3,3,3,2*nres))
16722       allocate(domicron(3,3,3,2*nres))
16723 !(3,3,3,maxres2)maxres2=2*maxres
16724 !----------------------
16725 ! common.var
16726 !      common /restr/
16727       allocate(varall(maxvar))
16728 !(maxvar)(maxvar=6*maxres)
16729       allocate(mask_theta(nres))
16730       allocate(mask_phi(nres))
16731       allocate(mask_side(nres))
16732 !(maxres)
16733 !----------------------
16734 ! common.vectors
16735 !      common /vectors/
16736       allocate(uy(3,nres))
16737       allocate(uz(3,nres))
16738 !(3,maxres)
16739       allocate(uygrad(3,3,2,nres))
16740       allocate(uzgrad(3,3,2,nres))
16741 !(3,3,2,maxres)
16742
16743       return
16744       end subroutine alloc_ener_arrays
16745 !-----------------------------------------------------------------------------
16746 !-----------------------------------------------------------------------------
16747       end module energy