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 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 217 !     & " nfgtasks",nfgtasks
 218       if (nfgtasks.gt.1) then
 219         time00=MPI_Wtime()
 220 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 221         if (fg_rank.eq.0) then
 222           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 223 !          print *,"Processor",myrank," BROADCAST iorder"
 224 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 225 ! FG slaves as WEIGHTS array.
 226           weights_(1)=wsc
 227           weights_(2)=wscp
 228           weights_(3)=welec
 229           weights_(4)=wcorr
 230           weights_(5)=wcorr5
 231           weights_(6)=wcorr6
 232           weights_(7)=wel_loc
 233           weights_(8)=wturn3
 234           weights_(9)=wturn4
 235           weights_(10)=wturn6
 236           weights_(11)=wang
 237           weights_(12)=wscloc
 238           weights_(13)=wtor
 239           weights_(14)=wtor_d
 240           weights_(15)=wstrain
 241           weights_(16)=wvdwpp
 242           weights_(17)=wbond
 243           weights_(18)=scal14
 244           weights_(21)=wsccor
 245 ! FG Master broadcasts the WEIGHTS_ array
 246           call MPI_Bcast(weights_(1),n_ene,&
 247              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 248         else
 249 ! FG slaves receive the WEIGHTS array
 250           call MPI_Bcast(weights(1),n_ene,&
 251               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 252           wsc=weights(1)
 253           wscp=weights(2)
 254           welec=weights(3)
 255           wcorr=weights(4)
 256           wcorr5=weights(5)
 257           wcorr6=weights(6)
 258           wel_loc=weights(7)
 259           wturn3=weights(8)
 260           wturn4=weights(9)
 261           wturn6=weights(10)
 262           wang=weights(11)
 263           wscloc=weights(12)
 264           wtor=weights(13)
 265           wtor_d=weights(14)
 266           wstrain=weights(15)
 267           wvdwpp=weights(16)
 268           wbond=weights(17)
 269           scal14=weights(18)
 270           wsccor=weights(21)
 271         endif
 272         time_Bcast=time_Bcast+MPI_Wtime()-time00
 273         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 274 !        call chainbuild_cart
 275       endif
 276 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 277 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 278 #else
 279 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 280 !        call int_from_cart1(.false.)
 281 !      endif
 282 #endif
 283 #ifdef TIMING
 284       time00=MPI_Wtime()
 285 #endif
 286 !
 287 ! Compute the side-chain and electrostatic interaction energy
 288 !
 289 !      goto (101,102,103,104,105,106) ipot
 290       select case(ipot)
 291 ! Lennard-Jones potential.
 292 !  101 call elj(evdw)
 293        case (1)
 294          call elj(evdw)
 295 !d    print '(a)','Exit ELJcall el'
 296 !      goto 107
 297 ! Lennard-Jones-Kihara potential (shifted).
 298 !  102 call eljk(evdw)
 299        case (2)
 300          call eljk(evdw)
 301 !      goto 107
 302 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 303 !  103 call ebp(evdw)
 304        case (3)
 305          call ebp(evdw)
 306 !      goto 107
 307 ! Gay-Berne potential (shifted LJ, angular dependence).
 308 !  104 call egb(evdw)
 309        case (4)
 310          call egb(evdw)
 311 !      goto 107
 312 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 313 !  105 call egbv(evdw)
 314        case (5)
 315          call egbv(evdw)
 316 !      goto 107
 317 ! Soft-sphere potential
 318 !  106 call e_softsphere(evdw)
 319        case (6)
 320          call e_softsphere(evdw)
 321 !
 322 ! Calculate electrostatic (H-bonding) energy of the main chain.
 323 !
 324 !  107 continue
 325        case default
 326          write(iout,*)"Wrong ipot"
 327 !         return
 328 !   50 continue
 329       end select
 330 !      continue
 331
 332 !mc
 333 !mc Sep-06: egb takes care of dynamic ss bonds too
 334 !mc
 335 !      if (dyn_ss) call dyn_set_nss
 336 !      print *,"Processor",myrank," computed USCSC"
 337 #ifdef TIMING
 338       time01=MPI_Wtime()
 339 #endif
 340       call vec_and_deriv
 341 #ifdef TIMING
 342       time_vec=time_vec+MPI_Wtime()-time01
 343 #endif
 344 !      print *,"Processor",myrank," left VEC_AND_DERIV"
 345       if (ipot.lt.6) then
 346 #ifdef SPLITELE
 347          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 348              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 349              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 350              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 351 #else
 352          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 353              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 354              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 355              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 356 #endif
 357             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 358 !        write (iout,*) "ELEC calc"
 359          else
 360             ees=0.0d0
 361             evdw1=0.0d0
 362             eel_loc=0.0d0
 363             eello_turn3=0.0d0
 364             eello_turn4=0.0d0
 365          endif
 366       else
 367 !        write (iout,*) "Soft-spheer ELEC potential"
 368         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 369          eello_turn4)
 370       endif
 371 !      print *,"Processor",myrank," computed UELEC"
 372 !
 373 ! Calculate excluded-volume interaction energy between peptide groups
 374 ! and side chains.
 375 !
 376 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 377
 378       if (ipot.lt.6) then
 379        if(wscp.gt.0d0) then
 380         call escp(evdw2,evdw2_14)
 381        else
 382         evdw2=0
 383         evdw2_14=0
 384        endif
 385       else
 386 !        write (iout,*) "Soft-sphere SCP potential"
 387         call escp_soft_sphere(evdw2,evdw2_14)
 388       endif
 389 !elwrite(iout,*) "in etotal before ebond",ipot
 390
 391 !
 392 ! Calculate the bond-stretching energy
 393 !
 394       call ebond(estr)
 395 !elwrite(iout,*) "in etotal afer ebond",ipot
 396
 397 !
 398 ! Calculate the disulfide-bridge and other energy and the contributions
 399 ! from other distance constraints.
 400 !      print *,'Calling EHPB'
 401       call edis(ehpb)
 402 !elwrite(iout,*) "in etotal afer edis",ipot
 403 !      print *,'EHPB exitted succesfully.'
 404 !
 405 ! Calculate the virtual-bond-angle energy.
 406 !
 407       if (wang.gt.0d0) then
 408         call ebend(ebe)
 409       else
 410         ebe=0
 411       endif
 412 !      print *,"Processor",myrank," computed UB"
 413 !
 414 ! Calculate the SC local energy.
 415 !
 416       call esc(escloc)
 417 !elwrite(iout,*) "in etotal afer esc",ipot
 418 !      print *,"Processor",myrank," computed USC"
 419 !
 420 ! Calculate the virtual-bond torsional energy.
 421 !
 422 !d    print *,'nterm=',nterm
 423       if (wtor.gt.0) then
 424        call etor(etors,edihcnstr)
 425       else
 426        etors=0
 427        edihcnstr=0
 428       endif
 429 !      print *,"Processor",myrank," computed Utor"
 430 !
 431 ! 6/23/01 Calculate double-torsional energy
 432 !
 433 !elwrite(iout,*) "in etotal",ipot
 434       if (wtor_d.gt.0) then
 435        call etor_d(etors_d)
 436       else
 437        etors_d=0
 438       endif
 439 !      print *,"Processor",myrank," computed Utord"
 440 !
 441 ! 21/5/07 Calculate local sicdechain correlation energy
 442 !
 443       if (wsccor.gt.0.0d0) then
 444         call eback_sc_corr(esccor)
 445       else
 446         esccor=0.0d0
 447       endif
 448 !      print *,"Processor",myrank," computed Usccorr"
 449 !
 450 ! 12/1/95 Multi-body terms
 451 !
 452       n_corr=0
 453       n_corr1=0
 454       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 455           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 456          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 457 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 458 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 459       else
 460          ecorr=0.0d0
 461          ecorr5=0.0d0
 462          ecorr6=0.0d0
 463          eturn6=0.0d0
 464       endif
 465 !elwrite(iout,*) "in etotal",ipot
 466       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 467          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 468 !d         write (iout,*) "multibody_hb ecorr",ecorr
 469       endif
 470 !elwrite(iout,*) "afeter  multibody hb"
 471
 472 !      print *,"Processor",myrank," computed Ucorr"
 473 !
 474 ! If performing constraint dynamics, call the constraint energy
 475 !  after the equilibration time
 476       if(usampl.and.totT.gt.eq_time) then
 477 !elwrite(iout,*) "afeter  multibody hb"
 478          call EconstrQ
 479 !elwrite(iout,*) "afeter  multibody hb"
 480          call Econstr_back
 481 !elwrite(iout,*) "afeter  multibody hb"
 482       else
 483          Uconst=0.0d0
 484          Uconst_back=0.0d0
 485       endif
 486 !elwrite(iout,*) "after Econstr"
 487
 488 #ifdef TIMING
 489       time_enecalc=time_enecalc+MPI_Wtime()-time00
 490 #endif
 491 !      print *,"Processor",myrank," computed Uconstr"
 492 #ifdef TIMING
 493       time00=MPI_Wtime()
 494 #endif
 495 !
 496 ! Sum the energies
 497 !
 498       energia(1)=evdw
 499 #ifdef SCP14
 500       energia(2)=evdw2-evdw2_14
 501       energia(18)=evdw2_14
 502 #else
 503       energia(2)=evdw2
 504       energia(18)=0.0d0
 505 #endif
 506 #ifdef SPLITELE
 507       energia(3)=ees
 508       energia(16)=evdw1
 509 #else
 510       energia(3)=ees+evdw1
 511       energia(16)=0.0d0
 512 #endif
 513       energia(4)=ecorr
 514       energia(5)=ecorr5
 515       energia(6)=ecorr6
 516       energia(7)=eel_loc
 517       energia(8)=eello_turn3
 518       energia(9)=eello_turn4
 519       energia(10)=eturn6
 520       energia(11)=ebe
 521       energia(12)=escloc
 522       energia(13)=etors
 523       energia(14)=etors_d
 524       energia(15)=ehpb
 525       energia(19)=edihcnstr
 526       energia(17)=estr
 527       energia(20)=Uconst+Uconst_back
 528       energia(21)=esccor
 529 !    Here are the energies showed per procesor if the are more processors
 530 !    per molecule then we sum it up in sum_energy subroutine
 531 !      print *," Processor",myrank," calls SUM_ENERGY"
 532       call sum_energy(energia,.true.)
 533       if (dyn_ss) call dyn_set_nss
 534 !      print *," Processor",myrank," left SUM_ENERGY"
 535 #ifdef TIMING
 536       time_sumene=time_sumene+MPI_Wtime()-time00
 537 #endif
 538 !el        call enerprint(energia)
 539 !elwrite(iout,*)"finish etotal"
 540       return
 541       end subroutine etotal
 542 !-----------------------------------------------------------------------------
 543       subroutine sum_energy(energia,reduce)
 544 !      implicit real*8 (a-h,o-z)
 545 !      include 'DIMENSIONS'
 546 #ifndef ISNAN
 547       external proc_proc
 548 #ifdef WINPGI
 549 !MS$ATTRIBUTES C ::  proc_proc
 550 #endif
 551 #endif
 552 #ifdef MPI
 553       include "mpif.h"
 554 #endif
 555 !      include 'COMMON.SETUP'
 556 !      include 'COMMON.IOUNITS'
 557       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 558 !      include 'COMMON.FFIELD'
 559 !      include 'COMMON.DERIV'
 560 !      include 'COMMON.INTERACT'
 561 !      include 'COMMON.SBRIDGE'
 562 !      include 'COMMON.CHAIN'
 563 !      include 'COMMON.VAR'
 564 !      include 'COMMON.CONTROL'
 565 !      include 'COMMON.TIME1'
 566       logical :: reduce
 567       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 568       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 569       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot
 570       integer :: i
 571 #ifdef MPI
 572       integer :: ierr
 573       real(kind=8) :: time00
 574       if (nfgtasks.gt.1 .and. reduce) then
 575
 576 #ifdef DEBUG
 577         write (iout,*) "energies before REDUCE"
 578         call enerprint(energia)
 579         call flush(iout)
 580 #endif
 581         do i=0,n_ene
 582           enebuff(i)=energia(i)
 583         enddo
 584         time00=MPI_Wtime()
 585         call MPI_Barrier(FG_COMM,IERR)
 586         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 587         time00=MPI_Wtime()
 588         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 589           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 590 #ifdef DEBUG
 591         write (iout,*) "energies after REDUCE"
 592         call enerprint(energia)
 593         call flush(iout)
 594 #endif
 595         time_Reduce=time_Reduce+MPI_Wtime()-time00
 596       endif
 597       if (fg_rank.eq.0) then
 598 #endif
 599       evdw=energia(1)
 600 #ifdef SCP14
 601       evdw2=energia(2)+energia(18)
 602       evdw2_14=energia(18)
 603 #else
 604       evdw2=energia(2)
 605 #endif
 606 #ifdef SPLITELE
 607       ees=energia(3)
 608       evdw1=energia(16)
 609 #else
 610       ees=energia(3)
 611       evdw1=0.0d0
 612 #endif
 613       ecorr=energia(4)
 614       ecorr5=energia(5)
 615       ecorr6=energia(6)
 616       eel_loc=energia(7)
 617       eello_turn3=energia(8)
 618       eello_turn4=energia(9)
 619       eturn6=energia(10)
 620       ebe=energia(11)
 621       escloc=energia(12)
 622       etors=energia(13)
 623       etors_d=energia(14)
 624       ehpb=energia(15)
 625       edihcnstr=energia(19)
 626       estr=energia(17)
 627       Uconst=energia(20)
 628       esccor=energia(21)
 629 #ifdef SPLITELE
 630       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 631        +wang*ebe+wtor*etors+wscloc*escloc &
 632        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 633        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 634        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 635        +wbond*estr+Uconst+wsccor*esccor
 636 #else
 637       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 638        +wang*ebe+wtor*etors+wscloc*escloc &
 639        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 640        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 641        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 642        +wbond*estr+Uconst+wsccor*esccor
 643 #endif
 644       energia(0)=etot
 645 ! detecting NaNQ
 646 #ifdef ISNAN
 647 #ifdef AIX
 648       if (isnan(etot).ne.0) energia(0)=1.0d+99
 649 #else
 650       if (isnan(etot)) energia(0)=1.0d+99
 651 #endif
 652 #else
 653       i=0
 654 #ifdef WINPGI
 655       idumm=proc_proc(etot,i)
 656 #else
 657       call proc_proc(etot,i)
 658 #endif
 659       if(i.eq.1)energia(0)=1.0d+99
 660 #endif
 661 #ifdef MPI
 662       endif
 663 #endif
 664 !      call enerprint(energia)
 665       call flush(iout)
 666       return
 667       end subroutine sum_energy
 668 !-----------------------------------------------------------------------------
 669       subroutine rescale_weights(t_bath)
 670 !      implicit real*8 (a-h,o-z)
 671 #ifdef MPI
 672       include 'mpif.h'
 673 #endif
 674 !      include 'DIMENSIONS'
 675 !      include 'COMMON.IOUNITS'
 676 !      include 'COMMON.FFIELD'
 677 !      include 'COMMON.SBRIDGE'
 678       real(kind=8) :: kfac=2.4d0
 679       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 680 !el local variables
 681       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 682       real(kind=8) :: T0=3.0d2
 683       integer :: ierror
 684 !      facT=temp0/t_bath
 685 !      facT=2*temp0/(t_bath+temp0)
 686       if (rescale_mode.eq.0) then
 687         facT(1)=1.0d0
 688         facT(2)=1.0d0
 689         facT(3)=1.0d0
 690         facT(4)=1.0d0
 691         facT(5)=1.0d0
 692         facT(6)=1.0d0
 693       else if (rescale_mode.eq.1) then
 694         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 695         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 696         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 697         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 698         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 699 #ifdef WHAM_RUN
 700 !#if defined(WHAM_RUN) || defined(CLUSTER)
 701 #if defined(FUNCTH)
 702 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 703         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 704 #elif defined(FUNCT)
 705         facT(6)=t_bath/T0
 706 #else
 707         facT(6)=1.0d0
 708 #endif
 709 #endif
 710       else if (rescale_mode.eq.2) then
 711         x=t_bath/temp0
 712         x2=x*x
 713         x3=x2*x
 714         x4=x3*x
 715         x5=x4*x
 716         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 717         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 718         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 719         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 720         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 721 #ifdef WHAM_RUN
 722 !#if defined(WHAM_RUN) || defined(CLUSTER)
 723 #if defined(FUNCTH)
 724         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 725 #elif defined(FUNCT)
 726         facT(6)=t_bath/T0
 727 #else
 728         facT(6)=1.0d0
 729 #endif
 730 #endif
 731       else
 732         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 733         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 734 #ifdef MPI
 735        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 736 #endif
 737        stop 555
 738       endif
 739       welec=weights(3)*fact(1)
 740       wcorr=weights(4)*fact(3)
 741       wcorr5=weights(5)*fact(4)
 742       wcorr6=weights(6)*fact(5)
 743       wel_loc=weights(7)*fact(2)
 744       wturn3=weights(8)*fact(2)
 745       wturn4=weights(9)*fact(3)
 746       wturn6=weights(10)*fact(5)
 747       wtor=weights(13)*fact(1)
 748       wtor_d=weights(14)*fact(2)
 749       wsccor=weights(21)*fact(1)
 750
 751       return
 752       end subroutine rescale_weights
 753 !-----------------------------------------------------------------------------
 754       subroutine enerprint(energia)
 755 !      implicit real*8 (a-h,o-z)
 756 !      include 'DIMENSIONS'
 757 !      include 'COMMON.IOUNITS'
 758 !      include 'COMMON.FFIELD'
 759 !      include 'COMMON.SBRIDGE'
 760 !      include 'COMMON.MD'
 761       real(kind=8) :: energia(0:n_ene)
 762 !el local variables
 763       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 764       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 765       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor
 766
 767       etot=energia(0)
 768       evdw=energia(1)
 769       evdw2=energia(2)
 770 #ifdef SCP14
 771       evdw2=energia(2)+energia(18)
 772 #else
 773       evdw2=energia(2)
 774 #endif
 775       ees=energia(3)
 776 #ifdef SPLITELE
 777       evdw1=energia(16)
 778 #endif
 779       ecorr=energia(4)
 780       ecorr5=energia(5)
 781       ecorr6=energia(6)
 782       eel_loc=energia(7)
 783       eello_turn3=energia(8)
 784       eello_turn4=energia(9)
 785       eello_turn6=energia(10)
 786       ebe=energia(11)
 787       escloc=energia(12)
 788       etors=energia(13)
 789       etors_d=energia(14)
 790       ehpb=energia(15)
 791       edihcnstr=energia(19)
 792       estr=energia(17)
 793       Uconst=energia(20)
 794       esccor=energia(21)
 795 #ifdef SPLITELE
 796       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 797         estr,wbond,ebe,wang,&
 798         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 799         ecorr,wcorr,&
 800         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 801         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 802         edihcnstr,ebr*nss,&
 803         Uconst,etot
 804    10 format (/'Virtual-chain energies:'// &
 805        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 806        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 807        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 808        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 809        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 810        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 811        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 812        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 813        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 814        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 815        ' (SS bridges & dist. cnstr.)'/ &
 816        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 817        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 818        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 819        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 820        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 821        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 822        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 823        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 824        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 825        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 826        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 827        'ETOT=  ',1pE16.6,' (total)')
 828 #else
 829       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 830         estr,wbond,ebe,wang,&
 831         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 832         ecorr,wcorr,&
 833         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 834         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 835         ebr*nss,Uconst,etot
 836    10 format (/'Virtual-chain energies:'// &
 837        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 838        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 839        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 840        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 841        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 842        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 843        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 844        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 845        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 846        ' (SS bridges & dist. cnstr.)'/ &
 847        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 848        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 849        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 850        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 851        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 852        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 853        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 854        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 855        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 856        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 857        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 858        'ETOT=  ',1pE16.6,' (total)')
 859 #endif
 860       return
 861       end subroutine enerprint
 862 !-----------------------------------------------------------------------------
 863       subroutine elj(evdw)
 864 !
 865 ! This subroutine calculates the interaction energy of nonbonded side chains
 866 ! assuming the LJ potential of interaction.
 867 !
 868 !      implicit real*8 (a-h,o-z)
 869 !      include 'DIMENSIONS'
 870       real(kind=8),parameter :: accur=1.0d-10
 871 !      include 'COMMON.GEO'
 872 !      include 'COMMON.VAR'
 873 !      include 'COMMON.LOCAL'
 874 !      include 'COMMON.CHAIN'
 875 !      include 'COMMON.DERIV'
 876 !      include 'COMMON.INTERACT'
 877 !      include 'COMMON.TORSION'
 878 !      include 'COMMON.SBRIDGE'
 879 !      include 'COMMON.NAMES'
 880 !      include 'COMMON.IOUNITS'
 881 !      include 'COMMON.CONTACTS'
 882       real(kind=8),dimension(3) :: gg
 883       integer :: num_conti
 884 !el local variables
 885       integer :: i,itypi,iint,j,itypi1,itypj,k
 886       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 887       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 888       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 889
 890 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 891       evdw=0.0D0
 892 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 893 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 894 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 895 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 896
 897       do i=iatsc_s,iatsc_e
 898         itypi=iabs(itype(i))
 899         if (itypi.eq.ntyp1) cycle
 900         itypi1=iabs(itype(i+1))
 901         xi=c(1,nres+i)
 902         yi=c(2,nres+i)
 903         zi=c(3,nres+i)
 904 ! Change 12/1/95
 905         num_conti=0
 906 !
 907 ! Calculate SC interaction energy.
 908 !
 909         do iint=1,nint_gr(i)
 910 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 911 !d   &                  'iend=',iend(i,iint)
 912           do j=istart(i,iint),iend(i,iint)
 913             itypj=iabs(itype(j))
 914             if (itypj.eq.ntyp1) cycle
 915             xj=c(1,nres+j)-xi
 916             yj=c(2,nres+j)-yi
 917             zj=c(3,nres+j)-zi
 918 ! Change 12/1/95 to calculate four-body interactions
 919             rij=xj*xj+yj*yj+zj*zj
 920             rrij=1.0D0/rij
 921 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 922             eps0ij=eps(itypi,itypj)
 923             fac=rrij**expon2
 924             e1=fac*fac*aa(itypi,itypj)
 925             e2=fac*bb(itypi,itypj)
 926             evdwij=e1+e2
 927 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 928 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 929 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 930 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 931 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 932 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 933             evdw=evdw+evdwij
 934 !
 935 ! Calculate the components of the gradient in DC and X
 936 !
 937             fac=-rrij*(e1+evdwij)
 938             gg(1)=xj*fac
 939             gg(2)=yj*fac
 940             gg(3)=zj*fac
 941             do k=1,3
 942               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 943               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 944               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 945               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 946             enddo
 947 !grad            do k=i,j-1
 948 !grad              do l=1,3
 949 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 950 !grad              enddo
 951 !grad            enddo
 952 !
 953 ! 12/1/95, revised on 5/20/97
 954 !
 955 ! Calculate the contact function. The ith column of the array JCONT will
 956 ! contain the numbers of atoms that make contacts with the atom I (of numbers
 957 ! greater than I). The arrays FACONT and GACONT will contain the values of
 958 ! the contact function and its derivative.
 959 !
 960 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
 961 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 962 ! Uncomment next line, if the correlation interactions are contact function only
 963             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 964               rij=dsqrt(rij)
 965               sigij=sigma(itypi,itypj)
 966               r0ij=rs0(itypi,itypj)
 967 !
 968 ! Check whether the SC's are not too far to make a contact.
 969 !
 970               rcut=1.5d0*r0ij
 971               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 972 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 973 !
 974               if (fcont.gt.0.0D0) then
 975 ! If the SC-SC distance if close to sigma, apply spline.
 976 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 977 !Adam &             fcont1,fprimcont1)
 978 !Adam           fcont1=1.0d0-fcont1
 979 !Adam           if (fcont1.gt.0.0d0) then
 980 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 981 !Adam             fcont=fcont*fcont1
 982 !Adam           endif
 983 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
 984 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
 985 !ga             do k=1,3
 986 !ga               gg(k)=gg(k)*eps0ij
 987 !ga             enddo
 988 !ga             eps0ij=-evdwij*eps0ij
 989 ! Uncomment for AL's type of SC correlation interactions.
 990 !adam           eps0ij=-evdwij
 991                 num_conti=num_conti+1
 992                 jcont(num_conti,i)=j
 993                 facont(num_conti,i)=fcont*eps0ij
 994                 fprimcont=eps0ij*fprimcont/rij
 995                 fcont=expon*fcont
 996 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 997 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 998 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 999 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1000                 gacont(1,num_conti,i)=-fprimcont*xj
1001                 gacont(2,num_conti,i)=-fprimcont*yj
1002                 gacont(3,num_conti,i)=-fprimcont*zj
1003 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1004 !d              write (iout,'(2i3,3f10.5)')
1005 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1006               endif
1007             endif
1008           enddo      ! j
1009         enddo        ! iint
1010 ! Change 12/1/95
1011         num_cont(i)=num_conti
1012       enddo          ! i
1013       do i=1,nct
1014         do j=1,3
1015           gvdwc(j,i)=expon*gvdwc(j,i)
1016           gvdwx(j,i)=expon*gvdwx(j,i)
1017         enddo
1018       enddo
1019 !******************************************************************************
1020 !
1021 !                              N O T E !!!
1022 !
1023 ! To save time, the factor of EXPON has been extracted from ALL components
1024 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1025 ! use!
1026 !
1027 !******************************************************************************
1028       return
1029       end subroutine elj
1030 !-----------------------------------------------------------------------------
1031       subroutine eljk(evdw)
1032 !
1033 ! This subroutine calculates the interaction energy of nonbonded side chains
1034 ! assuming the LJK potential of interaction.
1035 !
1036 !      implicit real*8 (a-h,o-z)
1037 !      include 'DIMENSIONS'
1038 !      include 'COMMON.GEO'
1039 !      include 'COMMON.VAR'
1040 !      include 'COMMON.LOCAL'
1041 !      include 'COMMON.CHAIN'
1042 !      include 'COMMON.DERIV'
1043 !      include 'COMMON.INTERACT'
1044 !      include 'COMMON.IOUNITS'
1045 !      include 'COMMON.NAMES'
1046       real(kind=8),dimension(3) :: gg
1047       logical :: scheck
1048 !el local variables
1049       integer :: i,iint,j,itypi,itypi1,k,itypj
1050       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1051       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1052
1053 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1054       evdw=0.0D0
1055       do i=iatsc_s,iatsc_e
1056         itypi=iabs(itype(i))
1057         if (itypi.eq.ntyp1) cycle
1058         itypi1=iabs(itype(i+1))
1059         xi=c(1,nres+i)
1060         yi=c(2,nres+i)
1061         zi=c(3,nres+i)
1062 !
1063 ! Calculate SC interaction energy.
1064 !
1065         do iint=1,nint_gr(i)
1066           do j=istart(i,iint),iend(i,iint)
1067             itypj=iabs(itype(j))
1068             if (itypj.eq.ntyp1) cycle
1069             xj=c(1,nres+j)-xi
1070             yj=c(2,nres+j)-yi
1071             zj=c(3,nres+j)-zi
1072             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1073             fac_augm=rrij**expon
1074             e_augm=augm(itypi,itypj)*fac_augm
1075             r_inv_ij=dsqrt(rrij)
1076             rij=1.0D0/r_inv_ij
1077             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1078             fac=r_shift_inv**expon
1079             e1=fac*fac*aa(itypi,itypj)
1080             e2=fac*bb(itypi,itypj)
1081             evdwij=e_augm+e1+e2
1082 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1083 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1084 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1085 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1086 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1087 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1088 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1089             evdw=evdw+evdwij
1090 !
1091 ! Calculate the components of the gradient in DC and X
1092 !
1093             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1094             gg(1)=xj*fac
1095             gg(2)=yj*fac
1096             gg(3)=zj*fac
1097             do k=1,3
1098               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1099               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1100               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1101               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1102             enddo
1103 !grad            do k=i,j-1
1104 !grad              do l=1,3
1105 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1106 !grad              enddo
1107 !grad            enddo
1108           enddo      ! j
1109         enddo        ! iint
1110       enddo          ! i
1111       do i=1,nct
1112         do j=1,3
1113           gvdwc(j,i)=expon*gvdwc(j,i)
1114           gvdwx(j,i)=expon*gvdwx(j,i)
1115         enddo
1116       enddo
1117       return
1118       end subroutine eljk
1119 !-----------------------------------------------------------------------------
1120       subroutine ebp(evdw)
1121 !
1122 ! This subroutine calculates the interaction energy of nonbonded side chains
1123 ! assuming the Berne-Pechukas potential of interaction.
1124 !
1125       use comm_srutu
1126       use calc_data
1127 !      implicit real*8 (a-h,o-z)
1128 !      include 'DIMENSIONS'
1129 !      include 'COMMON.GEO'
1130 !      include 'COMMON.VAR'
1131 !      include 'COMMON.LOCAL'
1132 !      include 'COMMON.CHAIN'
1133 !      include 'COMMON.DERIV'
1134 !      include 'COMMON.NAMES'
1135 !      include 'COMMON.INTERACT'
1136 !      include 'COMMON.IOUNITS'
1137 !      include 'COMMON.CALC'
1138       use comm_srutu
1139 !el      integer :: icall
1140 !el      common /srutu/ icall
1141 !     double precision rrsave(maxdim)
1142       logical :: lprn
1143 !el local variables
1144       integer :: iint,itypi,itypi1,itypj
1145       real(kind=8) :: rrij,xi,yi,zi
1146       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1147
1148 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1149       evdw=0.0D0
1150 !     if (icall.eq.0) then
1151 !       lprn=.true.
1152 !     else
1153         lprn=.false.
1154 !     endif
1155 !el      ind=0
1156       do i=iatsc_s,iatsc_e
1157         itypi=iabs(itype(i))
1158         if (itypi.eq.ntyp1) cycle
1159         itypi1=iabs(itype(i+1))
1160         xi=c(1,nres+i)
1161         yi=c(2,nres+i)
1162         zi=c(3,nres+i)
1163         dxi=dc_norm(1,nres+i)
1164         dyi=dc_norm(2,nres+i)
1165         dzi=dc_norm(3,nres+i)
1166 !        dsci_inv=dsc_inv(itypi)
1167         dsci_inv=vbld_inv(i+nres)
1168 !
1169 ! Calculate SC interaction energy.
1170 !
1171         do iint=1,nint_gr(i)
1172           do j=istart(i,iint),iend(i,iint)
1173 !el            ind=ind+1
1174             itypj=iabs(itype(j))
1175             if (itypj.eq.ntyp1) cycle
1176 !            dscj_inv=dsc_inv(itypj)
1177             dscj_inv=vbld_inv(j+nres)
1178             chi1=chi(itypi,itypj)
1179             chi2=chi(itypj,itypi)
1180             chi12=chi1*chi2
1181             chip1=chip(itypi)
1182             chip2=chip(itypj)
1183             chip12=chip1*chip2
1184             alf1=alp(itypi)
1185             alf2=alp(itypj)
1186             alf12=0.5D0*(alf1+alf2)
1187 ! For diagnostics only!!!
1188 !           chi1=0.0D0
1189 !           chi2=0.0D0
1190 !           chi12=0.0D0
1191 !           chip1=0.0D0
1192 !           chip2=0.0D0
1193 !           chip12=0.0D0
1194 !           alf1=0.0D0
1195 !           alf2=0.0D0
1196 !           alf12=0.0D0
1197             xj=c(1,nres+j)-xi
1198             yj=c(2,nres+j)-yi
1199             zj=c(3,nres+j)-zi
1200             dxj=dc_norm(1,nres+j)
1201             dyj=dc_norm(2,nres+j)
1202             dzj=dc_norm(3,nres+j)
1203             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1204 !d          if (icall.eq.0) then
1205 !d            rrsave(ind)=rrij
1206 !d          else
1207 !d            rrij=rrsave(ind)
1208 !d          endif
1209             rij=dsqrt(rrij)
1210 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1211             call sc_angular
1212 ! Calculate whole angle-dependent part of epsilon and contributions
1213 ! to its derivatives
1214             fac=(rrij*sigsq)**expon2
1215             e1=fac*fac*aa(itypi,itypj)
1216             e2=fac*bb(itypi,itypj)
1217             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1218             eps2der=evdwij*eps3rt
1219             eps3der=evdwij*eps2rt
1220             evdwij=evdwij*eps2rt*eps3rt
1221             evdw=evdw+evdwij
1222             if (lprn) then
1223             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1224             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1225 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1226 !d     &        restyp(itypi),i,restyp(itypj),j,
1227 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1228 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1229 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1230 !d     &        evdwij
1231             endif
1232 ! Calculate gradient components.
1233             e1=e1*eps1*eps2rt**2*eps3rt**2
1234             fac=-expon*(e1+evdwij)
1235             sigder=fac/sigsq
1236             fac=rrij*fac
1237 ! Calculate radial part of the gradient
1238             gg(1)=xj*fac
1239             gg(2)=yj*fac
1240             gg(3)=zj*fac
1241 ! Calculate the angular part of the gradient and sum add the contributions
1242 ! to the appropriate components of the Cartesian gradient.
1243             call sc_grad
1244           enddo      ! j
1245         enddo        ! iint
1246       enddo          ! i
1247 !     stop
1248       return
1249       end subroutine ebp
1250 !-----------------------------------------------------------------------------
1251       subroutine egb(evdw)
1252 !
1253 ! This subroutine calculates the interaction energy of nonbonded side chains
1254 ! assuming the Gay-Berne potential of interaction.
1255 !
1256       use calc_data
1257 !      implicit real*8 (a-h,o-z)
1258 !      include 'DIMENSIONS'
1259 !      include 'COMMON.GEO'
1260 !      include 'COMMON.VAR'
1261 !      include 'COMMON.LOCAL'
1262 !      include 'COMMON.CHAIN'
1263 !      include 'COMMON.DERIV'
1264 !      include 'COMMON.NAMES'
1265 !      include 'COMMON.INTERACT'
1266 !      include 'COMMON.IOUNITS'
1267 !      include 'COMMON.CALC'
1268 !      include 'COMMON.CONTROL'
1269 !      include 'COMMON.SBRIDGE'
1270       logical :: lprn
1271 !el local variables
1272       integer :: iint,itypi,itypi1,itypj
1273       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1274       real(kind=8) :: evdw,sig0ij
1275       integer :: ii
1276 !cccc      energy_dec=.false.
1277 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1278       evdw=0.0D0
1279       lprn=.false.
1280 !     if (icall.eq.0) lprn=.false.
1281 !el      ind=0
1282       do i=iatsc_s,iatsc_e
1283         itypi=iabs(itype(i))
1284         if (itypi.eq.ntyp1) cycle
1285         itypi1=iabs(itype(i+1))
1286         xi=c(1,nres+i)
1287         yi=c(2,nres+i)
1288         zi=c(3,nres+i)
1289         dxi=dc_norm(1,nres+i)
1290         dyi=dc_norm(2,nres+i)
1291         dzi=dc_norm(3,nres+i)
1292 !        dsci_inv=dsc_inv(itypi)
1293         dsci_inv=vbld_inv(i+nres)
1294 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1295 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1296 !
1297 ! Calculate SC interaction energy.
1298 !
1299         do iint=1,nint_gr(i)
1300           do j=istart(i,iint),iend(i,iint)
1301             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1302               call dyn_ssbond_ene(i,j,evdwij)
1303               evdw=evdw+evdwij
1304               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1305                               'evdw',i,j,evdwij,' ss'
1306 !              if (energy_dec) write (iout,*) &
1307 !                              'evdw',i,j,evdwij,' ss'
1308             ELSE
1309 !el            ind=ind+1
1310             itypj=iabs(itype(j))
1311             if (itypj.eq.ntyp1) cycle
1312 !            dscj_inv=dsc_inv(itypj)
1313             dscj_inv=vbld_inv(j+nres)
1314 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1315 !              1.0d0/vbld(j+nres) !d
1316 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1317             sig0ij=sigma(itypi,itypj)
1318             chi1=chi(itypi,itypj)
1319             chi2=chi(itypj,itypi)
1320             chi12=chi1*chi2
1321             chip1=chip(itypi)
1322             chip2=chip(itypj)
1323             chip12=chip1*chip2
1324             alf1=alp(itypi)
1325             alf2=alp(itypj)
1326             alf12=0.5D0*(alf1+alf2)
1327 ! For diagnostics only!!!
1328 !           chi1=0.0D0
1329 !           chi2=0.0D0
1330 !           chi12=0.0D0
1331 !           chip1=0.0D0
1332 !           chip2=0.0D0
1333 !           chip12=0.0D0
1334 !           alf1=0.0D0
1335 !           alf2=0.0D0
1336 !           alf12=0.0D0
1337             xj=c(1,nres+j)-xi
1338             yj=c(2,nres+j)-yi
1339             zj=c(3,nres+j)-zi
1340             dxj=dc_norm(1,nres+j)
1341             dyj=dc_norm(2,nres+j)
1342             dzj=dc_norm(3,nres+j)
1343 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1344 !            write (iout,*) "j",j," dc_norm",& !d
1345 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1346 !          write(iout,*)"rrij ",rrij
1347 !          write(iout,*)"xj yj zj ", xj, yj, zj
1348 !          write(iout,*)"xi yi zi ", xi, yi, zi
1349 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351             rij=dsqrt(rrij)
1352 ! Calculate angle-dependent terms of energy and contributions to their
1353 ! derivatives.
1354             call sc_angular
1355             sigsq=1.0D0/sigsq
1356             sig=sig0ij*dsqrt(sigsq)
1357             rij_shift=1.0D0/rij-sig+sig0ij
1358 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1359 !            "sig0ij",sig0ij
1360 ! for diagnostics; uncomment
1361 !            rij_shift=1.2*sig0ij
1362 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1363             if (rij_shift.le.0.0D0) then
1364               evdw=1.0D20
1365 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1366 !d     &        restyp(itypi),i,restyp(itypj),j,
1367 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1368               return
1369             endif
1370             sigder=-sig*sigsq
1371 !---------------------------------------------------------------
1372             rij_shift=1.0D0/rij_shift
1373             fac=rij_shift**expon
1374             e1=fac*fac*aa(itypi,itypj)
1375             e2=fac*bb(itypi,itypj)
1376             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1377             eps2der=evdwij*eps3rt
1378             eps3der=evdwij*eps2rt
1379 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1380 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1381 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1382             evdwij=evdwij*eps2rt*eps3rt
1383             evdw=evdw+evdwij
1384             if (lprn) then
1385             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1386             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1387             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1388               restyp(itypi),i,restyp(itypj),j, &
1389               epsi,sigm,chi1,chi2,chip1,chip2, &
1390               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1391               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1392               evdwij
1393             endif
1394
1395             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
1396                              'evdw',i,j,evdwij !,"egb"
1397 !            if (energy_dec) write (iout,*) &
1398 !                             'evdw',i,j,evdwij
1399
1400 ! Calculate gradient components.
1401             e1=e1*eps1*eps2rt**2*eps3rt**2
1402             fac=-expon*(e1+evdwij)*rij_shift
1403             sigder=fac*sigder
1404             fac=rij*fac
1405 !            fac=0.0d0
1406 ! Calculate the radial part of the gradient
1407             gg(1)=xj*fac
1408             gg(2)=yj*fac
1409             gg(3)=zj*fac
1410 ! Calculate angular part of the gradient.
1411             call sc_grad
1412             ENDIF    ! dyn_ss
1413           enddo      ! j
1414         enddo        ! iint
1415       enddo          ! i
1416 !      write (iout,*) "Number of loop steps in EGB:",ind
1417 !ccc      energy_dec=.false.
1418       return
1419       end subroutine egb
1420 !-----------------------------------------------------------------------------
1421       subroutine egbv(evdw)
1422 !
1423 ! This subroutine calculates the interaction energy of nonbonded side chains
1424 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1425 !
1426       use comm_srutu
1427       use calc_data
1428 !      implicit real*8 (a-h,o-z)
1429 !      include 'DIMENSIONS'
1430 !      include 'COMMON.GEO'
1431 !      include 'COMMON.VAR'
1432 !      include 'COMMON.LOCAL'
1433 !      include 'COMMON.CHAIN'
1434 !      include 'COMMON.DERIV'
1435 !      include 'COMMON.NAMES'
1436 !      include 'COMMON.INTERACT'
1437 !      include 'COMMON.IOUNITS'
1438 !      include 'COMMON.CALC'
1439       use comm_srutu
1440 !el      integer :: icall
1441 !el      common /srutu/ icall
1442       logical :: lprn
1443 !el local variables
1444       integer :: iint,itypi,itypi1,itypj
1445       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1446       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1447
1448 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1449       evdw=0.0D0
1450       lprn=.false.
1451 !     if (icall.eq.0) lprn=.true.
1452 !el      ind=0
1453       do i=iatsc_s,iatsc_e
1454         itypi=iabs(itype(i))
1455         if (itypi.eq.ntyp1) cycle
1456         itypi1=iabs(itype(i+1))
1457         xi=c(1,nres+i)
1458         yi=c(2,nres+i)
1459         zi=c(3,nres+i)
1460         dxi=dc_norm(1,nres+i)
1461         dyi=dc_norm(2,nres+i)
1462         dzi=dc_norm(3,nres+i)
1463 !        dsci_inv=dsc_inv(itypi)
1464         dsci_inv=vbld_inv(i+nres)
1465 !
1466 ! Calculate SC interaction energy.
1467 !
1468         do iint=1,nint_gr(i)
1469           do j=istart(i,iint),iend(i,iint)
1470 !el            ind=ind+1
1471             itypj=iabs(itype(j))
1472             if (itypj.eq.ntyp1) cycle
1473 !            dscj_inv=dsc_inv(itypj)
1474             dscj_inv=vbld_inv(j+nres)
1475             sig0ij=sigma(itypi,itypj)
1476             r0ij=r0(itypi,itypj)
1477             chi1=chi(itypi,itypj)
1478             chi2=chi(itypj,itypi)
1479             chi12=chi1*chi2
1480             chip1=chip(itypi)
1481             chip2=chip(itypj)
1482             chip12=chip1*chip2
1483             alf1=alp(itypi)
1484             alf2=alp(itypj)
1485             alf12=0.5D0*(alf1+alf2)
1486 ! For diagnostics only!!!
1487 !           chi1=0.0D0
1488 !           chi2=0.0D0
1489 !           chi12=0.0D0
1490 !           chip1=0.0D0
1491 !           chip2=0.0D0
1492 !           chip12=0.0D0
1493 !           alf1=0.0D0
1494 !           alf2=0.0D0
1495 !           alf12=0.0D0
1496             xj=c(1,nres+j)-xi
1497             yj=c(2,nres+j)-yi
1498             zj=c(3,nres+j)-zi
1499             dxj=dc_norm(1,nres+j)
1500             dyj=dc_norm(2,nres+j)
1501             dzj=dc_norm(3,nres+j)
1502             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1503             rij=dsqrt(rrij)
1504 ! Calculate angle-dependent terms of energy and contributions to their
1505 ! derivatives.
1506             call sc_angular
1507             sigsq=1.0D0/sigsq
1508             sig=sig0ij*dsqrt(sigsq)
1509             rij_shift=1.0D0/rij-sig+r0ij
1510 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1511             if (rij_shift.le.0.0D0) then
1512               evdw=1.0D20
1513               return
1514             endif
1515             sigder=-sig*sigsq
1516 !---------------------------------------------------------------
1517             rij_shift=1.0D0/rij_shift
1518             fac=rij_shift**expon
1519             e1=fac*fac*aa(itypi,itypj)
1520             e2=fac*bb(itypi,itypj)
1521             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1522             eps2der=evdwij*eps3rt
1523             eps3der=evdwij*eps2rt
1524             fac_augm=rrij**expon
1525             e_augm=augm(itypi,itypj)*fac_augm
1526             evdwij=evdwij*eps2rt*eps3rt
1527             evdw=evdw+evdwij+e_augm
1528             if (lprn) then
1529             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1530             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1531             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1532               restyp(itypi),i,restyp(itypj),j,&
1533               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1534               chi1,chi2,chip1,chip2,&
1535               eps1,eps2rt**2,eps3rt**2,&
1536               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1537               evdwij+e_augm
1538             endif
1539 ! Calculate gradient components.
1540             e1=e1*eps1*eps2rt**2*eps3rt**2
1541             fac=-expon*(e1+evdwij)*rij_shift
1542             sigder=fac*sigder
1543             fac=rij*fac-2*expon*rrij*e_augm
1544 ! Calculate the radial part of the gradient
1545             gg(1)=xj*fac
1546             gg(2)=yj*fac
1547             gg(3)=zj*fac
1548 ! Calculate angular part of the gradient.
1549             call sc_grad
1550           enddo      ! j
1551         enddo        ! iint
1552       enddo          ! i
1553       end subroutine egbv
1554 !-----------------------------------------------------------------------------
1555 !el      subroutine sc_angular in module geometry
1556 !-----------------------------------------------------------------------------
1557       subroutine e_softsphere(evdw)
1558 !
1559 ! This subroutine calculates the interaction energy of nonbonded side chains
1560 ! assuming the LJ potential of interaction.
1561 !
1562 !      implicit real*8 (a-h,o-z)
1563 !      include 'DIMENSIONS'
1564       real(kind=8),parameter :: accur=1.0d-10
1565 !      include 'COMMON.GEO'
1566 !      include 'COMMON.VAR'
1567 !      include 'COMMON.LOCAL'
1568 !      include 'COMMON.CHAIN'
1569 !      include 'COMMON.DERIV'
1570 !      include 'COMMON.INTERACT'
1571 !      include 'COMMON.TORSION'
1572 !      include 'COMMON.SBRIDGE'
1573 !      include 'COMMON.NAMES'
1574 !      include 'COMMON.IOUNITS'
1575 !      include 'COMMON.CONTACTS'
1576       real(kind=8),dimension(3) :: gg
1577 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1578 !el local variables
1579       integer :: i,iint,j,itypi,itypi1,itypj,k
1580       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1581       real(kind=8) :: fac
1582
1583       evdw=0.0D0
1584       do i=iatsc_s,iatsc_e
1585         itypi=iabs(itype(i))
1586         if (itypi.eq.ntyp1) cycle
1587         itypi1=iabs(itype(i+1))
1588         xi=c(1,nres+i)
1589         yi=c(2,nres+i)
1590         zi=c(3,nres+i)
1591 !
1592 ! Calculate SC interaction energy.
1593 !
1594         do iint=1,nint_gr(i)
1595 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1596 !d   &                  'iend=',iend(i,iint)
1597           do j=istart(i,iint),iend(i,iint)
1598             itypj=iabs(itype(j))
1599             if (itypj.eq.ntyp1) cycle
1600             xj=c(1,nres+j)-xi
1601             yj=c(2,nres+j)-yi
1602             zj=c(3,nres+j)-zi
1603             rij=xj*xj+yj*yj+zj*zj
1604 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1605             r0ij=r0(itypi,itypj)
1606             r0ijsq=r0ij*r0ij
1607 !            print *,i,j,r0ij,dsqrt(rij)
1608             if (rij.lt.r0ijsq) then
1609               evdwij=0.25d0*(rij-r0ijsq)**2
1610               fac=rij-r0ijsq
1611             else
1612               evdwij=0.0d0
1613               fac=0.0d0
1614             endif
1615             evdw=evdw+evdwij
1616 !
1617 ! Calculate the components of the gradient in DC and X
1618 !
1619             gg(1)=xj*fac
1620             gg(2)=yj*fac
1621             gg(3)=zj*fac
1622             do k=1,3
1623               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1624               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1625               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1626               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1627             enddo
1628 !grad            do k=i,j-1
1629 !grad              do l=1,3
1630 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1631 !grad              enddo
1632 !grad            enddo
1633           enddo ! j
1634         enddo ! iint
1635       enddo ! i
1636       return
1637       end subroutine e_softsphere
1638 !-----------------------------------------------------------------------------
1639       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1640 !
1641 ! Soft-sphere potential of p-p interaction
1642 !
1643 !      implicit real*8 (a-h,o-z)
1644 !      include 'DIMENSIONS'
1645 !      include 'COMMON.CONTROL'
1646 !      include 'COMMON.IOUNITS'
1647 !      include 'COMMON.GEO'
1648 !      include 'COMMON.VAR'
1649 !      include 'COMMON.LOCAL'
1650 !      include 'COMMON.CHAIN'
1651 !      include 'COMMON.DERIV'
1652 !      include 'COMMON.INTERACT'
1653 !      include 'COMMON.CONTACTS'
1654 !      include 'COMMON.TORSION'
1655 !      include 'COMMON.VECTORS'
1656 !      include 'COMMON.FFIELD'
1657       real(kind=8),dimension(3) :: ggg
1658 !d      write(iout,*) 'In EELEC_soft_sphere'
1659 !el local variables
1660       integer :: i,j,k,num_conti,iteli,itelj
1661       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1662       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1663       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1664
1665       ees=0.0D0
1666       evdw1=0.0D0
1667       eel_loc=0.0d0
1668       eello_turn3=0.0d0
1669       eello_turn4=0.0d0
1670 !el      ind=0
1671       do i=iatel_s,iatel_e
1672         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1673         dxi=dc(1,i)
1674         dyi=dc(2,i)
1675         dzi=dc(3,i)
1676         xmedi=c(1,i)+0.5d0*dxi
1677         ymedi=c(2,i)+0.5d0*dyi
1678         zmedi=c(3,i)+0.5d0*dzi
1679         num_conti=0
1680 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1681         do j=ielstart(i),ielend(i)
1682           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1683 !el          ind=ind+1
1684           iteli=itel(i)
1685           itelj=itel(j)
1686           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1687           r0ij=rpp(iteli,itelj)
1688           r0ijsq=r0ij*r0ij
1689           dxj=dc(1,j)
1690           dyj=dc(2,j)
1691           dzj=dc(3,j)
1692           xj=c(1,j)+0.5D0*dxj-xmedi
1693           yj=c(2,j)+0.5D0*dyj-ymedi
1694           zj=c(3,j)+0.5D0*dzj-zmedi
1695           rij=xj*xj+yj*yj+zj*zj
1696           if (rij.lt.r0ijsq) then
1697             evdw1ij=0.25d0*(rij-r0ijsq)**2
1698             fac=rij-r0ijsq
1699           else
1700             evdw1ij=0.0d0
1701             fac=0.0d0
1702           endif
1703           evdw1=evdw1+evdw1ij
1704 !
1705 ! Calculate contributions to the Cartesian gradient.
1706 !
1707           ggg(1)=fac*xj
1708           ggg(2)=fac*yj
1709           ggg(3)=fac*zj
1710           do k=1,3
1711             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1712             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1713           enddo
1714 !
1715 ! Loop over residues i+1 thru j-1.
1716 !
1717 !grad          do k=i+1,j-1
1718 !grad            do l=1,3
1719 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1720 !grad            enddo
1721 !grad          enddo
1722         enddo ! j
1723       enddo   ! i
1724 !grad      do i=nnt,nct-1
1725 !grad        do k=1,3
1726 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1727 !grad        enddo
1728 !grad        do j=i+1,nct-1
1729 !grad          do k=1,3
1730 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1731 !grad          enddo
1732 !grad        enddo
1733 !grad      enddo
1734       return
1735       end subroutine eelec_soft_sphere
1736 !-----------------------------------------------------------------------------
1737       subroutine vec_and_deriv
1738 !      implicit real*8 (a-h,o-z)
1739 !      include 'DIMENSIONS'
1740 #ifdef MPI
1741       include 'mpif.h'
1742 #endif
1743 !      include 'COMMON.IOUNITS'
1744 !      include 'COMMON.GEO'
1745 !      include 'COMMON.VAR'
1746 !      include 'COMMON.LOCAL'
1747 !      include 'COMMON.CHAIN'
1748 !      include 'COMMON.VECTORS'
1749 !      include 'COMMON.SETUP'
1750 !      include 'COMMON.TIME1'
1751       real(kind=8),dimension(3,3,2) :: uyder,uzder
1752       real(kind=8),dimension(2) :: vbld_inv_temp
1753 ! Compute the local reference systems. For reference system (i), the
1754 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1755 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1756 !el local variables
1757       integer :: i,j,k,l
1758       real(kind=8) :: facy,fac,costh
1759
1760 #ifdef PARVEC
1761       do i=ivec_start,ivec_end
1762 #else
1763       do i=1,nres-1
1764 #endif
1765           if (i.eq.nres-1) then
1766 ! Case of the last full residue
1767 ! Compute the Z-axis
1768             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1769             costh=dcos(pi-theta(nres))
1770             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1771             do k=1,3
1772               uz(k,i)=fac*uz(k,i)
1773             enddo
1774 ! Compute the derivatives of uz
1775             uzder(1,1,1)= 0.0d0
1776             uzder(2,1,1)=-dc_norm(3,i-1)
1777             uzder(3,1,1)= dc_norm(2,i-1)
1778             uzder(1,2,1)= dc_norm(3,i-1)
1779             uzder(2,2,1)= 0.0d0
1780             uzder(3,2,1)=-dc_norm(1,i-1)
1781             uzder(1,3,1)=-dc_norm(2,i-1)
1782             uzder(2,3,1)= dc_norm(1,i-1)
1783             uzder(3,3,1)= 0.0d0
1784             uzder(1,1,2)= 0.0d0
1785             uzder(2,1,2)= dc_norm(3,i)
1786             uzder(3,1,2)=-dc_norm(2,i)
1787             uzder(1,2,2)=-dc_norm(3,i)
1788             uzder(2,2,2)= 0.0d0
1789             uzder(3,2,2)= dc_norm(1,i)
1790             uzder(1,3,2)= dc_norm(2,i)
1791             uzder(2,3,2)=-dc_norm(1,i)
1792             uzder(3,3,2)= 0.0d0
1793 ! Compute the Y-axis
1794             facy=fac
1795             do k=1,3
1796               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1797             enddo
1798 ! Compute the derivatives of uy
1799             do j=1,3
1800               do k=1,3
1801                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
1802                               -dc_norm(k,i)*dc_norm(j,i-1)
1803                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1804               enddo
1805               uyder(j,j,1)=uyder(j,j,1)-costh
1806               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1807             enddo
1808             do j=1,2
1809               do k=1,3
1810                 do l=1,3
1811                   uygrad(l,k,j,i)=uyder(l,k,j)
1812                   uzgrad(l,k,j,i)=uzder(l,k,j)
1813                 enddo
1814               enddo
1815             enddo
1816             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1817             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1818             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1819             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1820           else
1821 ! Other residues
1822 ! Compute the Z-axis
1823             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1824             costh=dcos(pi-theta(i+2))
1825             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1826             do k=1,3
1827               uz(k,i)=fac*uz(k,i)
1828             enddo
1829 ! Compute the derivatives of uz
1830             uzder(1,1,1)= 0.0d0
1831             uzder(2,1,1)=-dc_norm(3,i+1)
1832             uzder(3,1,1)= dc_norm(2,i+1)
1833             uzder(1,2,1)= dc_norm(3,i+1)
1834             uzder(2,2,1)= 0.0d0
1835             uzder(3,2,1)=-dc_norm(1,i+1)
1836             uzder(1,3,1)=-dc_norm(2,i+1)
1837             uzder(2,3,1)= dc_norm(1,i+1)
1838             uzder(3,3,1)= 0.0d0
1839             uzder(1,1,2)= 0.0d0
1840             uzder(2,1,2)= dc_norm(3,i)
1841             uzder(3,1,2)=-dc_norm(2,i)
1842             uzder(1,2,2)=-dc_norm(3,i)
1843             uzder(2,2,2)= 0.0d0
1844             uzder(3,2,2)= dc_norm(1,i)
1845             uzder(1,3,2)= dc_norm(2,i)
1846             uzder(2,3,2)=-dc_norm(1,i)
1847             uzder(3,3,2)= 0.0d0
1848 ! Compute the Y-axis
1849             facy=fac
1850             do k=1,3
1851               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1852             enddo
1853 ! Compute the derivatives of uy
1854             do j=1,3
1855               do k=1,3
1856                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
1857                               -dc_norm(k,i)*dc_norm(j,i+1)
1858                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1859               enddo
1860               uyder(j,j,1)=uyder(j,j,1)-costh
1861               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1862             enddo
1863             do j=1,2
1864               do k=1,3
1865                 do l=1,3
1866                   uygrad(l,k,j,i)=uyder(l,k,j)
1867                   uzgrad(l,k,j,i)=uzder(l,k,j)
1868                 enddo
1869               enddo
1870             enddo
1871             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1872             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1873             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1874             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1875           endif
1876       enddo
1877       do i=1,nres-1
1878         vbld_inv_temp(1)=vbld_inv(i+1)
1879         if (i.lt.nres-1) then
1880           vbld_inv_temp(2)=vbld_inv(i+2)
1881           else
1882           vbld_inv_temp(2)=vbld_inv(i)
1883           endif
1884         do j=1,2
1885           do k=1,3
1886             do l=1,3
1887               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1888               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1889             enddo
1890           enddo
1891         enddo
1892       enddo
1893 #if defined(PARVEC) && defined(MPI)
1894       if (nfgtasks1.gt.1) then
1895         time00=MPI_Wtime()
1896 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
1897 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
1898 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
1899         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
1900          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1901          FG_COMM1,IERR)
1902         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
1903          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1904          FG_COMM1,IERR)
1905         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
1906          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
1907          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1908         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
1909          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
1910          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1911         time_gather=time_gather+MPI_Wtime()-time00
1912       endif
1913 !      if (fg_rank.eq.0) then
1914 !        write (iout,*) "Arrays UY and UZ"
1915 !        do i=1,nres-1
1916 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1917 !     &     (uz(k,i),k=1,3)
1918 !        enddo
1919 !      endif
1920 #endif
1921       return
1922       end subroutine vec_and_deriv
1923 !-----------------------------------------------------------------------------
1924       subroutine check_vecgrad
1925 !      implicit real*8 (a-h,o-z)
1926 !      include 'DIMENSIONS'
1927 !      include 'COMMON.IOUNITS'
1928 !      include 'COMMON.GEO'
1929 !      include 'COMMON.VAR'
1930 !      include 'COMMON.LOCAL'
1931 !      include 'COMMON.CHAIN'
1932 !      include 'COMMON.VECTORS'
1933       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
1934       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
1935       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
1936       real(kind=8),dimension(3) :: erij
1937       real(kind=8) :: delta=1.0d-7
1938 !el local variables
1939       integer :: i,j,k,l
1940
1941       call vec_and_deriv
1942 !d      do i=1,nres
1943 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1944 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1945 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1946 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1947 !d     &     (dc_norm(if90,i),if90=1,3)
1948 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1949 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1950 !d          write(iout,'(a)')
1951 !d      enddo
1952       do i=1,nres
1953         do j=1,2
1954           do k=1,3
1955             do l=1,3
1956               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1957               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1958             enddo
1959           enddo
1960         enddo
1961       enddo
1962       call vec_and_deriv
1963       do i=1,nres
1964         do j=1,3
1965           uyt(j,i)=uy(j,i)
1966           uzt(j,i)=uz(j,i)
1967         enddo
1968       enddo
1969       do i=1,nres
1970 !d        write (iout,*) 'i=',i
1971         do k=1,3
1972           erij(k)=dc_norm(k,i)
1973         enddo
1974         do j=1,3
1975           do k=1,3
1976             dc_norm(k,i)=erij(k)
1977           enddo
1978           dc_norm(j,i)=dc_norm(j,i)+delta
1979 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1980 !          do k=1,3
1981 !            dc_norm(k,i)=dc_norm(k,i)/fac
1982 !          enddo
1983 !          write (iout,*) (dc_norm(k,i),k=1,3)
1984 !          write (iout,*) (erij(k),k=1,3)
1985           call vec_and_deriv
1986           do k=1,3
1987             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1988             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1989             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1990             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1991           enddo
1992 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1993 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1994 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1995         enddo
1996         do k=1,3
1997           dc_norm(k,i)=erij(k)
1998         enddo
1999 !d        do k=1,3
2000 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2001 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2002 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2003 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2004 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2005 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2006 !d          write (iout,'(a)')
2007 !d        enddo
2008       enddo
2009       return
2010       end subroutine check_vecgrad
2011 !-----------------------------------------------------------------------------
2012       subroutine set_matrices
2013 !      implicit real*8 (a-h,o-z)
2014 !      include 'DIMENSIONS'
2015 #ifdef MPI
2016       include "mpif.h"
2017 !      include "COMMON.SETUP"
2018       integer :: IERR
2019       integer :: status(MPI_STATUS_SIZE)
2020 #endif
2021 !      include 'COMMON.IOUNITS'
2022 !      include 'COMMON.GEO'
2023 !      include 'COMMON.VAR'
2024 !      include 'COMMON.LOCAL'
2025 !      include 'COMMON.CHAIN'
2026 !      include 'COMMON.DERIV'
2027 !      include 'COMMON.INTERACT'
2028 !      include 'COMMON.CONTACTS'
2029 !      include 'COMMON.TORSION'
2030 !      include 'COMMON.VECTORS'
2031 !      include 'COMMON.FFIELD'
2032       real(kind=8) :: auxvec(2),auxmat(2,2)
2033       integer :: i,iti1,iti,k,l
2034       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2035
2036 !
2037 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2038 ! to calculate the el-loc multibody terms of various order.
2039 !
2040 !AL el      mu=0.0d0
2041 #ifdef PARMAT
2042       do i=ivec_start+2,ivec_end+2
2043 #else
2044       do i=3,nres+1
2045 #endif
2046         if (i .lt. nres+1) then
2047           sin1=dsin(phi(i))
2048           cos1=dcos(phi(i))
2049           sintab(i-2)=sin1
2050           costab(i-2)=cos1
2051           obrot(1,i-2)=cos1
2052           obrot(2,i-2)=sin1
2053           sin2=dsin(2*phi(i))
2054           cos2=dcos(2*phi(i))
2055           sintab2(i-2)=sin2
2056           costab2(i-2)=cos2
2057           obrot2(1,i-2)=cos2
2058           obrot2(2,i-2)=sin2
2059           Ug(1,1,i-2)=-cos1
2060           Ug(1,2,i-2)=-sin1
2061           Ug(2,1,i-2)=-sin1
2062           Ug(2,2,i-2)= cos1
2063           Ug2(1,1,i-2)=-cos2
2064           Ug2(1,2,i-2)=-sin2
2065           Ug2(2,1,i-2)=-sin2
2066           Ug2(2,2,i-2)= cos2
2067         else
2068           costab(i-2)=1.0d0
2069           sintab(i-2)=0.0d0
2070           obrot(1,i-2)=1.0d0
2071           obrot(2,i-2)=0.0d0
2072           obrot2(1,i-2)=0.0d0
2073           obrot2(2,i-2)=0.0d0
2074           Ug(1,1,i-2)=1.0d0
2075           Ug(1,2,i-2)=0.0d0
2076           Ug(2,1,i-2)=0.0d0
2077           Ug(2,2,i-2)=1.0d0
2078           Ug2(1,1,i-2)=0.0d0
2079           Ug2(1,2,i-2)=0.0d0
2080           Ug2(2,1,i-2)=0.0d0
2081           Ug2(2,2,i-2)=0.0d0
2082         endif
2083         if (i .gt. 3 .and. i .lt. nres+1) then
2084           obrot_der(1,i-2)=-sin1
2085           obrot_der(2,i-2)= cos1
2086           Ugder(1,1,i-2)= sin1
2087           Ugder(1,2,i-2)=-cos1
2088           Ugder(2,1,i-2)=-cos1
2089           Ugder(2,2,i-2)=-sin1
2090           dwacos2=cos2+cos2
2091           dwasin2=sin2+sin2
2092           obrot2_der(1,i-2)=-dwasin2
2093           obrot2_der(2,i-2)= dwacos2
2094           Ug2der(1,1,i-2)= dwasin2
2095           Ug2der(1,2,i-2)=-dwacos2
2096           Ug2der(2,1,i-2)=-dwacos2
2097           Ug2der(2,2,i-2)=-dwasin2
2098         else
2099           obrot_der(1,i-2)=0.0d0
2100           obrot_der(2,i-2)=0.0d0
2101           Ugder(1,1,i-2)=0.0d0
2102           Ugder(1,2,i-2)=0.0d0
2103           Ugder(2,1,i-2)=0.0d0
2104           Ugder(2,2,i-2)=0.0d0
2105           obrot2_der(1,i-2)=0.0d0
2106           obrot2_der(2,i-2)=0.0d0
2107           Ug2der(1,1,i-2)=0.0d0
2108           Ug2der(1,2,i-2)=0.0d0
2109           Ug2der(2,1,i-2)=0.0d0
2110           Ug2der(2,2,i-2)=0.0d0
2111         endif
2112 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2113         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2114           iti = itortyp(itype(i-2))
2115         else
2116           iti=ntortyp+1
2117         endif
2118 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2119         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2120           iti1 = itortyp(itype(i-1))
2121         else
2122           iti1=ntortyp+1
2123         endif
2124 !d        write (iout,*) '*******i',i,' iti1',iti
2125 !d        write (iout,*) 'b1',b1(:,iti)
2126 !d        write (iout,*) 'b2',b2(:,iti)
2127 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2128 !        if (i .gt. iatel_s+2) then
2129         if (i .gt. nnt+2) then
2130           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2131           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2132           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2133           then
2134           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2135           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2136           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2137           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2138           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2139           endif
2140         else
2141           do k=1,2
2142             Ub2(k,i-2)=0.0d0
2143             Ctobr(k,i-2)=0.0d0
2144             Dtobr2(k,i-2)=0.0d0
2145             do l=1,2
2146               EUg(l,k,i-2)=0.0d0
2147               CUg(l,k,i-2)=0.0d0
2148               DUg(l,k,i-2)=0.0d0
2149               DtUg2(l,k,i-2)=0.0d0
2150             enddo
2151           enddo
2152         endif
2153         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2154         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2155         do k=1,2
2156           muder(k,i-2)=Ub2der(k,i-2)
2157         enddo
2158 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2159         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2160           if (itype(i-1).le.ntyp) then
2161             iti1 = itortyp(itype(i-1))
2162           else
2163             iti1=ntortyp+1
2164           endif
2165         else
2166           iti1=ntortyp+1
2167         endif
2168         do k=1,2
2169           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2170         enddo
2171 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2172 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2173 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2174 !d        write (iout,*) 'mu1',mu1(:,i-2)
2175 !d        write (iout,*) 'mu2',mu2(:,i-2)
2176         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2177         then
2178         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2179         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2180         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2181         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2182         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2183 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2184         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2185         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2186         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2187         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2188         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2189         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2190         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2191         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2192         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2193         endif
2194       enddo
2195 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2196 ! The order of matrices is from left to right.
2197       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2198       then
2199 !      do i=max0(ivec_start,2),ivec_end
2200       do i=2,nres-1
2201         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2202         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2203         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2204         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2205         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2206         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2207         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2208         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2209       enddo
2210       endif
2211 #if defined(MPI) && defined(PARMAT)
2212 #ifdef DEBUG
2213 !      if (fg_rank.eq.0) then
2214         write (iout,*) "Arrays UG and UGDER before GATHER"
2215         do i=1,nres-1
2216           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2217            ((ug(l,k,i),l=1,2),k=1,2),&
2218            ((ugder(l,k,i),l=1,2),k=1,2)
2219         enddo
2220         write (iout,*) "Arrays UG2 and UG2DER"
2221         do i=1,nres-1
2222           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2223            ((ug2(l,k,i),l=1,2),k=1,2),&
2224            ((ug2der(l,k,i),l=1,2),k=1,2)
2225         enddo
2226         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2227         do i=1,nres-1
2228           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2229            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2230            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2231         enddo
2232         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2233         do i=1,nres-1
2234           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2235            costab(i),sintab(i),costab2(i),sintab2(i)
2236         enddo
2237         write (iout,*) "Array MUDER"
2238         do i=1,nres-1
2239           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2240         enddo
2241 !      endif
2242 #endif
2243       if (nfgtasks.gt.1) then
2244         time00=MPI_Wtime()
2245 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2246 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2247 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2248 #ifdef MATGATHER
2249         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2250          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2251          FG_COMM1,IERR)
2252         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2253          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2254          FG_COMM1,IERR)
2255         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2256          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2257          FG_COMM1,IERR)
2258         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2259          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2260          FG_COMM1,IERR)
2261         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2262          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2263          FG_COMM1,IERR)
2264         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2265          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2266          FG_COMM1,IERR)
2267         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2268          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2269          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2270         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2271          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2272          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2273         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2274          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2275          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2276         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2277          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2278          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2279         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2280         then
2281         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2282          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2283          FG_COMM1,IERR)
2284         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2285          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2286          FG_COMM1,IERR)
2287         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2288          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2289          FG_COMM1,IERR)
2290        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2291          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2292          FG_COMM1,IERR)
2293         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2294          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2295          FG_COMM1,IERR)
2296         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2297          ivec_count(fg_rank1),&
2298          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2299          FG_COMM1,IERR)
2300         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2301          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2302          FG_COMM1,IERR)
2303         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2304          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2305          FG_COMM1,IERR)
2306         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2307          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2308          FG_COMM1,IERR)
2309         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2310          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2311          FG_COMM1,IERR)
2312         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2313          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2314          FG_COMM1,IERR)
2315         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2316          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2317          FG_COMM1,IERR)
2318         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2319          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2320          FG_COMM1,IERR)
2321         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2322          ivec_count(fg_rank1),&
2323          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2324          FG_COMM1,IERR)
2325         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2326          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2327          FG_COMM1,IERR)
2328        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2329          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2330          FG_COMM1,IERR)
2331         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2332          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2333          FG_COMM1,IERR)
2334        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2335          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2336          FG_COMM1,IERR)
2337         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2338          ivec_count(fg_rank1),&
2339          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2340          FG_COMM1,IERR)
2341         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2342          ivec_count(fg_rank1),&
2343          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2344          FG_COMM1,IERR)
2345         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2346          ivec_count(fg_rank1),&
2347          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2348          MPI_MAT2,FG_COMM1,IERR)
2349         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2350          ivec_count(fg_rank1),&
2351          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2352          MPI_MAT2,FG_COMM1,IERR)
2353         endif
2354 #else
2355 ! Passes matrix info through the ring
2356       isend=fg_rank1
2357       irecv=fg_rank1-1
2358       if (irecv.lt.0) irecv=nfgtasks1-1
2359       iprev=irecv
2360       inext=fg_rank1+1
2361       if (inext.ge.nfgtasks1) inext=0
2362       do i=1,nfgtasks1-1
2363 !        write (iout,*) "isend",isend," irecv",irecv
2364 !        call flush(iout)
2365         lensend=lentyp(isend)
2366         lenrecv=lentyp(irecv)
2367 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2368 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2369 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2370 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2371 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2372 !        write (iout,*) "Gather ROTAT1"
2373 !        call flush(iout)
2374 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2375 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2376 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2377 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2378 !        write (iout,*) "Gather ROTAT2"
2379 !        call flush(iout)
2380         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2381          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2382          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2383          iprev,4400+irecv,FG_COMM,status,IERR)
2384 !        write (iout,*) "Gather ROTAT_OLD"
2385 !        call flush(iout)
2386         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2387          MPI_PRECOMP11(lensend),inext,5500+isend,&
2388          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2389          iprev,5500+irecv,FG_COMM,status,IERR)
2390 !        write (iout,*) "Gather PRECOMP11"
2391 !        call flush(iout)
2392         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2393          MPI_PRECOMP12(lensend),inext,6600+isend,&
2394          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2395          iprev,6600+irecv,FG_COMM,status,IERR)
2396 !        write (iout,*) "Gather PRECOMP12"
2397 !        call flush(iout)
2398         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2399         then
2400         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2401          MPI_ROTAT2(lensend),inext,7700+isend,&
2402          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2403          iprev,7700+irecv,FG_COMM,status,IERR)
2404 !        write (iout,*) "Gather PRECOMP21"
2405 !        call flush(iout)
2406         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2407          MPI_PRECOMP22(lensend),inext,8800+isend,&
2408          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2409          iprev,8800+irecv,FG_COMM,status,IERR)
2410 !        write (iout,*) "Gather PRECOMP22"
2411 !        call flush(iout)
2412         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2413          MPI_PRECOMP23(lensend),inext,9900+isend,&
2414          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2415          MPI_PRECOMP23(lenrecv),&
2416          iprev,9900+irecv,FG_COMM,status,IERR)
2417 !        write (iout,*) "Gather PRECOMP23"
2418 !        call flush(iout)
2419         endif
2420         isend=irecv
2421         irecv=irecv-1
2422         if (irecv.lt.0) irecv=nfgtasks1-1
2423       enddo
2424 #endif
2425         time_gather=time_gather+MPI_Wtime()-time00
2426       endif
2427 #ifdef DEBUG
2428 !      if (fg_rank.eq.0) then
2429         write (iout,*) "Arrays UG and UGDER"
2430         do i=1,nres-1
2431           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2432            ((ug(l,k,i),l=1,2),k=1,2),&
2433            ((ugder(l,k,i),l=1,2),k=1,2)
2434         enddo
2435         write (iout,*) "Arrays UG2 and UG2DER"
2436         do i=1,nres-1
2437           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2438            ((ug2(l,k,i),l=1,2),k=1,2),&
2439            ((ug2der(l,k,i),l=1,2),k=1,2)
2440         enddo
2441         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2442         do i=1,nres-1
2443           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2444            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2445            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2446         enddo
2447         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2448         do i=1,nres-1
2449           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2450            costab(i),sintab(i),costab2(i),sintab2(i)
2451         enddo
2452         write (iout,*) "Array MUDER"
2453         do i=1,nres-1
2454           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2455         enddo
2456 !      endif
2457 #endif
2458 #endif
2459 !d      do i=1,nres
2460 !d        iti = itortyp(itype(i))
2461 !d        write (iout,*) i
2462 !d        do j=1,2
2463 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2464 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2465 !d        enddo
2466 !d      enddo
2467       return
2468       end subroutine set_matrices
2469 !-----------------------------------------------------------------------------
2470       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2471 !
2472 ! This subroutine calculates the average interaction energy and its gradient
2473 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2474 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2475 ! The potential depends both on the distance of peptide-group centers and on
2476 ! the orientation of the CA-CA virtual bonds.
2477 !
2478       use comm_locel
2479 !      implicit real*8 (a-h,o-z)
2480 #ifdef MPI
2481       include 'mpif.h'
2482 #endif
2483 !      include 'DIMENSIONS'
2484 !      include 'COMMON.CONTROL'
2485 !      include 'COMMON.SETUP'
2486 !      include 'COMMON.IOUNITS'
2487 !      include 'COMMON.GEO'
2488 !      include 'COMMON.VAR'
2489 !      include 'COMMON.LOCAL'
2490 !      include 'COMMON.CHAIN'
2491 !      include 'COMMON.DERIV'
2492 !      include 'COMMON.INTERACT'
2493 !      include 'COMMON.CONTACTS'
2494 !      include 'COMMON.TORSION'
2495 !      include 'COMMON.VECTORS'
2496 !      include 'COMMON.FFIELD'
2497 !      include 'COMMON.TIME1'
2498       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2499       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2500       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2501 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2502       real(kind=8),dimension(4) :: muij
2503 !el      integer :: num_conti,j1,j2
2504 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2505 !el        dz_normi,xmedi,ymedi,zmedi
2506
2507 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2508 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2509 !el          num_conti,j1,j2
2510
2511 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2512 #ifdef MOMENT
2513       real(kind=8) :: scal_el=1.0d0
2514 #else
2515       real(kind=8) :: scal_el=0.5d0
2516 #endif
2517 ! 12/13/98
2518 ! 13-go grudnia roku pamietnego...
2519       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2520                                              0.0d0,1.0d0,0.0d0,&
2521                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2522 !el local variables
2523       integer :: i,k,j
2524       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2525       real(kind=8) :: fac,t_eelecij
2526
2527
2528 !d      write(iout,*) 'In EELEC'
2529 !d      do i=1,nloctyp
2530 !d        write(iout,*) 'Type',i
2531 !d        write(iout,*) 'B1',B1(:,i)
2532 !d        write(iout,*) 'B2',B2(:,i)
2533 !d        write(iout,*) 'CC',CC(:,:,i)
2534 !d        write(iout,*) 'DD',DD(:,:,i)
2535 !d        write(iout,*) 'EE',EE(:,:,i)
2536 !d      enddo
2537 !d      call check_vecgrad
2538 !d      stop
2539 !      ees=0.0d0  !AS
2540 !      evdw1=0.0d0
2541 !      eel_loc=0.0d0
2542 !      eello_turn3=0.0d0
2543 !      eello_turn4=0.0d0
2544       t_eelecij=0.0d0
2545       ees=0.0D0
2546       evdw1=0.0D0
2547       eel_loc=0.0d0
2548       eello_turn3=0.0d0
2549       eello_turn4=0.0d0
2550 !
2551
2552       if (icheckgrad.eq.1) then
2553 !el
2554 !        do i=0,2*nres+2
2555 !          dc_norm(1,i)=0.0d0
2556 !          dc_norm(2,i)=0.0d0
2557 !          dc_norm(3,i)=0.0d0
2558 !        enddo
2559         do i=1,nres-1
2560           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2561           do k=1,3
2562             dc_norm(k,i)=dc(k,i)*fac
2563           enddo
2564 !          write (iout,*) 'i',i,' fac',fac
2565         enddo
2566       endif
2567       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2568           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2569           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2570 !        call vec_and_deriv
2571 #ifdef TIMING
2572         time01=MPI_Wtime()
2573 #endif
2574         call set_matrices
2575 #ifdef TIMING
2576         time_mat=time_mat+MPI_Wtime()-time01
2577 #endif
2578       endif
2579 !d      do i=1,nres-1
2580 !d        write (iout,*) 'i=',i
2581 !d        do k=1,3
2582 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2583 !d        enddo
2584 !d        do k=1,3
2585 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2586 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2587 !d        enddo
2588 !d      enddo
2589       t_eelecij=0.0d0
2590       ees=0.0D0
2591       evdw1=0.0D0
2592       eel_loc=0.0d0
2593       eello_turn3=0.0d0
2594       eello_turn4=0.0d0
2595 !el      ind=0
2596       do i=1,nres
2597         num_cont_hb(i)=0
2598       enddo
2599 !d      print '(a)','Enter EELEC'
2600 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2601 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2602 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2603       do i=1,nres
2604         gel_loc_loc(i)=0.0d0
2605         gcorr_loc(i)=0.0d0
2606       enddo
2607 !
2608 !
2609 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2610 !
2611 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2612 !
2613
2614
2615
2616       do i=iturn3_start,iturn3_end
2617         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2618         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2619         dxi=dc(1,i)
2620         dyi=dc(2,i)
2621         dzi=dc(3,i)
2622         dx_normi=dc_norm(1,i)
2623         dy_normi=dc_norm(2,i)
2624         dz_normi=dc_norm(3,i)
2625         xmedi=c(1,i)+0.5d0*dxi
2626         ymedi=c(2,i)+0.5d0*dyi
2627         zmedi=c(3,i)+0.5d0*dzi
2628         num_conti=0
2629         call eelecij(i,i+2,ees,evdw1,eel_loc)
2630         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2631         num_cont_hb(i)=num_conti
2632       enddo
2633       do i=iturn4_start,iturn4_end
2634         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2635           .or. itype(i+3).eq.ntyp1 &
2636           .or. itype(i+4).eq.ntyp1) cycle
2637         dxi=dc(1,i)
2638         dyi=dc(2,i)
2639         dzi=dc(3,i)
2640         dx_normi=dc_norm(1,i)
2641         dy_normi=dc_norm(2,i)
2642         dz_normi=dc_norm(3,i)
2643         xmedi=c(1,i)+0.5d0*dxi
2644         ymedi=c(2,i)+0.5d0*dyi
2645         zmedi=c(3,i)+0.5d0*dzi
2646         num_conti=num_cont_hb(i)
2647         call eelecij(i,i+3,ees,evdw1,eel_loc)
2648         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2649          call eturn4(i,eello_turn4)
2650         num_cont_hb(i)=num_conti
2651       enddo   ! i
2652 !
2653 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2654 !
2655       do i=iatel_s,iatel_e
2656         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2657         dxi=dc(1,i)
2658         dyi=dc(2,i)
2659         dzi=dc(3,i)
2660         dx_normi=dc_norm(1,i)
2661         dy_normi=dc_norm(2,i)
2662         dz_normi=dc_norm(3,i)
2663         xmedi=c(1,i)+0.5d0*dxi
2664         ymedi=c(2,i)+0.5d0*dyi
2665         zmedi=c(3,i)+0.5d0*dzi
2666 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2667         num_conti=num_cont_hb(i)
2668         do j=ielstart(i),ielend(i)
2669 !          write (iout,*) i,j,itype(i),itype(j)
2670           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2671           call eelecij(i,j,ees,evdw1,eel_loc)
2672         enddo ! j
2673         num_cont_hb(i)=num_conti
2674       enddo   ! i
2675 !      write (iout,*) "Number of loop steps in EELEC:",ind
2676 !d      do i=1,nres
2677 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2678 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2679 !d      enddo
2680 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2681 !cc      eel_loc=eel_loc+eello_turn3
2682 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2683       return
2684       end subroutine eelec
2685 !-----------------------------------------------------------------------------
2686       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2687
2688       use comm_locel
2689 !      implicit real*8 (a-h,o-z)
2690 !      include 'DIMENSIONS'
2691 #ifdef MPI
2692       include "mpif.h"
2693 #endif
2694 !      include 'COMMON.CONTROL'
2695 !      include 'COMMON.IOUNITS'
2696 !      include 'COMMON.GEO'
2697 !      include 'COMMON.VAR'
2698 !      include 'COMMON.LOCAL'
2699 !      include 'COMMON.CHAIN'
2700 !      include 'COMMON.DERIV'
2701 !      include 'COMMON.INTERACT'
2702 !      include 'COMMON.CONTACTS'
2703 !      include 'COMMON.TORSION'
2704 !      include 'COMMON.VECTORS'
2705 !      include 'COMMON.FFIELD'
2706 !      include 'COMMON.TIME1'
2707       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2708       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2709       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2710 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2711       real(kind=8),dimension(4) :: muij
2712 !el      integer :: num_conti,j1,j2
2713 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2714 !el        dz_normi,xmedi,ymedi,zmedi
2715
2716 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2717 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2718 !el          num_conti,j1,j2
2719
2720 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2721 #ifdef MOMENT
2722       real(kind=8) :: scal_el=1.0d0
2723 #else
2724       real(kind=8) :: scal_el=0.5d0
2725 #endif
2726 ! 12/13/98
2727 ! 13-go grudnia roku pamietnego...
2728       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2729                                              0.0d0,1.0d0,0.0d0,&
2730                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2731 !      integer :: maxconts=nres/4
2732 !el local variables
2733       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m
2734       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
2735       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
2736       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
2737                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
2738                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
2739                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
2740                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
2741                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
2742                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
2743                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
2744 !      maxconts=nres/4
2745 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
2746 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
2747
2748 !          time00=MPI_Wtime()
2749 !d      write (iout,*) "eelecij",i,j
2750 !          ind=ind+1
2751           iteli=itel(i)
2752           itelj=itel(j)
2753           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2754           aaa=app(iteli,itelj)
2755           bbb=bpp(iteli,itelj)
2756           ael6i=ael6(iteli,itelj)
2757           ael3i=ael3(iteli,itelj)
2758           dxj=dc(1,j)
2759           dyj=dc(2,j)
2760           dzj=dc(3,j)
2761           dx_normj=dc_norm(1,j)
2762           dy_normj=dc_norm(2,j)
2763           dz_normj=dc_norm(3,j)
2764           xj=c(1,j)+0.5D0*dxj-xmedi
2765           yj=c(2,j)+0.5D0*dyj-ymedi
2766           zj=c(3,j)+0.5D0*dzj-zmedi
2767           rij=xj*xj+yj*yj+zj*zj
2768           rrmij=1.0D0/rij
2769           rij=dsqrt(rij)
2770           rmij=1.0D0/rij
2771           r3ij=rrmij*rmij
2772           r6ij=r3ij*r3ij
2773           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2774           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2775           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2776           fac=cosa-3.0D0*cosb*cosg
2777           ev1=aaa*r6ij*r6ij
2778 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2779           if (j.eq.i+2) ev1=scal_el*ev1
2780           ev2=bbb*r6ij
2781           fac3=ael6i*r6ij
2782           fac4=ael3i*r3ij
2783           evdwij=ev1+ev2
2784           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2785           el2=fac4*fac
2786           eesij=el1+el2
2787 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
2788           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2789           ees=ees+eesij
2790           evdw1=evdw1+evdwij
2791 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2792 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2793 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2794 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
2795
2796           if (energy_dec) then
2797 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
2798 !                  'evdw1',i,j,evdwij,&
2799 !                  iteli,itelj,aaa,evdw1
2800               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2801               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2802           endif
2803 !
2804 ! Calculate contributions to the Cartesian gradient.
2805 !
2806 #ifdef SPLITELE
2807           facvdw=-6*rrmij*(ev1+evdwij)
2808           facel=-3*rrmij*(el1+eesij)
2809           fac1=fac
2810           erij(1)=xj*rmij
2811           erij(2)=yj*rmij
2812           erij(3)=zj*rmij
2813 !
2814 ! Radial derivatives. First process both termini of the fragment (i,j)
2815 !
2816           ggg(1)=facel*xj
2817           ggg(2)=facel*yj
2818           ggg(3)=facel*zj
2819 !          do k=1,3
2820 !            ghalf=0.5D0*ggg(k)
2821 !            gelc(k,i)=gelc(k,i)+ghalf
2822 !            gelc(k,j)=gelc(k,j)+ghalf
2823 !          enddo
2824 ! 9/28/08 AL Gradient compotents will be summed only at the end
2825           do k=1,3
2826             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2827             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2828           enddo
2829 !
2830 ! Loop over residues i+1 thru j-1.
2831 !
2832 !grad          do k=i+1,j-1
2833 !grad            do l=1,3
2834 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2835 !grad            enddo
2836 !grad          enddo
2837           ggg(1)=facvdw*xj
2838           ggg(2)=facvdw*yj
2839           ggg(3)=facvdw*zj
2840 !          do k=1,3
2841 !            ghalf=0.5D0*ggg(k)
2842 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2843 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2844 !          enddo
2845 ! 9/28/08 AL Gradient compotents will be summed only at the end
2846           do k=1,3
2847             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2848             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2849           enddo
2850 !
2851 ! Loop over residues i+1 thru j-1.
2852 !
2853 !grad          do k=i+1,j-1
2854 !grad            do l=1,3
2855 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2856 !grad            enddo
2857 !grad          enddo
2858 #else
2859           facvdw=ev1+evdwij
2860           facel=el1+eesij
2861           fac1=fac
2862           fac=-3*rrmij*(facvdw+facvdw+facel)
2863           erij(1)=xj*rmij
2864           erij(2)=yj*rmij
2865           erij(3)=zj*rmij
2866 !
2867 ! Radial derivatives. First process both termini of the fragment (i,j)
2868 !
2869           ggg(1)=fac*xj
2870           ggg(2)=fac*yj
2871           ggg(3)=fac*zj
2872 !          do k=1,3
2873 !            ghalf=0.5D0*ggg(k)
2874 !            gelc(k,i)=gelc(k,i)+ghalf
2875 !            gelc(k,j)=gelc(k,j)+ghalf
2876 !          enddo
2877 ! 9/28/08 AL Gradient compotents will be summed only at the end
2878           do k=1,3
2879             gelc_long(k,j)=gelc(k,j)+ggg(k)
2880             gelc_long(k,i)=gelc(k,i)-ggg(k)
2881           enddo
2882 !
2883 ! Loop over residues i+1 thru j-1.
2884 !
2885 !grad          do k=i+1,j-1
2886 !grad            do l=1,3
2887 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2888 !grad            enddo
2889 !grad          enddo
2890 ! 9/28/08 AL Gradient compotents will be summed only at the end
2891           ggg(1)=facvdw*xj
2892           ggg(2)=facvdw*yj
2893           ggg(3)=facvdw*zj
2894           do k=1,3
2895             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2896             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2897           enddo
2898 #endif
2899 !
2900 ! Angular part
2901 !
2902           ecosa=2.0D0*fac3*fac1+fac4
2903           fac4=-3.0D0*fac4
2904           fac3=-6.0D0*fac3
2905           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2906           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2907           do k=1,3
2908             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2909             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2910           enddo
2911 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2912 !d   &          (dcosg(k),k=1,3)
2913           do k=1,3
2914             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2915           enddo
2916 !          do k=1,3
2917 !            ghalf=0.5D0*ggg(k)
2918 !            gelc(k,i)=gelc(k,i)+ghalf
2919 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2920 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2921 !            gelc(k,j)=gelc(k,j)+ghalf
2922 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2923 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2924 !          enddo
2925 !grad          do k=i+1,j-1
2926 !grad            do l=1,3
2927 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2928 !grad            enddo
2929 !grad          enddo
2930           do k=1,3
2931             gelc(k,i)=gelc(k,i) &
2932                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
2933                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2934             gelc(k,j)=gelc(k,j) &
2935                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
2936                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2937             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2938             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2939           enddo
2940           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2941               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
2942               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2943 !
2944 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2945 !   energy of a peptide unit is assumed in the form of a second-order
2946 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2947 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2948 !   are computed for EVERY pair of non-contiguous peptide groups.
2949 !
2950           if (j.lt.nres-1) then
2951             j1=j+1
2952             j2=j-1
2953           else
2954             j1=j-1
2955             j2=j-2
2956           endif
2957           kkk=0
2958           do k=1,2
2959             do l=1,2
2960               kkk=kkk+1
2961               muij(kkk)=mu(k,i)*mu(l,j)
2962             enddo
2963           enddo
2964 !d         write (iout,*) 'EELEC: i',i,' j',j
2965 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
2966 !d          write(iout,*) 'muij',muij
2967           ury=scalar(uy(1,i),erij)
2968           urz=scalar(uz(1,i),erij)
2969           vry=scalar(uy(1,j),erij)
2970           vrz=scalar(uz(1,j),erij)
2971           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2972           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2973           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2974           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2975           fac=dsqrt(-ael6i)*r3ij
2976           a22=a22*fac
2977           a23=a23*fac
2978           a32=a32*fac
2979           a33=a33*fac
2980 !d          write (iout,'(4i5,4f10.5)')
2981 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2982 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2983 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2984 !d     &      uy(:,j),uz(:,j)
2985 !d          write (iout,'(4f10.5)')
2986 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2987 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2988 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
2989 !d           write (iout,'(9f10.5/)')
2990 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2991 ! Derivatives of the elements of A in virtual-bond vectors
2992           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2993           do k=1,3
2994             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2995             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2996             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2997             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2998             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2999             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3000             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3001             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3002             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3003             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3004             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3005             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3006           enddo
3007 ! Compute radial contributions to the gradient
3008           facr=-3.0d0*rrmij
3009           a22der=a22*facr
3010           a23der=a23*facr
3011           a32der=a32*facr
3012           a33der=a33*facr
3013           agg(1,1)=a22der*xj
3014           agg(2,1)=a22der*yj
3015           agg(3,1)=a22der*zj
3016           agg(1,2)=a23der*xj
3017           agg(2,2)=a23der*yj
3018           agg(3,2)=a23der*zj
3019           agg(1,3)=a32der*xj
3020           agg(2,3)=a32der*yj
3021           agg(3,3)=a32der*zj
3022           agg(1,4)=a33der*xj
3023           agg(2,4)=a33der*yj
3024           agg(3,4)=a33der*zj
3025 ! Add the contributions coming from er
3026           fac3=-3.0d0*fac
3027           do k=1,3
3028             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3029             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3030             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3031             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3032           enddo
3033           do k=1,3
3034 ! Derivatives in DC(i)
3035 !grad            ghalf1=0.5d0*agg(k,1)
3036 !grad            ghalf2=0.5d0*agg(k,2)
3037 !grad            ghalf3=0.5d0*agg(k,3)
3038 !grad            ghalf4=0.5d0*agg(k,4)
3039             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3040             -3.0d0*uryg(k,2)*vry)!+ghalf1
3041             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3042             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3043             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3044             -3.0d0*urzg(k,2)*vry)!+ghalf3
3045             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3046             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3047 ! Derivatives in DC(i+1)
3048             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3049             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3050             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3051             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3052             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3053             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3054             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3055             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3056 ! Derivatives in DC(j)
3057             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3058             -3.0d0*vryg(k,2)*ury)!+ghalf1
3059             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3060             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3061             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3062             -3.0d0*vryg(k,2)*urz)!+ghalf3
3063             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3064             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3065 ! Derivatives in DC(j+1) or DC(nres-1)
3066             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3067             -3.0d0*vryg(k,3)*ury)
3068             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3069             -3.0d0*vrzg(k,3)*ury)
3070             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3071             -3.0d0*vryg(k,3)*urz)
3072             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3073             -3.0d0*vrzg(k,3)*urz)
3074 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3075 !grad              do l=1,4
3076 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3077 !grad              enddo
3078 !grad            endif
3079           enddo
3080           acipa(1,1)=a22
3081           acipa(1,2)=a23
3082           acipa(2,1)=a32
3083           acipa(2,2)=a33
3084           a22=-a22
3085           a23=-a23
3086           do l=1,2
3087             do k=1,3
3088               agg(k,l)=-agg(k,l)
3089               aggi(k,l)=-aggi(k,l)
3090               aggi1(k,l)=-aggi1(k,l)
3091               aggj(k,l)=-aggj(k,l)
3092               aggj1(k,l)=-aggj1(k,l)
3093             enddo
3094           enddo
3095           if (j.lt.nres-1) then
3096             a22=-a22
3097             a32=-a32
3098             do l=1,3,2
3099               do k=1,3
3100                 agg(k,l)=-agg(k,l)
3101                 aggi(k,l)=-aggi(k,l)
3102                 aggi1(k,l)=-aggi1(k,l)
3103                 aggj(k,l)=-aggj(k,l)
3104                 aggj1(k,l)=-aggj1(k,l)
3105               enddo
3106             enddo
3107           else
3108             a22=-a22
3109             a23=-a23
3110             a32=-a32
3111             a33=-a33
3112             do l=1,4
3113               do k=1,3
3114                 agg(k,l)=-agg(k,l)
3115                 aggi(k,l)=-aggi(k,l)
3116                 aggi1(k,l)=-aggi1(k,l)
3117                 aggj(k,l)=-aggj(k,l)
3118                 aggj1(k,l)=-aggj1(k,l)
3119               enddo
3120             enddo
3121           endif
3122           ENDIF ! WCORR
3123           IF (wel_loc.gt.0.0d0) THEN
3124 ! Contribution to the local-electrostatic energy coming from the i-j pair
3125           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3126            +a33*muij(4)
3127 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3128
3129           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3130                   'eelloc',i,j,eel_loc_ij
3131 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3132 !          if (energy_dec) write (iout,*) "muij",muij
3133 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3134
3135           eel_loc=eel_loc+eel_loc_ij
3136 ! Partial derivatives in virtual-bond dihedral angles gamma
3137           if (i.gt.1) &
3138           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3139                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3140                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3141           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3142                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3143                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3144 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3145           do l=1,3
3146             ggg(l)=agg(l,1)*muij(1)+ &
3147                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3148             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3149             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3150 !grad            ghalf=0.5d0*ggg(l)
3151 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3152 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3153           enddo
3154 !grad          do k=i+1,j2
3155 !grad            do l=1,3
3156 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3157 !grad            enddo
3158 !grad          enddo
3159 ! Remaining derivatives of eello
3160           do l=1,3
3161             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
3162                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3163             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
3164                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3165             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
3166                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3167             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
3168                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3169           enddo
3170           ENDIF
3171 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3172 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3173           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3174              .and. num_conti.le.maxconts) then
3175 !            write (iout,*) i,j," entered corr"
3176 !
3177 ! Calculate the contact function. The ith column of the array JCONT will
3178 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3179 ! greater than I). The arrays FACONT and GACONT will contain the values of
3180 ! the contact function and its derivative.
3181 !           r0ij=1.02D0*rpp(iteli,itelj)
3182 !           r0ij=1.11D0*rpp(iteli,itelj)
3183             r0ij=2.20D0*rpp(iteli,itelj)
3184 !           r0ij=1.55D0*rpp(iteli,itelj)
3185             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3186 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3187             if (fcont.gt.0.0D0) then
3188               num_conti=num_conti+1
3189               if (num_conti.gt.maxconts) then
3190 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3191 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3192                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3193                                ' will skip next contacts for this conf.', num_conti
3194               else
3195                 jcont_hb(num_conti,i)=j
3196 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3197 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3198                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3199                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3200 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3201 !  terms.
3202                 d_cont(num_conti,i)=rij
3203 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3204 !     --- Electrostatic-interaction matrix ---
3205                 a_chuj(1,1,num_conti,i)=a22
3206                 a_chuj(1,2,num_conti,i)=a23
3207                 a_chuj(2,1,num_conti,i)=a32
3208                 a_chuj(2,2,num_conti,i)=a33
3209 !     --- Gradient of rij
3210                 do kkk=1,3
3211                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3212                 enddo
3213                 kkll=0
3214                 do k=1,2
3215                   do l=1,2
3216                     kkll=kkll+1
3217                     do m=1,3
3218                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3219                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3220                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3221                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3222                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3223                     enddo
3224                   enddo
3225                 enddo
3226                 ENDIF
3227                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3228 ! Calculate contact energies
3229                 cosa4=4.0D0*cosa
3230                 wij=cosa-3.0D0*cosb*cosg
3231                 cosbg1=cosb+cosg
3232                 cosbg2=cosb-cosg
3233 !               fac3=dsqrt(-ael6i)/r0ij**3
3234                 fac3=dsqrt(-ael6i)*r3ij
3235 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3236                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3237                 if (ees0tmp.gt.0) then
3238                   ees0pij=dsqrt(ees0tmp)
3239                 else
3240                   ees0pij=0
3241                 endif
3242 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3243                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3244                 if (ees0tmp.gt.0) then
3245                   ees0mij=dsqrt(ees0tmp)
3246                 else
3247                   ees0mij=0
3248                 endif
3249 !               ees0mij=0.0D0
3250                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3251                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3252 ! Diagnostics. Comment out or remove after debugging!
3253 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3254 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3255 !               ees0m(num_conti,i)=0.0D0
3256 ! End diagnostics.
3257 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3258 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3259 ! Angular derivatives of the contact function
3260                 ees0pij1=fac3/ees0pij
3261                 ees0mij1=fac3/ees0mij
3262                 fac3p=-3.0D0*fac3*rrmij
3263                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3264                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3265 !               ees0mij1=0.0D0
3266                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3267                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3268                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3269                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3270                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3271                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3272                 ecosap=ecosa1+ecosa2
3273                 ecosbp=ecosb1+ecosb2
3274                 ecosgp=ecosg1+ecosg2
3275                 ecosam=ecosa1-ecosa2
3276                 ecosbm=ecosb1-ecosb2
3277                 ecosgm=ecosg1-ecosg2
3278 ! Diagnostics
3279 !               ecosap=ecosa1
3280 !               ecosbp=ecosb1
3281 !               ecosgp=ecosg1
3282 !               ecosam=0.0D0
3283 !               ecosbm=0.0D0
3284 !               ecosgm=0.0D0
3285 ! End diagnostics
3286                 facont_hb(num_conti,i)=fcont
3287                 fprimcont=fprimcont/rij
3288 !d              facont_hb(num_conti,i)=1.0D0
3289 ! Following line is for diagnostics.
3290 !d              fprimcont=0.0D0
3291                 do k=1,3
3292                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3293                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3294                 enddo
3295                 do k=1,3
3296                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3297                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3298                 enddo
3299                 gggp(1)=gggp(1)+ees0pijp*xj
3300                 gggp(2)=gggp(2)+ees0pijp*yj
3301                 gggp(3)=gggp(3)+ees0pijp*zj
3302                 gggm(1)=gggm(1)+ees0mijp*xj
3303                 gggm(2)=gggm(2)+ees0mijp*yj
3304                 gggm(3)=gggm(3)+ees0mijp*zj
3305 ! Derivatives due to the contact function
3306                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3307                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3308                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3309                 do k=1,3
3310 !
3311 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3312 !          following the change of gradient-summation algorithm.
3313 !
3314 !grad                  ghalfp=0.5D0*gggp(k)
3315 !grad                  ghalfm=0.5D0*gggm(k)
3316                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3317                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3318                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3319                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3320                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3321                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3322                   gacontp_hb3(k,num_conti,i)=gggp(k)
3323                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3324                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3325                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3326                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3327                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3328                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3329                   gacontm_hb3(k,num_conti,i)=gggm(k)
3330                 enddo
3331 ! Diagnostics. Comment out or remove after debugging!
3332 !diag           do k=1,3
3333 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3334 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3335 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3336 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3337 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3338 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3339 !diag           enddo
3340               ENDIF ! wcorr
3341               endif  ! num_conti.le.maxconts
3342             endif  ! fcont.gt.0
3343           endif    ! j.gt.i+1
3344           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3345             do k=1,4
3346               do l=1,3
3347                 ghalf=0.5d0*agg(l,k)
3348                 aggi(l,k)=aggi(l,k)+ghalf
3349                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3350                 aggj(l,k)=aggj(l,k)+ghalf
3351               enddo
3352             enddo
3353             if (j.eq.nres-1 .and. i.lt.j-2) then
3354               do k=1,4
3355                 do l=1,3
3356                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3357                 enddo
3358               enddo
3359             endif
3360           endif
3361 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3362       return
3363       end subroutine eelecij
3364 !-----------------------------------------------------------------------------
3365       subroutine eturn3(i,eello_turn3)
3366 ! Third- and fourth-order contributions from turns
3367
3368       use comm_locel
3369 !      implicit real*8 (a-h,o-z)
3370 !      include 'DIMENSIONS'
3371 !      include 'COMMON.IOUNITS'
3372 !      include 'COMMON.GEO'
3373 !      include 'COMMON.VAR'
3374 !      include 'COMMON.LOCAL'
3375 !      include 'COMMON.CHAIN'
3376 !      include 'COMMON.DERIV'
3377 !      include 'COMMON.INTERACT'
3378 !      include 'COMMON.CONTACTS'
3379 !      include 'COMMON.TORSION'
3380 !      include 'COMMON.VECTORS'
3381 !      include 'COMMON.FFIELD'
3382 !      include 'COMMON.CONTROL'
3383       real(kind=8),dimension(3) :: ggg
3384       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3385         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3386       real(kind=8),dimension(2) :: auxvec,auxvec1
3387 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3388       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3389 !el      integer :: num_conti,j1,j2
3390 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3391 !el        dz_normi,xmedi,ymedi,zmedi
3392
3393 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3394 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3395 !el         num_conti,j1,j2
3396 !el local variables
3397       integer :: i,j,l
3398       real(kind=8) :: eello_turn3
3399
3400       j=i+2
3401 !      write (iout,*) "eturn3",i,j,j1,j2
3402       a_temp(1,1)=a22
3403       a_temp(1,2)=a23
3404       a_temp(2,1)=a32
3405       a_temp(2,2)=a33
3406 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3407 !
3408 !               Third-order contributions
3409 !
3410 !                 (i+2)o----(i+3)
3411 !                      | |
3412 !                      | |
3413 !                 (i+1)o----i
3414 !
3415 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3416 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3417         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3418         call transpose2(auxmat(1,1),auxmat1(1,1))
3419         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3420         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3421         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3422                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3423 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3424 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3425 !d     &    ' eello_turn3_num',4*eello_turn3_num
3426 ! Derivatives in gamma(i)
3427         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3428         call transpose2(auxmat2(1,1),auxmat3(1,1))
3429         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3430         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3431 ! Derivatives in gamma(i+1)
3432         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3433         call transpose2(auxmat2(1,1),auxmat3(1,1))
3434         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3435         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3436           +0.5d0*(pizda(1,1)+pizda(2,2))
3437 ! Cartesian derivatives
3438         do l=1,3
3439 !            ghalf1=0.5d0*agg(l,1)
3440 !            ghalf2=0.5d0*agg(l,2)
3441 !            ghalf3=0.5d0*agg(l,3)
3442 !            ghalf4=0.5d0*agg(l,4)
3443           a_temp(1,1)=aggi(l,1)!+ghalf1
3444           a_temp(1,2)=aggi(l,2)!+ghalf2
3445           a_temp(2,1)=aggi(l,3)!+ghalf3
3446           a_temp(2,2)=aggi(l,4)!+ghalf4
3447           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3448           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3449             +0.5d0*(pizda(1,1)+pizda(2,2))
3450           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3451           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3452           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3453           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3454           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3455           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3456             +0.5d0*(pizda(1,1)+pizda(2,2))
3457           a_temp(1,1)=aggj(l,1)!+ghalf1
3458           a_temp(1,2)=aggj(l,2)!+ghalf2
3459           a_temp(2,1)=aggj(l,3)!+ghalf3
3460           a_temp(2,2)=aggj(l,4)!+ghalf4
3461           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3462           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3463             +0.5d0*(pizda(1,1)+pizda(2,2))
3464           a_temp(1,1)=aggj1(l,1)
3465           a_temp(1,2)=aggj1(l,2)
3466           a_temp(2,1)=aggj1(l,3)
3467           a_temp(2,2)=aggj1(l,4)
3468           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3469           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3470             +0.5d0*(pizda(1,1)+pizda(2,2))
3471         enddo
3472       return
3473       end subroutine eturn3
3474 !-----------------------------------------------------------------------------
3475       subroutine eturn4(i,eello_turn4)
3476 ! Third- and fourth-order contributions from turns
3477
3478       use comm_locel
3479 !      implicit real*8 (a-h,o-z)
3480 !      include 'DIMENSIONS'
3481 !      include 'COMMON.IOUNITS'
3482 !      include 'COMMON.GEO'
3483 !      include 'COMMON.VAR'
3484 !      include 'COMMON.LOCAL'
3485 !      include 'COMMON.CHAIN'
3486 !      include 'COMMON.DERIV'
3487 !      include 'COMMON.INTERACT'
3488 !      include 'COMMON.CONTACTS'
3489 !      include 'COMMON.TORSION'
3490 !      include 'COMMON.VECTORS'
3491 !      include 'COMMON.FFIELD'
3492 !      include 'COMMON.CONTROL'
3493       real(kind=8),dimension(3) :: ggg
3494       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3495         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3496       real(kind=8),dimension(2) :: auxvec,auxvec1
3497 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3498       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3499 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3500 !el        dz_normi,xmedi,ymedi,zmedi
3501 !el      integer :: num_conti,j1,j2
3502 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3503 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3504 !el          num_conti,j1,j2
3505 !el local variables
3506       integer :: i,j,iti1,iti2,iti3,l
3507       real(kind=8) :: eello_turn4,s1,s2,s3
3508
3509       j=i+3
3510 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3511 !
3512 !               Fourth-order contributions
3513 !
3514 !                 (i+3)o----(i+4)
3515 !                     /  |
3516 !               (i+2)o   |
3517 !                     \  |
3518 !                 (i+1)o----i
3519 !
3520 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3521 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3522 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3523         a_temp(1,1)=a22
3524         a_temp(1,2)=a23
3525         a_temp(2,1)=a32
3526         a_temp(2,2)=a33
3527         iti1=itortyp(itype(i+1))
3528         iti2=itortyp(itype(i+2))
3529         iti3=itortyp(itype(i+3))
3530 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3531         call transpose2(EUg(1,1,i+1),e1t(1,1))
3532         call transpose2(Eug(1,1,i+2),e2t(1,1))
3533         call transpose2(Eug(1,1,i+3),e3t(1,1))
3534         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3535         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3536         s1=scalar2(b1(1,iti2),auxvec(1))
3537         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3538         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3539         s2=scalar2(b1(1,iti1),auxvec(1))
3540         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3541         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3542         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3543         eello_turn4=eello_turn4-(s1+s2+s3)
3544         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3545            'eturn4',i,j,-(s1+s2+s3)
3546 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3547 !d     &    ' eello_turn4_num',8*eello_turn4_num
3548 ! Derivatives in gamma(i)
3549         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3550         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3551         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3552         s1=scalar2(b1(1,iti2),auxvec(1))
3553         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3554         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3555         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3556 ! Derivatives in gamma(i+1)
3557         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3558         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3559         s2=scalar2(b1(1,iti1),auxvec(1))
3560         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3561         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3562         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3563         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3564 ! Derivatives in gamma(i+2)
3565         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3566         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3567         s1=scalar2(b1(1,iti2),auxvec(1))
3568         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3569         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3570         s2=scalar2(b1(1,iti1),auxvec(1))
3571         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3572         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3573         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3574         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3575 ! Cartesian derivatives
3576 ! Derivatives of this turn contributions in DC(i+2)
3577         if (j.lt.nres-1) then
3578           do l=1,3
3579             a_temp(1,1)=agg(l,1)
3580             a_temp(1,2)=agg(l,2)
3581             a_temp(2,1)=agg(l,3)
3582             a_temp(2,2)=agg(l,4)
3583             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3584             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3585             s1=scalar2(b1(1,iti2),auxvec(1))
3586             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3587             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3588             s2=scalar2(b1(1,iti1),auxvec(1))
3589             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3590             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3591             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3592             ggg(l)=-(s1+s2+s3)
3593             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3594           enddo
3595         endif
3596 ! Remaining derivatives of this turn contribution
3597         do l=1,3
3598           a_temp(1,1)=aggi(l,1)
3599           a_temp(1,2)=aggi(l,2)
3600           a_temp(2,1)=aggi(l,3)
3601           a_temp(2,2)=aggi(l,4)
3602           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3603           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3604           s1=scalar2(b1(1,iti2),auxvec(1))
3605           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3606           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3607           s2=scalar2(b1(1,iti1),auxvec(1))
3608           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3609           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3610           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3611           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3612           a_temp(1,1)=aggi1(l,1)
3613           a_temp(1,2)=aggi1(l,2)
3614           a_temp(2,1)=aggi1(l,3)
3615           a_temp(2,2)=aggi1(l,4)
3616           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3617           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3618           s1=scalar2(b1(1,iti2),auxvec(1))
3619           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3620           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3621           s2=scalar2(b1(1,iti1),auxvec(1))
3622           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3623           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3624           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3625           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3626           a_temp(1,1)=aggj(l,1)
3627           a_temp(1,2)=aggj(l,2)
3628           a_temp(2,1)=aggj(l,3)
3629           a_temp(2,2)=aggj(l,4)
3630           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3631           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3632           s1=scalar2(b1(1,iti2),auxvec(1))
3633           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3634           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3635           s2=scalar2(b1(1,iti1),auxvec(1))
3636           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3637           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3638           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3639           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3640           a_temp(1,1)=aggj1(l,1)
3641           a_temp(1,2)=aggj1(l,2)
3642           a_temp(2,1)=aggj1(l,3)
3643           a_temp(2,2)=aggj1(l,4)
3644           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3645           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3646           s1=scalar2(b1(1,iti2),auxvec(1))
3647           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3648           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3649           s2=scalar2(b1(1,iti1),auxvec(1))
3650           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3651           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3652           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3653 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3654           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3655         enddo
3656       return
3657       end subroutine eturn4
3658 !-----------------------------------------------------------------------------
3659       subroutine unormderiv(u,ugrad,unorm,ungrad)
3660 ! This subroutine computes the derivatives of a normalized vector u, given
3661 ! the derivatives computed without normalization conditions, ugrad. Returns
3662 ! ungrad.
3663 !      implicit none
3664       real(kind=8),dimension(3) :: u,vec
3665       real(kind=8),dimension(3,3) ::ugrad,ungrad
3666       real(kind=8) :: unorm     !,scalar
3667       integer :: i,j
3668 !      write (2,*) 'ugrad',ugrad
3669 !      write (2,*) 'u',u
3670       do i=1,3
3671         vec(i)=scalar(ugrad(1,i),u(1))
3672       enddo
3673 !      write (2,*) 'vec',vec
3674       do i=1,3
3675         do j=1,3
3676           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3677         enddo
3678       enddo
3679 !      write (2,*) 'ungrad',ungrad
3680       return
3681       end subroutine unormderiv
3682 !-----------------------------------------------------------------------------
3683       subroutine escp_soft_sphere(evdw2,evdw2_14)
3684 !
3685 ! This subroutine calculates the excluded-volume interaction energy between
3686 ! peptide-group centers and side chains and its gradient in virtual-bond and
3687 ! side-chain vectors.
3688 !
3689 !      implicit real*8 (a-h,o-z)
3690 !      include 'DIMENSIONS'
3691 !      include 'COMMON.GEO'
3692 !      include 'COMMON.VAR'
3693 !      include 'COMMON.LOCAL'
3694 !      include 'COMMON.CHAIN'
3695 !      include 'COMMON.DERIV'
3696 !      include 'COMMON.INTERACT'
3697 !      include 'COMMON.FFIELD'
3698 !      include 'COMMON.IOUNITS'
3699 !      include 'COMMON.CONTROL'
3700       real(kind=8),dimension(3) :: ggg
3701 !el local variables
3702       integer :: i,iint,j,k,iteli,itypj
3703       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3704                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3705
3706       evdw2=0.0D0
3707       evdw2_14=0.0d0
3708       r0_scp=4.5d0
3709 !d    print '(a)','Enter ESCP'
3710 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3711       do i=iatscp_s,iatscp_e
3712         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3713         iteli=itel(i)
3714         xi=0.5D0*(c(1,i)+c(1,i+1))
3715         yi=0.5D0*(c(2,i)+c(2,i+1))
3716         zi=0.5D0*(c(3,i)+c(3,i+1))
3717
3718         do iint=1,nscp_gr(i)
3719
3720         do j=iscpstart(i,iint),iscpend(i,iint)
3721           if (itype(j).eq.ntyp1) cycle
3722           itypj=iabs(itype(j))
3723 ! Uncomment following three lines for SC-p interactions
3724 !         xj=c(1,nres+j)-xi
3725 !         yj=c(2,nres+j)-yi
3726 !         zj=c(3,nres+j)-zi
3727 ! Uncomment following three lines for Ca-p interactions
3728           xj=c(1,j)-xi
3729           yj=c(2,j)-yi
3730           zj=c(3,j)-zi
3731           rij=xj*xj+yj*yj+zj*zj
3732           r0ij=r0_scp
3733           r0ijsq=r0ij*r0ij
3734           if (rij.lt.r0ijsq) then
3735             evdwij=0.25d0*(rij-r0ijsq)**2
3736             fac=rij-r0ijsq
3737           else
3738             evdwij=0.0d0
3739             fac=0.0d0
3740           endif
3741           evdw2=evdw2+evdwij
3742 !
3743 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3744 !
3745           ggg(1)=xj*fac
3746           ggg(2)=yj*fac
3747           ggg(3)=zj*fac
3748 !grad          if (j.lt.i) then
3749 !d          write (iout,*) 'j<i'
3750 ! Uncomment following three lines for SC-p interactions
3751 !           do k=1,3
3752 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3753 !           enddo
3754 !grad          else
3755 !d          write (iout,*) 'j>i'
3756 !grad            do k=1,3
3757 !grad              ggg(k)=-ggg(k)
3758 ! Uncomment following line for SC-p interactions
3759 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3760 !grad            enddo
3761 !grad          endif
3762 !grad          do k=1,3
3763 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3764 !grad          enddo
3765 !grad          kstart=min0(i+1,j)
3766 !grad          kend=max0(i-1,j-1)
3767 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3768 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3769 !grad          do k=kstart,kend
3770 !grad            do l=1,3
3771 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3772 !grad            enddo
3773 !grad          enddo
3774           do k=1,3
3775             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3776             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3777           enddo
3778         enddo
3779
3780         enddo ! iint
3781       enddo ! i
3782       return
3783       end subroutine escp_soft_sphere
3784 !-----------------------------------------------------------------------------
3785       subroutine escp(evdw2,evdw2_14)
3786 !
3787 ! This subroutine calculates the excluded-volume interaction energy between
3788 ! peptide-group centers and side chains and its gradient in virtual-bond and
3789 ! side-chain vectors.
3790 !
3791 !      implicit real*8 (a-h,o-z)
3792 !      include 'DIMENSIONS'
3793 !      include 'COMMON.GEO'
3794 !      include 'COMMON.VAR'
3795 !      include 'COMMON.LOCAL'
3796 !      include 'COMMON.CHAIN'
3797 !      include 'COMMON.DERIV'
3798 !      include 'COMMON.INTERACT'
3799 !      include 'COMMON.FFIELD'
3800 !      include 'COMMON.IOUNITS'
3801 !      include 'COMMON.CONTROL'
3802       real(kind=8),dimension(3) :: ggg
3803 !el local variables
3804       integer :: i,iint,j,k,iteli,itypj
3805       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
3806                    e1,e2,evdwij
3807
3808       evdw2=0.0D0
3809       evdw2_14=0.0d0
3810 !d    print '(a)','Enter ESCP'
3811 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3812       do i=iatscp_s,iatscp_e
3813         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3814         iteli=itel(i)
3815         xi=0.5D0*(c(1,i)+c(1,i+1))
3816         yi=0.5D0*(c(2,i)+c(2,i+1))
3817         zi=0.5D0*(c(3,i)+c(3,i+1))
3818
3819         do iint=1,nscp_gr(i)
3820
3821         do j=iscpstart(i,iint),iscpend(i,iint)
3822           itypj=iabs(itype(j))
3823           if (itypj.eq.ntyp1) cycle
3824 ! Uncomment following three lines for SC-p interactions
3825 !         xj=c(1,nres+j)-xi
3826 !         yj=c(2,nres+j)-yi
3827 !         zj=c(3,nres+j)-zi
3828 ! Uncomment following three lines for Ca-p interactions
3829           xj=c(1,j)-xi
3830           yj=c(2,j)-yi
3831           zj=c(3,j)-zi
3832           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3833           fac=rrij**expon2
3834           e1=fac*fac*aad(itypj,iteli)
3835           e2=fac*bad(itypj,iteli)
3836           if (iabs(j-i) .le. 2) then
3837             e1=scal14*e1
3838             e2=scal14*e2
3839             evdw2_14=evdw2_14+e1+e2
3840           endif
3841           evdwij=e1+e2
3842           evdw2=evdw2+evdwij
3843 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
3844 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
3845           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3846              'evdw2',i,j,evdwij
3847 !
3848 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3849 !
3850           fac=-(evdwij+e1)*rrij
3851           ggg(1)=xj*fac
3852           ggg(2)=yj*fac
3853           ggg(3)=zj*fac
3854 !grad          if (j.lt.i) then
3855 !d          write (iout,*) 'j<i'
3856 ! Uncomment following three lines for SC-p interactions
3857 !           do k=1,3
3858 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3859 !           enddo
3860 !grad          else
3861 !d          write (iout,*) 'j>i'
3862 !grad            do k=1,3
3863 !grad              ggg(k)=-ggg(k)
3864 ! Uncomment following line for SC-p interactions
3865 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3866 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3867 !grad            enddo
3868 !grad          endif
3869 !grad          do k=1,3
3870 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3871 !grad          enddo
3872 !grad          kstart=min0(i+1,j)
3873 !grad          kend=max0(i-1,j-1)
3874 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3875 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3876 !grad          do k=kstart,kend
3877 !grad            do l=1,3
3878 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3879 !grad            enddo
3880 !grad          enddo
3881           do k=1,3
3882             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3883             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3884           enddo
3885         enddo
3886
3887         enddo ! iint
3888       enddo ! i
3889       do i=1,nct
3890         do j=1,3
3891           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3892           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3893           gradx_scp(j,i)=expon*gradx_scp(j,i)
3894         enddo
3895       enddo
3896 !******************************************************************************
3897 !
3898 !                              N O T E !!!
3899 !
3900 ! To save time the factor EXPON has been extracted from ALL components
3901 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
3902 ! use!
3903 !
3904 !******************************************************************************
3905       return
3906       end subroutine escp
3907 !-----------------------------------------------------------------------------
3908       subroutine edis(ehpb)
3909 !
3910 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3911 !
3912 !      implicit real*8 (a-h,o-z)
3913 !      include 'DIMENSIONS'
3914 !      include 'COMMON.SBRIDGE'
3915 !      include 'COMMON.CHAIN'
3916 !      include 'COMMON.DERIV'
3917 !      include 'COMMON.VAR'
3918 !      include 'COMMON.INTERACT'
3919 !      include 'COMMON.IOUNITS'
3920       real(kind=8),dimension(3) :: ggg
3921 !el local variables
3922       integer :: i,j,ii,jj,iii,jjj,k
3923       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
3924
3925       ehpb=0.0D0
3926 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3927 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
3928       if (link_end.eq.0) return
3929       do i=link_start,link_end
3930 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3931 ! CA-CA distance used in regularization of structure.
3932         ii=ihpb(i)
3933         jj=jhpb(i)
3934 ! iii and jjj point to the residues for which the distance is assigned.
3935         if (ii.gt.nres) then
3936           iii=ii-nres
3937           jjj=jj-nres
3938         else
3939           iii=ii
3940           jjj=jj
3941         endif
3942 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
3943 !     &    dhpb(i),dhpb1(i),forcon(i)
3944 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
3945 !    distance and angle dependent SS bond potential.
3946 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3947 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
3948         if (.not.dyn_ss .and. i.le.nss) then
3949 ! 15/02/13 CC dynamic SSbond - additional check
3950          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
3951         iabs(itype(jjj)).eq.1) then
3952           call ssbond_ene(iii,jjj,eij)
3953           ehpb=ehpb+2*eij
3954 !d          write (iout,*) "eij",eij
3955          endif
3956         else
3957 ! Calculate the distance between the two points and its difference from the
3958 ! target distance.
3959         dd=dist(ii,jj)
3960         rdis=dd-dhpb(i)
3961 ! Get the force constant corresponding to this distance.
3962         waga=forcon(i)
3963 ! Calculate the contribution to energy.
3964         ehpb=ehpb+waga*rdis*rdis
3965 !
3966 ! Evaluate gradient.
3967 !
3968         fac=waga*rdis/dd
3969 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3970 !d   &   ' waga=',waga,' fac=',fac
3971         do j=1,3
3972           ggg(j)=fac*(c(j,jj)-c(j,ii))
3973         enddo
3974 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3975 ! If this is a SC-SC distance, we need to calculate the contributions to the
3976 ! Cartesian gradient in the SC vectors (ghpbx).
3977         if (iii.lt.ii) then
3978           do j=1,3
3979             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3980             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3981           enddo
3982         endif
3983 !grad        do j=iii,jjj-1
3984 !grad          do k=1,3
3985 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3986 !grad          enddo
3987 !grad        enddo
3988         do k=1,3
3989           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3990           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3991         enddo
3992         endif
3993       enddo
3994       ehpb=0.5D0*ehpb
3995       return
3996       end subroutine edis
3997 !-----------------------------------------------------------------------------
3998       subroutine ssbond_ene(i,j,eij)
3999 !
4000 ! Calculate the distance and angle dependent SS-bond potential energy
4001 ! using a free-energy function derived based on RHF/6-31G** ab initio
4002 ! calculations of diethyl disulfide.
4003 !
4004 ! A. Liwo and U. Kozlowska, 11/24/03
4005 !
4006 !      implicit real*8 (a-h,o-z)
4007 !      include 'DIMENSIONS'
4008 !      include 'COMMON.SBRIDGE'
4009 !      include 'COMMON.CHAIN'
4010 !      include 'COMMON.DERIV'
4011 !      include 'COMMON.LOCAL'
4012 !      include 'COMMON.INTERACT'
4013 !      include 'COMMON.VAR'
4014 !      include 'COMMON.IOUNITS'
4015       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4016 !el local variables
4017       integer :: i,j,itypi,itypj,k
4018       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4019                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4020                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4021                    cosphi,ggk
4022
4023       itypi=iabs(itype(i))
4024       xi=c(1,nres+i)
4025       yi=c(2,nres+i)
4026       zi=c(3,nres+i)
4027       dxi=dc_norm(1,nres+i)
4028       dyi=dc_norm(2,nres+i)
4029       dzi=dc_norm(3,nres+i)
4030 !      dsci_inv=dsc_inv(itypi)
4031       dsci_inv=vbld_inv(nres+i)
4032       itypj=iabs(itype(j))
4033 !      dscj_inv=dsc_inv(itypj)
4034       dscj_inv=vbld_inv(nres+j)
4035       xj=c(1,nres+j)-xi
4036       yj=c(2,nres+j)-yi
4037       zj=c(3,nres+j)-zi
4038       dxj=dc_norm(1,nres+j)
4039       dyj=dc_norm(2,nres+j)
4040       dzj=dc_norm(3,nres+j)
4041       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4042       rij=dsqrt(rrij)
4043       erij(1)=xj*rij
4044       erij(2)=yj*rij
4045       erij(3)=zj*rij
4046       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4047       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4048       om12=dxi*dxj+dyi*dyj+dzi*dzj
4049       do k=1,3
4050         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4051         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4052       enddo
4053       rij=1.0d0/rij
4054       deltad=rij-d0cm
4055       deltat1=1.0d0-om1
4056       deltat2=1.0d0+om2
4057       deltat12=om2-om1+2.0d0
4058       cosphi=om12-om1*om2
4059       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4060         +akct*deltad*deltat12 &
4061         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4062 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4063 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4064 !     &  " deltat12",deltat12," eij",eij
4065       ed=2*akcm*deltad+akct*deltat12
4066       pom1=akct*deltad
4067       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4068       eom1=-2*akth*deltat1-pom1-om2*pom2
4069       eom2= 2*akth*deltat2+pom1-om1*pom2
4070       eom12=pom2
4071       do k=1,3
4072         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4073         ghpbx(k,i)=ghpbx(k,i)-ggk &
4074                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4075                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4076         ghpbx(k,j)=ghpbx(k,j)+ggk &
4077                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4078                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4079         ghpbc(k,i)=ghpbc(k,i)-ggk
4080         ghpbc(k,j)=ghpbc(k,j)+ggk
4081       enddo
4082 !
4083 ! Calculate the components of the gradient in DC and X
4084 !
4085 !grad      do k=i,j-1
4086 !grad        do l=1,3
4087 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4088 !grad        enddo
4089 !grad      enddo
4090       return
4091       end subroutine ssbond_ene
4092 !-----------------------------------------------------------------------------
4093       subroutine ebond(estr)
4094 !
4095 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4096 !
4097 !      implicit real*8 (a-h,o-z)
4098 !      include 'DIMENSIONS'
4099 !      include 'COMMON.LOCAL'
4100 !      include 'COMMON.GEO'
4101 !      include 'COMMON.INTERACT'
4102 !      include 'COMMON.DERIV'
4103 !      include 'COMMON.VAR'
4104 !      include 'COMMON.CHAIN'
4105 !      include 'COMMON.IOUNITS'
4106 !      include 'COMMON.NAMES'
4107 !      include 'COMMON.FFIELD'
4108 !      include 'COMMON.CONTROL'
4109 !      include 'COMMON.SETUP'
4110       real(kind=8),dimension(3) :: u,ud
4111 !el local variables
4112       integer :: i,j,iti,nbi,k
4113       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4114                    uprod1,uprod2
4115
4116       estr=0.0d0
4117       estr1=0.0d0
4118 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4119 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4120
4121       do i=ibondp_start,ibondp_end
4122         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4123           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4124           do j=1,3
4125           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4126             *dc(j,i-1)/vbld(i)
4127           enddo
4128           if (energy_dec) write(iout,*) &
4129              "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4130         else
4131         diff = vbld(i)-vbldp0
4132         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4133            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4134         estr=estr+diff*diff
4135         do j=1,3
4136           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4137         enddo
4138 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4139         endif
4140       enddo
4141       estr=0.5d0*AKP*estr+estr1
4142 !
4143 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4144 !
4145       do i=ibond_start,ibond_end
4146         iti=iabs(itype(i))
4147         if (iti.ne.10 .and. iti.ne.ntyp1) then
4148           nbi=nbondterm(iti)
4149           if (nbi.eq.1) then
4150             diff=vbld(i+nres)-vbldsc0(1,iti)
4151             if (energy_dec) write (iout,*) &
4152             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4153             AKSC(1,iti),AKSC(1,iti)*diff*diff
4154             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4155             do j=1,3
4156               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4157             enddo
4158           else
4159             do j=1,nbi
4160               diff=vbld(i+nres)-vbldsc0(j,iti)
4161               ud(j)=aksc(j,iti)*diff
4162               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4163             enddo
4164             uprod=u(1)
4165             do j=2,nbi
4166               uprod=uprod*u(j)
4167             enddo
4168             usum=0.0d0
4169             usumsqder=0.0d0
4170             do j=1,nbi
4171               uprod1=1.0d0
4172               uprod2=1.0d0
4173               do k=1,nbi
4174                 if (k.ne.j) then
4175                   uprod1=uprod1*u(k)
4176                   uprod2=uprod2*u(k)*u(k)
4177                 endif
4178               enddo
4179               usum=usum+uprod1
4180               usumsqder=usumsqder+ud(j)*uprod2
4181             enddo
4182             estr=estr+uprod/usum
4183             do j=1,3
4184              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4185             enddo
4186           endif
4187         endif
4188       enddo
4189       return
4190       end subroutine ebond
4191 #ifdef CRYST_THETA
4192 !-----------------------------------------------------------------------------
4193       subroutine ebend(etheta)
4194 !
4195 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4196 ! angles gamma and its derivatives in consecutive thetas and gammas.
4197 !
4198       use comm_calcthet
4199 !      implicit real*8 (a-h,o-z)
4200 !      include 'DIMENSIONS'
4201 !      include 'COMMON.LOCAL'
4202 !      include 'COMMON.GEO'
4203 !      include 'COMMON.INTERACT'
4204 !      include 'COMMON.DERIV'
4205 !      include 'COMMON.VAR'
4206 !      include 'COMMON.CHAIN'
4207 !      include 'COMMON.IOUNITS'
4208 !      include 'COMMON.NAMES'
4209 !      include 'COMMON.FFIELD'
4210 !      include 'COMMON.CONTROL'
4211 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4212 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4213 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4214 !el      integer :: it
4215 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4216 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4217 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4218 !el local variables
4219       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4220        ichir21,ichir22
4221       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4222        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4223        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4224       real(kind=8),dimension(2) :: y,z
4225
4226       delta=0.02d0*pi
4227 !      time11=dexp(-2*time)
4228 !      time12=1.0d0
4229       etheta=0.0D0
4230 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4231       do i=ithet_start,ithet_end
4232         if (itype(i-1).eq.ntyp1) cycle
4233 ! Zero the energy function and its derivative at 0 or pi.
4234         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4235         it=itype(i-1)
4236         ichir1=isign(1,itype(i-2))
4237         ichir2=isign(1,itype(i))
4238          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4239          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4240          if (itype(i-1).eq.10) then
4241           itype1=isign(10,itype(i-2))
4242           ichir11=isign(1,itype(i-2))
4243           ichir12=isign(1,itype(i-2))
4244           itype2=isign(10,itype(i))
4245           ichir21=isign(1,itype(i))
4246           ichir22=isign(1,itype(i))
4247          endif
4248
4249         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4250 #ifdef OSF
4251           phii=phi(i)
4252           if (phii.ne.phii) phii=150.0
4253 #else
4254           phii=phi(i)
4255 #endif
4256           y(1)=dcos(phii)
4257           y(2)=dsin(phii)
4258         else
4259           y(1)=0.0D0
4260           y(2)=0.0D0
4261         endif
4262         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4263 #ifdef OSF
4264           phii1=phi(i+1)
4265           if (phii1.ne.phii1) phii1=150.0
4266           phii1=pinorm(phii1)
4267           z(1)=cos(phii1)
4268 #else
4269           phii1=phi(i+1)
4270           z(1)=dcos(phii1)
4271 #endif
4272           z(2)=dsin(phii1)
4273         else
4274           z(1)=0.0D0
4275           z(2)=0.0D0
4276         endif
4277 ! Calculate the "mean" value of theta from the part of the distribution
4278 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4279 ! In following comments this theta will be referred to as t_c.
4280         thet_pred_mean=0.0d0
4281         do k=1,2
4282             athetk=athet(k,it,ichir1,ichir2)
4283             bthetk=bthet(k,it,ichir1,ichir2)
4284           if (it.eq.10) then
4285              athetk=athet(k,itype1,ichir11,ichir12)
4286              bthetk=bthet(k,itype2,ichir21,ichir22)
4287           endif
4288          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4289         enddo
4290         dthett=thet_pred_mean*ssd
4291         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4292 ! Derivatives of the "mean" values in gamma1 and gamma2.
4293         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4294                +athet(2,it,ichir1,ichir2)*y(1))*ss
4295         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4296                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4297          if (it.eq.10) then
4298         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4299              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4300         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4301                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4302          endif
4303         if (theta(i).gt.pi-delta) then
4304           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4305                E_tc0)
4306           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4307           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4308           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4309               E_theta)
4310           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4311               E_tc)
4312         else if (theta(i).lt.delta) then
4313           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4314           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4315           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4316               E_theta)
4317           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4318           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4319               E_tc)
4320         else
4321           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4322               E_theta,E_tc)
4323         endif
4324         etheta=etheta+ethetai
4325         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4326             'ebend',i,ethetai
4327         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4328         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4329         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4330       enddo
4331 ! Ufff.... We've done all this!!!
4332       return
4333       end subroutine ebend
4334 !-----------------------------------------------------------------------------
4335       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4336
4337       use comm_calcthet
4338 !      implicit real*8 (a-h,o-z)
4339 !      include 'DIMENSIONS'
4340 !      include 'COMMON.LOCAL'
4341 !      include 'COMMON.IOUNITS'
4342 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4343 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4344 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4345       integer :: i,j,k
4346       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4347 !el      integer :: it
4348 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4349 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4350 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4351 !el local variables
4352       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4353        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4354
4355 ! Calculate the contributions to both Gaussian lobes.
4356 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4357 ! The "polynomial part" of the "standard deviation" of this part of
4358 ! the distribution.
4359         sig=polthet(3,it)
4360         do j=2,0,-1
4361           sig=sig*thet_pred_mean+polthet(j,it)
4362         enddo
4363 ! Derivative of the "interior part" of the "standard deviation of the"
4364 ! gamma-dependent Gaussian lobe in t_c.
4365         sigtc=3*polthet(3,it)
4366         do j=2,1,-1
4367           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4368         enddo
4369         sigtc=sig*sigtc
4370 ! Set the parameters of both Gaussian lobes of the distribution.
4371 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4372         fac=sig*sig+sigc0(it)
4373         sigcsq=fac+fac
4374         sigc=1.0D0/sigcsq
4375 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4376         sigsqtc=-4.0D0*sigcsq*sigtc
4377 !       print *,i,sig,sigtc,sigsqtc
4378 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4379         sigtc=-sigtc/(fac*fac)
4380 ! Following variable is sigma(t_c)**(-2)
4381         sigcsq=sigcsq*sigcsq
4382         sig0i=sig0(it)
4383         sig0inv=1.0D0/sig0i**2
4384         delthec=thetai-thet_pred_mean
4385         delthe0=thetai-theta0i
4386         term1=-0.5D0*sigcsq*delthec*delthec
4387         term2=-0.5D0*sig0inv*delthe0*delthe0
4388 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4389 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4390 ! to the energy (this being the log of the distribution) at the end of energy
4391 ! term evaluation for this virtual-bond angle.
4392         if (term1.gt.term2) then
4393           termm=term1
4394           term2=dexp(term2-termm)
4395           term1=1.0d0
4396         else
4397           termm=term2
4398           term1=dexp(term1-termm)
4399           term2=1.0d0
4400         endif
4401 ! The ratio between the gamma-independent and gamma-dependent lobes of
4402 ! the distribution is a Gaussian function of thet_pred_mean too.
4403         diffak=gthet(2,it)-thet_pred_mean
4404         ratak=diffak/gthet(3,it)**2
4405         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4406 ! Let's differentiate it in thet_pred_mean NOW.
4407         aktc=ak*ratak
4408 ! Now put together the distribution terms to make complete distribution.
4409         termexp=term1+ak*term2
4410         termpre=sigc+ak*sig0i
4411 ! Contribution of the bending energy from this theta is just the -log of
4412 ! the sum of the contributions from the two lobes and the pre-exponential
4413 ! factor. Simple enough, isn't it?
4414         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4415 ! NOW the derivatives!!!
4416 ! 6/6/97 Take into account the deformation.
4417         E_theta=(delthec*sigcsq*term1 &
4418              +ak*delthe0*sig0inv*term2)/termexp
4419         E_tc=((sigtc+aktc*sig0i)/termpre &
4420             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4421              aktc*term2)/termexp)
4422       return
4423       end subroutine theteng
4424 #else
4425 !-----------------------------------------------------------------------------
4426       subroutine ebend(etheta)
4427 !
4428 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4429 ! angles gamma and its derivatives in consecutive thetas and gammas.
4430 ! ab initio-derived potentials from
4431 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4432 !
4433 !      implicit real*8 (a-h,o-z)
4434 !      include 'DIMENSIONS'
4435 !      include 'COMMON.LOCAL'
4436 !      include 'COMMON.GEO'
4437 !      include 'COMMON.INTERACT'
4438 !      include 'COMMON.DERIV'
4439 !      include 'COMMON.VAR'
4440 !      include 'COMMON.CHAIN'
4441 !      include 'COMMON.IOUNITS'
4442 !      include 'COMMON.NAMES'
4443 !      include 'COMMON.FFIELD'
4444 !      include 'COMMON.CONTROL'
4445       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4446       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4447       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4448       logical :: lprn=.false., lprn1=.false.
4449 !el local variables
4450       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4451       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4452       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4453
4454       etheta=0.0D0
4455       do i=ithet_start,ithet_end
4456         if (itype(i-1).eq.ntyp1) cycle
4457         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
4458         if (iabs(itype(i+1)).eq.20) iblock=2
4459         if (iabs(itype(i+1)).ne.20) iblock=1
4460         dethetai=0.0d0
4461         dephii=0.0d0
4462         dephii1=0.0d0
4463         theti2=0.5d0*theta(i)
4464         ityp2=ithetyp((itype(i-1)))
4465         do k=1,nntheterm
4466           coskt(k)=dcos(k*theti2)
4467           sinkt(k)=dsin(k*theti2)
4468         enddo
4469         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4470 #ifdef OSF
4471           phii=phi(i)
4472           if (phii.ne.phii) phii=150.0
4473 #else
4474           phii=phi(i)
4475 #endif
4476           ityp1=ithetyp((itype(i-2)))
4477 ! propagation of chirality for glycine type
4478           do k=1,nsingle
4479             cosph1(k)=dcos(k*phii)
4480             sinph1(k)=dsin(k*phii)
4481           enddo
4482         else
4483           phii=0.0d0
4484           ityp1=ithetyp(itype(i-2))
4485           do k=1,nsingle
4486             cosph1(k)=0.0d0
4487             sinph1(k)=0.0d0
4488           enddo
4489         endif
4490         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4491 #ifdef OSF
4492           phii1=phi(i+1)
4493           if (phii1.ne.phii1) phii1=150.0
4494           phii1=pinorm(phii1)
4495 #else
4496           phii1=phi(i+1)
4497 #endif
4498           ityp3=ithetyp((itype(i)))
4499           do k=1,nsingle
4500             cosph2(k)=dcos(k*phii1)
4501             sinph2(k)=dsin(k*phii1)
4502           enddo
4503         else
4504           phii1=0.0d0
4505           ityp3=ithetyp(itype(i))
4506           do k=1,nsingle
4507             cosph2(k)=0.0d0
4508             sinph2(k)=0.0d0
4509           enddo
4510         endif
4511         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4512         do k=1,ndouble
4513           do l=1,k-1
4514             ccl=cosph1(l)*cosph2(k-l)
4515             ssl=sinph1(l)*sinph2(k-l)
4516             scl=sinph1(l)*cosph2(k-l)
4517             csl=cosph1(l)*sinph2(k-l)
4518             cosph1ph2(l,k)=ccl-ssl
4519             cosph1ph2(k,l)=ccl+ssl
4520             sinph1ph2(l,k)=scl+csl
4521             sinph1ph2(k,l)=scl-csl
4522           enddo
4523         enddo
4524         if (lprn) then
4525         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4526           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4527         write (iout,*) "coskt and sinkt"
4528         do k=1,nntheterm
4529           write (iout,*) k,coskt(k),sinkt(k)
4530         enddo
4531         endif
4532         do k=1,ntheterm
4533           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4534           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4535             *coskt(k)
4536           if (lprn) &
4537           write (iout,*) "k",k,&
4538            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4539            " ethetai",ethetai
4540         enddo
4541         if (lprn) then
4542         write (iout,*) "cosph and sinph"
4543         do k=1,nsingle
4544           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4545         enddo
4546         write (iout,*) "cosph1ph2 and sinph2ph2"
4547         do k=2,ndouble
4548           do l=1,k-1
4549             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4550                sinph1ph2(l,k),sinph1ph2(k,l)
4551           enddo
4552         enddo
4553         write(iout,*) "ethetai",ethetai
4554         endif
4555         do m=1,ntheterm2
4556           do k=1,nsingle
4557             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4558                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4559                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4560                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4561             ethetai=ethetai+sinkt(m)*aux
4562             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4563             dephii=dephii+k*sinkt(m)* &
4564                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4565                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4566             dephii1=dephii1+k*sinkt(m)* &
4567                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4568                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4569             if (lprn) &
4570             write (iout,*) "m",m," k",k," bbthet", &
4571                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4572                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4573                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4574                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4575           enddo
4576         enddo
4577         if (lprn) &
4578         write(iout,*) "ethetai",ethetai
4579         do m=1,ntheterm3
4580           do k=2,ndouble
4581             do l=1,k-1
4582               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4583                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4584                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4585                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4586               ethetai=ethetai+sinkt(m)*aux
4587               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4588               dephii=dephii+l*sinkt(m)* &
4589                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4590                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4591                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4592                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4593               dephii1=dephii1+(k-l)*sinkt(m)* &
4594                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4595                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4596                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4597                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4598               if (lprn) then
4599               write (iout,*) "m",m," k",k," l",l," ffthet",&
4600                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4601                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4602                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4603                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4604                   " ethetai",ethetai
4605               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4606                   cosph1ph2(k,l)*sinkt(m),&
4607                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4608               endif
4609             enddo
4610           enddo
4611         enddo
4612 10      continue
4613 !        lprn1=.true.
4614         if (lprn1) &
4615           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4616          i,theta(i)*rad2deg,phii*rad2deg,&
4617          phii1*rad2deg,ethetai
4618 !        lprn1=.false.
4619         etheta=etheta+ethetai
4620         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4621                                     'ebend',i,ethetai
4622         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4623         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4624         gloc(nphi+i-2,icg)=wang*dethetai
4625       enddo
4626       return
4627       end subroutine ebend
4628 #endif
4629 #ifdef CRYST_SC
4630 !-----------------------------------------------------------------------------
4631       subroutine esc(escloc)
4632 ! Calculate the local energy of a side chain and its derivatives in the
4633 ! corresponding virtual-bond valence angles THETA and the spherical angles
4634 ! ALPHA and OMEGA.
4635 !
4636       use comm_sccalc
4637 !      implicit real*8 (a-h,o-z)
4638 !      include 'DIMENSIONS'
4639 !      include 'COMMON.GEO'
4640 !      include 'COMMON.LOCAL'
4641 !      include 'COMMON.VAR'
4642 !      include 'COMMON.INTERACT'
4643 !      include 'COMMON.DERIV'
4644 !      include 'COMMON.CHAIN'
4645 !      include 'COMMON.IOUNITS'
4646 !      include 'COMMON.NAMES'
4647 !      include 'COMMON.FFIELD'
4648 !      include 'COMMON.CONTROL'
4649       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4650          ddersc0,ddummy,xtemp,temp
4651 !el      real(kind=8) :: time11,time12,time112,theti
4652       real(kind=8) :: escloc,delta
4653 !el      integer :: it,nlobit
4654 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4655 !el local variables
4656       integer :: i,k
4657       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4658        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4659       delta=0.02d0*pi
4660       escloc=0.0D0
4661 !     write (iout,'(a)') 'ESC'
4662       do i=loc_start,loc_end
4663         it=itype(i)
4664         if (it.eq.ntyp1) cycle
4665         if (it.eq.10) goto 1
4666         nlobit=nlob(iabs(it))
4667 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4668 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4669         theti=theta(i+1)-pipol
4670         x(1)=dtan(theti)
4671         x(2)=alph(i)
4672         x(3)=omeg(i)
4673
4674         if (x(2).gt.pi-delta) then
4675           xtemp(1)=x(1)
4676           xtemp(2)=pi-delta
4677           xtemp(3)=x(3)
4678           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4679           xtemp(2)=pi
4680           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4681           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4682               escloci,dersc(2))
4683           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4684               ddersc0(1),dersc(1))
4685           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4686               ddersc0(3),dersc(3))
4687           xtemp(2)=pi-delta
4688           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4689           xtemp(2)=pi
4690           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4691           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4692                   dersc0(2),esclocbi,dersc02)
4693           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4694                   dersc12,dersc01)
4695           call splinthet(x(2),0.5d0*delta,ss,ssd)
4696           dersc0(1)=dersc01
4697           dersc0(2)=dersc02
4698           dersc0(3)=0.0d0
4699           do k=1,3
4700             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4701           enddo
4702           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4703 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4704 !    &             esclocbi,ss,ssd
4705           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4706 !         escloci=esclocbi
4707 !         write (iout,*) escloci
4708         else if (x(2).lt.delta) then
4709           xtemp(1)=x(1)
4710           xtemp(2)=delta
4711           xtemp(3)=x(3)
4712           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4713           xtemp(2)=0.0d0
4714           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4715           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4716               escloci,dersc(2))
4717           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4718               ddersc0(1),dersc(1))
4719           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4720               ddersc0(3),dersc(3))
4721           xtemp(2)=delta
4722           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4723           xtemp(2)=0.0d0
4724           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4725           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4726                   dersc0(2),esclocbi,dersc02)
4727           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4728                   dersc12,dersc01)
4729           dersc0(1)=dersc01
4730           dersc0(2)=dersc02
4731           dersc0(3)=0.0d0
4732           call splinthet(x(2),0.5d0*delta,ss,ssd)
4733           do k=1,3
4734             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4735           enddo
4736           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4737 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4738 !    &             esclocbi,ss,ssd
4739           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4740 !         write (iout,*) escloci
4741         else
4742           call enesc(x,escloci,dersc,ddummy,.false.)
4743         endif
4744
4745         escloc=escloc+escloci
4746         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4747            'escloc',i,escloci
4748 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4749
4750         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
4751          wscloc*dersc(1)
4752         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4753         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4754     1   continue
4755       enddo
4756       return
4757       end subroutine esc
4758 !-----------------------------------------------------------------------------
4759       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4760
4761       use comm_sccalc
4762 !      implicit real*8 (a-h,o-z)
4763 !      include 'DIMENSIONS'
4764 !      include 'COMMON.GEO'
4765 !      include 'COMMON.LOCAL'
4766 !      include 'COMMON.IOUNITS'
4767 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4768       real(kind=8),dimension(3) :: x,z,dersc,ddersc
4769       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
4770       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
4771       real(kind=8) :: escloci
4772       logical :: mixed
4773 !el local variables
4774       integer :: j,iii,l,k !el,it,nlobit
4775       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
4776 !el       time11,time12,time112
4777 !       write (iout,*) 'it=',it,' nlobit=',nlobit
4778         escloc_i=0.0D0
4779         do j=1,3
4780           dersc(j)=0.0D0
4781           if (mixed) ddersc(j)=0.0d0
4782         enddo
4783         x3=x(3)
4784
4785 ! Because of periodicity of the dependence of the SC energy in omega we have
4786 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4787 ! To avoid underflows, first compute & store the exponents.
4788
4789         do iii=-1,1
4790
4791           x(3)=x3+iii*dwapi
4792
4793           do j=1,nlobit
4794             do k=1,3
4795               z(k)=x(k)-censc(k,j,it)
4796             enddo
4797             do k=1,3
4798               Axk=0.0D0
4799               do l=1,3
4800                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4801               enddo
4802               Ax(k,j,iii)=Axk
4803             enddo
4804             expfac=0.0D0
4805             do k=1,3
4806               expfac=expfac+Ax(k,j,iii)*z(k)
4807             enddo
4808             contr(j,iii)=expfac
4809           enddo ! j
4810
4811         enddo ! iii
4812
4813         x(3)=x3
4814 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4815 ! subsequent NaNs and INFs in energy calculation.
4816 ! Find the largest exponent
4817         emin=contr(1,-1)
4818         do iii=-1,1
4819           do j=1,nlobit
4820             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4821           enddo
4822         enddo
4823         emin=0.5D0*emin
4824 !d      print *,'it=',it,' emin=',emin
4825
4826 ! Compute the contribution to SC energy and derivatives
4827         do iii=-1,1
4828
4829           do j=1,nlobit
4830 #ifdef OSF
4831             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4832             if(adexp.ne.adexp) adexp=1.0
4833             expfac=dexp(adexp)
4834 #else
4835             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4836 #endif
4837 !d          print *,'j=',j,' expfac=',expfac
4838             escloc_i=escloc_i+expfac
4839             do k=1,3
4840               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4841             enddo
4842             if (mixed) then
4843               do k=1,3,2
4844                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
4845                   +gaussc(k,2,j,it))*expfac
4846               enddo
4847             endif
4848           enddo
4849
4850         enddo ! iii
4851
4852         dersc(1)=dersc(1)/cos(theti)**2
4853         ddersc(1)=ddersc(1)/cos(theti)**2
4854         ddersc(3)=ddersc(3)
4855
4856         escloci=-(dlog(escloc_i)-emin)
4857         do j=1,3
4858           dersc(j)=dersc(j)/escloc_i
4859         enddo
4860         if (mixed) then
4861           do j=1,3,2
4862             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4863           enddo
4864         endif
4865       return
4866       end subroutine enesc
4867 !-----------------------------------------------------------------------------
4868       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4869
4870       use comm_sccalc
4871 !      implicit real*8 (a-h,o-z)
4872 !      include 'DIMENSIONS'
4873 !      include 'COMMON.GEO'
4874 !      include 'COMMON.LOCAL'
4875 !      include 'COMMON.IOUNITS'
4876 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4877       real(kind=8),dimension(3) :: x,z,dersc
4878       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
4879       real(kind=8),dimension(nlobit) :: contr !(maxlob)
4880       real(kind=8) :: escloci,dersc12,emin
4881       logical :: mixed
4882 !el local varables
4883       integer :: j,k,l !el,it,nlobit
4884       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
4885
4886       escloc_i=0.0D0
4887
4888       do j=1,3
4889         dersc(j)=0.0D0
4890       enddo
4891
4892       do j=1,nlobit
4893         do k=1,2
4894           z(k)=x(k)-censc(k,j,it)
4895         enddo
4896         z(3)=dwapi
4897         do k=1,3
4898           Axk=0.0D0
4899           do l=1,3
4900             Axk=Axk+gaussc(l,k,j,it)*z(l)
4901           enddo
4902           Ax(k,j)=Axk
4903         enddo
4904         expfac=0.0D0
4905         do k=1,3
4906           expfac=expfac+Ax(k,j)*z(k)
4907         enddo
4908         contr(j)=expfac
4909       enddo ! j
4910
4911 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4912 ! subsequent NaNs and INFs in energy calculation.
4913 ! Find the largest exponent
4914       emin=contr(1)
4915       do j=1,nlobit
4916         if (emin.gt.contr(j)) emin=contr(j)
4917       enddo
4918       emin=0.5D0*emin
4919
4920 ! Compute the contribution to SC energy and derivatives
4921
4922       dersc12=0.0d0
4923       do j=1,nlobit
4924         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4925         escloc_i=escloc_i+expfac
4926         do k=1,2
4927           dersc(k)=dersc(k)+Ax(k,j)*expfac
4928         enddo
4929         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
4930                   +gaussc(1,2,j,it))*expfac
4931         dersc(3)=0.0d0
4932       enddo
4933
4934       dersc(1)=dersc(1)/cos(theti)**2
4935       dersc12=dersc12/cos(theti)**2
4936       escloci=-(dlog(escloc_i)-emin)
4937       do j=1,2
4938         dersc(j)=dersc(j)/escloc_i
4939       enddo
4940       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4941       return
4942       end subroutine enesc_bound
4943 #else
4944 !-----------------------------------------------------------------------------
4945       subroutine esc(escloc)
4946 ! Calculate the local energy of a side chain and its derivatives in the
4947 ! corresponding virtual-bond valence angles THETA and the spherical angles
4948 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
4949 ! added by Urszula Kozlowska. 07/11/2007
4950 !
4951       use comm_sccalc
4952 !      implicit real*8 (a-h,o-z)
4953 !      include 'DIMENSIONS'
4954 !      include 'COMMON.GEO'
4955 !      include 'COMMON.LOCAL'
4956 !      include 'COMMON.VAR'
4957 !      include 'COMMON.SCROT'
4958 !      include 'COMMON.INTERACT'
4959 !      include 'COMMON.DERIV'
4960 !      include 'COMMON.CHAIN'
4961 !      include 'COMMON.IOUNITS'
4962 !      include 'COMMON.NAMES'
4963 !      include 'COMMON.FFIELD'
4964 !      include 'COMMON.CONTROL'
4965 !      include 'COMMON.VECTORS'
4966       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
4967       real(kind=8),dimension(65) :: x
4968       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
4969          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
4970       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
4971       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
4972          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
4973 !el local variables
4974       integer :: i,j,k !el,it,nlobit
4975       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
4976 !el      real(kind=8) :: time11,time12,time112,theti
4977 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4978       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
4979                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
4980                    sumene1x,sumene2x,sumene3x,sumene4x,&
4981                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
4982                    cosfac2xx,sinfac2yy
4983 #ifdef DEBUG
4984       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
4985                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
4986                    de_dt_num
4987 #endif
4988 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
4989
4990       delta=0.02d0*pi
4991       escloc=0.0D0
4992       do i=loc_start,loc_end
4993         if (itype(i).eq.ntyp1) cycle
4994         costtab(i+1) =dcos(theta(i+1))
4995         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4996         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4997         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4998         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4999         cosfac=dsqrt(cosfac2)
5000         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5001         sinfac=dsqrt(sinfac2)
5002         it=iabs(itype(i))
5003         if (it.eq.10) goto 1
5004 !
5005 !  Compute the axes of tghe local cartesian coordinates system; store in
5006 !   x_prime, y_prime and z_prime
5007 !
5008         do j=1,3
5009           x_prime(j) = 0.00
5010           y_prime(j) = 0.00
5011           z_prime(j) = 0.00
5012         enddo
5013 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5014 !     &   dc_norm(3,i+nres)
5015         do j = 1,3
5016           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5017           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5018         enddo
5019         do j = 1,3
5020           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5021         enddo
5022 !       write (2,*) "i",i
5023 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5024 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5025 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5026 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5027 !      & " xy",scalar(x_prime(1),y_prime(1)),
5028 !      & " xz",scalar(x_prime(1),z_prime(1)),
5029 !      & " yy",scalar(y_prime(1),y_prime(1)),
5030 !      & " yz",scalar(y_prime(1),z_prime(1)),
5031 !      & " zz",scalar(z_prime(1),z_prime(1))
5032 !
5033 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5034 ! to local coordinate system. Store in xx, yy, zz.
5035 !
5036         xx=0.0d0
5037         yy=0.0d0
5038         zz=0.0d0
5039         do j = 1,3
5040           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5041           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5042           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5043         enddo
5044
5045         xxtab(i)=xx
5046         yytab(i)=yy
5047         zztab(i)=zz
5048 !
5049 ! Compute the energy of the ith side cbain
5050 !
5051 !        write (2,*) "xx",xx," yy",yy," zz",zz
5052         it=iabs(itype(i))
5053         do j = 1,65
5054           x(j) = sc_parmin(j,it)
5055         enddo
5056 #ifdef CHECK_COORD
5057 !c diagnostics - remove later
5058         xx1 = dcos(alph(2))
5059         yy1 = dsin(alph(2))*dcos(omeg(2))
5060         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5061         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5062           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5063           xx1,yy1,zz1
5064 !,"  --- ", xx_w,yy_w,zz_w
5065 ! end diagnostics
5066 #endif
5067         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5068          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5069          + x(10)*yy*zz
5070         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5071          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5072          + x(20)*yy*zz
5073         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5074          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5075          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5076          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5077          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5078          +x(40)*xx*yy*zz
5079         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5080          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5081          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5082          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5083          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5084          +x(60)*xx*yy*zz
5085         dsc_i   = 0.743d0+x(61)
5086         dp2_i   = 1.9d0+x(62)
5087         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5088                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5089         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5090                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5091         s1=(1+x(63))/(0.1d0 + dscp1)
5092         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5093         s2=(1+x(65))/(0.1d0 + dscp2)
5094         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5095         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5096       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5097 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5098 !     &   sumene4,
5099 !     &   dscp1,dscp2,sumene
5100 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5101         escloc = escloc + sumene
5102 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5103 !     & ,zz,xx,yy
5104 !#define DEBUG
5105 #ifdef DEBUG
5106 !
5107 ! This section to check the numerical derivatives of the energy of ith side
5108 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5109 ! #define DEBUG in the code to turn it on.
5110 !
5111         write (2,*) "sumene               =",sumene
5112         aincr=1.0d-7
5113         xxsave=xx
5114         xx=xx+aincr
5115         write (2,*) xx,yy,zz
5116         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5117         de_dxx_num=(sumenep-sumene)/aincr
5118         xx=xxsave
5119         write (2,*) "xx+ sumene from enesc=",sumenep
5120         yysave=yy
5121         yy=yy+aincr
5122         write (2,*) xx,yy,zz
5123         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5124         de_dyy_num=(sumenep-sumene)/aincr
5125         yy=yysave
5126         write (2,*) "yy+ sumene from enesc=",sumenep
5127         zzsave=zz
5128         zz=zz+aincr
5129         write (2,*) xx,yy,zz
5130         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5131         de_dzz_num=(sumenep-sumene)/aincr
5132         zz=zzsave
5133         write (2,*) "zz+ sumene from enesc=",sumenep
5134         costsave=cost2tab(i+1)
5135         sintsave=sint2tab(i+1)
5136         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5137         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5138         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5139         de_dt_num=(sumenep-sumene)/aincr
5140         write (2,*) " t+ sumene from enesc=",sumenep
5141         cost2tab(i+1)=costsave
5142         sint2tab(i+1)=sintsave
5143 ! End of diagnostics section.
5144 #endif
5145 !
5146 ! Compute the gradient of esc
5147 !
5148 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5149         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5150         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5151         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5152         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5153         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5154         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5155         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5156         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5157         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5158            *(pom_s1/dscp1+pom_s16*dscp1**4)
5159         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5160            *(pom_s2/dscp2+pom_s26*dscp2**4)
5161         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5162         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5163         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5164         +x(40)*yy*zz
5165         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5166         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5167         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5168         +x(60)*yy*zz
5169         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5170               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5171               +(pom1+pom2)*pom_dx
5172 #ifdef DEBUG
5173         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5174 #endif
5175 !
5176         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5177         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5178         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5179         +x(40)*xx*zz
5180         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5181         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5182         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5183         +x(59)*zz**2 +x(60)*xx*zz
5184         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5185               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5186               +(pom1-pom2)*pom_dy
5187 #ifdef DEBUG
5188         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5189 #endif
5190 !
5191         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5192         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5193         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5194         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5195         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5196         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5197         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5198         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5199 #ifdef DEBUG
5200         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5201 #endif
5202 !
5203         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5204         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5205         +pom1*pom_dt1+pom2*pom_dt2
5206 #ifdef DEBUG
5207         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5208 #endif
5209 !
5210 !
5211        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5212        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5213        cosfac2xx=cosfac2*xx
5214        sinfac2yy=sinfac2*yy
5215        do k = 1,3
5216          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5217             vbld_inv(i+1)
5218          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5219             vbld_inv(i)
5220          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5221          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5222 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5223 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5224 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5225 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5226          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5227          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5228          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5229          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5230          dZZ_Ci1(k)=0.0d0
5231          dZZ_Ci(k)=0.0d0
5232          do j=1,3
5233            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5234            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5235            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5236            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5237          enddo
5238
5239          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5240          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5241          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5242          (z_prime(k)-zz*dC_norm(k,i+nres))
5243 !
5244          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5245          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5246        enddo
5247
5248        do k=1,3
5249          dXX_Ctab(k,i)=dXX_Ci(k)
5250          dXX_C1tab(k,i)=dXX_Ci1(k)
5251          dYY_Ctab(k,i)=dYY_Ci(k)
5252          dYY_C1tab(k,i)=dYY_Ci1(k)
5253          dZZ_Ctab(k,i)=dZZ_Ci(k)
5254          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5255          dXX_XYZtab(k,i)=dXX_XYZ(k)
5256          dYY_XYZtab(k,i)=dYY_XYZ(k)
5257          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5258        enddo
5259
5260        do k = 1,3
5261 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5262 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5263 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5264 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5265 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5266 !     &    dt_dci(k)
5267 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5268 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5269          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5270           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5271          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5272           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5273          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5274           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5275        enddo
5276 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5277 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5278
5279 ! to check gradient call subroutine check_grad
5280
5281     1 continue
5282       enddo
5283       return
5284       end subroutine esc
5285 !-----------------------------------------------------------------------------
5286       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5287 !      implicit none
5288       real(kind=8),dimension(65) :: x
5289       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5290         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5291
5292       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5293         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5294         + x(10)*yy*zz
5295       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5296         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5297         + x(20)*yy*zz
5298       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5299         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5300         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5301         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5302         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5303         +x(40)*xx*yy*zz
5304       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5305         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5306         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5307         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5308         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5309         +x(60)*xx*yy*zz
5310       dsc_i   = 0.743d0+x(61)
5311       dp2_i   = 1.9d0+x(62)
5312       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5313                 *(xx*cost2+yy*sint2))
5314       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5315                 *(xx*cost2-yy*sint2))
5316       s1=(1+x(63))/(0.1d0 + dscp1)
5317       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5318       s2=(1+x(65))/(0.1d0 + dscp2)
5319       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5320       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5321        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5322       enesc=sumene
5323       return
5324       end function enesc
5325 #endif
5326 !-----------------------------------------------------------------------------
5327       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5328 !
5329 ! This procedure calculates two-body contact function g(rij) and its derivative:
5330 !
5331 !           eps0ij                                     !       x < -1
5332 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5333 !            0                                         !       x > 1
5334 !
5335 ! where x=(rij-r0ij)/delta
5336 !
5337 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5338 !
5339 !      implicit none
5340       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5341       real(kind=8) :: x,x2,x4,delta
5342 !     delta=0.02D0*r0ij
5343 !      delta=0.2D0*r0ij
5344       x=(rij-r0ij)/delta
5345       if (x.lt.-1.0D0) then
5346         fcont=eps0ij
5347         fprimcont=0.0D0
5348       else if (x.le.1.0D0) then
5349         x2=x*x
5350         x4=x2*x2
5351         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5352         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5353       else
5354         fcont=0.0D0
5355         fprimcont=0.0D0
5356       endif
5357       return
5358       end subroutine gcont
5359 !-----------------------------------------------------------------------------
5360       subroutine splinthet(theti,delta,ss,ssder)
5361 !      implicit real*8 (a-h,o-z)
5362 !      include 'DIMENSIONS'
5363 !      include 'COMMON.VAR'
5364 !      include 'COMMON.GEO'
5365       real(kind=8) :: theti,delta,ss,ssder
5366       real(kind=8) :: thetup,thetlow
5367       thetup=pi-delta
5368       thetlow=delta
5369       if (theti.gt.pipol) then
5370         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5371       else
5372         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5373         ssder=-ssder
5374       endif
5375       return
5376       end subroutine splinthet
5377 !-----------------------------------------------------------------------------
5378       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5379 !      implicit none
5380       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5381       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5382       a1=fprim0*delta/(f1-f0)
5383       a2=3.0d0-2.0d0*a1
5384       a3=a1-2.0d0
5385       ksi=(x-x0)/delta
5386       ksi2=ksi*ksi
5387       ksi3=ksi2*ksi
5388       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5389       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5390       return
5391       end subroutine spline1
5392 !-----------------------------------------------------------------------------
5393       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5394 !      implicit none
5395       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5396       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5397       ksi=(x-x0)/delta
5398       ksi2=ksi*ksi
5399       ksi3=ksi2*ksi
5400       a1=fprim0x*delta
5401       a2=3*(f1x-f0x)-2*fprim0x*delta
5402       a3=fprim0x*delta-2*(f1x-f0x)
5403       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5404       return
5405       end subroutine spline2
5406 !-----------------------------------------------------------------------------
5407 #ifdef CRYST_TOR
5408 !-----------------------------------------------------------------------------
5409       subroutine etor(etors,edihcnstr)
5410 !      implicit real*8 (a-h,o-z)
5411 !      include 'DIMENSIONS'
5412 !      include 'COMMON.VAR'
5413 !      include 'COMMON.GEO'
5414 !      include 'COMMON.LOCAL'
5415 !      include 'COMMON.TORSION'
5416 !      include 'COMMON.INTERACT'
5417 !      include 'COMMON.DERIV'
5418 !      include 'COMMON.CHAIN'
5419 !      include 'COMMON.NAMES'
5420 !      include 'COMMON.IOUNITS'
5421 !      include 'COMMON.FFIELD'
5422 !      include 'COMMON.TORCNSTR'
5423 !      include 'COMMON.CONTROL'
5424       real(kind=8) :: etors,edihcnstr
5425       logical :: lprn
5426 !el local variables
5427       integer :: i,j,
5428       real(kind=8) :: phii,fac,etors_ii
5429
5430 ! Set lprn=.true. for debugging
5431       lprn=.false.
5432 !      lprn=.true.
5433       etors=0.0D0
5434       do i=iphi_start,iphi_end
5435       etors_ii=0.0D0
5436         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5437             .or. itype(i).eq.ntyp1) cycle
5438         itori=itortyp(itype(i-2))
5439         itori1=itortyp(itype(i-1))
5440         phii=phi(i)
5441         gloci=0.0D0
5442 ! Proline-Proline pair is a special case...
5443         if (itori.eq.3 .and. itori1.eq.3) then
5444           if (phii.gt.-dwapi3) then
5445             cosphi=dcos(3*phii)
5446             fac=1.0D0/(1.0D0-cosphi)
5447             etorsi=v1(1,3,3)*fac
5448             etorsi=etorsi+etorsi
5449             etors=etors+etorsi-v1(1,3,3)
5450             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5451             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5452           endif
5453           do j=1,3
5454             v1ij=v1(j+1,itori,itori1)
5455             v2ij=v2(j+1,itori,itori1)
5456             cosphi=dcos(j*phii)
5457             sinphi=dsin(j*phii)
5458             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5459             if (energy_dec) etors_ii=etors_ii+ &
5460                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5461             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5462           enddo
5463         else
5464           do j=1,nterm_old
5465             v1ij=v1(j,itori,itori1)
5466             v2ij=v2(j,itori,itori1)
5467             cosphi=dcos(j*phii)
5468             sinphi=dsin(j*phii)
5469             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5470             if (energy_dec) etors_ii=etors_ii+ &
5471                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5472             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5473           enddo
5474         endif
5475         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5476              'etor',i,etors_ii
5477         if (lprn) &
5478         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5479         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5480         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5481         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5482 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5483       enddo
5484 ! 6/20/98 - dihedral angle constraints
5485       edihcnstr=0.0d0
5486       do i=1,ndih_constr
5487         itori=idih_constr(i)
5488         phii=phi(itori)
5489         difi=phii-phi0(i)
5490         if (difi.gt.drange(i)) then
5491           difi=difi-drange(i)
5492           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5493           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5494         else if (difi.lt.-drange(i)) then
5495           difi=difi+drange(i)
5496           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5497           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5498         endif
5499 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5500 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5501       enddo
5502 !      write (iout,*) 'edihcnstr',edihcnstr
5503       return
5504       end subroutine etor
5505 !-----------------------------------------------------------------------------
5506       subroutine etor_d(etors_d)
5507       real(kind=8) :: etors_d
5508       etors_d=0.0d0
5509       return
5510       end subroutine etor_d
5511 #else
5512 !-----------------------------------------------------------------------------
5513       subroutine etor(etors,edihcnstr)
5514 !      implicit real*8 (a-h,o-z)
5515 !      include 'DIMENSIONS'
5516 !      include 'COMMON.VAR'
5517 !      include 'COMMON.GEO'
5518 !      include 'COMMON.LOCAL'
5519 !      include 'COMMON.TORSION'
5520 !      include 'COMMON.INTERACT'
5521 !      include 'COMMON.DERIV'
5522 !      include 'COMMON.CHAIN'
5523 !      include 'COMMON.NAMES'
5524 !      include 'COMMON.IOUNITS'
5525 !      include 'COMMON.FFIELD'
5526 !      include 'COMMON.TORCNSTR'
5527 !      include 'COMMON.CONTROL'
5528       real(kind=8) :: etors,edihcnstr
5529       logical :: lprn
5530 !el local variables
5531       integer :: i,j,iblock,itori,itori1
5532       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5533                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5534 ! Set lprn=.true. for debugging
5535       lprn=.false.
5536 !     lprn=.true.
5537       etors=0.0D0
5538       do i=iphi_start,iphi_end
5539         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5540              .or. itype(i-3).eq.ntyp1 &
5541              .or. itype(i).eq.ntyp1) cycle
5542         etors_ii=0.0D0
5543          if (iabs(itype(i)).eq.20) then
5544          iblock=2
5545          else
5546          iblock=1
5547          endif
5548         itori=itortyp(itype(i-2))
5549         itori1=itortyp(itype(i-1))
5550         phii=phi(i)
5551         gloci=0.0D0
5552 ! Regular cosine and sine terms
5553         do j=1,nterm(itori,itori1,iblock)
5554           v1ij=v1(j,itori,itori1,iblock)
5555           v2ij=v2(j,itori,itori1,iblock)
5556           cosphi=dcos(j*phii)
5557           sinphi=dsin(j*phii)
5558           etors=etors+v1ij*cosphi+v2ij*sinphi
5559           if (energy_dec) etors_ii=etors_ii+ &
5560                      v1ij*cosphi+v2ij*sinphi
5561           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5562         enddo
5563 ! Lorentz terms
5564 !                         v1
5565 !  E = SUM ----------------------------------- - v1
5566 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5567 !
5568         cosphi=dcos(0.5d0*phii)
5569         sinphi=dsin(0.5d0*phii)
5570         do j=1,nlor(itori,itori1,iblock)
5571           vl1ij=vlor1(j,itori,itori1)
5572           vl2ij=vlor2(j,itori,itori1)
5573           vl3ij=vlor3(j,itori,itori1)
5574           pom=vl2ij*cosphi+vl3ij*sinphi
5575           pom1=1.0d0/(pom*pom+1.0d0)
5576           etors=etors+vl1ij*pom1
5577           if (energy_dec) etors_ii=etors_ii+ &
5578                      vl1ij*pom1
5579           pom=-pom*pom1*pom1
5580           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5581         enddo
5582 ! Subtract the constant term
5583         etors=etors-v0(itori,itori1,iblock)
5584           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5585                'etor',i,etors_ii-v0(itori,itori1,iblock)
5586         if (lprn) &
5587         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5588         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5589         (v1(j,itori,itori1,iblock),j=1,6),&
5590         (v2(j,itori,itori1,iblock),j=1,6)
5591         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5592 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5593       enddo
5594 ! 6/20/98 - dihedral angle constraints
5595       edihcnstr=0.0d0
5596 !      do i=1,ndih_constr
5597       do i=idihconstr_start,idihconstr_end
5598         itori=idih_constr(i)
5599         phii=phi(itori)
5600         difi=pinorm(phii-phi0(i))
5601         if (difi.gt.drange(i)) then
5602           difi=difi-drange(i)
5603           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5604           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5605         else if (difi.lt.-drange(i)) then
5606           difi=difi+drange(i)
5607           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5608           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5609         else
5610           difi=0.0
5611         endif
5612 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5613 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5614 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5615       enddo
5616 !d       write (iout,*) 'edihcnstr',edihcnstr
5617       return
5618       end subroutine etor
5619 !-----------------------------------------------------------------------------
5620       subroutine etor_d(etors_d)
5621 ! 6/23/01 Compute double torsional energy
5622 !      implicit real*8 (a-h,o-z)
5623 !      include 'DIMENSIONS'
5624 !      include 'COMMON.VAR'
5625 !      include 'COMMON.GEO'
5626 !      include 'COMMON.LOCAL'
5627 !      include 'COMMON.TORSION'
5628 !      include 'COMMON.INTERACT'
5629 !      include 'COMMON.DERIV'
5630 !      include 'COMMON.CHAIN'
5631 !      include 'COMMON.NAMES'
5632 !      include 'COMMON.IOUNITS'
5633 !      include 'COMMON.FFIELD'
5634 !      include 'COMMON.TORCNSTR'
5635       real(kind=8) :: etors_d,etors_d_ii
5636       logical :: lprn
5637 !el local variables
5638       integer :: i,j,k,l,itori,itori1,itori2,iblock
5639       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5640                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5641                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5642                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5643 ! Set lprn=.true. for debugging
5644       lprn=.false.
5645 !     lprn=.true.
5646       etors_d=0.0D0
5647 !      write(iout,*) "a tu??"
5648       do i=iphid_start,iphid_end
5649         etors_d_ii=0.0D0
5650         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5651             .or. itype(i-3).eq.ntyp1 &
5652             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5653         itori=itortyp(itype(i-2))
5654         itori1=itortyp(itype(i-1))
5655         itori2=itortyp(itype(i))
5656         phii=phi(i)
5657         phii1=phi(i+1)
5658         gloci1=0.0D0
5659         gloci2=0.0D0
5660         iblock=1
5661         if (iabs(itype(i+1)).eq.20) iblock=2
5662
5663 ! Regular cosine and sine terms
5664         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5665           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5666           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5667           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5668           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5669           cosphi1=dcos(j*phii)
5670           sinphi1=dsin(j*phii)
5671           cosphi2=dcos(j*phii1)
5672           sinphi2=dsin(j*phii1)
5673           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5674            v2cij*cosphi2+v2sij*sinphi2
5675           if (energy_dec) etors_d_ii=etors_d_ii+ &
5676            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5677           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5678           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5679         enddo
5680         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5681           do l=1,k-1
5682             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5683             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5684             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5685             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5686             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5687             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5688             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5689             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5690             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5691               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5692             if (energy_dec) etors_d_ii=etors_d_ii+ &
5693               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5694               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5695             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5696               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5697             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5698               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5699           enddo
5700         enddo
5701         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5702                             'etor_d',i,etors_d_ii
5703         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5704         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5705       enddo
5706       return
5707       end subroutine etor_d
5708 #endif
5709 !-----------------------------------------------------------------------------
5710       subroutine eback_sc_corr(esccor)
5711 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5712 !        conformational states; temporarily implemented as differences
5713 !        between UNRES torsional potentials (dependent on three types of
5714 !        residues) and the torsional potentials dependent on all 20 types
5715 !        of residues computed from AM1  energy surfaces of terminally-blocked
5716 !        amino-acid residues.
5717 !      implicit real*8 (a-h,o-z)
5718 !      include 'DIMENSIONS'
5719 !      include 'COMMON.VAR'
5720 !      include 'COMMON.GEO'
5721 !      include 'COMMON.LOCAL'
5722 !      include 'COMMON.TORSION'
5723 !      include 'COMMON.SCCOR'
5724 !      include 'COMMON.INTERACT'
5725 !      include 'COMMON.DERIV'
5726 !      include 'COMMON.CHAIN'
5727 !      include 'COMMON.NAMES'
5728 !      include 'COMMON.IOUNITS'
5729 !      include 'COMMON.FFIELD'
5730 !      include 'COMMON.CONTROL'
5731       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5732                    cosphi,sinphi
5733       logical :: lprn
5734       integer :: i,interty,j,isccori,isccori1,intertyp
5735 ! Set lprn=.true. for debugging
5736       lprn=.false.
5737 !      lprn=.true.
5738 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5739       esccor=0.0D0
5740       do i=itau_start,itau_end
5741         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5742         esccor_ii=0.0D0
5743         isccori=isccortyp(itype(i-2))
5744         isccori1=isccortyp(itype(i-1))
5745
5746 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5747         phii=phi(i)
5748         do intertyp=1,3 !intertyp
5749          esccor_ii=0.0D0
5750 !c Added 09 May 2012 (Adasko)
5751 !c  Intertyp means interaction type of backbone mainchain correlation:
5752 !   1 = SC...Ca...Ca...Ca
5753 !   2 = Ca...Ca...Ca...SC
5754 !   3 = SC...Ca...Ca...SCi
5755         gloci=0.0D0
5756         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5757             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5758             (itype(i-1).eq.ntyp1))) &
5759           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5760            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5761            .or.(itype(i).eq.ntyp1))) &
5762           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5763             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5764             (itype(i-3).eq.ntyp1)))) cycle
5765         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5766         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5767        cycle
5768        do j=1,nterm_sccor(isccori,isccori1)
5769           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5770           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5771           cosphi=dcos(j*tauangle(intertyp,i))
5772           sinphi=dsin(j*tauangle(intertyp,i))
5773           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5774           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5775           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5776         enddo
5777         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
5778                                 'esccor',i,intertyp,esccor_ii
5779 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5780         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5781         if (lprn) &
5782         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5783         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5784         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5785         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5786         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5787        enddo !intertyp
5788       enddo
5789
5790       return
5791       end subroutine eback_sc_corr
5792 !-----------------------------------------------------------------------------
5793       subroutine multibody(ecorr)
5794 ! This subroutine calculates multi-body contributions to energy following
5795 ! the idea of Skolnick et al. If side chains I and J make a contact and
5796 ! at the same time side chains I+1 and J+1 make a contact, an extra
5797 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5798 !      implicit real*8 (a-h,o-z)
5799 !      include 'DIMENSIONS'
5800 !      include 'COMMON.IOUNITS'
5801 !      include 'COMMON.DERIV'
5802 !      include 'COMMON.INTERACT'
5803 !      include 'COMMON.CONTACTS'
5804       real(kind=8),dimension(3) :: gx,gx1
5805       logical :: lprn
5806       real(kind=8) :: ecorr
5807       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5808 ! Set lprn=.true. for debugging
5809       lprn=.false.
5810
5811       if (lprn) then
5812         write (iout,'(a)') 'Contact function values:'
5813         do i=nnt,nct-2
5814           write (iout,'(i2,20(1x,i2,f10.5))') &
5815               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5816         enddo
5817       endif
5818       ecorr=0.0D0
5819
5820 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
5821 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
5822       do i=nnt,nct
5823         do j=1,3
5824           gradcorr(j,i)=0.0D0
5825           gradxorr(j,i)=0.0D0
5826         enddo
5827       enddo
5828       do i=nnt,nct-2
5829
5830         DO ISHIFT = 3,4
5831
5832         i1=i+ishift
5833         num_conti=num_cont(i)
5834         num_conti1=num_cont(i1)
5835         do jj=1,num_conti
5836           j=jcont(jj,i)
5837           do kk=1,num_conti1
5838             j1=jcont(kk,i1)
5839             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5840 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5841 !d   &                   ' ishift=',ishift
5842 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5843 ! The system gains extra energy.
5844               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5845             endif   ! j1==j+-ishift
5846           enddo     ! kk
5847         enddo       ! jj
5848
5849         ENDDO ! ISHIFT
5850
5851       enddo         ! i
5852       return
5853       end subroutine multibody
5854 !-----------------------------------------------------------------------------
5855       real(kind=8) function esccorr(i,j,k,l,jj,kk)
5856 !      implicit real*8 (a-h,o-z)
5857 !      include 'DIMENSIONS'
5858 !      include 'COMMON.IOUNITS'
5859 !      include 'COMMON.DERIV'
5860 !      include 'COMMON.INTERACT'
5861 !      include 'COMMON.CONTACTS'
5862       real(kind=8),dimension(3) :: gx,gx1
5863       logical :: lprn
5864       integer :: i,j,k,l,jj,kk,m,ll
5865       real(kind=8) :: eij,ekl
5866       lprn=.false.
5867       eij=facont(jj,i)
5868       ekl=facont(kk,k)
5869 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5870 ! Calculate the multi-body contribution to energy.
5871 ! Calculate multi-body contributions to the gradient.
5872 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5873 !d   & k,l,(gacont(m,kk,k),m=1,3)
5874       do m=1,3
5875         gx(m) =ekl*gacont(m,jj,i)
5876         gx1(m)=eij*gacont(m,kk,k)
5877         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5878         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5879         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5880         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5881       enddo
5882       do m=i,j-1
5883         do ll=1,3
5884           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5885         enddo
5886       enddo
5887       do m=k,l-1
5888         do ll=1,3
5889           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5890         enddo
5891       enddo
5892       esccorr=-eij*ekl
5893       return
5894       end function esccorr
5895 !-----------------------------------------------------------------------------
5896       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5897 ! This subroutine calculates multi-body contributions to hydrogen-bonding
5898 !      implicit real*8 (a-h,o-z)
5899 !      include 'DIMENSIONS'
5900 !      include 'COMMON.IOUNITS'
5901 #ifdef MPI
5902       include "mpif.h"
5903 !      integer :: maxconts !max_cont=maxconts  =nres/4
5904       integer,parameter :: max_dim=26
5905       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5906       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
5907 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
5908 !el      common /przechowalnia/ zapas
5909       integer :: status(MPI_STATUS_SIZE)
5910       integer,dimension((nres/4)*2) :: req !maxconts*2
5911       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
5912 #endif
5913 !      include 'COMMON.SETUP'
5914 !      include 'COMMON.FFIELD'
5915 !      include 'COMMON.DERIV'
5916 !      include 'COMMON.INTERACT'
5917 !      include 'COMMON.CONTACTS'
5918 !      include 'COMMON.CONTROL'
5919 !      include 'COMMON.LOCAL'
5920       real(kind=8),dimension(3) :: gx,gx1
5921       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
5922       logical :: lprn,ldone
5923 !el local variables
5924       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
5925               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
5926
5927 ! Set lprn=.true. for debugging
5928       lprn=.false.
5929 #ifdef MPI
5930 !      maxconts=nres/4
5931       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
5932       n_corr=0
5933       n_corr1=0
5934       if (nfgtasks.le.1) goto 30
5935       if (lprn) then
5936         write (iout,'(a)') 'Contact function values before RECEIVE:'
5937         do i=nnt,nct-2
5938           write (iout,'(2i3,50(1x,i2,f5.2))') &
5939           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
5940           j=1,num_cont_hb(i))
5941         enddo
5942       endif
5943       call flush(iout)
5944       do i=1,ntask_cont_from
5945         ncont_recv(i)=0
5946       enddo
5947       do i=1,ntask_cont_to
5948         ncont_sent(i)=0
5949       enddo
5950 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5951 !     & ntask_cont_to
5952 ! Make the list of contacts to send to send to other procesors
5953 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5954 !      call flush(iout)
5955       do i=iturn3_start,iturn3_end
5956 !        write (iout,*) "make contact list turn3",i," num_cont",
5957 !     &    num_cont_hb(i)
5958         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5959       enddo
5960       do i=iturn4_start,iturn4_end
5961 !        write (iout,*) "make contact list turn4",i," num_cont",
5962 !     &   num_cont_hb(i)
5963         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5964       enddo
5965       do ii=1,nat_sent
5966         i=iat_sent(ii)
5967 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
5968 !     &    num_cont_hb(i)
5969         do j=1,num_cont_hb(i)
5970         do k=1,4
5971           jjc=jcont_hb(j,i)
5972           iproc=iint_sent_local(k,jjc,ii)
5973 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5974           if (iproc.gt.0) then
5975             ncont_sent(iproc)=ncont_sent(iproc)+1
5976             nn=ncont_sent(iproc)
5977             zapas(1,nn,iproc)=i
5978             zapas(2,nn,iproc)=jjc
5979             zapas(3,nn,iproc)=facont_hb(j,i)
5980             zapas(4,nn,iproc)=ees0p(j,i)
5981             zapas(5,nn,iproc)=ees0m(j,i)
5982             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5983             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5984             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5985             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5986             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5987             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5988             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5989             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5990             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5991             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5992             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5993             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5994             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5995             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5996             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5997             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5998             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5999             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6000             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6001             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6002             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6003           endif
6004         enddo
6005         enddo
6006       enddo
6007       if (lprn) then
6008       write (iout,*) &
6009         "Numbers of contacts to be sent to other processors",&
6010         (ncont_sent(i),i=1,ntask_cont_to)
6011       write (iout,*) "Contacts sent"
6012       do ii=1,ntask_cont_to
6013         nn=ncont_sent(ii)
6014         iproc=itask_cont_to(ii)
6015         write (iout,*) nn," contacts to processor",iproc,&
6016          " of CONT_TO_COMM group"
6017         do i=1,nn
6018           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6019         enddo
6020       enddo
6021       call flush(iout)
6022       endif
6023       CorrelType=477
6024       CorrelID=fg_rank+1
6025       CorrelType1=478
6026       CorrelID1=nfgtasks+fg_rank+1
6027       ireq=0
6028 ! Receive the numbers of needed contacts from other processors
6029       do ii=1,ntask_cont_from
6030         iproc=itask_cont_from(ii)
6031         ireq=ireq+1
6032         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6033           FG_COMM,req(ireq),IERR)
6034       enddo
6035 !      write (iout,*) "IRECV ended"
6036 !      call flush(iout)
6037 ! Send the number of contacts needed by other processors
6038       do ii=1,ntask_cont_to
6039         iproc=itask_cont_to(ii)
6040         ireq=ireq+1
6041         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6042           FG_COMM,req(ireq),IERR)
6043       enddo
6044 !      write (iout,*) "ISEND ended"
6045 !      write (iout,*) "number of requests (nn)",ireq
6046       call flush(iout)
6047       if (ireq.gt.0) &
6048         call MPI_Waitall(ireq,req,status_array,ierr)
6049 !      write (iout,*)
6050 !     &  "Numbers of contacts to be received from other processors",
6051 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6052 !      call flush(iout)
6053 ! Receive contacts
6054       ireq=0
6055       do ii=1,ntask_cont_from
6056         iproc=itask_cont_from(ii)
6057         nn=ncont_recv(ii)
6058 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6059 !     &   " of CONT_TO_COMM group"
6060         call flush(iout)
6061         if (nn.gt.0) then
6062           ireq=ireq+1
6063           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6064           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6065 !          write (iout,*) "ireq,req",ireq,req(ireq)
6066         endif
6067       enddo
6068 ! Send the contacts to processors that need them
6069       do ii=1,ntask_cont_to
6070         iproc=itask_cont_to(ii)
6071         nn=ncont_sent(ii)
6072 !        write (iout,*) nn," contacts to processor",iproc,
6073 !     &   " of CONT_TO_COMM group"
6074         if (nn.gt.0) then
6075           ireq=ireq+1
6076           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6077             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6078 !          write (iout,*) "ireq,req",ireq,req(ireq)
6079 !          do i=1,nn
6080 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6081 !          enddo
6082         endif
6083       enddo
6084 !      write (iout,*) "number of requests (contacts)",ireq
6085 !      write (iout,*) "req",(req(i),i=1,4)
6086 !      call flush(iout)
6087       if (ireq.gt.0) &
6088        call MPI_Waitall(ireq,req,status_array,ierr)
6089       do iii=1,ntask_cont_from
6090         iproc=itask_cont_from(iii)
6091         nn=ncont_recv(iii)
6092         if (lprn) then
6093         write (iout,*) "Received",nn," contacts from processor",iproc,&
6094          " of CONT_FROM_COMM group"
6095         call flush(iout)
6096         do i=1,nn
6097           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6098         enddo
6099         call flush(iout)
6100         endif
6101         do i=1,nn
6102           ii=zapas_recv(1,i,iii)
6103 ! Flag the received contacts to prevent double-counting
6104           jj=-zapas_recv(2,i,iii)
6105 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6106 !          call flush(iout)
6107           nnn=num_cont_hb(ii)+1
6108           num_cont_hb(ii)=nnn
6109           jcont_hb(nnn,ii)=jj
6110           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6111           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6112           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6113           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6114           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6115           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6116           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6117           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6118           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6119           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6120           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6121           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6122           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6123           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6124           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6125           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6126           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6127           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6128           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6129           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6130           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6131           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6132           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6133           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6134         enddo
6135       enddo
6136       call flush(iout)
6137       if (lprn) then
6138         write (iout,'(a)') 'Contact function values after receive:'
6139         do i=nnt,nct-2
6140           write (iout,'(2i3,50(1x,i3,f5.2))') &
6141           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6142           j=1,num_cont_hb(i))
6143         enddo
6144         call flush(iout)
6145       endif
6146    30 continue
6147 #endif
6148       if (lprn) then
6149         write (iout,'(a)') 'Contact function values:'
6150         do i=nnt,nct-2
6151           write (iout,'(2i3,50(1x,i3,f5.2))') &
6152           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6153           j=1,num_cont_hb(i))
6154         enddo
6155       endif
6156       ecorr=0.0D0
6157
6158 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6159 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6160 ! Remove the loop below after debugging !!!
6161       do i=nnt,nct
6162         do j=1,3
6163           gradcorr(j,i)=0.0D0
6164           gradxorr(j,i)=0.0D0
6165         enddo
6166       enddo
6167 ! Calculate the local-electrostatic correlation terms
6168       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6169         i1=i+1
6170         num_conti=num_cont_hb(i)
6171         num_conti1=num_cont_hb(i+1)
6172         do jj=1,num_conti
6173           j=jcont_hb(jj,i)
6174           jp=iabs(j)
6175           do kk=1,num_conti1
6176             j1=jcont_hb(kk,i1)
6177             jp1=iabs(j1)
6178 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6179 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6180             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6181                 .or. j.lt.0 .and. j1.gt.0) .and. &
6182                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6183 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6184 ! The system gains extra energy.
6185               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6186               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6187                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6188               n_corr=n_corr+1
6189             else if (j1.eq.j) then
6190 ! Contacts I-J and I-(J+1) occur simultaneously.
6191 ! The system loses extra energy.
6192 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6193             endif
6194           enddo ! kk
6195           do kk=1,num_conti
6196             j1=jcont_hb(kk,i)
6197 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6198 !    &         ' jj=',jj,' kk=',kk
6199             if (j1.eq.j+1) then
6200 ! Contacts I-J and (I+1)-J occur simultaneously.
6201 ! The system loses extra energy.
6202 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6203             endif ! j1==j+1
6204           enddo ! kk
6205         enddo ! jj
6206       enddo ! i
6207       return
6208       end subroutine multibody_hb
6209 !-----------------------------------------------------------------------------
6210       subroutine add_hb_contact(ii,jj,itask)
6211 !      implicit real*8 (a-h,o-z)
6212 !      include "DIMENSIONS"
6213 !      include "COMMON.IOUNITS"
6214 !      include "COMMON.CONTACTS"
6215 !      integer,parameter :: maxconts=nres/4
6216       integer,parameter :: max_dim=26
6217       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6218 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6219 !      common /przechowalnia/ zapas
6220       integer :: i,j,ii,jj,iproc,nn,jjc
6221       integer,dimension(4) :: itask
6222 !      write (iout,*) "itask",itask
6223       do i=1,2
6224         iproc=itask(i)
6225         if (iproc.gt.0) then
6226           do j=1,num_cont_hb(ii)
6227             jjc=jcont_hb(j,ii)
6228 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6229             if (jjc.eq.jj) then
6230               ncont_sent(iproc)=ncont_sent(iproc)+1
6231               nn=ncont_sent(iproc)
6232               zapas(1,nn,iproc)=ii
6233               zapas(2,nn,iproc)=jjc
6234               zapas(3,nn,iproc)=facont_hb(j,ii)
6235               zapas(4,nn,iproc)=ees0p(j,ii)
6236               zapas(5,nn,iproc)=ees0m(j,ii)
6237               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6238               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6239               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6240               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6241               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6242               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6243               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6244               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6245               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6246               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6247               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6248               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6249               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6250               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6251               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6252               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6253               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6254               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6255               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6256               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6257               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6258               exit
6259             endif
6260           enddo
6261         endif
6262       enddo
6263       return
6264       end subroutine add_hb_contact
6265 !-----------------------------------------------------------------------------
6266       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6267 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6268 !      implicit real*8 (a-h,o-z)
6269 !      include 'DIMENSIONS'
6270 !      include 'COMMON.IOUNITS'
6271       integer,parameter :: max_dim=70
6272 #ifdef MPI
6273       include "mpif.h"
6274 !      integer :: maxconts !max_cont=maxconts=nres/4
6275       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6276       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6277 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6278 !      common /przechowalnia/ zapas
6279       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6280         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6281         ierr,iii,nnn
6282 #endif
6283 !      include 'COMMON.SETUP'
6284 !      include 'COMMON.FFIELD'
6285 !      include 'COMMON.DERIV'
6286 !      include 'COMMON.LOCAL'
6287 !      include 'COMMON.INTERACT'
6288 !      include 'COMMON.CONTACTS'
6289 !      include 'COMMON.CHAIN'
6290 !      include 'COMMON.CONTROL'
6291       real(kind=8),dimension(3) :: gx,gx1
6292       integer,dimension(nres) :: num_cont_hb_old
6293       logical :: lprn,ldone
6294 !EL      double precision eello4,eello5,eelo6,eello_turn6
6295 !EL      external eello4,eello5,eello6,eello_turn6
6296 !el local variables
6297       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6298               j1,jp1,i1,num_conti1
6299       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6300       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6301
6302 ! Set lprn=.true. for debugging
6303       lprn=.false.
6304       eturn6=0.0d0
6305 #ifdef MPI
6306 !      maxconts=nres/4
6307       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6308       do i=1,nres
6309         num_cont_hb_old(i)=num_cont_hb(i)
6310       enddo
6311       n_corr=0
6312       n_corr1=0
6313       if (nfgtasks.le.1) goto 30
6314       if (lprn) then
6315         write (iout,'(a)') 'Contact function values before RECEIVE:'
6316         do i=nnt,nct-2
6317           write (iout,'(2i3,50(1x,i2,f5.2))') &
6318           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6319           j=1,num_cont_hb(i))
6320         enddo
6321       endif
6322       call flush(iout)
6323       do i=1,ntask_cont_from
6324         ncont_recv(i)=0
6325       enddo
6326       do i=1,ntask_cont_to
6327         ncont_sent(i)=0
6328       enddo
6329 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6330 !     & ntask_cont_to
6331 ! Make the list of contacts to send to send to other procesors
6332       do i=iturn3_start,iturn3_end
6333 !        write (iout,*) "make contact list turn3",i," num_cont",
6334 !     &    num_cont_hb(i)
6335         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6336       enddo
6337       do i=iturn4_start,iturn4_end
6338 !        write (iout,*) "make contact list turn4",i," num_cont",
6339 !     &   num_cont_hb(i)
6340         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6341       enddo
6342       do ii=1,nat_sent
6343         i=iat_sent(ii)
6344 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6345 !     &    num_cont_hb(i)
6346         do j=1,num_cont_hb(i)
6347         do k=1,4
6348           jjc=jcont_hb(j,i)
6349           iproc=iint_sent_local(k,jjc,ii)
6350 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6351           if (iproc.ne.0) then
6352             ncont_sent(iproc)=ncont_sent(iproc)+1
6353             nn=ncont_sent(iproc)
6354             zapas(1,nn,iproc)=i
6355             zapas(2,nn,iproc)=jjc
6356             zapas(3,nn,iproc)=d_cont(j,i)
6357             ind=3
6358             do kk=1,3
6359               ind=ind+1
6360               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6361             enddo
6362             do kk=1,2
6363               do ll=1,2
6364                 ind=ind+1
6365                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6366               enddo
6367             enddo
6368             do jj=1,5
6369               do kk=1,3
6370                 do ll=1,2
6371                   do mm=1,2
6372                     ind=ind+1
6373                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6374                   enddo
6375                 enddo
6376               enddo
6377             enddo
6378           endif
6379         enddo
6380         enddo
6381       enddo
6382       if (lprn) then
6383       write (iout,*) &
6384         "Numbers of contacts to be sent to other processors",&
6385         (ncont_sent(i),i=1,ntask_cont_to)
6386       write (iout,*) "Contacts sent"
6387       do ii=1,ntask_cont_to
6388         nn=ncont_sent(ii)
6389         iproc=itask_cont_to(ii)
6390         write (iout,*) nn," contacts to processor",iproc,&
6391          " of CONT_TO_COMM group"
6392         do i=1,nn
6393           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6394         enddo
6395       enddo
6396       call flush(iout)
6397       endif
6398       CorrelType=477
6399       CorrelID=fg_rank+1
6400       CorrelType1=478
6401       CorrelID1=nfgtasks+fg_rank+1
6402       ireq=0
6403 ! Receive the numbers of needed contacts from other processors
6404       do ii=1,ntask_cont_from
6405         iproc=itask_cont_from(ii)
6406         ireq=ireq+1
6407         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6408           FG_COMM,req(ireq),IERR)
6409       enddo
6410 !      write (iout,*) "IRECV ended"
6411 !      call flush(iout)
6412 ! Send the number of contacts needed by other processors
6413       do ii=1,ntask_cont_to
6414         iproc=itask_cont_to(ii)
6415         ireq=ireq+1
6416         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6417           FG_COMM,req(ireq),IERR)
6418       enddo
6419 !      write (iout,*) "ISEND ended"
6420 !      write (iout,*) "number of requests (nn)",ireq
6421       call flush(iout)
6422       if (ireq.gt.0) &
6423         call MPI_Waitall(ireq,req,status_array,ierr)
6424 !      write (iout,*)
6425 !     &  "Numbers of contacts to be received from other processors",
6426 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6427 !      call flush(iout)
6428 ! Receive contacts
6429       ireq=0
6430       do ii=1,ntask_cont_from
6431         iproc=itask_cont_from(ii)
6432         nn=ncont_recv(ii)
6433 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6434 !     &   " of CONT_TO_COMM group"
6435         call flush(iout)
6436         if (nn.gt.0) then
6437           ireq=ireq+1
6438           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6439           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6440 !          write (iout,*) "ireq,req",ireq,req(ireq)
6441         endif
6442       enddo
6443 ! Send the contacts to processors that need them
6444       do ii=1,ntask_cont_to
6445         iproc=itask_cont_to(ii)
6446         nn=ncont_sent(ii)
6447 !        write (iout,*) nn," contacts to processor",iproc,
6448 !     &   " of CONT_TO_COMM group"
6449         if (nn.gt.0) then
6450           ireq=ireq+1
6451           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6452             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6453 !          write (iout,*) "ireq,req",ireq,req(ireq)
6454 !          do i=1,nn
6455 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6456 !          enddo
6457         endif
6458       enddo
6459 !      write (iout,*) "number of requests (contacts)",ireq
6460 !      write (iout,*) "req",(req(i),i=1,4)
6461 !      call flush(iout)
6462       if (ireq.gt.0) &
6463        call MPI_Waitall(ireq,req,status_array,ierr)
6464       do iii=1,ntask_cont_from
6465         iproc=itask_cont_from(iii)
6466         nn=ncont_recv(iii)
6467         if (lprn) then
6468         write (iout,*) "Received",nn," contacts from processor",iproc,&
6469          " of CONT_FROM_COMM group"
6470         call flush(iout)
6471         do i=1,nn
6472           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6473         enddo
6474         call flush(iout)
6475         endif
6476         do i=1,nn
6477           ii=zapas_recv(1,i,iii)
6478 ! Flag the received contacts to prevent double-counting
6479           jj=-zapas_recv(2,i,iii)
6480 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6481 !          call flush(iout)
6482           nnn=num_cont_hb(ii)+1
6483           num_cont_hb(ii)=nnn
6484           jcont_hb(nnn,ii)=jj
6485           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6486           ind=3
6487           do kk=1,3
6488             ind=ind+1
6489             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6490           enddo
6491           do kk=1,2
6492             do ll=1,2
6493               ind=ind+1
6494               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6495             enddo
6496           enddo
6497           do jj=1,5
6498             do kk=1,3
6499               do ll=1,2
6500                 do mm=1,2
6501                   ind=ind+1
6502                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6503                 enddo
6504               enddo
6505             enddo
6506           enddo
6507         enddo
6508       enddo
6509       call flush(iout)
6510       if (lprn) then
6511         write (iout,'(a)') 'Contact function values after receive:'
6512         do i=nnt,nct-2
6513           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6514           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6515           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6516         enddo
6517         call flush(iout)
6518       endif
6519    30 continue
6520 #endif
6521       if (lprn) then
6522         write (iout,'(a)') 'Contact function values:'
6523         do i=nnt,nct-2
6524           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6525           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6526           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6527         enddo
6528       endif
6529       ecorr=0.0D0
6530       ecorr5=0.0d0
6531       ecorr6=0.0d0
6532
6533 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6534 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6535 ! Remove the loop below after debugging !!!
6536       do i=nnt,nct
6537         do j=1,3
6538           gradcorr(j,i)=0.0D0
6539           gradxorr(j,i)=0.0D0
6540         enddo
6541       enddo
6542 ! Calculate the dipole-dipole interaction energies
6543       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6544       do i=iatel_s,iatel_e+1
6545         num_conti=num_cont_hb(i)
6546         do jj=1,num_conti
6547           j=jcont_hb(jj,i)
6548 #ifdef MOMENT
6549           call dipole(i,j,jj)
6550 #endif
6551         enddo
6552       enddo
6553       endif
6554 ! Calculate the local-electrostatic correlation terms
6555 !                write (iout,*) "gradcorr5 in eello5 before loop"
6556 !                do iii=1,nres
6557 !                  write (iout,'(i5,3f10.5)')
6558 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6559 !                enddo
6560       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6561 !        write (iout,*) "corr loop i",i
6562         i1=i+1
6563         num_conti=num_cont_hb(i)
6564         num_conti1=num_cont_hb(i+1)
6565         do jj=1,num_conti
6566           j=jcont_hb(jj,i)
6567           jp=iabs(j)
6568           do kk=1,num_conti1
6569             j1=jcont_hb(kk,i1)
6570             jp1=iabs(j1)
6571 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6572 !     &         ' jj=',jj,' kk=',kk
6573 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6574             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6575                 .or. j.lt.0 .and. j1.gt.0) .and. &
6576                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6577 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6578 ! The system gains extra energy.
6579               n_corr=n_corr+1
6580               sqd1=dsqrt(d_cont(jj,i))
6581               sqd2=dsqrt(d_cont(kk,i1))
6582               sred_geom = sqd1*sqd2
6583               IF (sred_geom.lt.cutoff_corr) THEN
6584                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6585                   ekont,fprimcont)
6586 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6587 !d     &         ' jj=',jj,' kk=',kk
6588                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6589                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6590                 do l=1,3
6591                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6592                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6593                 enddo
6594                 n_corr1=n_corr1+1
6595 !d               write (iout,*) 'sred_geom=',sred_geom,
6596 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6597 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6598 !d               write (iout,*) "g_contij",g_contij
6599 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6600 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6601                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6602                 if (wcorr4.gt.0.0d0) &
6603                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6604                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6605                        write (iout,'(a6,4i5,0pf7.3)') &
6606                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6607 !                write (iout,*) "gradcorr5 before eello5"
6608 !                do iii=1,nres
6609 !                  write (iout,'(i5,3f10.5)')
6610 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6611 !                enddo
6612                 if (wcorr5.gt.0.0d0) &
6613                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6614 !                write (iout,*) "gradcorr5 after eello5"
6615 !                do iii=1,nres
6616 !                  write (iout,'(i5,3f10.5)')
6617 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6618 !                enddo
6619                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6620                        write (iout,'(a6,4i5,0pf7.3)') &
6621                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6622 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6623 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6624                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6625                      .or. wturn6.eq.0.0d0))then
6626 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6627                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6628                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6629                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6630 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6631 !d     &            'ecorr6=',ecorr6
6632 !d                write (iout,'(4e15.5)') sred_geom,
6633 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6634 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6635 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6636                 else if (wturn6.gt.0.0d0 &
6637                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6638 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6639                   eturn6=eturn6+eello_turn6(i,jj,kk)
6640                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6641                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6642 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6643                 endif
6644               ENDIF
6645 1111          continue
6646             endif
6647           enddo ! kk
6648         enddo ! jj
6649       enddo ! i
6650       do i=1,nres
6651         num_cont_hb(i)=num_cont_hb_old(i)
6652       enddo
6653 !                write (iout,*) "gradcorr5 in eello5"
6654 !                do iii=1,nres
6655 !                  write (iout,'(i5,3f10.5)')
6656 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6657 !                enddo
6658       return
6659       end subroutine multibody_eello
6660 !-----------------------------------------------------------------------------
6661       subroutine add_hb_contact_eello(ii,jj,itask)
6662 !      implicit real*8 (a-h,o-z)
6663 !      include "DIMENSIONS"
6664 !      include "COMMON.IOUNITS"
6665 !      include "COMMON.CONTACTS"
6666 !      integer,parameter :: maxconts=nres/4
6667       integer,parameter :: max_dim=70
6668       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6669 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6670 !      common /przechowalnia/ zapas
6671
6672       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6673       integer,dimension(4) ::itask
6674 !      write (iout,*) "itask",itask
6675       do i=1,2
6676         iproc=itask(i)
6677         if (iproc.gt.0) then
6678           do j=1,num_cont_hb(ii)
6679             jjc=jcont_hb(j,ii)
6680 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6681             if (jjc.eq.jj) then
6682               ncont_sent(iproc)=ncont_sent(iproc)+1
6683               nn=ncont_sent(iproc)
6684               zapas(1,nn,iproc)=ii
6685               zapas(2,nn,iproc)=jjc
6686               zapas(3,nn,iproc)=d_cont(j,ii)
6687               ind=3
6688               do kk=1,3
6689                 ind=ind+1
6690                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6691               enddo
6692               do kk=1,2
6693                 do ll=1,2
6694                   ind=ind+1
6695                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6696                 enddo
6697               enddo
6698               do jj=1,5
6699                 do kk=1,3
6700                   do ll=1,2
6701                     do mm=1,2
6702                       ind=ind+1
6703                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6704                     enddo
6705                   enddo
6706                 enddo
6707               enddo
6708               exit
6709             endif
6710           enddo
6711         endif
6712       enddo
6713       return
6714       end subroutine add_hb_contact_eello
6715 !-----------------------------------------------------------------------------
6716       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6717 !      implicit real*8 (a-h,o-z)
6718 !      include 'DIMENSIONS'
6719 !      include 'COMMON.IOUNITS'
6720 !      include 'COMMON.DERIV'
6721 !      include 'COMMON.INTERACT'
6722 !      include 'COMMON.CONTACTS'
6723       real(kind=8),dimension(3) :: gx,gx1
6724       logical :: lprn
6725 !el local variables
6726       integer :: i,j,k,l,jj,kk,ll
6727       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6728                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6729                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6730
6731       lprn=.false.
6732       eij=facont_hb(jj,i)
6733       ekl=facont_hb(kk,k)
6734       ees0pij=ees0p(jj,i)
6735       ees0pkl=ees0p(kk,k)
6736       ees0mij=ees0m(jj,i)
6737       ees0mkl=ees0m(kk,k)
6738       ekont=eij*ekl
6739       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6740 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6741 ! Following 4 lines for diagnostics.
6742 !d    ees0pkl=0.0D0
6743 !d    ees0pij=1.0D0
6744 !d    ees0mkl=0.0D0
6745 !d    ees0mij=1.0D0
6746 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6747 !     & 'Contacts ',i,j,
6748 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6749 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6750 !     & 'gradcorr_long'
6751 ! Calculate the multi-body contribution to energy.
6752 !      ecorr=ecorr+ekont*ees
6753 ! Calculate multi-body contributions to the gradient.
6754       coeffpees0pij=coeffp*ees0pij
6755       coeffmees0mij=coeffm*ees0mij
6756       coeffpees0pkl=coeffp*ees0pkl
6757       coeffmees0mkl=coeffm*ees0mkl
6758       do ll=1,3
6759 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6760         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6761         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6762         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6763         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6764         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6765         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6766 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6767         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6768         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6769         coeffmees0mij*gacontm_hb1(ll,kk,k))
6770         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6771         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6772         coeffmees0mij*gacontm_hb2(ll,kk,k))
6773         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6774            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6775            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6776         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6777         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6778         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6779            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6780            coeffmees0mij*gacontm_hb3(ll,kk,k))
6781         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6782         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6783 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6784       enddo
6785 !      write (iout,*)
6786 !grad      do m=i+1,j-1
6787 !grad        do ll=1,3
6788 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6789 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6790 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6791 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6792 !grad        enddo
6793 !grad      enddo
6794 !grad      do m=k+1,l-1
6795 !grad        do ll=1,3
6796 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6797 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6798 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6799 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6800 !grad        enddo
6801 !grad      enddo
6802 !      write (iout,*) "ehbcorr",ekont*ees
6803       ehbcorr=ekont*ees
6804       return
6805       end function ehbcorr
6806 #ifdef MOMENT
6807 !-----------------------------------------------------------------------------
6808       subroutine dipole(i,j,jj)
6809 !      implicit real*8 (a-h,o-z)
6810 !      include 'DIMENSIONS'
6811 !      include 'COMMON.IOUNITS'
6812 !      include 'COMMON.CHAIN'
6813 !      include 'COMMON.FFIELD'
6814 !      include 'COMMON.DERIV'
6815 !      include 'COMMON.INTERACT'
6816 !      include 'COMMON.CONTACTS'
6817 !      include 'COMMON.TORSION'
6818 !      include 'COMMON.VAR'
6819 !      include 'COMMON.GEO'
6820       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
6821       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
6822       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
6823
6824       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
6825       allocate(dipderx(3,5,4,maxconts,nres))
6826 !
6827
6828       iti1 = itortyp(itype(i+1))
6829       if (j.lt.nres-1) then
6830         itj1 = itortyp(itype(j+1))
6831       else
6832         itj1=ntortyp+1
6833       endif
6834       do iii=1,2
6835         dipi(iii,1)=Ub2(iii,i)
6836         dipderi(iii)=Ub2der(iii,i)
6837         dipi(iii,2)=b1(iii,iti1)
6838         dipj(iii,1)=Ub2(iii,j)
6839         dipderj(iii)=Ub2der(iii,j)
6840         dipj(iii,2)=b1(iii,itj1)
6841       enddo
6842       kkk=0
6843       do iii=1,2
6844         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6845         do jjj=1,2
6846           kkk=kkk+1
6847           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6848         enddo
6849       enddo
6850       do kkk=1,5
6851         do lll=1,3
6852           mmm=0
6853           do iii=1,2
6854             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
6855               auxvec(1))
6856             do jjj=1,2
6857               mmm=mmm+1
6858               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6859             enddo
6860           enddo
6861         enddo
6862       enddo
6863       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6864       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6865       do iii=1,2
6866         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6867       enddo
6868       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6869       do iii=1,2
6870         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6871       enddo
6872       return
6873       end subroutine dipole
6874 #endif
6875 !-----------------------------------------------------------------------------
6876       subroutine calc_eello(i,j,k,l,jj,kk)
6877 !
6878 ! This subroutine computes matrices and vectors needed to calculate
6879 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
6880 !
6881       use comm_kut
6882 !      implicit real*8 (a-h,o-z)
6883 !      include 'DIMENSIONS'
6884 !      include 'COMMON.IOUNITS'
6885 !      include 'COMMON.CHAIN'
6886 !      include 'COMMON.DERIV'
6887 !      include 'COMMON.INTERACT'
6888 !      include 'COMMON.CONTACTS'
6889 !      include 'COMMON.TORSION'
6890 !      include 'COMMON.VAR'
6891 !      include 'COMMON.GEO'
6892 !      include 'COMMON.FFIELD'
6893       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
6894       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
6895       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
6896               itj1
6897 !el      logical :: lprn
6898 !el      common /kutas/ lprn
6899 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6900 !d     & ' jj=',jj,' kk=',kk
6901 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6902 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6903 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6904       do iii=1,2
6905         do jjj=1,2
6906           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6907           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6908         enddo
6909       enddo
6910       call transpose2(aa1(1,1),aa1t(1,1))
6911       call transpose2(aa2(1,1),aa2t(1,1))
6912       do kkk=1,5
6913         do lll=1,3
6914           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
6915             aa1tder(1,1,lll,kkk))
6916           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
6917             aa2tder(1,1,lll,kkk))
6918         enddo
6919       enddo
6920       if (l.eq.j+1) then
6921 ! parallel orientation of the two CA-CA-CA frames.
6922         if (i.gt.1) then
6923           iti=itortyp(itype(i))
6924         else
6925           iti=ntortyp+1
6926         endif
6927         itk1=itortyp(itype(k+1))
6928         itj=itortyp(itype(j))
6929         if (l.lt.nres-1) then
6930           itl1=itortyp(itype(l+1))
6931         else
6932           itl1=ntortyp+1
6933         endif
6934 ! A1 kernel(j+1) A2T
6935 !d        do iii=1,2
6936 !d          write (iout,'(3f10.5,5x,3f10.5)')
6937 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6938 !d        enddo
6939         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6940          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
6941          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6942 ! Following matrices are needed only for 6-th order cumulants
6943         IF (wcorr6.gt.0.0d0) THEN
6944         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6945          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
6946          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6947         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6948          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
6949          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
6950          ADtEAderx(1,1,1,1,1,1))
6951         lprn=.false.
6952         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6953          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
6954          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
6955          ADtEA1derx(1,1,1,1,1,1))
6956         ENDIF
6957 ! End 6-th order cumulants
6958 !d        lprn=.false.
6959 !d        if (lprn) then
6960 !d        write (2,*) 'In calc_eello6'
6961 !d        do iii=1,2
6962 !d          write (2,*) 'iii=',iii
6963 !d          do kkk=1,5
6964 !d            write (2,*) 'kkk=',kkk
6965 !d            do jjj=1,2
6966 !d              write (2,'(3(2f10.5),5x)')
6967 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6968 !d            enddo
6969 !d          enddo
6970 !d        enddo
6971 !d        endif
6972         call transpose2(EUgder(1,1,k),auxmat(1,1))
6973         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6974         call transpose2(EUg(1,1,k),auxmat(1,1))
6975         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6976         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6977         do iii=1,2
6978           do kkk=1,5
6979             do lll=1,3
6980               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
6981                 EAEAderx(1,1,lll,kkk,iii,1))
6982             enddo
6983           enddo
6984         enddo
6985 ! A1T kernel(i+1) A2
6986         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6987          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
6988          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6989 ! Following matrices are needed only for 6-th order cumulants
6990         IF (wcorr6.gt.0.0d0) THEN
6991         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6992          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
6993          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6994         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6995          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
6996          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
6997          ADtEAderx(1,1,1,1,1,2))
6998         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6999          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7000          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7001          ADtEA1derx(1,1,1,1,1,2))
7002         ENDIF
7003 ! End 6-th order cumulants
7004         call transpose2(EUgder(1,1,l),auxmat(1,1))
7005         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7006         call transpose2(EUg(1,1,l),auxmat(1,1))
7007         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7008         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7009         do iii=1,2
7010           do kkk=1,5
7011             do lll=1,3
7012               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7013                 EAEAderx(1,1,lll,kkk,iii,2))
7014             enddo
7015           enddo
7016         enddo
7017 ! AEAb1 and AEAb2
7018 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7019 ! They are needed only when the fifth- or the sixth-order cumulants are
7020 ! indluded.
7021         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7022         call transpose2(AEA(1,1,1),auxmat(1,1))
7023         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7024         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7025         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7026         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7027         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7028         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7029         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7030         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7031         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7032         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7033         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7034         call transpose2(AEA(1,1,2),auxmat(1,1))
7035         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7036         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7037         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7038         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7039         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7040         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7041         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7042         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7043         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7044         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7045         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7046 ! Calculate the Cartesian derivatives of the vectors.
7047         do iii=1,2
7048           do kkk=1,5
7049             do lll=1,3
7050               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7051               call matvec2(auxmat(1,1),b1(1,iti),&
7052                 AEAb1derx(1,lll,kkk,iii,1,1))
7053               call matvec2(auxmat(1,1),Ub2(1,i),&
7054                 AEAb2derx(1,lll,kkk,iii,1,1))
7055               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7056                 AEAb1derx(1,lll,kkk,iii,2,1))
7057               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7058                 AEAb2derx(1,lll,kkk,iii,2,1))
7059               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7060               call matvec2(auxmat(1,1),b1(1,itj),&
7061                 AEAb1derx(1,lll,kkk,iii,1,2))
7062               call matvec2(auxmat(1,1),Ub2(1,j),&
7063                 AEAb2derx(1,lll,kkk,iii,1,2))
7064               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7065                 AEAb1derx(1,lll,kkk,iii,2,2))
7066               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7067                 AEAb2derx(1,lll,kkk,iii,2,2))
7068             enddo
7069           enddo
7070         enddo
7071         ENDIF
7072 ! End vectors
7073       else
7074 ! Antiparallel orientation of the two CA-CA-CA frames.
7075         if (i.gt.1) then
7076           iti=itortyp(itype(i))
7077         else
7078           iti=ntortyp+1
7079         endif
7080         itk1=itortyp(itype(k+1))
7081         itl=itortyp(itype(l))
7082         itj=itortyp(itype(j))
7083         if (j.lt.nres-1) then
7084           itj1=itortyp(itype(j+1))
7085         else
7086           itj1=ntortyp+1
7087         endif
7088 ! A2 kernel(j-1)T A1T
7089         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7090          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7091          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7092 ! Following matrices are needed only for 6-th order cumulants
7093         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7094            j.eq.i+4 .and. l.eq.i+3)) THEN
7095         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7096          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7097          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7098         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7099          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7100          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7101          ADtEAderx(1,1,1,1,1,1))
7102         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7103          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7104          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7105          ADtEA1derx(1,1,1,1,1,1))
7106         ENDIF
7107 ! End 6-th order cumulants
7108         call transpose2(EUgder(1,1,k),auxmat(1,1))
7109         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7110         call transpose2(EUg(1,1,k),auxmat(1,1))
7111         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7112         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7113         do iii=1,2
7114           do kkk=1,5
7115             do lll=1,3
7116               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7117                 EAEAderx(1,1,lll,kkk,iii,1))
7118             enddo
7119           enddo
7120         enddo
7121 ! A2T kernel(i+1)T A1
7122         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7123          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7124          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7125 ! Following matrices are needed only for 6-th order cumulants
7126         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7127            j.eq.i+4 .and. l.eq.i+3)) THEN
7128         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7129          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7130          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7131         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7132          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7133          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7134          ADtEAderx(1,1,1,1,1,2))
7135         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7136          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7137          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7138          ADtEA1derx(1,1,1,1,1,2))
7139         ENDIF
7140 ! End 6-th order cumulants
7141         call transpose2(EUgder(1,1,j),auxmat(1,1))
7142         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7143         call transpose2(EUg(1,1,j),auxmat(1,1))
7144         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7145         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7146         do iii=1,2
7147           do kkk=1,5
7148             do lll=1,3
7149               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7150                 EAEAderx(1,1,lll,kkk,iii,2))
7151             enddo
7152           enddo
7153         enddo
7154 ! AEAb1 and AEAb2
7155 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7156 ! They are needed only when the fifth- or the sixth-order cumulants are
7157 ! indluded.
7158         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7159           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7160         call transpose2(AEA(1,1,1),auxmat(1,1))
7161         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7162         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7163         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7164         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7165         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7166         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7167         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7168         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7169         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7170         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7171         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7172         call transpose2(AEA(1,1,2),auxmat(1,1))
7173         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7174         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7175         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7176         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7177         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7178         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7179         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7180         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7181         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7182         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7183         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7184 ! Calculate the Cartesian derivatives of the vectors.
7185         do iii=1,2
7186           do kkk=1,5
7187             do lll=1,3
7188               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7189               call matvec2(auxmat(1,1),b1(1,iti),&
7190                 AEAb1derx(1,lll,kkk,iii,1,1))
7191               call matvec2(auxmat(1,1),Ub2(1,i),&
7192                 AEAb2derx(1,lll,kkk,iii,1,1))
7193               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7194                 AEAb1derx(1,lll,kkk,iii,2,1))
7195               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7196                 AEAb2derx(1,lll,kkk,iii,2,1))
7197               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7198               call matvec2(auxmat(1,1),b1(1,itl),&
7199                 AEAb1derx(1,lll,kkk,iii,1,2))
7200               call matvec2(auxmat(1,1),Ub2(1,l),&
7201                 AEAb2derx(1,lll,kkk,iii,1,2))
7202               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7203                 AEAb1derx(1,lll,kkk,iii,2,2))
7204               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7205                 AEAb2derx(1,lll,kkk,iii,2,2))
7206             enddo
7207           enddo
7208         enddo
7209         ENDIF
7210 ! End vectors
7211       endif
7212       return
7213       end subroutine calc_eello
7214 !-----------------------------------------------------------------------------
7215       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7216       use comm_kut
7217       implicit none
7218       integer :: nderg
7219       logical :: transp
7220       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7221       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7222       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7223       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7224       integer :: iii,kkk,lll
7225       integer :: jjj,mmm
7226 !el      logical :: lprn
7227 !el      common /kutas/ lprn
7228       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7229       do iii=1,nderg
7230         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7231           AKAderg(1,1,iii))
7232       enddo
7233 !d      if (lprn) write (2,*) 'In kernel'
7234       do kkk=1,5
7235 !d        if (lprn) write (2,*) 'kkk=',kkk
7236         do lll=1,3
7237           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7238             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7239 !d          if (lprn) then
7240 !d            write (2,*) 'lll=',lll
7241 !d            write (2,*) 'iii=1'
7242 !d            do jjj=1,2
7243 !d              write (2,'(3(2f10.5),5x)')
7244 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7245 !d            enddo
7246 !d          endif
7247           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7248             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7249 !d          if (lprn) then
7250 !d            write (2,*) 'lll=',lll
7251 !d            write (2,*) 'iii=2'
7252 !d            do jjj=1,2
7253 !d              write (2,'(3(2f10.5),5x)')
7254 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7255 !d            enddo
7256 !d          endif
7257         enddo
7258       enddo
7259       return
7260       end subroutine kernel
7261 !-----------------------------------------------------------------------------
7262       real(kind=8) function eello4(i,j,k,l,jj,kk)
7263 !      implicit real*8 (a-h,o-z)
7264 !      include 'DIMENSIONS'
7265 !      include 'COMMON.IOUNITS'
7266 !      include 'COMMON.CHAIN'
7267 !      include 'COMMON.DERIV'
7268 !      include 'COMMON.INTERACT'
7269 !      include 'COMMON.CONTACTS'
7270 !      include 'COMMON.TORSION'
7271 !      include 'COMMON.VAR'
7272 !      include 'COMMON.GEO'
7273       real(kind=8),dimension(2,2) :: pizda
7274       real(kind=8),dimension(3) :: ggg1,ggg2
7275       real(kind=8) ::  eel4,glongij,glongkl
7276       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7277 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7278 !d        eello4=0.0d0
7279 !d        return
7280 !d      endif
7281 !d      print *,'eello4:',i,j,k,l,jj,kk
7282 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7283 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7284 !old      eij=facont_hb(jj,i)
7285 !old      ekl=facont_hb(kk,k)
7286 !old      ekont=eij*ekl
7287       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7288 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7289       gcorr_loc(k-1)=gcorr_loc(k-1) &
7290          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7291       if (l.eq.j+1) then
7292         gcorr_loc(l-1)=gcorr_loc(l-1) &
7293            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7294       else
7295         gcorr_loc(j-1)=gcorr_loc(j-1) &
7296            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7297       endif
7298       do iii=1,2
7299         do kkk=1,5
7300           do lll=1,3
7301             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7302                               -EAEAderx(2,2,lll,kkk,iii,1)
7303 !d            derx(lll,kkk,iii)=0.0d0
7304           enddo
7305         enddo
7306       enddo
7307 !d      gcorr_loc(l-1)=0.0d0
7308 !d      gcorr_loc(j-1)=0.0d0
7309 !d      gcorr_loc(k-1)=0.0d0
7310 !d      eel4=1.0d0
7311 !d      write (iout,*)'Contacts have occurred for peptide groups',
7312 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7313 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7314       if (j.lt.nres-1) then
7315         j1=j+1
7316         j2=j-1
7317       else
7318         j1=j-1
7319         j2=j-2
7320       endif
7321       if (l.lt.nres-1) then
7322         l1=l+1
7323         l2=l-1
7324       else
7325         l1=l-1
7326         l2=l-2
7327       endif
7328       do ll=1,3
7329 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7330 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7331         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7332         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7333 !grad        ghalf=0.5d0*ggg1(ll)
7334         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7335         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7336         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7337         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7338         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7339         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7340 !grad        ghalf=0.5d0*ggg2(ll)
7341         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7342         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7343         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7344         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7345         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7346         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7347       enddo
7348 !grad      do m=i+1,j-1
7349 !grad        do ll=1,3
7350 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7351 !grad        enddo
7352 !grad      enddo
7353 !grad      do m=k+1,l-1
7354 !grad        do ll=1,3
7355 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7356 !grad        enddo
7357 !grad      enddo
7358 !grad      do m=i+2,j2
7359 !grad        do ll=1,3
7360 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7361 !grad        enddo
7362 !grad      enddo
7363 !grad      do m=k+2,l2
7364 !grad        do ll=1,3
7365 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7366 !grad        enddo
7367 !grad      enddo
7368 !d      do iii=1,nres-3
7369 !d        write (2,*) iii,gcorr_loc(iii)
7370 !d      enddo
7371       eello4=ekont*eel4
7372 !d      write (2,*) 'ekont',ekont
7373 !d      write (iout,*) 'eello4',ekont*eel4
7374       return
7375       end function eello4
7376 !-----------------------------------------------------------------------------
7377       real(kind=8) function eello5(i,j,k,l,jj,kk)
7378 !      implicit real*8 (a-h,o-z)
7379 !      include 'DIMENSIONS'
7380 !      include 'COMMON.IOUNITS'
7381 !      include 'COMMON.CHAIN'
7382 !      include 'COMMON.DERIV'
7383 !      include 'COMMON.INTERACT'
7384 !      include 'COMMON.CONTACTS'
7385 !      include 'COMMON.TORSION'
7386 !      include 'COMMON.VAR'
7387 !      include 'COMMON.GEO'
7388       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7389       real(kind=8),dimension(2) :: vv
7390       real(kind=8),dimension(3) :: ggg1,ggg2
7391       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7392       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7393       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7394 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7395 !                                                                              C
7396 !                            Parallel chains                                   C
7397 !                                                                              C
7398 !          o             o                   o             o                   C
7399 !         /l\           / \             \   / \           / \   /              C
7400 !        /   \         /   \             \ /   \         /   \ /               C
7401 !       j| o |l1       | o |              o| o |         | o |o                C
7402 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7403 !      \i/   \         /   \ /             /   \         /   \                 C
7404 !       o    k1             o                                                  C
7405 !         (I)          (II)                (III)          (IV)                 C
7406 !                                                                              C
7407 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7408 !                                                                              C
7409 !                            Antiparallel chains                               C
7410 !                                                                              C
7411 !          o             o                   o             o                   C
7412 !         /j\           / \             \   / \           / \   /              C
7413 !        /   \         /   \             \ /   \         /   \ /               C
7414 !      j1| o |l        | o |              o| o |         | o |o                C
7415 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7416 !      \i/   \         /   \ /             /   \         /   \                 C
7417 !       o     k1            o                                                  C
7418 !         (I)          (II)                (III)          (IV)                 C
7419 !                                                                              C
7420 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7421 !                                                                              C
7422 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7423 !                                                                              C
7424 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7425 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7426 !d        eello5=0.0d0
7427 !d        return
7428 !d      endif
7429 !d      write (iout,*)
7430 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7431 !d     &   ' and',k,l
7432       itk=itortyp(itype(k))
7433       itl=itortyp(itype(l))
7434       itj=itortyp(itype(j))
7435       eello5_1=0.0d0
7436       eello5_2=0.0d0
7437       eello5_3=0.0d0
7438       eello5_4=0.0d0
7439 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7440 !d     &   eel5_3_num,eel5_4_num)
7441       do iii=1,2
7442         do kkk=1,5
7443           do lll=1,3
7444             derx(lll,kkk,iii)=0.0d0
7445           enddo
7446         enddo
7447       enddo
7448 !d      eij=facont_hb(jj,i)
7449 !d      ekl=facont_hb(kk,k)
7450 !d      ekont=eij*ekl
7451 !d      write (iout,*)'Contacts have occurred for peptide groups',
7452 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7453 !d      goto 1111
7454 ! Contribution from the graph I.
7455 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7456 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7457       call transpose2(EUg(1,1,k),auxmat(1,1))
7458       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7459       vv(1)=pizda(1,1)-pizda(2,2)
7460       vv(2)=pizda(1,2)+pizda(2,1)
7461       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7462        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7463 ! Explicit gradient in virtual-dihedral angles.
7464       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7465        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7466        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7467       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7468       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7469       vv(1)=pizda(1,1)-pizda(2,2)
7470       vv(2)=pizda(1,2)+pizda(2,1)
7471       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7472        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7473        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7474       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7475       vv(1)=pizda(1,1)-pizda(2,2)
7476       vv(2)=pizda(1,2)+pizda(2,1)
7477       if (l.eq.j+1) then
7478         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7479          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7480          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7481       else
7482         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7483          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7484          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7485       endif
7486 ! Cartesian gradient
7487       do iii=1,2
7488         do kkk=1,5
7489           do lll=1,3
7490             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7491               pizda(1,1))
7492             vv(1)=pizda(1,1)-pizda(2,2)
7493             vv(2)=pizda(1,2)+pizda(2,1)
7494             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7495              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7496              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7497           enddo
7498         enddo
7499       enddo
7500 !      goto 1112
7501 !1111  continue
7502 ! Contribution from graph II
7503       call transpose2(EE(1,1,itk),auxmat(1,1))
7504       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7505       vv(1)=pizda(1,1)+pizda(2,2)
7506       vv(2)=pizda(2,1)-pizda(1,2)
7507       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7508        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7509 ! Explicit gradient in virtual-dihedral angles.
7510       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7511        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7512       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7513       vv(1)=pizda(1,1)+pizda(2,2)
7514       vv(2)=pizda(2,1)-pizda(1,2)
7515       if (l.eq.j+1) then
7516         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7517          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7518          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7519       else
7520         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7521          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7522          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7523       endif
7524 ! Cartesian gradient
7525       do iii=1,2
7526         do kkk=1,5
7527           do lll=1,3
7528             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7529               pizda(1,1))
7530             vv(1)=pizda(1,1)+pizda(2,2)
7531             vv(2)=pizda(2,1)-pizda(1,2)
7532             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7533              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7534              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7535           enddo
7536         enddo
7537       enddo
7538 !d      goto 1112
7539 !d1111  continue
7540       if (l.eq.j+1) then
7541 !d        goto 1110
7542 ! Parallel orientation
7543 ! Contribution from graph III
7544         call transpose2(EUg(1,1,l),auxmat(1,1))
7545         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7546         vv(1)=pizda(1,1)-pizda(2,2)
7547         vv(2)=pizda(1,2)+pizda(2,1)
7548         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7549          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7550 ! Explicit gradient in virtual-dihedral angles.
7551         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7552          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7553          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7554         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7555         vv(1)=pizda(1,1)-pizda(2,2)
7556         vv(2)=pizda(1,2)+pizda(2,1)
7557         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7558          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7559          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7560         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7561         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7562         vv(1)=pizda(1,1)-pizda(2,2)
7563         vv(2)=pizda(1,2)+pizda(2,1)
7564         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7565          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7566          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7567 ! Cartesian gradient
7568         do iii=1,2
7569           do kkk=1,5
7570             do lll=1,3
7571               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7572                 pizda(1,1))
7573               vv(1)=pizda(1,1)-pizda(2,2)
7574               vv(2)=pizda(1,2)+pizda(2,1)
7575               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7576                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7577                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7578             enddo
7579           enddo
7580         enddo
7581 !d        goto 1112
7582 ! Contribution from graph IV
7583 !d1110    continue
7584         call transpose2(EE(1,1,itl),auxmat(1,1))
7585         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7586         vv(1)=pizda(1,1)+pizda(2,2)
7587         vv(2)=pizda(2,1)-pizda(1,2)
7588         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7589          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7590 ! Explicit gradient in virtual-dihedral angles.
7591         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7592          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7593         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7594         vv(1)=pizda(1,1)+pizda(2,2)
7595         vv(2)=pizda(2,1)-pizda(1,2)
7596         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7597          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7598          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7599 ! Cartesian gradient
7600         do iii=1,2
7601           do kkk=1,5
7602             do lll=1,3
7603               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7604                 pizda(1,1))
7605               vv(1)=pizda(1,1)+pizda(2,2)
7606               vv(2)=pizda(2,1)-pizda(1,2)
7607               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7608                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7609                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7610             enddo
7611           enddo
7612         enddo
7613       else
7614 ! Antiparallel orientation
7615 ! Contribution from graph III
7616 !        goto 1110
7617         call transpose2(EUg(1,1,j),auxmat(1,1))
7618         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7619         vv(1)=pizda(1,1)-pizda(2,2)
7620         vv(2)=pizda(1,2)+pizda(2,1)
7621         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7622          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7623 ! Explicit gradient in virtual-dihedral angles.
7624         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7625          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7626          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7627         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7628         vv(1)=pizda(1,1)-pizda(2,2)
7629         vv(2)=pizda(1,2)+pizda(2,1)
7630         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7631          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7632          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7633         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7634         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7635         vv(1)=pizda(1,1)-pizda(2,2)
7636         vv(2)=pizda(1,2)+pizda(2,1)
7637         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7638          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7639          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7640 ! Cartesian gradient
7641         do iii=1,2
7642           do kkk=1,5
7643             do lll=1,3
7644               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7645                 pizda(1,1))
7646               vv(1)=pizda(1,1)-pizda(2,2)
7647               vv(2)=pizda(1,2)+pizda(2,1)
7648               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7649                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7650                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7651             enddo
7652           enddo
7653         enddo
7654 !d        goto 1112
7655 ! Contribution from graph IV
7656 1110    continue
7657         call transpose2(EE(1,1,itj),auxmat(1,1))
7658         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7659         vv(1)=pizda(1,1)+pizda(2,2)
7660         vv(2)=pizda(2,1)-pizda(1,2)
7661         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7662          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7663 ! Explicit gradient in virtual-dihedral angles.
7664         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7665          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7666         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7667         vv(1)=pizda(1,1)+pizda(2,2)
7668         vv(2)=pizda(2,1)-pizda(1,2)
7669         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7670          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7671          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7672 ! Cartesian gradient
7673         do iii=1,2
7674           do kkk=1,5
7675             do lll=1,3
7676               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7677                 pizda(1,1))
7678               vv(1)=pizda(1,1)+pizda(2,2)
7679               vv(2)=pizda(2,1)-pizda(1,2)
7680               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7681                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7682                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7683             enddo
7684           enddo
7685         enddo
7686       endif
7687 1112  continue
7688       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7689 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7690 !d        write (2,*) 'ijkl',i,j,k,l
7691 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7692 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7693 !d      endif
7694 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7695 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7696 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7697 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7698       if (j.lt.nres-1) then
7699         j1=j+1
7700         j2=j-1
7701       else
7702         j1=j-1
7703         j2=j-2
7704       endif
7705       if (l.lt.nres-1) then
7706         l1=l+1
7707         l2=l-1
7708       else
7709         l1=l-1
7710         l2=l-2
7711       endif
7712 !d      eij=1.0d0
7713 !d      ekl=1.0d0
7714 !d      ekont=1.0d0
7715 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7716 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7717 !        summed up outside the subrouine as for the other subroutines
7718 !        handling long-range interactions. The old code is commented out
7719 !        with "cgrad" to keep track of changes.
7720       do ll=1,3
7721 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7722 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7723         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7724         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7725 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7726 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7727 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7728 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7729 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7730 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7731 !     &   gradcorr5ij,
7732 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7733 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7734 !grad        ghalf=0.5d0*ggg1(ll)
7735 !d        ghalf=0.0d0
7736         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7737         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7738         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7739         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7740         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7741         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7742 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7743 !grad        ghalf=0.5d0*ggg2(ll)
7744         ghalf=0.0d0
7745         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7746         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7747         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7748         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7749         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7750         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7751       enddo
7752 !d      goto 1112
7753 !grad      do m=i+1,j-1
7754 !grad        do ll=1,3
7755 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7756 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7757 !grad        enddo
7758 !grad      enddo
7759 !grad      do m=k+1,l-1
7760 !grad        do ll=1,3
7761 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7762 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7763 !grad        enddo
7764 !grad      enddo
7765 !1112  continue
7766 !grad      do m=i+2,j2
7767 !grad        do ll=1,3
7768 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7769 !grad        enddo
7770 !grad      enddo
7771 !grad      do m=k+2,l2
7772 !grad        do ll=1,3
7773 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7774 !grad        enddo
7775 !grad      enddo
7776 !d      do iii=1,nres-3
7777 !d        write (2,*) iii,g_corr5_loc(iii)
7778 !d      enddo
7779       eello5=ekont*eel5
7780 !d      write (2,*) 'ekont',ekont
7781 !d      write (iout,*) 'eello5',ekont*eel5
7782       return
7783       end function eello5
7784 !-----------------------------------------------------------------------------
7785       real(kind=8) function eello6(i,j,k,l,jj,kk)
7786 !      implicit real*8 (a-h,o-z)
7787 !      include 'DIMENSIONS'
7788 !      include 'COMMON.IOUNITS'
7789 !      include 'COMMON.CHAIN'
7790 !      include 'COMMON.DERIV'
7791 !      include 'COMMON.INTERACT'
7792 !      include 'COMMON.CONTACTS'
7793 !      include 'COMMON.TORSION'
7794 !      include 'COMMON.VAR'
7795 !      include 'COMMON.GEO'
7796 !      include 'COMMON.FFIELD'
7797       real(kind=8),dimension(3) :: ggg1,ggg2
7798       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7799                    eello6_6,eel6
7800       real(kind=8) :: gradcorr6ij,gradcorr6kl
7801       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7802 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7803 !d        eello6=0.0d0
7804 !d        return
7805 !d      endif
7806 !d      write (iout,*)
7807 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7808 !d     &   ' and',k,l
7809       eello6_1=0.0d0
7810       eello6_2=0.0d0
7811       eello6_3=0.0d0
7812       eello6_4=0.0d0
7813       eello6_5=0.0d0
7814       eello6_6=0.0d0
7815 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7816 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7817       do iii=1,2
7818         do kkk=1,5
7819           do lll=1,3
7820             derx(lll,kkk,iii)=0.0d0
7821           enddo
7822         enddo
7823       enddo
7824 !d      eij=facont_hb(jj,i)
7825 !d      ekl=facont_hb(kk,k)
7826 !d      ekont=eij*ekl
7827 !d      eij=1.0d0
7828 !d      ekl=1.0d0
7829 !d      ekont=1.0d0
7830       if (l.eq.j+1) then
7831         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7832         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7833         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7834         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7835         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7836         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7837       else
7838         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7839         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7840         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7841         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7842         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7843           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7844         else
7845           eello6_5=0.0d0
7846         endif
7847         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7848       endif
7849 ! If turn contributions are considered, they will be handled separately.
7850       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7851 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7852 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7853 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7854 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7855 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7856 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7857 !d      goto 1112
7858       if (j.lt.nres-1) then
7859         j1=j+1
7860         j2=j-1
7861       else
7862         j1=j-1
7863         j2=j-2
7864       endif
7865       if (l.lt.nres-1) then
7866         l1=l+1
7867         l2=l-1
7868       else
7869         l1=l-1
7870         l2=l-2
7871       endif
7872       do ll=1,3
7873 !grad        ggg1(ll)=eel6*g_contij(ll,1)
7874 !grad        ggg2(ll)=eel6*g_contij(ll,2)
7875 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7876 !grad        ghalf=0.5d0*ggg1(ll)
7877 !d        ghalf=0.0d0
7878         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7879         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7880         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7881         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7882         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7883         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7884         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7885         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7886 !grad        ghalf=0.5d0*ggg2(ll)
7887 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7888 !d        ghalf=0.0d0
7889         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7890         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7891         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7892         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7893         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7894         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7895       enddo
7896 !d      goto 1112
7897 !grad      do m=i+1,j-1
7898 !grad        do ll=1,3
7899 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7900 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7901 !grad        enddo
7902 !grad      enddo
7903 !grad      do m=k+1,l-1
7904 !grad        do ll=1,3
7905 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7906 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7907 !grad        enddo
7908 !grad      enddo
7909 !grad1112  continue
7910 !grad      do m=i+2,j2
7911 !grad        do ll=1,3
7912 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7913 !grad        enddo
7914 !grad      enddo
7915 !grad      do m=k+2,l2
7916 !grad        do ll=1,3
7917 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7918 !grad        enddo
7919 !grad      enddo
7920 !d      do iii=1,nres-3
7921 !d        write (2,*) iii,g_corr6_loc(iii)
7922 !d      enddo
7923       eello6=ekont*eel6
7924 !d      write (2,*) 'ekont',ekont
7925 !d      write (iout,*) 'eello6',ekont*eel6
7926       return
7927       end function eello6
7928 !-----------------------------------------------------------------------------
7929       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
7930       use comm_kut
7931 !      implicit real*8 (a-h,o-z)
7932 !      include 'DIMENSIONS'
7933 !      include 'COMMON.IOUNITS'
7934 !      include 'COMMON.CHAIN'
7935 !      include 'COMMON.DERIV'
7936 !      include 'COMMON.INTERACT'
7937 !      include 'COMMON.CONTACTS'
7938 !      include 'COMMON.TORSION'
7939 !      include 'COMMON.VAR'
7940 !      include 'COMMON.GEO'
7941       real(kind=8),dimension(2) :: vv,vv1
7942       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
7943       logical :: swap
7944 !el      logical :: lprn
7945 !el      common /kutas/ lprn
7946       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
7947       real(kind=8) :: s1,s2,s3,s4,s5
7948 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7949 !                                                                              C
7950 !      Parallel       Antiparallel                                             C
7951 !                                                                              C
7952 !          o             o                                                     C
7953 !         /l\           /j\                                                    C
7954 !        /   \         /   \                                                   C
7955 !       /| o |         | o |\                                                  C
7956 !     \ j|/k\|  /   \  |/k\|l /                                                C
7957 !      \ /   \ /     \ /   \ /                                                 C
7958 !       o     o       o     o                                                  C
7959 !       i             i                                                        C
7960 !                                                                              C
7961 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7962       itk=itortyp(itype(k))
7963       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7964       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7965       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7966       call transpose2(EUgC(1,1,k),auxmat(1,1))
7967       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7968       vv1(1)=pizda1(1,1)-pizda1(2,2)
7969       vv1(2)=pizda1(1,2)+pizda1(2,1)
7970       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7971       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7972       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7973       s5=scalar2(vv(1),Dtobr2(1,i))
7974 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7975       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7976       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
7977        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
7978        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
7979        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
7980        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
7981        +scalar2(vv(1),Dtobr2der(1,i)))
7982       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7983       vv1(1)=pizda1(1,1)-pizda1(2,2)
7984       vv1(2)=pizda1(1,2)+pizda1(2,1)
7985       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7986       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7987       if (l.eq.j+1) then
7988         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
7989        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7990        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7991        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7992        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7993       else
7994         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
7995        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7996        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7997        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7998        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7999       endif
8000       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8001       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8002       vv1(1)=pizda1(1,1)-pizda1(2,2)
8003       vv1(2)=pizda1(1,2)+pizda1(2,1)
8004       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8005        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8006        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8007        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8008       do iii=1,2
8009         if (swap) then
8010           ind=3-iii
8011         else
8012           ind=iii
8013         endif
8014         do kkk=1,5
8015           do lll=1,3
8016             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8017             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8018             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8019             call transpose2(EUgC(1,1,k),auxmat(1,1))
8020             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8021               pizda1(1,1))
8022             vv1(1)=pizda1(1,1)-pizda1(2,2)
8023             vv1(2)=pizda1(1,2)+pizda1(2,1)
8024             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8025             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8026              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8027             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8028              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8029             s5=scalar2(vv(1),Dtobr2(1,i))
8030             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8031           enddo
8032         enddo
8033       enddo
8034       return
8035       end function eello6_graph1
8036 !-----------------------------------------------------------------------------
8037       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8038       use comm_kut
8039 !      implicit real*8 (a-h,o-z)
8040 !      include 'DIMENSIONS'
8041 !      include 'COMMON.IOUNITS'
8042 !      include 'COMMON.CHAIN'
8043 !      include 'COMMON.DERIV'
8044 !      include 'COMMON.INTERACT'
8045 !      include 'COMMON.CONTACTS'
8046 !      include 'COMMON.TORSION'
8047 !      include 'COMMON.VAR'
8048 !      include 'COMMON.GEO'
8049       logical :: swap
8050       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8051       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8052 !el      logical :: lprn
8053 !el      common /kutas/ lprn
8054       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8055       real(kind=8) :: s2,s3,s4
8056 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8057 !                                                                              C
8058 !      Parallel       Antiparallel                                             C
8059 !                                                                              C
8060 !          o             o                                                     C
8061 !     \   /l\           /j\   /                                                C
8062 !      \ /   \         /   \ /                                                 C
8063 !       o| o |         | o |o                                                  C
8064 !     \ j|/k\|      \  |/k\|l                                                  C
8065 !      \ /   \       \ /   \                                                   C
8066 !       o             o                                                        C
8067 !       i             i                                                        C
8068 !                                                                              C
8069 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8070 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8071 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8072 !           but not in a cluster cumulant
8073 #ifdef MOMENT
8074       s1=dip(1,jj,i)*dip(1,kk,k)
8075 #endif
8076       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8077       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8078       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8079       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8080       call transpose2(EUg(1,1,k),auxmat(1,1))
8081       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8082       vv(1)=pizda(1,1)-pizda(2,2)
8083       vv(2)=pizda(1,2)+pizda(2,1)
8084       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8085 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8086 #ifdef MOMENT
8087       eello6_graph2=-(s1+s2+s3+s4)
8088 #else
8089       eello6_graph2=-(s2+s3+s4)
8090 #endif
8091 !      eello6_graph2=-s3
8092 ! Derivatives in gamma(i-1)
8093       if (i.gt.1) then
8094 #ifdef MOMENT
8095         s1=dipderg(1,jj,i)*dip(1,kk,k)
8096 #endif
8097         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8098         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8099         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8100         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8101 #ifdef MOMENT
8102         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8103 #else
8104         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8105 #endif
8106 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8107       endif
8108 ! Derivatives in gamma(k-1)
8109 #ifdef MOMENT
8110       s1=dip(1,jj,i)*dipderg(1,kk,k)
8111 #endif
8112       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8113       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8114       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8115       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8116       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8117       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8118       vv(1)=pizda(1,1)-pizda(2,2)
8119       vv(2)=pizda(1,2)+pizda(2,1)
8120       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8121 #ifdef MOMENT
8122       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8123 #else
8124       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8125 #endif
8126 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8127 ! Derivatives in gamma(j-1) or gamma(l-1)
8128       if (j.gt.1) then
8129 #ifdef MOMENT
8130         s1=dipderg(3,jj,i)*dip(1,kk,k)
8131 #endif
8132         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8133         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8134         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8135         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8136         vv(1)=pizda(1,1)-pizda(2,2)
8137         vv(2)=pizda(1,2)+pizda(2,1)
8138         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8139 #ifdef MOMENT
8140         if (swap) then
8141           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8142         else
8143           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8144         endif
8145 #endif
8146         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8147 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8148       endif
8149 ! Derivatives in gamma(l-1) or gamma(j-1)
8150       if (l.gt.1) then
8151 #ifdef MOMENT
8152         s1=dip(1,jj,i)*dipderg(3,kk,k)
8153 #endif
8154         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8155         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8156         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8157         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8158         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8159         vv(1)=pizda(1,1)-pizda(2,2)
8160         vv(2)=pizda(1,2)+pizda(2,1)
8161         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8162 #ifdef MOMENT
8163         if (swap) then
8164           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8165         else
8166           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8167         endif
8168 #endif
8169         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8170 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8171       endif
8172 ! Cartesian derivatives.
8173       if (lprn) then
8174         write (2,*) 'In eello6_graph2'
8175         do iii=1,2
8176           write (2,*) 'iii=',iii
8177           do kkk=1,5
8178             write (2,*) 'kkk=',kkk
8179             do jjj=1,2
8180               write (2,'(3(2f10.5),5x)') &
8181               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8182             enddo
8183           enddo
8184         enddo
8185       endif
8186       do iii=1,2
8187         do kkk=1,5
8188           do lll=1,3
8189 #ifdef MOMENT
8190             if (iii.eq.1) then
8191               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8192             else
8193               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8194             endif
8195 #endif
8196             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8197               auxvec(1))
8198             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8199             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8200               auxvec(1))
8201             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8202             call transpose2(EUg(1,1,k),auxmat(1,1))
8203             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8204               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 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8209 #ifdef MOMENT
8210             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8211 #else
8212             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8213 #endif
8214             if (swap) then
8215               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8216             else
8217               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8218             endif
8219           enddo
8220         enddo
8221       enddo
8222       return
8223       end function eello6_graph2
8224 !-----------------------------------------------------------------------------
8225       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8226 !      implicit real*8 (a-h,o-z)
8227 !      include 'DIMENSIONS'
8228 !      include 'COMMON.IOUNITS'
8229 !      include 'COMMON.CHAIN'
8230 !      include 'COMMON.DERIV'
8231 !      include 'COMMON.INTERACT'
8232 !      include 'COMMON.CONTACTS'
8233 !      include 'COMMON.TORSION'
8234 !      include 'COMMON.VAR'
8235 !      include 'COMMON.GEO'
8236       real(kind=8),dimension(2) :: vv,auxvec
8237       real(kind=8),dimension(2,2) :: pizda,auxmat
8238       logical :: swap
8239       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8240       real(kind=8) :: s1,s2,s3,s4
8241 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8242 !                                                                              C
8243 !      Parallel       Antiparallel                                             C
8244 !                                                                              C
8245 !          o             o                                                     C
8246 !         /l\   /   \   /j\                                                    C
8247 !        /   \ /     \ /   \                                                   C
8248 !       /| o |o       o| o |\                                                  C
8249 !       j|/k\|  /      |/k\|l /                                                C
8250 !        /   \ /       /   \ /                                                 C
8251 !       /     o       /     o                                                  C
8252 !       i             i                                                        C
8253 !                                                                              C
8254 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8255 !
8256 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8257 !           energy moment and not to the cluster cumulant.
8258       iti=itortyp(itype(i))
8259       if (j.lt.nres-1) then
8260         itj1=itortyp(itype(j+1))
8261       else
8262         itj1=ntortyp+1
8263       endif
8264       itk=itortyp(itype(k))
8265       itk1=itortyp(itype(k+1))
8266       if (l.lt.nres-1) then
8267         itl1=itortyp(itype(l+1))
8268       else
8269         itl1=ntortyp+1
8270       endif
8271 #ifdef MOMENT
8272       s1=dip(4,jj,i)*dip(4,kk,k)
8273 #endif
8274       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8275       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8276       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8277       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8278       call transpose2(EE(1,1,itk),auxmat(1,1))
8279       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8280       vv(1)=pizda(1,1)+pizda(2,2)
8281       vv(2)=pizda(2,1)-pizda(1,2)
8282       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8283 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8284 !d     & "sum",-(s2+s3+s4)
8285 #ifdef MOMENT
8286       eello6_graph3=-(s1+s2+s3+s4)
8287 #else
8288       eello6_graph3=-(s2+s3+s4)
8289 #endif
8290 !      eello6_graph3=-s4
8291 ! Derivatives in gamma(k-1)
8292       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8293       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8294       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8295       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8296 ! Derivatives in gamma(l-1)
8297       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8298       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8299       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8300       vv(1)=pizda(1,1)+pizda(2,2)
8301       vv(2)=pizda(2,1)-pizda(1,2)
8302       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8303       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8304 ! Cartesian derivatives.
8305       do iii=1,2
8306         do kkk=1,5
8307           do lll=1,3
8308 #ifdef MOMENT
8309             if (iii.eq.1) then
8310               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8311             else
8312               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8313             endif
8314 #endif
8315             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8316               auxvec(1))
8317             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8318             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8319               auxvec(1))
8320             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8321             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8322               pizda(1,1))
8323             vv(1)=pizda(1,1)+pizda(2,2)
8324             vv(2)=pizda(2,1)-pizda(1,2)
8325             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8326 #ifdef MOMENT
8327             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8328 #else
8329             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8330 #endif
8331             if (swap) then
8332               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8333             else
8334               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8335             endif
8336 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8337           enddo
8338         enddo
8339       enddo
8340       return
8341       end function eello6_graph3
8342 !-----------------------------------------------------------------------------
8343       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8344 !      implicit real*8 (a-h,o-z)
8345 !      include 'DIMENSIONS'
8346 !      include 'COMMON.IOUNITS'
8347 !      include 'COMMON.CHAIN'
8348 !      include 'COMMON.DERIV'
8349 !      include 'COMMON.INTERACT'
8350 !      include 'COMMON.CONTACTS'
8351 !      include 'COMMON.TORSION'
8352 !      include 'COMMON.VAR'
8353 !      include 'COMMON.GEO'
8354 !      include 'COMMON.FFIELD'
8355       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8356       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8357       logical :: swap
8358       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8359               iii,kkk,lll
8360       real(kind=8) :: s1,s2,s3,s4
8361 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8362 !                                                                              C
8363 !      Parallel       Antiparallel                                             C
8364 !                                                                              C
8365 !          o             o                                                     C
8366 !         /l\   /   \   /j\                                                    C
8367 !        /   \ /     \ /   \                                                   C
8368 !       /| o |o       o| o |\                                                  C
8369 !     \ j|/k\|      \  |/k\|l                                                  C
8370 !      \ /   \       \ /   \                                                   C
8371 !       o     \       o     \                                                  C
8372 !       i             i                                                        C
8373 !                                                                              C
8374 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8375 !
8376 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8377 !           energy moment and not to the cluster cumulant.
8378 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8379       iti=itortyp(itype(i))
8380       itj=itortyp(itype(j))
8381       if (j.lt.nres-1) then
8382         itj1=itortyp(itype(j+1))
8383       else
8384         itj1=ntortyp+1
8385       endif
8386       itk=itortyp(itype(k))
8387       if (k.lt.nres-1) then
8388         itk1=itortyp(itype(k+1))
8389       else
8390         itk1=ntortyp+1
8391       endif
8392       itl=itortyp(itype(l))
8393       if (l.lt.nres-1) then
8394         itl1=itortyp(itype(l+1))
8395       else
8396         itl1=ntortyp+1
8397       endif
8398 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8399 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8400 !d     & ' itl',itl,' itl1',itl1
8401 #ifdef MOMENT
8402       if (imat.eq.1) then
8403         s1=dip(3,jj,i)*dip(3,kk,k)
8404       else
8405         s1=dip(2,jj,j)*dip(2,kk,l)
8406       endif
8407 #endif
8408       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8409       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8410       if (j.eq.l+1) then
8411         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8412         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8413       else
8414         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8415         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8416       endif
8417       call transpose2(EUg(1,1,k),auxmat(1,1))
8418       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8419       vv(1)=pizda(1,1)-pizda(2,2)
8420       vv(2)=pizda(2,1)+pizda(1,2)
8421       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8422 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8423 #ifdef MOMENT
8424       eello6_graph4=-(s1+s2+s3+s4)
8425 #else
8426       eello6_graph4=-(s2+s3+s4)
8427 #endif
8428 ! Derivatives in gamma(i-1)
8429       if (i.gt.1) then
8430 #ifdef MOMENT
8431         if (imat.eq.1) then
8432           s1=dipderg(2,jj,i)*dip(3,kk,k)
8433         else
8434           s1=dipderg(4,jj,j)*dip(2,kk,l)
8435         endif
8436 #endif
8437         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8438         if (j.eq.l+1) then
8439           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8440           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8441         else
8442           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8443           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8444         endif
8445         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8446         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8447 !d          write (2,*) 'turn6 derivatives'
8448 #ifdef MOMENT
8449           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8450 #else
8451           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8452 #endif
8453         else
8454 #ifdef MOMENT
8455           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8456 #else
8457           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8458 #endif
8459         endif
8460       endif
8461 ! Derivatives in gamma(k-1)
8462 #ifdef MOMENT
8463       if (imat.eq.1) then
8464         s1=dip(3,jj,i)*dipderg(2,kk,k)
8465       else
8466         s1=dip(2,jj,j)*dipderg(4,kk,l)
8467       endif
8468 #endif
8469       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8470       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8471       if (j.eq.l+1) then
8472         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8473         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8474       else
8475         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8476         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8477       endif
8478       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8479       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8480       vv(1)=pizda(1,1)-pizda(2,2)
8481       vv(2)=pizda(2,1)+pizda(1,2)
8482       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8483       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8484 #ifdef MOMENT
8485         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8486 #else
8487         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8488 #endif
8489       else
8490 #ifdef MOMENT
8491         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8492 #else
8493         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8494 #endif
8495       endif
8496 ! Derivatives in gamma(j-1) or gamma(l-1)
8497       if (l.eq.j+1 .and. l.gt.1) then
8498         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8499         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8500         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8501         vv(1)=pizda(1,1)-pizda(2,2)
8502         vv(2)=pizda(2,1)+pizda(1,2)
8503         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8504         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8505       else if (j.gt.1) then
8506         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8507         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8508         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8509         vv(1)=pizda(1,1)-pizda(2,2)
8510         vv(2)=pizda(2,1)+pizda(1,2)
8511         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8512         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8513           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8514         else
8515           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8516         endif
8517       endif
8518 ! Cartesian derivatives.
8519       do iii=1,2
8520         do kkk=1,5
8521           do lll=1,3
8522 #ifdef MOMENT
8523             if (iii.eq.1) then
8524               if (imat.eq.1) then
8525                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8526               else
8527                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8528               endif
8529             else
8530               if (imat.eq.1) then
8531                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8532               else
8533                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8534               endif
8535             endif
8536 #endif
8537             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8538               auxvec(1))
8539             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8540             if (j.eq.l+1) then
8541               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8542                 b1(1,itj1),auxvec(1))
8543               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8544             else
8545               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8546                 b1(1,itl1),auxvec(1))
8547               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8548             endif
8549             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8550               pizda(1,1))
8551             vv(1)=pizda(1,1)-pizda(2,2)
8552             vv(2)=pizda(2,1)+pizda(1,2)
8553             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8554             if (swap) then
8555               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8556 #ifdef MOMENT
8557                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8558                    -(s1+s2+s4)
8559 #else
8560                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8561                    -(s2+s4)
8562 #endif
8563                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8564               else
8565 #ifdef MOMENT
8566                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8567 #else
8568                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8569 #endif
8570                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8571               endif
8572             else
8573 #ifdef MOMENT
8574               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8575 #else
8576               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8577 #endif
8578               if (l.eq.j+1) then
8579                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8580               else
8581                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8582               endif
8583             endif
8584           enddo
8585         enddo
8586       enddo
8587       return
8588       end function eello6_graph4
8589 !-----------------------------------------------------------------------------
8590       real(kind=8) function eello_turn6(i,jj,kk)
8591 !      implicit real*8 (a-h,o-z)
8592 !      include 'DIMENSIONS'
8593 !      include 'COMMON.IOUNITS'
8594 !      include 'COMMON.CHAIN'
8595 !      include 'COMMON.DERIV'
8596 !      include 'COMMON.INTERACT'
8597 !      include 'COMMON.CONTACTS'
8598 !      include 'COMMON.TORSION'
8599 !      include 'COMMON.VAR'
8600 !      include 'COMMON.GEO'
8601       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8602       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8603       real(kind=8),dimension(3) :: ggg1,ggg2
8604       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8605       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8606 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8607 !           the respective energy moment and not to the cluster cumulant.
8608 !el local variables
8609       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8610       integer :: j1,j2,l1,l2,ll
8611       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8612       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8613       s1=0.0d0
8614       s8=0.0d0
8615       s13=0.0d0
8616 !
8617       eello_turn6=0.0d0
8618       j=i+4
8619       k=i+1
8620       l=i+3
8621       iti=itortyp(itype(i))
8622       itk=itortyp(itype(k))
8623       itk1=itortyp(itype(k+1))
8624       itl=itortyp(itype(l))
8625       itj=itortyp(itype(j))
8626 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8627 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8628 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8629 !d        eello6=0.0d0
8630 !d        return
8631 !d      endif
8632 !d      write (iout,*)
8633 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8634 !d     &   ' and',k,l
8635 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8636       do iii=1,2
8637         do kkk=1,5
8638           do lll=1,3
8639             derx_turn(lll,kkk,iii)=0.0d0
8640           enddo
8641         enddo
8642       enddo
8643 !d      eij=1.0d0
8644 !d      ekl=1.0d0
8645 !d      ekont=1.0d0
8646       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8647 !d      eello6_5=0.0d0
8648 !d      write (2,*) 'eello6_5',eello6_5
8649 #ifdef MOMENT
8650       call transpose2(AEA(1,1,1),auxmat(1,1))
8651       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8652       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8653       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8654 #endif
8655       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8656       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8657       s2 = scalar2(b1(1,itk),vtemp1(1))
8658 #ifdef MOMENT
8659       call transpose2(AEA(1,1,2),atemp(1,1))
8660       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8661       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8662       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8663 #endif
8664       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8665       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8666       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8667 #ifdef MOMENT
8668       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8669       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8670       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8671       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8672       ss13 = scalar2(b1(1,itk),vtemp4(1))
8673       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8674 #endif
8675 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8676 !      s1=0.0d0
8677 !      s2=0.0d0
8678 !      s8=0.0d0
8679 !      s12=0.0d0
8680 !      s13=0.0d0
8681       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8682 ! Derivatives in gamma(i+2)
8683       s1d =0.0d0
8684       s8d =0.0d0
8685 #ifdef MOMENT
8686       call transpose2(AEA(1,1,1),auxmatd(1,1))
8687       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8688       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8689       call transpose2(AEAderg(1,1,2),atempd(1,1))
8690       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8691       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8692 #endif
8693       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8694       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8695       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8696 !      s1d=0.0d0
8697 !      s2d=0.0d0
8698 !      s8d=0.0d0
8699 !      s12d=0.0d0
8700 !      s13d=0.0d0
8701       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8702 ! Derivatives in gamma(i+3)
8703 #ifdef MOMENT
8704       call transpose2(AEA(1,1,1),auxmatd(1,1))
8705       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8706       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8707       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8708 #endif
8709       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8710       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8711       s2d = scalar2(b1(1,itk),vtemp1d(1))
8712 #ifdef MOMENT
8713       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8714       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8715 #endif
8716       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8717 #ifdef MOMENT
8718       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8719       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8720       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8721 #endif
8722 !      s1d=0.0d0
8723 !      s2d=0.0d0
8724 !      s8d=0.0d0
8725 !      s12d=0.0d0
8726 !      s13d=0.0d0
8727 #ifdef MOMENT
8728       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8729                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8730 #else
8731       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8732                     -0.5d0*ekont*(s2d+s12d)
8733 #endif
8734 ! Derivatives in gamma(i+4)
8735       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8736       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8737       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8738 #ifdef MOMENT
8739       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8740       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8741       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8742 #endif
8743 !      s1d=0.0d0
8744 !      s2d=0.0d0
8745 !      s8d=0.0d0
8746 !      s12d=0.0d0
8747 !      s13d=0.0d0
8748 #ifdef MOMENT
8749       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8750 #else
8751       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8752 #endif
8753 ! Derivatives in gamma(i+5)
8754 #ifdef MOMENT
8755       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8756       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8757       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8758 #endif
8759       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8760       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8761       s2d = scalar2(b1(1,itk),vtemp1d(1))
8762 #ifdef MOMENT
8763       call transpose2(AEA(1,1,2),atempd(1,1))
8764       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8765       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8766 #endif
8767       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8768       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8769 #ifdef MOMENT
8770       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8771       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8772       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8773 #endif
8774 !      s1d=0.0d0
8775 !      s2d=0.0d0
8776 !      s8d=0.0d0
8777 !      s12d=0.0d0
8778 !      s13d=0.0d0
8779 #ifdef MOMENT
8780       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8781                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8782 #else
8783       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8784                     -0.5d0*ekont*(s2d+s12d)
8785 #endif
8786 ! Cartesian derivatives
8787       do iii=1,2
8788         do kkk=1,5
8789           do lll=1,3
8790 #ifdef MOMENT
8791             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8792             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8793             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8794 #endif
8795             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8796             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8797                 vtemp1d(1))
8798             s2d = scalar2(b1(1,itk),vtemp1d(1))
8799 #ifdef MOMENT
8800             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8801             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8802             s8d = -(atempd(1,1)+atempd(2,2))* &
8803                  scalar2(cc(1,1,itl),vtemp2(1))
8804 #endif
8805             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8806                  auxmatd(1,1))
8807             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8808             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8809 !      s1d=0.0d0
8810 !      s2d=0.0d0
8811 !      s8d=0.0d0
8812 !      s12d=0.0d0
8813 !      s13d=0.0d0
8814 #ifdef MOMENT
8815             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8816               - 0.5d0*(s1d+s2d)
8817 #else
8818             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8819               - 0.5d0*s2d
8820 #endif
8821 #ifdef MOMENT
8822             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8823               - 0.5d0*(s8d+s12d)
8824 #else
8825             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8826               - 0.5d0*s12d
8827 #endif
8828           enddo
8829         enddo
8830       enddo
8831 #ifdef MOMENT
8832       do kkk=1,5
8833         do lll=1,3
8834           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
8835             achuj_tempd(1,1))
8836           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8837           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8838           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8839           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8840           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
8841             vtemp4d(1))
8842           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8843           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8844           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8845         enddo
8846       enddo
8847 #endif
8848 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8849 !d     &  16*eel_turn6_num
8850 !d      goto 1112
8851       if (j.lt.nres-1) then
8852         j1=j+1
8853         j2=j-1
8854       else
8855         j1=j-1
8856         j2=j-2
8857       endif
8858       if (l.lt.nres-1) then
8859         l1=l+1
8860         l2=l-1
8861       else
8862         l1=l-1
8863         l2=l-2
8864       endif
8865       do ll=1,3
8866 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8867 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8868 !grad        ghalf=0.5d0*ggg1(ll)
8869 !d        ghalf=0.0d0
8870         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8871         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8872         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
8873           +ekont*derx_turn(ll,2,1)
8874         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8875         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
8876           +ekont*derx_turn(ll,4,1)
8877         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8878         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8879         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8880 !grad        ghalf=0.5d0*ggg2(ll)
8881 !d        ghalf=0.0d0
8882         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
8883           +ekont*derx_turn(ll,2,2)
8884         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8885         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
8886           +ekont*derx_turn(ll,4,2)
8887         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8888         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8889         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8890       enddo
8891 !d      goto 1112
8892 !grad      do m=i+1,j-1
8893 !grad        do ll=1,3
8894 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8895 !grad        enddo
8896 !grad      enddo
8897 !grad      do m=k+1,l-1
8898 !grad        do ll=1,3
8899 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8900 !grad        enddo
8901 !grad      enddo
8902 !grad1112  continue
8903 !grad      do m=i+2,j2
8904 !grad        do ll=1,3
8905 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8906 !grad        enddo
8907 !grad      enddo
8908 !grad      do m=k+2,l2
8909 !grad        do ll=1,3
8910 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8911 !grad        enddo
8912 !grad      enddo
8913 !d      do iii=1,nres-3
8914 !d        write (2,*) iii,g_corr6_loc(iii)
8915 !d      enddo
8916       eello_turn6=ekont*eel_turn6
8917 !d      write (2,*) 'ekont',ekont
8918 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
8919       return
8920       end function eello_turn6
8921 !-----------------------------------------------------------------------------
8922       subroutine MATVEC2(A1,V1,V2)
8923 !DIR$ INLINEALWAYS MATVEC2
8924 #ifndef OSF
8925 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8926 #endif
8927 !      implicit real*8 (a-h,o-z)
8928 !      include 'DIMENSIONS'
8929       real(kind=8),dimension(2) :: V1,V2
8930       real(kind=8),dimension(2,2) :: A1
8931       real(kind=8) :: vaux1,vaux2
8932 !      DO 1 I=1,2
8933 !        VI=0.0
8934 !        DO 3 K=1,2
8935 !    3     VI=VI+A1(I,K)*V1(K)
8936 !        Vaux(I)=VI
8937 !    1 CONTINUE
8938
8939       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8940       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8941
8942       v2(1)=vaux1
8943       v2(2)=vaux2
8944       end subroutine MATVEC2
8945 !-----------------------------------------------------------------------------
8946       subroutine MATMAT2(A1,A2,A3)
8947 #ifndef OSF
8948 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8949 #endif
8950 !      implicit real*8 (a-h,o-z)
8951 !      include 'DIMENSIONS'
8952       real(kind=8),dimension(2,2) :: A1,A2,A3
8953       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
8954 !      DIMENSION AI3(2,2)
8955 !        DO  J=1,2
8956 !          A3IJ=0.0
8957 !          DO K=1,2
8958 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8959 !          enddo
8960 !          A3(I,J)=A3IJ
8961 !       enddo
8962 !      enddo
8963
8964       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8965       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8966       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8967       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8968
8969       A3(1,1)=AI3_11
8970       A3(2,1)=AI3_21
8971       A3(1,2)=AI3_12
8972       A3(2,2)=AI3_22
8973       end subroutine MATMAT2
8974 !-----------------------------------------------------------------------------
8975       real(kind=8) function scalar2(u,v)
8976 !DIR$ INLINEALWAYS scalar2
8977       implicit none
8978       real(kind=8),dimension(2) :: u,v
8979       real(kind=8) :: sc
8980       integer :: i
8981       scalar2=u(1)*v(1)+u(2)*v(2)
8982       return
8983       end function scalar2
8984 !-----------------------------------------------------------------------------
8985       subroutine transpose2(a,at)
8986 !DIR$ INLINEALWAYS transpose2
8987 #ifndef OSF
8988 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
8989 #endif
8990       implicit none
8991       real(kind=8),dimension(2,2) :: a,at
8992       at(1,1)=a(1,1)
8993       at(1,2)=a(2,1)
8994       at(2,1)=a(1,2)
8995       at(2,2)=a(2,2)
8996       return
8997       end subroutine transpose2
8998 !-----------------------------------------------------------------------------
8999       subroutine transpose(n,a,at)
9000       implicit none
9001       integer :: n,i,j
9002       real(kind=8),dimension(n,n) :: a,at
9003       do i=1,n
9004         do j=1,n
9005           at(j,i)=a(i,j)
9006         enddo
9007       enddo
9008       return
9009       end subroutine transpose
9010 !-----------------------------------------------------------------------------
9011       subroutine prodmat3(a1,a2,kk,transp,prod)
9012 !DIR$ INLINEALWAYS prodmat3
9013 #ifndef OSF
9014 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9015 #endif
9016       implicit none
9017       integer :: i,j
9018       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9019       logical :: transp
9020 !rc      double precision auxmat(2,2),prod_(2,2)
9021
9022       if (transp) then
9023 !rc        call transpose2(kk(1,1),auxmat(1,1))
9024 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9025 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9026
9027            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9028        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9029            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9030        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9031            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9032        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9033            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9034        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9035
9036       else
9037 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9038 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9039
9040            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9041         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9042            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9043         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9044            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9045         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9046            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9047         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9048
9049       endif
9050 !      call transpose2(a2(1,1),a2t(1,1))
9051
9052 !rc      print *,transp
9053 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9054 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9055
9056       return
9057       end subroutine prodmat3
9058 !-----------------------------------------------------------------------------
9059 ! energy_p_new_barrier.F
9060 !-----------------------------------------------------------------------------
9061       subroutine sum_gradient
9062 !      implicit real*8 (a-h,o-z)
9063       use io_base, only: pdbout
9064 !      include 'DIMENSIONS'
9065 #ifndef ISNAN
9066       external proc_proc
9067 #ifdef WINPGI
9068 !MS$ATTRIBUTES C ::  proc_proc
9069 #endif
9070 #endif
9071 #ifdef MPI
9072       include 'mpif.h'
9073 #endif
9074       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9075                    gloc_scbuf !(3,maxres)
9076
9077       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9078 !#endif
9079 !el local variables
9080       integer :: i,j,k,ierror,ierr
9081       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9082                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9083                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9084                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9085                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9086                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9087                    gsccorr_max,gsccorrx_max,time00
9088
9089 !      include 'COMMON.SETUP'
9090 !      include 'COMMON.IOUNITS'
9091 !      include 'COMMON.FFIELD'
9092 !      include 'COMMON.DERIV'
9093 !      include 'COMMON.INTERACT'
9094 !      include 'COMMON.SBRIDGE'
9095 !      include 'COMMON.CHAIN'
9096 !      include 'COMMON.VAR'
9097 !      include 'COMMON.CONTROL'
9098 !      include 'COMMON.TIME1'
9099 !      include 'COMMON.MAXGRAD'
9100 !      include 'COMMON.SCCOR'
9101 #ifdef TIMING
9102       time01=MPI_Wtime()
9103 #endif
9104 #ifdef DEBUG
9105       write (iout,*) "sum_gradient gvdwc, gvdwx"
9106       do i=1,nres
9107         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9108          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9109       enddo
9110       call flush(iout)
9111 #endif
9112 #ifdef MPI
9113         gradbufc=0.0d0
9114         gradbufx=0.0d0
9115         gradbufc_sum=0.0d0
9116         gloc_scbuf=0.0d0
9117         glocbuf=0.0d0
9118 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9119         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9120           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9121 #endif
9122 !
9123 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9124 !            in virtual-bond-vector coordinates
9125 !
9126 #ifdef DEBUG
9127 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9128 !      do i=1,nres-1
9129 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9130 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9131 !      enddo
9132 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9133 !      do i=1,nres-1
9134 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9135 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9136 !      enddo
9137       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9138       do i=1,nres
9139         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9140          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9141          (gvdwc_scpp(j,i),j=1,3)
9142       enddo
9143       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9144       do i=1,nres
9145         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9146          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9147          (gelc_loc_long(j,i),j=1,3)
9148       enddo
9149       call flush(iout)
9150 #endif
9151 #ifdef SPLITELE
9152       do i=1,nct
9153         do j=1,3
9154           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9155                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9156                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9157                       wel_loc*gel_loc_long(j,i)+ &
9158                       wcorr*gradcorr_long(j,i)+ &
9159                       wcorr5*gradcorr5_long(j,i)+ &
9160                       wcorr6*gradcorr6_long(j,i)+ &
9161                       wturn6*gcorr6_turn_long(j,i)+ &
9162                       wstrain*ghpbc(j,i)
9163         enddo
9164       enddo
9165 #else
9166       do i=1,nct
9167         do j=1,3
9168           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9169                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9170                       welec*gelc_long(j,i)+ &
9171                       wbond*gradb(j,i)+ &
9172                       wel_loc*gel_loc_long(j,i)+ &
9173                       wcorr*gradcorr_long(j,i)+ &
9174                       wcorr5*gradcorr5_long(j,i)+ &
9175                       wcorr6*gradcorr6_long(j,i)+ &
9176                       wturn6*gcorr6_turn_long(j,i)+ &
9177                       wstrain*ghpbc(j,i)
9178         enddo
9179       enddo
9180 #endif
9181 #ifdef MPI
9182       if (nfgtasks.gt.1) then
9183       time00=MPI_Wtime()
9184 #ifdef DEBUG
9185       write (iout,*) "gradbufc before allreduce"
9186       do i=1,nres
9187         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9188       enddo
9189       call flush(iout)
9190 #endif
9191       do i=1,nres
9192         do j=1,3
9193           gradbufc_sum(j,i)=gradbufc(j,i)
9194         enddo
9195       enddo
9196 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9197 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9198 !      time_reduce=time_reduce+MPI_Wtime()-time00
9199 #ifdef DEBUG
9200 !      write (iout,*) "gradbufc_sum after allreduce"
9201 !      do i=1,nres
9202 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9203 !      enddo
9204 !      call flush(iout)
9205 #endif
9206 #ifdef TIMING
9207 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9208 #endif
9209       do i=nnt,nres
9210         do k=1,3
9211           gradbufc(k,i)=0.0d0
9212         enddo
9213       enddo
9214 #ifdef DEBUG
9215       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9216       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9217                         " jgrad_end  ",jgrad_end(i),&
9218                         i=igrad_start,igrad_end)
9219 #endif
9220 !
9221 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9222 ! do not parallelize this part.
9223 !
9224 !      do i=igrad_start,igrad_end
9225 !        do j=jgrad_start(i),jgrad_end(i)
9226 !          do k=1,3
9227 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9228 !          enddo
9229 !        enddo
9230 !      enddo
9231       do j=1,3
9232         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9233       enddo
9234       do i=nres-2,nnt,-1
9235         do j=1,3
9236           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9237         enddo
9238       enddo
9239 #ifdef DEBUG
9240       write (iout,*) "gradbufc after summing"
9241       do i=1,nres
9242         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9243       enddo
9244       call flush(iout)
9245 #endif
9246       else
9247 #endif
9248 !el#define DEBUG
9249 #ifdef DEBUG
9250       write (iout,*) "gradbufc"
9251       do i=1,nres
9252         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9253       enddo
9254       call flush(iout)
9255 #endif
9256 !el#undef DEBUG
9257       do i=1,nres
9258         do j=1,3
9259           gradbufc_sum(j,i)=gradbufc(j,i)
9260           gradbufc(j,i)=0.0d0
9261         enddo
9262       enddo
9263       do j=1,3
9264         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9265       enddo
9266       do i=nres-2,nnt,-1
9267         do j=1,3
9268           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9269         enddo
9270       enddo
9271 !      do i=nnt,nres-1
9272 !        do k=1,3
9273 !          gradbufc(k,i)=0.0d0
9274 !        enddo
9275 !        do j=i+1,nres
9276 !          do k=1,3
9277 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9278 !          enddo
9279 !        enddo
9280 !      enddo
9281 !el#define DEBUG
9282 #ifdef DEBUG
9283       write (iout,*) "gradbufc after summing"
9284       do i=1,nres
9285         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9286       enddo
9287       call flush(iout)
9288 #endif
9289 !el#undef DEBUG
9290 #ifdef MPI
9291       endif
9292 #endif
9293       do k=1,3
9294         gradbufc(k,nres)=0.0d0
9295       enddo
9296 !el----------------
9297 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9298 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9299 !el-----------------
9300       do i=1,nct
9301         do j=1,3
9302 #ifdef SPLITELE
9303           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9304                       wel_loc*gel_loc(j,i)+ &
9305                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9306                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9307                       wel_loc*gel_loc_long(j,i)+ &
9308                       wcorr*gradcorr_long(j,i)+ &
9309                       wcorr5*gradcorr5_long(j,i)+ &
9310                       wcorr6*gradcorr6_long(j,i)+ &
9311                       wturn6*gcorr6_turn_long(j,i))+ &
9312                       wbond*gradb(j,i)+ &
9313                       wcorr*gradcorr(j,i)+ &
9314                       wturn3*gcorr3_turn(j,i)+ &
9315                       wturn4*gcorr4_turn(j,i)+ &
9316                       wcorr5*gradcorr5(j,i)+ &
9317                       wcorr6*gradcorr6(j,i)+ &
9318                       wturn6*gcorr6_turn(j,i)+ &
9319                       wsccor*gsccorc(j,i) &
9320                      +wscloc*gscloc(j,i)
9321 #else
9322           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9323                       wel_loc*gel_loc(j,i)+ &
9324                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9325                       welec*gelc_long(j,i)+ &
9326                       wel_loc*gel_loc_long(j,i)+ &
9327 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9328                       wcorr5*gradcorr5_long(j,i)+ &
9329                       wcorr6*gradcorr6_long(j,i)+ &
9330                       wturn6*gcorr6_turn_long(j,i))+ &
9331                       wbond*gradb(j,i)+ &
9332                       wcorr*gradcorr(j,i)+ &
9333                       wturn3*gcorr3_turn(j,i)+ &
9334                       wturn4*gcorr4_turn(j,i)+ &
9335                       wcorr5*gradcorr5(j,i)+ &
9336                       wcorr6*gradcorr6(j,i)+ &
9337                       wturn6*gcorr6_turn(j,i)+ &
9338                       wsccor*gsccorc(j,i) &
9339                      +wscloc*gscloc(j,i)
9340 #endif
9341           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9342                         wbond*gradbx(j,i)+ &
9343                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9344                         wsccor*gsccorx(j,i) &
9345                        +wscloc*gsclocx(j,i)
9346         enddo
9347       enddo
9348 #ifdef DEBUG
9349       write (iout,*) "gloc before adding corr"
9350       do i=1,4*nres
9351         write (iout,*) i,gloc(i,icg)
9352       enddo
9353 #endif
9354       do i=1,nres-3
9355         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9356          +wcorr5*g_corr5_loc(i) &
9357          +wcorr6*g_corr6_loc(i) &
9358          +wturn4*gel_loc_turn4(i) &
9359          +wturn3*gel_loc_turn3(i) &
9360          +wturn6*gel_loc_turn6(i) &
9361          +wel_loc*gel_loc_loc(i)
9362       enddo
9363 #ifdef DEBUG
9364       write (iout,*) "gloc after adding corr"
9365       do i=1,4*nres
9366         write (iout,*) i,gloc(i,icg)
9367       enddo
9368 #endif
9369 #ifdef MPI
9370       if (nfgtasks.gt.1) then
9371         do j=1,3
9372           do i=1,nres
9373             gradbufc(j,i)=gradc(j,i,icg)
9374             gradbufx(j,i)=gradx(j,i,icg)
9375           enddo
9376         enddo
9377         do i=1,4*nres
9378           glocbuf(i)=gloc(i,icg)
9379         enddo
9380 !#define DEBUG
9381 #ifdef DEBUG
9382       write (iout,*) "gloc_sc before reduce"
9383       do i=1,nres
9384        do j=1,1
9385         write (iout,*) i,j,gloc_sc(j,i,icg)
9386        enddo
9387       enddo
9388 #endif
9389 !#undef DEBUG
9390         do i=1,nres
9391          do j=1,3
9392           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9393          enddo
9394         enddo
9395         time00=MPI_Wtime()
9396         call MPI_Barrier(FG_COMM,IERR)
9397         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9398         time00=MPI_Wtime()
9399         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9400           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9401         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9402           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9403         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9404           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9405         time_reduce=time_reduce+MPI_Wtime()-time00
9406         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9407           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9408         time_reduce=time_reduce+MPI_Wtime()-time00
9409 !#define DEBUG
9410 #ifdef DEBUG
9411       write (iout,*) "gloc_sc after reduce"
9412       do i=1,nres
9413        do j=1,1
9414         write (iout,*) i,j,gloc_sc(j,i,icg)
9415        enddo
9416       enddo
9417 #endif
9418 !#undef DEBUG
9419 #ifdef DEBUG
9420       write (iout,*) "gloc after reduce"
9421       do i=1,4*nres
9422         write (iout,*) i,gloc(i,icg)
9423       enddo
9424 #endif
9425       endif
9426 #endif
9427       if (gnorm_check) then
9428 !
9429 ! Compute the maximum elements of the gradient
9430 !
9431       gvdwc_max=0.0d0
9432       gvdwc_scp_max=0.0d0
9433       gelc_max=0.0d0
9434       gvdwpp_max=0.0d0
9435       gradb_max=0.0d0
9436       ghpbc_max=0.0d0
9437       gradcorr_max=0.0d0
9438       gel_loc_max=0.0d0
9439       gcorr3_turn_max=0.0d0
9440       gcorr4_turn_max=0.0d0
9441       gradcorr5_max=0.0d0
9442       gradcorr6_max=0.0d0
9443       gcorr6_turn_max=0.0d0
9444       gsccorc_max=0.0d0
9445       gscloc_max=0.0d0
9446       gvdwx_max=0.0d0
9447       gradx_scp_max=0.0d0
9448       ghpbx_max=0.0d0
9449       gradxorr_max=0.0d0
9450       gsccorx_max=0.0d0
9451       gsclocx_max=0.0d0
9452       do i=1,nct
9453         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9454         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9455         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9456         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9457          gvdwc_scp_max=gvdwc_scp_norm
9458         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9459         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9460         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9461         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9462         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9463         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9464         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9465         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9466         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9467         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9468         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9469         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9470         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9471           gcorr3_turn(1,i)))
9472         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9473           gcorr3_turn_max=gcorr3_turn_norm
9474         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9475           gcorr4_turn(1,i)))
9476         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9477           gcorr4_turn_max=gcorr4_turn_norm
9478         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9479         if (gradcorr5_norm.gt.gradcorr5_max) &
9480           gradcorr5_max=gradcorr5_norm
9481         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9482         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9483         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9484           gcorr6_turn(1,i)))
9485         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9486           gcorr6_turn_max=gcorr6_turn_norm
9487         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9488         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9489         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9490         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9491         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9492         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9493         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9494         if (gradx_scp_norm.gt.gradx_scp_max) &
9495           gradx_scp_max=gradx_scp_norm
9496         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9497         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9498         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9499         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9500         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9501         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9502         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9503         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9504       enddo
9505       if (gradout) then
9506 #ifdef AIX
9507         open(istat,file=statname,position="append")
9508 #else
9509         open(istat,file=statname,access="append")
9510 #endif
9511         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9512            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9513            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9514            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9515            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9516            gsccorx_max,gsclocx_max
9517         close(istat)
9518         if (gvdwc_max.gt.1.0d4) then
9519           write (iout,*) "gvdwc gvdwx gradb gradbx"
9520           do i=nnt,nct
9521             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9522               gradb(j,i),gradbx(j,i),j=1,3)
9523           enddo
9524           call pdbout(0.0d0,'cipiszcze',iout)
9525           call flush(iout)
9526         endif
9527       endif
9528       endif
9529 !el#define DEBUG
9530 #ifdef DEBUG
9531       write (iout,*) "gradc gradx gloc"
9532       do i=1,nres
9533         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9534          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9535       enddo
9536 #endif
9537 !el#undef DEBUG
9538 #ifdef TIMING
9539       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9540 #endif
9541       return
9542       end subroutine sum_gradient
9543 !-----------------------------------------------------------------------------
9544       subroutine sc_grad
9545 !      implicit real*8 (a-h,o-z)
9546       use calc_data
9547 !      include 'DIMENSIONS'
9548 !      include 'COMMON.CHAIN'
9549 !      include 'COMMON.DERIV'
9550 !      include 'COMMON.CALC'
9551 !      include 'COMMON.IOUNITS'
9552       real(kind=8), dimension(3) :: dcosom1,dcosom2
9553
9554       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9555       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9556       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9557            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9558 ! diagnostics only
9559 !      eom1=0.0d0
9560 !      eom2=0.0d0
9561 !      eom12=evdwij*eps1_om12
9562 ! end diagnostics
9563 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9564 !       " sigder",sigder
9565 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9566 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9567       do k=1,3
9568         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9569         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9570       enddo
9571       do k=1,3
9572         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
9573       enddo
9574 !      write (iout,*) "gg",(gg(k),k=1,3)
9575       do k=1,3
9576         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9577                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9578                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9579         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9580                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9581                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9582 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9583 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9584 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9585 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9586       enddo
9587 !
9588 ! Calculate the components of the gradient in DC and X
9589 !
9590 !grad      do k=i,j-1
9591 !grad        do l=1,3
9592 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9593 !grad        enddo
9594 !grad      enddo
9595       do l=1,3
9596         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9597         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9598       enddo
9599       return
9600       end subroutine sc_grad
9601 #ifdef CRYST_THETA
9602 !-----------------------------------------------------------------------------
9603       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9604
9605       use comm_calcthet
9606 !      implicit real*8 (a-h,o-z)
9607 !      include 'DIMENSIONS'
9608 !      include 'COMMON.LOCAL'
9609 !      include 'COMMON.IOUNITS'
9610 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9611 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9612 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9613       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9614       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9615 !el      integer :: it
9616 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9617 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9618 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9619 !el local variables
9620
9621       delthec=thetai-thet_pred_mean
9622       delthe0=thetai-theta0i
9623 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9624       t3 = thetai-thet_pred_mean
9625       t6 = t3**2
9626       t9 = term1
9627       t12 = t3*sigcsq
9628       t14 = t12+t6*sigsqtc
9629       t16 = 1.0d0
9630       t21 = thetai-theta0i
9631       t23 = t21**2
9632       t26 = term2
9633       t27 = t21*t26
9634       t32 = termexp
9635       t40 = t32**2
9636       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9637        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9638        *(-t12*t9-ak*sig0inv*t27)
9639       return
9640       end subroutine mixder
9641 #endif
9642 !-----------------------------------------------------------------------------
9643 ! cartder.F
9644 !-----------------------------------------------------------------------------
9645       subroutine cartder
9646 !-----------------------------------------------------------------------------
9647 ! This subroutine calculates the derivatives of the consecutive virtual
9648 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9649 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9650 ! in the angles alpha and omega, describing the location of a side chain
9651 ! in its local coordinate system.
9652 !
9653 ! The derivatives are stored in the following arrays:
9654 !
9655 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9656 ! The structure is as follows:
9657 !
9658 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9659 ! 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)
9660 !         . . . . . . . . . . . .  . . . . . .
9661 ! 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)
9662 !                          .
9663 !                          .
9664 !                          .
9665 ! 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)
9666 !
9667 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9668 ! The structure is same as above.
9669 !
9670 ! DCDS - the derivatives of the side chain vectors in the local spherical
9671 ! andgles alph and omega:
9672 !
9673 ! 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)
9674 ! 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)
9675 !                          .
9676 !                          .
9677 !                          .
9678 ! 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)
9679 !
9680 ! Version of March '95, based on an early version of November '91.
9681 !
9682 !**********************************************************************
9683 !      implicit real*8 (a-h,o-z)
9684 !      include 'DIMENSIONS'
9685 !      include 'COMMON.VAR'
9686 !      include 'COMMON.CHAIN'
9687 !      include 'COMMON.DERIV'
9688 !      include 'COMMON.GEO'
9689 !      include 'COMMON.LOCAL'
9690 !      include 'COMMON.INTERACT'
9691       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9692       real(kind=8),dimension(3,3) :: dp,temp
9693 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9694       real(kind=8),dimension(3) :: xx,xx1
9695 !el local variables
9696       integer :: i,k,l,j,m,ind,ind1,jjj
9697       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9698                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9699                  sint2,xp,yp,xxp,yyp,zzp,dj
9700
9701 !      common /przechowalnia/ fromto
9702       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9703 ! get the position of the jth ijth fragment of the chain coordinate system
9704 ! in the fromto array.
9705 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9706 !
9707 !      maxdim=(nres-1)*(nres-2)/2
9708 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9709 ! calculate the derivatives of transformation matrix elements in theta
9710 !
9711
9712 !el      call flush(iout) !el
9713       do i=1,nres-2
9714         rdt(1,1,i)=-rt(1,2,i)
9715         rdt(1,2,i)= rt(1,1,i)
9716         rdt(1,3,i)= 0.0d0
9717         rdt(2,1,i)=-rt(2,2,i)
9718         rdt(2,2,i)= rt(2,1,i)
9719         rdt(2,3,i)= 0.0d0
9720         rdt(3,1,i)=-rt(3,2,i)
9721         rdt(3,2,i)= rt(3,1,i)
9722         rdt(3,3,i)= 0.0d0
9723       enddo
9724 !
9725 ! derivatives in phi
9726 !
9727       do i=2,nres-2
9728         drt(1,1,i)= 0.0d0
9729         drt(1,2,i)= 0.0d0
9730         drt(1,3,i)= 0.0d0
9731         drt(2,1,i)= rt(3,1,i)
9732         drt(2,2,i)= rt(3,2,i)
9733         drt(2,3,i)= rt(3,3,i)
9734         drt(3,1,i)=-rt(2,1,i)
9735         drt(3,2,i)=-rt(2,2,i)
9736         drt(3,3,i)=-rt(2,3,i)
9737       enddo
9738 !
9739 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9740 !
9741       do i=2,nres-2
9742         ind=indmat(i,i+1)
9743         do k=1,3
9744           do l=1,3
9745             temp(k,l)=rt(k,l,i)
9746           enddo
9747         enddo
9748         do k=1,3
9749           do l=1,3
9750             fromto(k,l,ind)=temp(k,l)
9751           enddo
9752         enddo
9753         do j=i+1,nres-2
9754           ind=indmat(i,j+1)
9755           do k=1,3
9756             do l=1,3
9757               dpkl=0.0d0
9758               do m=1,3
9759                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9760               enddo
9761               dp(k,l)=dpkl
9762               fromto(k,l,ind)=dpkl
9763             enddo
9764           enddo
9765           do k=1,3
9766             do l=1,3
9767               temp(k,l)=dp(k,l)
9768             enddo
9769           enddo
9770         enddo
9771       enddo
9772 !
9773 ! Calculate derivatives.
9774 !
9775       ind1=0
9776       do i=1,nres-2
9777         ind1=ind1+1
9778 !
9779 ! Derivatives of DC(i+1) in theta(i+2)
9780 !
9781         do j=1,3
9782           do k=1,2
9783             dpjk=0.0D0
9784             do l=1,3
9785               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9786             enddo
9787             dp(j,k)=dpjk
9788             prordt(j,k,i)=dp(j,k)
9789           enddo
9790           dp(j,3)=0.0D0
9791           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9792         enddo
9793 !
9794 ! Derivatives of SC(i+1) in theta(i+2)
9795 !
9796         xx1(1)=-0.5D0*xloc(2,i+1)
9797         xx1(2)= 0.5D0*xloc(1,i+1)
9798         do j=1,3
9799           xj=0.0D0
9800           do k=1,2
9801             xj=xj+r(j,k,i)*xx1(k)
9802           enddo
9803           xx(j)=xj
9804         enddo
9805         do j=1,3
9806           rj=0.0D0
9807           do k=1,3
9808             rj=rj+prod(j,k,i)*xx(k)
9809           enddo
9810           dxdv(j,ind1)=rj
9811         enddo
9812 !
9813 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
9814 ! than the other off-diagonal derivatives.
9815 !
9816         do j=1,3
9817           dxoiij=0.0D0
9818           do k=1,3
9819             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9820           enddo
9821           dxdv(j,ind1+1)=dxoiij
9822         enddo
9823 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
9824 !
9825 ! Derivatives of DC(i+1) in phi(i+2)
9826 !
9827         do j=1,3
9828           do k=1,3
9829             dpjk=0.0
9830             do l=2,3
9831               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
9832             enddo
9833             dp(j,k)=dpjk
9834             prodrt(j,k,i)=dp(j,k)
9835           enddo
9836           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
9837         enddo
9838 !
9839 ! Derivatives of SC(i+1) in phi(i+2)
9840 !
9841         xx(1)= 0.0D0
9842         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
9843         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
9844         do j=1,3
9845           rj=0.0D0
9846           do k=2,3
9847             rj=rj+prod(j,k,i)*xx(k)
9848           enddo
9849           dxdv(j+3,ind1)=-rj
9850         enddo
9851 !
9852 ! Derivatives of SC(i+1) in phi(i+3).
9853 !
9854         do j=1,3
9855           dxoiij=0.0D0
9856           do k=1,3
9857             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9858           enddo
9859           dxdv(j+3,ind1+1)=dxoiij
9860         enddo
9861 !
9862 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
9863 ! theta(nres) and phi(i+3) thru phi(nres).
9864 !
9865         do j=i+1,nres-2
9866           ind1=ind1+1
9867           ind=indmat(i+1,j+1)
9868 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
9869           do k=1,3
9870             do l=1,3
9871               tempkl=0.0D0
9872               do m=1,2
9873                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
9874               enddo
9875               temp(k,l)=tempkl
9876             enddo
9877           enddo
9878 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
9879 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
9880 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
9881 ! Derivatives of virtual-bond vectors in theta
9882           do k=1,3
9883             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
9884           enddo
9885 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
9886 ! Derivatives of SC vectors in theta
9887           do k=1,3
9888             dxoijk=0.0D0
9889             do l=1,3
9890               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9891             enddo
9892             dxdv(k,ind1+1)=dxoijk
9893           enddo
9894 !
9895 !--- Calculate the derivatives in phi
9896 !
9897           do k=1,3
9898             do l=1,3
9899               tempkl=0.0D0
9900               do m=1,3
9901                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
9902               enddo
9903               temp(k,l)=tempkl
9904             enddo
9905           enddo
9906           do k=1,3
9907             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
9908           enddo
9909           do k=1,3
9910             dxoijk=0.0D0
9911             do l=1,3
9912               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9913             enddo
9914             dxdv(k+3,ind1+1)=dxoijk
9915           enddo
9916         enddo
9917       enddo
9918 !
9919 ! Derivatives in alpha and omega:
9920 !
9921       do i=2,nres-1
9922 !       dsci=dsc(itype(i))
9923         dsci=vbld(i+nres)
9924 #ifdef OSF
9925         alphi=alph(i)
9926         omegi=omeg(i)
9927         if(alphi.ne.alphi) alphi=100.0
9928         if(omegi.ne.omegi) omegi=-100.0
9929 #else
9930         alphi=alph(i)
9931         omegi=omeg(i)
9932 #endif
9933 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
9934         cosalphi=dcos(alphi)
9935         sinalphi=dsin(alphi)
9936         cosomegi=dcos(omegi)
9937         sinomegi=dsin(omegi)
9938         temp(1,1)=-dsci*sinalphi
9939         temp(2,1)= dsci*cosalphi*cosomegi
9940         temp(3,1)=-dsci*cosalphi*sinomegi
9941         temp(1,2)=0.0D0
9942         temp(2,2)=-dsci*sinalphi*sinomegi
9943         temp(3,2)=-dsci*sinalphi*cosomegi
9944         theta2=pi-0.5D0*theta(i+1)
9945         cost2=dcos(theta2)
9946         sint2=dsin(theta2)
9947         jjj=0
9948 !d      print *,((temp(l,k),l=1,3),k=1,2)
9949         do j=1,2
9950           xp=temp(1,j)
9951           yp=temp(2,j)
9952           xxp= xp*cost2+yp*sint2
9953           yyp=-xp*sint2+yp*cost2
9954           zzp=temp(3,j)
9955           xx(1)=xxp
9956           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
9957           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
9958           do k=1,3
9959             dj=0.0D0
9960             do l=1,3
9961               dj=dj+prod(k,l,i-1)*xx(l)
9962             enddo
9963             dxds(jjj+k,i)=dj
9964           enddo
9965           jjj=jjj+3
9966         enddo
9967       enddo
9968       return
9969       end subroutine cartder
9970 !-----------------------------------------------------------------------------
9971 ! checkder_p.F
9972 !-----------------------------------------------------------------------------
9973       subroutine check_cartgrad
9974 ! Check the gradient of Cartesian coordinates in internal coordinates.
9975 !      implicit real*8 (a-h,o-z)
9976 !      include 'DIMENSIONS'
9977 !      include 'COMMON.IOUNITS'
9978 !      include 'COMMON.VAR'
9979 !      include 'COMMON.CHAIN'
9980 !      include 'COMMON.GEO'
9981 !      include 'COMMON.LOCAL'
9982 !      include 'COMMON.DERIV'
9983       real(kind=8),dimension(6,nres) :: temp
9984       real(kind=8),dimension(3) :: xx,gg
9985       integer :: i,k,j,ii
9986       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
9987 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9988 !
9989 ! Check the gradient of the virtual-bond and SC vectors in the internal
9990 ! coordinates.
9991 !
9992       aincr=1.0d-7
9993       aincr2=5.0d-8
9994       call cartder
9995       write (iout,'(a)') '**************** dx/dalpha'
9996       write (iout,'(a)')
9997       do i=2,nres-1
9998         alphi=alph(i)
9999         alph(i)=alph(i)+aincr
10000         do k=1,3
10001           temp(k,i)=dc(k,nres+i)
10002         enddo
10003         call chainbuild
10004         do k=1,3
10005           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10006           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10007         enddo
10008         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10009         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10010         write (iout,'(a)')
10011         alph(i)=alphi
10012         call chainbuild
10013       enddo
10014       write (iout,'(a)')
10015       write (iout,'(a)') '**************** dx/domega'
10016       write (iout,'(a)')
10017       do i=2,nres-1
10018         omegi=omeg(i)
10019         omeg(i)=omeg(i)+aincr
10020         do k=1,3
10021           temp(k,i)=dc(k,nres+i)
10022         enddo
10023         call chainbuild
10024         do k=1,3
10025           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10026           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10027                 (aincr*dabs(dxds(k+3,i))+aincr))
10028         enddo
10029         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10030             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10031         write (iout,'(a)')
10032         omeg(i)=omegi
10033         call chainbuild
10034       enddo
10035       write (iout,'(a)')
10036       write (iout,'(a)') '**************** dx/dtheta'
10037       write (iout,'(a)')
10038       do i=3,nres
10039         theti=theta(i)
10040         theta(i)=theta(i)+aincr
10041         do j=i-1,nres-1
10042           do k=1,3
10043             temp(k,j)=dc(k,nres+j)
10044           enddo
10045         enddo
10046         call chainbuild
10047         do j=i-1,nres-1
10048           ii = indmat(i-2,j)
10049 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10050           do k=1,3
10051             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10052             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10053                   (aincr*dabs(dxdv(k,ii))+aincr))
10054           enddo
10055           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10056               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10057           write(iout,'(a)')
10058         enddo
10059         write (iout,'(a)')
10060         theta(i)=theti
10061         call chainbuild
10062       enddo
10063       write (iout,'(a)') '***************** dx/dphi'
10064       write (iout,'(a)')
10065       do i=4,nres
10066         phi(i)=phi(i)+aincr
10067         do j=i-1,nres-1
10068           do k=1,3
10069             temp(k,j)=dc(k,nres+j)
10070           enddo
10071         enddo
10072         call chainbuild
10073         do j=i-1,nres-1
10074           ii = indmat(i-2,j)
10075 !         print *,'ii=',ii
10076           do k=1,3
10077             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10078             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10079                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10080           enddo
10081           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10082               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10083           write(iout,'(a)')
10084         enddo
10085         phi(i)=phi(i)-aincr
10086         call chainbuild
10087       enddo
10088       write (iout,'(a)') '****************** ddc/dtheta'
10089       do i=1,nres-2
10090         thet=theta(i+2)
10091         theta(i+2)=thet+aincr
10092         do j=i,nres
10093           do k=1,3
10094             temp(k,j)=dc(k,j)
10095           enddo
10096         enddo
10097         call chainbuild
10098         do j=i+1,nres-1
10099           ii = indmat(i,j)
10100 !         print *,'ii=',ii
10101           do k=1,3
10102             gg(k)=(dc(k,j)-temp(k,j))/aincr
10103             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10104                  (aincr*dabs(dcdv(k,ii))+aincr))
10105           enddo
10106           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10107                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10108           write (iout,'(a)')
10109         enddo
10110         do j=1,nres
10111           do k=1,3
10112             dc(k,j)=temp(k,j)
10113           enddo
10114         enddo
10115         theta(i+2)=thet
10116       enddo
10117       write (iout,'(a)') '******************* ddc/dphi'
10118       do i=1,nres-3
10119         phii=phi(i+3)
10120         phi(i+3)=phii+aincr
10121         do j=1,nres
10122           do k=1,3
10123             temp(k,j)=dc(k,j)
10124           enddo
10125         enddo
10126         call chainbuild
10127         do j=i+2,nres-1
10128           ii = indmat(i+1,j)
10129 !         print *,'ii=',ii
10130           do k=1,3
10131             gg(k)=(dc(k,j)-temp(k,j))/aincr
10132             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10133                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10134           enddo
10135           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10136                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10137           write (iout,'(a)')
10138         enddo
10139         do j=1,nres
10140           do k=1,3
10141             dc(k,j)=temp(k,j)
10142           enddo
10143         enddo
10144         phi(i+3)=phii
10145       enddo
10146       return
10147       end subroutine check_cartgrad
10148 !-----------------------------------------------------------------------------
10149       subroutine check_ecart
10150 ! Check the gradient of the energy in Cartesian coordinates.
10151 !     implicit real*8 (a-h,o-z)
10152 !     include 'DIMENSIONS'
10153 !     include 'COMMON.CHAIN'
10154 !     include 'COMMON.DERIV'
10155 !     include 'COMMON.IOUNITS'
10156 !     include 'COMMON.VAR'
10157 !     include 'COMMON.CONTACTS'
10158       use comm_srutu
10159 !el      integer :: icall
10160 !el      common /srutu/ icall
10161       real(kind=8),dimension(6) :: ggg
10162       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10163       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10164       real(kind=8),dimension(6,nres) :: grad_s
10165       real(kind=8),dimension(0:n_ene) :: energia,energia1
10166       integer :: uiparm(1)
10167       real(kind=8) :: urparm(1)
10168 !EL      external fdum
10169       integer :: nf,i,j,k
10170       real(kind=8) :: aincr,etot,etot1
10171       icg=1
10172       nf=0
10173       nfl=0
10174       call zerograd
10175       aincr=1.0D-7
10176       print '(a)','CG processor',me,' calling CHECK_CART.'
10177       nf=0
10178       icall=0
10179       call geom_to_var(nvar,x)
10180       call etotal(energia)
10181       etot=energia(0)
10182 !el      call enerprint(energia)
10183       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10184       icall =1
10185       do i=1,nres
10186         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10187       enddo
10188       do i=1,nres
10189         do j=1,3
10190           grad_s(j,i)=gradc(j,i,icg)
10191           grad_s(j+3,i)=gradx(j,i,icg)
10192         enddo
10193       enddo
10194       call flush(iout)
10195       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10196       do i=1,nres
10197         do j=1,3
10198           xx(j)=c(j,i+nres)
10199           ddc(j)=dc(j,i)
10200           ddx(j)=dc(j,i+nres)
10201         enddo
10202         do j=1,3
10203           dc(j,i)=dc(j,i)+aincr
10204           do k=i+1,nres
10205             c(j,k)=c(j,k)+aincr
10206             c(j,k+nres)=c(j,k+nres)+aincr
10207           enddo
10208           call etotal(energia1)
10209           etot1=energia1(0)
10210           ggg(j)=(etot1-etot)/aincr
10211           dc(j,i)=ddc(j)
10212           do k=i+1,nres
10213             c(j,k)=c(j,k)-aincr
10214             c(j,k+nres)=c(j,k+nres)-aincr
10215           enddo
10216         enddo
10217         do j=1,3
10218           c(j,i+nres)=c(j,i+nres)+aincr
10219           dc(j,i+nres)=dc(j,i+nres)+aincr
10220           call etotal(energia1)
10221           etot1=energia1(0)
10222           ggg(j+3)=(etot1-etot)/aincr
10223           c(j,i+nres)=xx(j)
10224           dc(j,i+nres)=ddx(j)
10225         enddo
10226         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10227          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10228       enddo
10229       return
10230       end subroutine check_ecart
10231 #ifdef CARGRAD
10232 !-----------------------------------------------------------------------------
10233       subroutine check_ecartint
10234 ! Check the gradient of the energy in Cartesian coordinates.
10235       use io_base, only: intout
10236 !      implicit real*8 (a-h,o-z)
10237 !      include 'DIMENSIONS'
10238 !      include 'COMMON.CONTROL'
10239 !      include 'COMMON.CHAIN'
10240 !      include 'COMMON.DERIV'
10241 !      include 'COMMON.IOUNITS'
10242 !      include 'COMMON.VAR'
10243 !      include 'COMMON.CONTACTS'
10244 !      include 'COMMON.MD'
10245 !      include 'COMMON.LOCAL'
10246 !      include 'COMMON.SPLITELE'
10247       use comm_srutu
10248 !el      integer :: icall
10249 !el      common /srutu/ icall
10250       real(kind=8),dimension(6) :: ggg,ggg1
10251       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
10252       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10253       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
10254       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10255       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10256       real(kind=8),dimension(0:n_ene) :: energia,energia1
10257       integer :: uiparm(1)
10258       real(kind=8) :: urparm(1)
10259 !EL      external fdum
10260       integer :: i,j,k,nf
10261       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10262                    etot21,etot22
10263       r_cut=2.0d0
10264       rlambd=0.3d0
10265       icg=1
10266       nf=0
10267       nfl=0
10268       call intout
10269 !      call intcartderiv
10270 !      call checkintcartgrad
10271       call zerograd
10272       aincr=1.0D-5
10273       write(iout,*) 'Calling CHECK_ECARTINT.'
10274       nf=0
10275       icall=0
10276       write (iout,*) "Before geom_to_var"
10277       call geom_to_var(nvar,x)
10278       write (iout,*) "after geom_to_var"
10279       write (iout,*) "split_ene ",split_ene
10280       call flush(iout)
10281       if (.not.split_ene) then
10282         write(iout,*) 'Calling CHECK_ECARTINT if'
10283         call etotal(energia)
10284 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10285         etot=energia(0)
10286         write (iout,*) "etot",etot
10287         call flush(iout)
10288 !el        call enerprint(energia)
10289 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10290         call flush(iout)
10291         write (iout,*) "enter cartgrad"
10292         call flush(iout)
10293         call cartgrad
10294 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10295         write (iout,*) "exit cartgrad"
10296         call flush(iout)
10297         icall =1
10298         do i=1,nres
10299           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10300         enddo
10301         do j=1,3
10302           grad_s(j,0)=gcart(j,0)
10303         enddo
10304 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10305         do i=1,nres
10306           do j=1,3
10307             grad_s(j,i)=gcart(j,i)
10308             grad_s(j+3,i)=gxcart(j,i)
10309           enddo
10310         enddo
10311       else
10312 write(iout,*) 'Calling CHECK_ECARTIN else.'
10313 !- split gradient check
10314         call zerograd
10315         call etotal_long(energia)
10316 !el        call enerprint(energia)
10317         call flush(iout)
10318         write (iout,*) "enter cartgrad"
10319         call flush(iout)
10320         call cartgrad
10321         write (iout,*) "exit cartgrad"
10322         call flush(iout)
10323         icall =1
10324         write (iout,*) "longrange grad"
10325         do i=1,nres
10326           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10327           (gxcart(j,i),j=1,3)
10328         enddo
10329         do j=1,3
10330           grad_s(j,0)=gcart(j,0)
10331         enddo
10332         do i=1,nres
10333           do j=1,3
10334             grad_s(j,i)=gcart(j,i)
10335             grad_s(j+3,i)=gxcart(j,i)
10336           enddo
10337         enddo
10338         call zerograd
10339         call etotal_short(energia)
10340 !el        call enerprint(energia)
10341         call flush(iout)
10342         write (iout,*) "enter cartgrad"
10343         call flush(iout)
10344         call cartgrad
10345         write (iout,*) "exit cartgrad"
10346         call flush(iout)
10347         icall =1
10348         write (iout,*) "shortrange grad"
10349         do i=1,nres
10350           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10351           (gxcart(j,i),j=1,3)
10352         enddo
10353         do j=1,3
10354           grad_s1(j,0)=gcart(j,0)
10355         enddo
10356         do i=1,nres
10357           do j=1,3
10358             grad_s1(j,i)=gcart(j,i)
10359             grad_s1(j+3,i)=gxcart(j,i)
10360           enddo
10361         enddo
10362       endif
10363       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10364 !      do i=1,nres
10365       do i=nnt,nct
10366         do j=1,3
10367           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
10368           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
10369           ddc(j)=c(j,i)
10370           ddx(j)=c(j,i+nres)
10371           dcnorm_safe1(j)=dc_norm(j,i-1)
10372           dcnorm_safe2(j)=dc_norm(j,i)
10373           dxnorm_safe(j)=dc_norm(j,i+nres)
10374         enddo
10375         do j=1,3
10376           c(j,i)=ddc(j)+aincr
10377           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
10378           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
10379           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10380           dc(j,i)=c(j,i+1)-c(j,i)
10381           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10382           call int_from_cart1(.false.)
10383           if (.not.split_ene) then
10384             call etotal(energia1)
10385             etot1=energia1(0)
10386             write (iout,*) "ij",i,j," etot1",etot1
10387           else
10388 !- split gradient
10389             call etotal_long(energia1)
10390             etot11=energia1(0)
10391             call etotal_short(energia1)
10392             etot12=energia1(0)
10393           endif
10394 !- end split gradient
10395 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10396           c(j,i)=ddc(j)-aincr
10397           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
10398           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
10399           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10400           dc(j,i)=c(j,i+1)-c(j,i)
10401           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10402           call int_from_cart1(.false.)
10403           if (.not.split_ene) then
10404             call etotal(energia1)
10405             etot2=energia1(0)
10406             write (iout,*) "ij",i,j," etot2",etot2
10407             ggg(j)=(etot1-etot2)/(2*aincr)
10408           else
10409 !- split gradient
10410             call etotal_long(energia1)
10411             etot21=energia1(0)
10412             ggg(j)=(etot11-etot21)/(2*aincr)
10413             call etotal_short(energia1)
10414             etot22=energia1(0)
10415             ggg1(j)=(etot12-etot22)/(2*aincr)
10416 !- end split gradient
10417 !            write (iout,*) "etot21",etot21," etot22",etot22
10418           endif
10419 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10420           c(j,i)=ddc(j)
10421           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
10422           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
10423           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10424           dc(j,i)=c(j,i+1)-c(j,i)
10425           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10426           dc_norm(j,i-1)=dcnorm_safe1(j)
10427           dc_norm(j,i)=dcnorm_safe2(j)
10428           dc_norm(j,i+nres)=dxnorm_safe(j)
10429         enddo
10430         do j=1,3
10431           c(j,i+nres)=ddx(j)+aincr
10432           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10433           call int_from_cart1(.false.)
10434           if (.not.split_ene) then
10435             call etotal(energia1)
10436             etot1=energia1(0)
10437           else
10438 !- split gradient
10439             call etotal_long(energia1)
10440             etot11=energia1(0)
10441             call etotal_short(energia1)
10442             etot12=energia1(0)
10443           endif
10444 !- end split gradient
10445           c(j,i+nres)=ddx(j)-aincr
10446           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10447           call int_from_cart1(.false.)
10448           if (.not.split_ene) then
10449             call etotal(energia1)
10450             etot2=energia1(0)
10451             ggg(j+3)=(etot1-etot2)/(2*aincr)
10452           else
10453 !- split gradient
10454             call etotal_long(energia1)
10455             etot21=energia1(0)
10456             ggg(j+3)=(etot11-etot21)/(2*aincr)
10457             call etotal_short(energia1)
10458             etot22=energia1(0)
10459             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10460 !- end split gradient
10461           endif
10462 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10463           c(j,i+nres)=ddx(j)
10464           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10465           dc_norm(j,i+nres)=dxnorm_safe(j)
10466           call int_from_cart1(.false.)
10467         enddo
10468         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10469          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10470         if (split_ene) then
10471           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10472          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10473          k=1,6)
10474          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10475          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10476          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10477         endif
10478       enddo
10479       return
10480       end subroutine check_ecartint
10481 #else
10482 !-----------------------------------------------------------------------------
10483       subroutine check_ecartint
10484 ! Check the gradient of the energy in Cartesian coordinates.
10485       use io_base, only: intout
10486 !      implicit real*8 (a-h,o-z)
10487 !      include 'DIMENSIONS'
10488 !      include 'COMMON.CONTROL'
10489 !      include 'COMMON.CHAIN'
10490 !      include 'COMMON.DERIV'
10491 !      include 'COMMON.IOUNITS'
10492 !      include 'COMMON.VAR'
10493 !      include 'COMMON.CONTACTS'
10494 !      include 'COMMON.MD'
10495 !      include 'COMMON.LOCAL'
10496 !      include 'COMMON.SPLITELE'
10497       use comm_srutu
10498 !el      integer :: icall
10499 !el      common /srutu/ icall
10500       real(kind=8),dimension(6) :: ggg,ggg1
10501       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10502       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10503       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10504       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10505       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10506       real(kind=8),dimension(0:n_ene) :: energia,energia1
10507       integer :: uiparm(1)
10508       real(kind=8) :: urparm(1)
10509 !EL      external fdum
10510       integer :: i,j,k,nf
10511       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10512                    etot21,etot22
10513       r_cut=2.0d0
10514       rlambd=0.3d0
10515       icg=1
10516       nf=0
10517       nfl=0
10518       call intout
10519 !      call intcartderiv
10520 !      call checkintcartgrad
10521       call zerograd
10522       aincr=1.0D-4
10523       write(iout,*) 'Calling CHECK_ECARTINT.'
10524       nf=0
10525       icall=0
10526       call geom_to_var(nvar,x)
10527       if (.not.split_ene) then
10528         call etotal(energia)
10529         etot=energia(0)
10530 !el        call enerprint(energia)
10531         call flush(iout)
10532         write (iout,*) "enter cartgrad"
10533         call flush(iout)
10534         call cartgrad
10535         write (iout,*) "exit cartgrad"
10536         call flush(iout)
10537         icall =1
10538         do i=1,nres
10539           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10540         enddo
10541         do j=1,3
10542           grad_s(j,0)=gcart(j,0)
10543         enddo
10544         do i=1,nres
10545           do j=1,3
10546             grad_s(j,i)=gcart(j,i)
10547             grad_s(j+3,i)=gxcart(j,i)
10548           enddo
10549         enddo
10550       else
10551 !- split gradient check
10552         call zerograd
10553         call etotal_long(energia)
10554 !el        call enerprint(energia)
10555         call flush(iout)
10556         write (iout,*) "enter cartgrad"
10557         call flush(iout)
10558         call cartgrad
10559         write (iout,*) "exit cartgrad"
10560         call flush(iout)
10561         icall =1
10562         write (iout,*) "longrange grad"
10563         do i=1,nres
10564           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10565           (gxcart(j,i),j=1,3)
10566         enddo
10567         do j=1,3
10568           grad_s(j,0)=gcart(j,0)
10569         enddo
10570         do i=1,nres
10571           do j=1,3
10572             grad_s(j,i)=gcart(j,i)
10573             grad_s(j+3,i)=gxcart(j,i)
10574           enddo
10575         enddo
10576         call zerograd
10577         call etotal_short(energia)
10578 !el        call enerprint(energia)
10579         call flush(iout)
10580         write (iout,*) "enter cartgrad"
10581         call flush(iout)
10582         call cartgrad
10583         write (iout,*) "exit cartgrad"
10584         call flush(iout)
10585         icall =1
10586         write (iout,*) "shortrange grad"
10587         do i=1,nres
10588           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10589           (gxcart(j,i),j=1,3)
10590         enddo
10591         do j=1,3
10592           grad_s1(j,0)=gcart(j,0)
10593         enddo
10594         do i=1,nres
10595           do j=1,3
10596             grad_s1(j,i)=gcart(j,i)
10597             grad_s1(j+3,i)=gxcart(j,i)
10598           enddo
10599         enddo
10600       endif
10601       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10602       do i=0,nres
10603         do j=1,3
10604           xx(j)=c(j,i+nres)
10605           ddc(j)=dc(j,i)
10606           ddx(j)=dc(j,i+nres)
10607           do k=1,3
10608             dcnorm_safe(k)=dc_norm(k,i)
10609             dxnorm_safe(k)=dc_norm(k,i+nres)
10610           enddo
10611         enddo
10612         do j=1,3
10613           dc(j,i)=ddc(j)+aincr
10614           call chainbuild_cart
10615 #ifdef MPI
10616 ! Broadcast the order to compute internal coordinates to the slaves.
10617 !          if (nfgtasks.gt.1)
10618 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10619 #endif
10620 !          call int_from_cart1(.false.)
10621           if (.not.split_ene) then
10622             call etotal(energia1)
10623             etot1=energia1(0)
10624           else
10625 !- split gradient
10626             call etotal_long(energia1)
10627             etot11=energia1(0)
10628             call etotal_short(energia1)
10629             etot12=energia1(0)
10630 !            write (iout,*) "etot11",etot11," etot12",etot12
10631           endif
10632 !- end split gradient
10633 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10634           dc(j,i)=ddc(j)-aincr
10635           call chainbuild_cart
10636 !          call int_from_cart1(.false.)
10637           if (.not.split_ene) then
10638             call etotal(energia1)
10639             etot2=energia1(0)
10640             ggg(j)=(etot1-etot2)/(2*aincr)
10641           else
10642 !- split gradient
10643             call etotal_long(energia1)
10644             etot21=energia1(0)
10645             ggg(j)=(etot11-etot21)/(2*aincr)
10646             call etotal_short(energia1)
10647             etot22=energia1(0)
10648             ggg1(j)=(etot12-etot22)/(2*aincr)
10649 !- end split gradient
10650 !            write (iout,*) "etot21",etot21," etot22",etot22
10651           endif
10652 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10653           dc(j,i)=ddc(j)
10654           call chainbuild_cart
10655         enddo
10656         do j=1,3
10657           dc(j,i+nres)=ddx(j)+aincr
10658           call chainbuild_cart
10659 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10660 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10661 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10662 !          write (iout,*) "dxnormnorm",dsqrt(
10663 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10664 !          write (iout,*) "dxnormnormsafe",dsqrt(
10665 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10666 !          write (iout,*)
10667           if (.not.split_ene) then
10668             call etotal(energia1)
10669             etot1=energia1(0)
10670           else
10671 !- split gradient
10672             call etotal_long(energia1)
10673             etot11=energia1(0)
10674             call etotal_short(energia1)
10675             etot12=energia1(0)
10676           endif
10677 !- end split gradient
10678 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10679           dc(j,i+nres)=ddx(j)-aincr
10680           call chainbuild_cart
10681 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10682 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10683 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10684 !          write (iout,*)
10685 !          write (iout,*) "dxnormnorm",dsqrt(
10686 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10687 !          write (iout,*) "dxnormnormsafe",dsqrt(
10688 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10689           if (.not.split_ene) then
10690             call etotal(energia1)
10691             etot2=energia1(0)
10692             ggg(j+3)=(etot1-etot2)/(2*aincr)
10693           else
10694 !- split gradient
10695             call etotal_long(energia1)
10696             etot21=energia1(0)
10697             ggg(j+3)=(etot11-etot21)/(2*aincr)
10698             call etotal_short(energia1)
10699             etot22=energia1(0)
10700             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10701 !- end split gradient
10702           endif
10703 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10704           dc(j,i+nres)=ddx(j)
10705           call chainbuild_cart
10706         enddo
10707         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10708          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10709         if (split_ene) then
10710           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10711          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10712          k=1,6)
10713          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10714          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10715          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10716         endif
10717       enddo
10718       return
10719       end subroutine check_ecartint
10720 #endif
10721 !-----------------------------------------------------------------------------
10722       subroutine check_eint
10723 ! Check the gradient of energy in internal coordinates.
10724 !      implicit real*8 (a-h,o-z)
10725 !      include 'DIMENSIONS'
10726 !      include 'COMMON.CHAIN'
10727 !      include 'COMMON.DERIV'
10728 !      include 'COMMON.IOUNITS'
10729 !      include 'COMMON.VAR'
10730 !      include 'COMMON.GEO'
10731       use comm_srutu
10732 !el      integer :: icall
10733 !el      common /srutu/ icall
10734       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10735       integer :: uiparm(1)
10736       real(kind=8) :: urparm(1)
10737       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10738       character(len=6) :: key
10739 !EL      external fdum
10740       integer :: i,ii,nf
10741       real(kind=8) :: xi,aincr,etot,etot1,etot2
10742       call zerograd
10743       aincr=1.0D-7
10744       print '(a)','Calling CHECK_INT.'
10745       nf=0
10746       nfl=0
10747       icg=1
10748       call geom_to_var(nvar,x)
10749       call var_to_geom(nvar,x)
10750       call chainbuild
10751       icall=1
10752       print *,'ICG=',ICG
10753       call etotal(energia)
10754       etot = energia(0)
10755 !el      call enerprint(energia)
10756       print *,'ICG=',ICG
10757 #ifdef MPL
10758       if (MyID.ne.BossID) then
10759         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10760         nf=x(nvar+1)
10761         nfl=x(nvar+2)
10762         icg=x(nvar+3)
10763       endif
10764 #endif
10765       nf=1
10766       nfl=3
10767 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10768       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10769 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10770       icall=1
10771       do i=1,nvar
10772         xi=x(i)
10773         x(i)=xi-0.5D0*aincr
10774         call var_to_geom(nvar,x)
10775         call chainbuild
10776         call etotal(energia1)
10777         etot1=energia1(0)
10778         x(i)=xi+0.5D0*aincr
10779         call var_to_geom(nvar,x)
10780         call chainbuild
10781         call etotal(energia2)
10782         etot2=energia2(0)
10783         gg(i)=(etot2-etot1)/aincr
10784         write (iout,*) i,etot1,etot2
10785         x(i)=xi
10786       enddo
10787       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10788           '     RelDiff*100% '
10789       do i=1,nvar
10790         if (i.le.nphi) then
10791           ii=i
10792           key = ' phi'
10793         else if (i.le.nphi+ntheta) then
10794           ii=i-nphi
10795           key=' theta'
10796         else if (i.le.nphi+ntheta+nside) then
10797            ii=i-(nphi+ntheta)
10798            key=' alpha'
10799         else
10800            ii=i-(nphi+ntheta+nside)
10801            key=' omega'
10802         endif
10803         write (iout,'(i3,a,i3,3(1pd16.6))') &
10804        i,key,ii,gg(i),gana(i),&
10805        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10806       enddo
10807       return
10808       end subroutine check_eint
10809 !-----------------------------------------------------------------------------
10810 ! econstr_local.F
10811 !-----------------------------------------------------------------------------
10812       subroutine Econstr_back
10813 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
10814 !      implicit real*8 (a-h,o-z)
10815 !      include 'DIMENSIONS'
10816 !      include 'COMMON.CONTROL'
10817 !      include 'COMMON.VAR'
10818 !      include 'COMMON.MD'
10819       use MD_data
10820 !#ifndef LANG0
10821 !      include 'COMMON.LANGEVIN'
10822 !#else
10823 !      include 'COMMON.LANGEVIN.lang0'
10824 !#endif
10825 !      include 'COMMON.CHAIN'
10826 !      include 'COMMON.DERIV'
10827 !      include 'COMMON.GEO'
10828 !      include 'COMMON.LOCAL'
10829 !      include 'COMMON.INTERACT'
10830 !      include 'COMMON.IOUNITS'
10831 !      include 'COMMON.NAMES'
10832 !      include 'COMMON.TIME1'
10833       integer :: i,j,ii,k
10834       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
10835
10836       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
10837       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
10838       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
10839
10840       Uconst_back=0.0d0
10841       do i=1,nres
10842         dutheta(i)=0.0d0
10843         dugamma(i)=0.0d0
10844         do j=1,3
10845           duscdiff(j,i)=0.0d0
10846           duscdiffx(j,i)=0.0d0
10847         enddo
10848       enddo
10849       do i=1,nfrag_back
10850         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10851 !
10852 ! Deviations from theta angles
10853 !
10854         utheta_i=0.0d0
10855         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
10856           dtheta_i=theta(j)-thetaref(j)
10857           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
10858           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10859         enddo
10860         utheta(i)=utheta_i/(ii-1)
10861 !
10862 ! Deviations from gamma angles
10863 !
10864         ugamma_i=0.0d0
10865         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
10866           dgamma_i=pinorm(phi(j)-phiref(j))
10867 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
10868           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
10869           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
10870 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
10871         enddo
10872         ugamma(i)=ugamma_i/(ii-2)
10873 !
10874 ! Deviations from local SC geometry
10875 !
10876         uscdiff(i)=0.0d0
10877         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
10878           dxx=xxtab(j)-xxref(j)
10879           dyy=yytab(j)-yyref(j)
10880           dzz=zztab(j)-zzref(j)
10881           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
10882           do k=1,3
10883             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
10884              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
10885              (ii-1)
10886             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
10887              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
10888              (ii-1)
10889             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
10890            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
10891             /(ii-1)
10892           enddo
10893 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10894 !     &      xxref(j),yyref(j),zzref(j)
10895         enddo
10896         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
10897 !        write (iout,*) i," uscdiff",uscdiff(i)
10898 !
10899 ! Put together deviations from local geometry
10900 !
10901         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
10902           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
10903 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
10904 !     &   " uconst_back",uconst_back
10905         utheta(i)=dsqrt(utheta(i))
10906         ugamma(i)=dsqrt(ugamma(i))
10907         uscdiff(i)=dsqrt(uscdiff(i))
10908       enddo
10909       return
10910       end subroutine Econstr_back
10911 !-----------------------------------------------------------------------------
10912 ! energy_p_new-sep_barrier.F
10913 !-----------------------------------------------------------------------------
10914       real(kind=8) function sscale(r)
10915 !      include "COMMON.SPLITELE"
10916       real(kind=8) :: r,gamm
10917       if(r.lt.r_cut-rlamb) then
10918         sscale=1.0d0
10919       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10920         gamm=(r-(r_cut-rlamb))/rlamb
10921         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10922       else
10923         sscale=0d0
10924       endif
10925       return
10926       end function sscale
10927 !-----------------------------------------------------------------------------
10928       subroutine elj_long(evdw)
10929 !
10930 ! This subroutine calculates the interaction energy of nonbonded side chains
10931 ! assuming the LJ potential of interaction.
10932 !
10933 !      implicit real*8 (a-h,o-z)
10934 !      include 'DIMENSIONS'
10935 !      include 'COMMON.GEO'
10936 !      include 'COMMON.VAR'
10937 !      include 'COMMON.LOCAL'
10938 !      include 'COMMON.CHAIN'
10939 !      include 'COMMON.DERIV'
10940 !      include 'COMMON.INTERACT'
10941 !      include 'COMMON.TORSION'
10942 !      include 'COMMON.SBRIDGE'
10943 !      include 'COMMON.NAMES'
10944 !      include 'COMMON.IOUNITS'
10945 !      include 'COMMON.CONTACTS'
10946       real(kind=8),parameter :: accur=1.0d-10
10947       real(kind=8),dimension(3) :: gg
10948 !el local variables
10949       integer :: i,iint,j,k,itypi,itypi1,itypj
10950       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
10951       real(kind=8) :: e1,e2,evdwij,evdw
10952 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
10953       evdw=0.0D0
10954       do i=iatsc_s,iatsc_e
10955         itypi=itype(i)
10956         if (itypi.eq.ntyp1) cycle
10957         itypi1=itype(i+1)
10958         xi=c(1,nres+i)
10959         yi=c(2,nres+i)
10960         zi=c(3,nres+i)
10961 !
10962 ! Calculate SC interaction energy.
10963 !
10964         do iint=1,nint_gr(i)
10965 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
10966 !d   &                  'iend=',iend(i,iint)
10967           do j=istart(i,iint),iend(i,iint)
10968             itypj=itype(j)
10969             if (itypj.eq.ntyp1) cycle
10970             xj=c(1,nres+j)-xi
10971             yj=c(2,nres+j)-yi
10972             zj=c(3,nres+j)-zi
10973             rij=xj*xj+yj*yj+zj*zj
10974             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
10975             if (sss.lt.1.0d0) then
10976               rrij=1.0D0/rij
10977               eps0ij=eps(itypi,itypj)
10978               fac=rrij**expon2
10979               e1=fac*fac*aa(itypi,itypj)
10980               e2=fac*bb(itypi,itypj)
10981               evdwij=e1+e2
10982               evdw=evdw+(1.0d0-sss)*evdwij
10983 !
10984 ! Calculate the components of the gradient in DC and X
10985 !
10986               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
10987               gg(1)=xj*fac
10988               gg(2)=yj*fac
10989               gg(3)=zj*fac
10990               do k=1,3
10991                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10992                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10993                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10994                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10995               enddo
10996             endif
10997           enddo      ! j
10998         enddo        ! iint
10999       enddo          ! i
11000       do i=1,nct
11001         do j=1,3
11002           gvdwc(j,i)=expon*gvdwc(j,i)
11003           gvdwx(j,i)=expon*gvdwx(j,i)
11004         enddo
11005       enddo
11006 !******************************************************************************
11007 !
11008 !                              N O T E !!!
11009 !
11010 ! To save time, the factor of EXPON has been extracted from ALL components
11011 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11012 ! use!
11013 !
11014 !******************************************************************************
11015       return
11016       end subroutine elj_long
11017 !-----------------------------------------------------------------------------
11018       subroutine elj_short(evdw)
11019 !
11020 ! This subroutine calculates the interaction energy of nonbonded side chains
11021 ! assuming the LJ potential of interaction.
11022 !
11023 !      implicit real*8 (a-h,o-z)
11024 !      include 'DIMENSIONS'
11025 !      include 'COMMON.GEO'
11026 !      include 'COMMON.VAR'
11027 !      include 'COMMON.LOCAL'
11028 !      include 'COMMON.CHAIN'
11029 !      include 'COMMON.DERIV'
11030 !      include 'COMMON.INTERACT'
11031 !      include 'COMMON.TORSION'
11032 !      include 'COMMON.SBRIDGE'
11033 !      include 'COMMON.NAMES'
11034 !      include 'COMMON.IOUNITS'
11035 !      include 'COMMON.CONTACTS'
11036       real(kind=8),parameter :: accur=1.0d-10
11037       real(kind=8),dimension(3) :: gg
11038 !el local variables
11039       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
11040       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11041       real(kind=8) :: e1,e2,evdwij,evdw
11042 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11043       evdw=0.0D0
11044       do i=iatsc_s,iatsc_e
11045         itypi=itype(i)
11046         if (itypi.eq.ntyp1) cycle
11047         itypi1=itype(i+1)
11048         xi=c(1,nres+i)
11049         yi=c(2,nres+i)
11050         zi=c(3,nres+i)
11051 ! Change 12/1/95
11052         num_conti=0
11053 !
11054 ! Calculate SC interaction energy.
11055 !
11056         do iint=1,nint_gr(i)
11057 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11058 !d   &                  'iend=',iend(i,iint)
11059           do j=istart(i,iint),iend(i,iint)
11060             itypj=itype(j)
11061             if (itypj.eq.ntyp1) cycle
11062             xj=c(1,nres+j)-xi
11063             yj=c(2,nres+j)-yi
11064             zj=c(3,nres+j)-zi
11065 ! Change 12/1/95 to calculate four-body interactions
11066             rij=xj*xj+yj*yj+zj*zj
11067             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11068             if (sss.gt.0.0d0) then
11069               rrij=1.0D0/rij
11070               eps0ij=eps(itypi,itypj)
11071               fac=rrij**expon2
11072               e1=fac*fac*aa(itypi,itypj)
11073               e2=fac*bb(itypi,itypj)
11074               evdwij=e1+e2
11075               evdw=evdw+sss*evdwij
11076 !
11077 ! Calculate the components of the gradient in DC and X
11078 !
11079               fac=-rrij*(e1+evdwij)*sss
11080               gg(1)=xj*fac
11081               gg(2)=yj*fac
11082               gg(3)=zj*fac
11083               do k=1,3
11084                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11085                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11086                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11087                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11088               enddo
11089             endif
11090           enddo      ! j
11091         enddo        ! iint
11092       enddo          ! i
11093       do i=1,nct
11094         do j=1,3
11095           gvdwc(j,i)=expon*gvdwc(j,i)
11096           gvdwx(j,i)=expon*gvdwx(j,i)
11097         enddo
11098       enddo
11099 !******************************************************************************
11100 !
11101 !                              N O T E !!!
11102 !
11103 ! To save time, the factor of EXPON has been extracted from ALL components
11104 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11105 ! use!
11106 !
11107 !******************************************************************************
11108       return
11109       end subroutine elj_short
11110 !-----------------------------------------------------------------------------
11111       subroutine eljk_long(evdw)
11112 !
11113 ! This subroutine calculates the interaction energy of nonbonded side chains
11114 ! assuming the LJK potential of interaction.
11115 !
11116 !      implicit real*8 (a-h,o-z)
11117 !      include 'DIMENSIONS'
11118 !      include 'COMMON.GEO'
11119 !      include 'COMMON.VAR'
11120 !      include 'COMMON.LOCAL'
11121 !      include 'COMMON.CHAIN'
11122 !      include 'COMMON.DERIV'
11123 !      include 'COMMON.INTERACT'
11124 !      include 'COMMON.IOUNITS'
11125 !      include 'COMMON.NAMES'
11126       real(kind=8),dimension(3) :: gg
11127       logical :: scheck
11128 !el local variables
11129       integer :: i,iint,j,k,itypi,itypi1,itypj
11130       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11131                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11132 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11133       evdw=0.0D0
11134       do i=iatsc_s,iatsc_e
11135         itypi=itype(i)
11136         if (itypi.eq.ntyp1) cycle
11137         itypi1=itype(i+1)
11138         xi=c(1,nres+i)
11139         yi=c(2,nres+i)
11140         zi=c(3,nres+i)
11141 !
11142 ! Calculate SC interaction energy.
11143 !
11144         do iint=1,nint_gr(i)
11145           do j=istart(i,iint),iend(i,iint)
11146             itypj=itype(j)
11147             if (itypj.eq.ntyp1) cycle
11148             xj=c(1,nres+j)-xi
11149             yj=c(2,nres+j)-yi
11150             zj=c(3,nres+j)-zi
11151             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11152             fac_augm=rrij**expon
11153             e_augm=augm(itypi,itypj)*fac_augm
11154             r_inv_ij=dsqrt(rrij)
11155             rij=1.0D0/r_inv_ij
11156             sss=sscale(rij/sigma(itypi,itypj))
11157             if (sss.lt.1.0d0) then
11158               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11159               fac=r_shift_inv**expon
11160               e1=fac*fac*aa(itypi,itypj)
11161               e2=fac*bb(itypi,itypj)
11162               evdwij=e_augm+e1+e2
11163 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11164 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11165 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11166 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11167 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11168 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11169 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11170               evdw=evdw+(1.0d0-sss)*evdwij
11171 !
11172 ! Calculate the components of the gradient in DC and X
11173 !
11174               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11175               fac=fac*(1.0d0-sss)
11176               gg(1)=xj*fac
11177               gg(2)=yj*fac
11178               gg(3)=zj*fac
11179               do k=1,3
11180                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11181                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11182                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11183                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11184               enddo
11185             endif
11186           enddo      ! j
11187         enddo        ! iint
11188       enddo          ! i
11189       do i=1,nct
11190         do j=1,3
11191           gvdwc(j,i)=expon*gvdwc(j,i)
11192           gvdwx(j,i)=expon*gvdwx(j,i)
11193         enddo
11194       enddo
11195       return
11196       end subroutine eljk_long
11197 !-----------------------------------------------------------------------------
11198       subroutine eljk_short(evdw)
11199 !
11200 ! This subroutine calculates the interaction energy of nonbonded side chains
11201 ! assuming the LJK potential of interaction.
11202 !
11203 !      implicit real*8 (a-h,o-z)
11204 !      include 'DIMENSIONS'
11205 !      include 'COMMON.GEO'
11206 !      include 'COMMON.VAR'
11207 !      include 'COMMON.LOCAL'
11208 !      include 'COMMON.CHAIN'
11209 !      include 'COMMON.DERIV'
11210 !      include 'COMMON.INTERACT'
11211 !      include 'COMMON.IOUNITS'
11212 !      include 'COMMON.NAMES'
11213       real(kind=8),dimension(3) :: gg
11214       logical :: scheck
11215 !el local variables
11216       integer :: i,iint,j,k,itypi,itypi1,itypj
11217       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11218                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11219 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11220       evdw=0.0D0
11221       do i=iatsc_s,iatsc_e
11222         itypi=itype(i)
11223         if (itypi.eq.ntyp1) cycle
11224         itypi1=itype(i+1)
11225         xi=c(1,nres+i)
11226         yi=c(2,nres+i)
11227         zi=c(3,nres+i)
11228 !
11229 ! Calculate SC interaction energy.
11230 !
11231         do iint=1,nint_gr(i)
11232           do j=istart(i,iint),iend(i,iint)
11233             itypj=itype(j)
11234             if (itypj.eq.ntyp1) cycle
11235             xj=c(1,nres+j)-xi
11236             yj=c(2,nres+j)-yi
11237             zj=c(3,nres+j)-zi
11238             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11239             fac_augm=rrij**expon
11240             e_augm=augm(itypi,itypj)*fac_augm
11241             r_inv_ij=dsqrt(rrij)
11242             rij=1.0D0/r_inv_ij
11243             sss=sscale(rij/sigma(itypi,itypj))
11244             if (sss.gt.0.0d0) then
11245               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11246               fac=r_shift_inv**expon
11247               e1=fac*fac*aa(itypi,itypj)
11248               e2=fac*bb(itypi,itypj)
11249               evdwij=e_augm+e1+e2
11250 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11251 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11252 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11253 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11254 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11255 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11256 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11257               evdw=evdw+sss*evdwij
11258 !
11259 ! Calculate the components of the gradient in DC and X
11260 !
11261               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11262               fac=fac*sss
11263               gg(1)=xj*fac
11264               gg(2)=yj*fac
11265               gg(3)=zj*fac
11266               do k=1,3
11267                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11268                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11269                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11270                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11271               enddo
11272             endif
11273           enddo      ! j
11274         enddo        ! iint
11275       enddo          ! i
11276       do i=1,nct
11277         do j=1,3
11278           gvdwc(j,i)=expon*gvdwc(j,i)
11279           gvdwx(j,i)=expon*gvdwx(j,i)
11280         enddo
11281       enddo
11282       return
11283       end subroutine eljk_short
11284 !-----------------------------------------------------------------------------
11285       subroutine ebp_long(evdw)
11286 !
11287 ! This subroutine calculates the interaction energy of nonbonded side chains
11288 ! assuming the Berne-Pechukas potential of interaction.
11289 !
11290       use calc_data
11291 !      implicit real*8 (a-h,o-z)
11292 !      include 'DIMENSIONS'
11293 !      include 'COMMON.GEO'
11294 !      include 'COMMON.VAR'
11295 !      include 'COMMON.LOCAL'
11296 !      include 'COMMON.CHAIN'
11297 !      include 'COMMON.DERIV'
11298 !      include 'COMMON.NAMES'
11299 !      include 'COMMON.INTERACT'
11300 !      include 'COMMON.IOUNITS'
11301 !      include 'COMMON.CALC'
11302       use comm_srutu
11303 !el      integer :: icall
11304 !el      common /srutu/ icall
11305 !     double precision rrsave(maxdim)
11306       logical :: lprn
11307 !el local variables
11308       integer :: iint,itypi,itypi1,itypj
11309       real(kind=8) :: rrij,xi,yi,zi,fac
11310       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11311       evdw=0.0D0
11312 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11313       evdw=0.0D0
11314 !     if (icall.eq.0) then
11315 !       lprn=.true.
11316 !     else
11317         lprn=.false.
11318 !     endif
11319 !el      ind=0
11320       do i=iatsc_s,iatsc_e
11321         itypi=itype(i)
11322         if (itypi.eq.ntyp1) cycle
11323         itypi1=itype(i+1)
11324         xi=c(1,nres+i)
11325         yi=c(2,nres+i)
11326         zi=c(3,nres+i)
11327         dxi=dc_norm(1,nres+i)
11328         dyi=dc_norm(2,nres+i)
11329         dzi=dc_norm(3,nres+i)
11330 !        dsci_inv=dsc_inv(itypi)
11331         dsci_inv=vbld_inv(i+nres)
11332 !
11333 ! Calculate SC interaction energy.
11334 !
11335         do iint=1,nint_gr(i)
11336           do j=istart(i,iint),iend(i,iint)
11337 !el            ind=ind+1
11338             itypj=itype(j)
11339             if (itypj.eq.ntyp1) cycle
11340 !            dscj_inv=dsc_inv(itypj)
11341             dscj_inv=vbld_inv(j+nres)
11342             chi1=chi(itypi,itypj)
11343             chi2=chi(itypj,itypi)
11344             chi12=chi1*chi2
11345             chip1=chip(itypi)
11346             chip2=chip(itypj)
11347             chip12=chip1*chip2
11348             alf1=alp(itypi)
11349             alf2=alp(itypj)
11350             alf12=0.5D0*(alf1+alf2)
11351             xj=c(1,nres+j)-xi
11352             yj=c(2,nres+j)-yi
11353             zj=c(3,nres+j)-zi
11354             dxj=dc_norm(1,nres+j)
11355             dyj=dc_norm(2,nres+j)
11356             dzj=dc_norm(3,nres+j)
11357             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11358             rij=dsqrt(rrij)
11359             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11360
11361             if (sss.lt.1.0d0) then
11362
11363 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11364               call sc_angular
11365 ! Calculate whole angle-dependent part of epsilon and contributions
11366 ! to its derivatives
11367               fac=(rrij*sigsq)**expon2
11368               e1=fac*fac*aa(itypi,itypj)
11369               e2=fac*bb(itypi,itypj)
11370               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11371               eps2der=evdwij*eps3rt
11372               eps3der=evdwij*eps2rt
11373               evdwij=evdwij*eps2rt*eps3rt
11374               evdw=evdw+evdwij*(1.0d0-sss)
11375               if (lprn) then
11376               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11377               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11378 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11379 !d     &          restyp(itypi),i,restyp(itypj),j,
11380 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11381 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11382 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11383 !d     &          evdwij
11384               endif
11385 ! Calculate gradient components.
11386               e1=e1*eps1*eps2rt**2*eps3rt**2
11387               fac=-expon*(e1+evdwij)
11388               sigder=fac/sigsq
11389               fac=rrij*fac
11390 ! Calculate radial part of the gradient
11391               gg(1)=xj*fac
11392               gg(2)=yj*fac
11393               gg(3)=zj*fac
11394 ! Calculate the angular part of the gradient and sum add the contributions
11395 ! to the appropriate components of the Cartesian gradient.
11396               call sc_grad_scale(1.0d0-sss)
11397             endif
11398           enddo      ! j
11399         enddo        ! iint
11400       enddo          ! i
11401 !     stop
11402       return
11403       end subroutine ebp_long
11404 !-----------------------------------------------------------------------------
11405       subroutine ebp_short(evdw)
11406 !
11407 ! This subroutine calculates the interaction energy of nonbonded side chains
11408 ! assuming the Berne-Pechukas potential of interaction.
11409 !
11410       use calc_data
11411 !      implicit real*8 (a-h,o-z)
11412 !      include 'DIMENSIONS'
11413 !      include 'COMMON.GEO'
11414 !      include 'COMMON.VAR'
11415 !      include 'COMMON.LOCAL'
11416 !      include 'COMMON.CHAIN'
11417 !      include 'COMMON.DERIV'
11418 !      include 'COMMON.NAMES'
11419 !      include 'COMMON.INTERACT'
11420 !      include 'COMMON.IOUNITS'
11421 !      include 'COMMON.CALC'
11422       use comm_srutu
11423 !el      integer :: icall
11424 !el      common /srutu/ icall
11425 !     double precision rrsave(maxdim)
11426       logical :: lprn
11427 !el local variables
11428       integer :: iint,itypi,itypi1,itypj
11429       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11430       real(kind=8) :: sss,e1,e2,evdw
11431       evdw=0.0D0
11432 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11433       evdw=0.0D0
11434 !     if (icall.eq.0) then
11435 !       lprn=.true.
11436 !     else
11437         lprn=.false.
11438 !     endif
11439 !el      ind=0
11440       do i=iatsc_s,iatsc_e
11441         itypi=itype(i)
11442         if (itypi.eq.ntyp1) cycle
11443         itypi1=itype(i+1)
11444         xi=c(1,nres+i)
11445         yi=c(2,nres+i)
11446         zi=c(3,nres+i)
11447         dxi=dc_norm(1,nres+i)
11448         dyi=dc_norm(2,nres+i)
11449         dzi=dc_norm(3,nres+i)
11450 !        dsci_inv=dsc_inv(itypi)
11451         dsci_inv=vbld_inv(i+nres)
11452 !
11453 ! Calculate SC interaction energy.
11454 !
11455         do iint=1,nint_gr(i)
11456           do j=istart(i,iint),iend(i,iint)
11457 !el            ind=ind+1
11458             itypj=itype(j)
11459             if (itypj.eq.ntyp1) cycle
11460 !            dscj_inv=dsc_inv(itypj)
11461             dscj_inv=vbld_inv(j+nres)
11462             chi1=chi(itypi,itypj)
11463             chi2=chi(itypj,itypi)
11464             chi12=chi1*chi2
11465             chip1=chip(itypi)
11466             chip2=chip(itypj)
11467             chip12=chip1*chip2
11468             alf1=alp(itypi)
11469             alf2=alp(itypj)
11470             alf12=0.5D0*(alf1+alf2)
11471             xj=c(1,nres+j)-xi
11472             yj=c(2,nres+j)-yi
11473             zj=c(3,nres+j)-zi
11474             dxj=dc_norm(1,nres+j)
11475             dyj=dc_norm(2,nres+j)
11476             dzj=dc_norm(3,nres+j)
11477             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11478             rij=dsqrt(rrij)
11479             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11480
11481             if (sss.gt.0.0d0) then
11482
11483 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11484               call sc_angular
11485 ! Calculate whole angle-dependent part of epsilon and contributions
11486 ! to its derivatives
11487               fac=(rrij*sigsq)**expon2
11488               e1=fac*fac*aa(itypi,itypj)
11489               e2=fac*bb(itypi,itypj)
11490               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11491               eps2der=evdwij*eps3rt
11492               eps3der=evdwij*eps2rt
11493               evdwij=evdwij*eps2rt*eps3rt
11494               evdw=evdw+evdwij*sss
11495               if (lprn) then
11496               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11497               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11498 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11499 !d     &          restyp(itypi),i,restyp(itypj),j,
11500 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11501 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11502 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11503 !d     &          evdwij
11504               endif
11505 ! Calculate gradient components.
11506               e1=e1*eps1*eps2rt**2*eps3rt**2
11507               fac=-expon*(e1+evdwij)
11508               sigder=fac/sigsq
11509               fac=rrij*fac
11510 ! Calculate radial part of the gradient
11511               gg(1)=xj*fac
11512               gg(2)=yj*fac
11513               gg(3)=zj*fac
11514 ! Calculate the angular part of the gradient and sum add the contributions
11515 ! to the appropriate components of the Cartesian gradient.
11516               call sc_grad_scale(sss)
11517             endif
11518           enddo      ! j
11519         enddo        ! iint
11520       enddo          ! i
11521 !     stop
11522       return
11523       end subroutine ebp_short
11524 !-----------------------------------------------------------------------------
11525       subroutine egb_long(evdw)
11526 !
11527 ! This subroutine calculates the interaction energy of nonbonded side chains
11528 ! assuming the Gay-Berne potential of interaction.
11529 !
11530       use calc_data
11531 !      implicit real*8 (a-h,o-z)
11532 !      include 'DIMENSIONS'
11533 !      include 'COMMON.GEO'
11534 !      include 'COMMON.VAR'
11535 !      include 'COMMON.LOCAL'
11536 !      include 'COMMON.CHAIN'
11537 !      include 'COMMON.DERIV'
11538 !      include 'COMMON.NAMES'
11539 !      include 'COMMON.INTERACT'
11540 !      include 'COMMON.IOUNITS'
11541 !      include 'COMMON.CALC'
11542 !      include 'COMMON.CONTROL'
11543       logical :: lprn
11544 !el local variables
11545       integer :: iint,itypi,itypi1,itypj
11546       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11547       real(kind=8) :: sss,e1,e2,evdw
11548       evdw=0.0D0
11549 !cccc      energy_dec=.false.
11550 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11551       evdw=0.0D0
11552       lprn=.false.
11553 !     if (icall.eq.0) lprn=.false.
11554 !el      ind=0
11555       do i=iatsc_s,iatsc_e
11556         itypi=itype(i)
11557         if (itypi.eq.ntyp1) cycle
11558         itypi1=itype(i+1)
11559         xi=c(1,nres+i)
11560         yi=c(2,nres+i)
11561         zi=c(3,nres+i)
11562         dxi=dc_norm(1,nres+i)
11563         dyi=dc_norm(2,nres+i)
11564         dzi=dc_norm(3,nres+i)
11565 !        dsci_inv=dsc_inv(itypi)
11566         dsci_inv=vbld_inv(i+nres)
11567 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11568 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11569 !
11570 ! Calculate SC interaction energy.
11571 !
11572         do iint=1,nint_gr(i)
11573           do j=istart(i,iint),iend(i,iint)
11574 !el            ind=ind+1
11575             itypj=itype(j)
11576             if (itypj.eq.ntyp1) cycle
11577 !            dscj_inv=dsc_inv(itypj)
11578             dscj_inv=vbld_inv(j+nres)
11579 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11580 !     &       1.0d0/vbld(j+nres)
11581 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11582             sig0ij=sigma(itypi,itypj)
11583             chi1=chi(itypi,itypj)
11584             chi2=chi(itypj,itypi)
11585             chi12=chi1*chi2
11586             chip1=chip(itypi)
11587             chip2=chip(itypj)
11588             chip12=chip1*chip2
11589             alf1=alp(itypi)
11590             alf2=alp(itypj)
11591             alf12=0.5D0*(alf1+alf2)
11592             xj=c(1,nres+j)-xi
11593             yj=c(2,nres+j)-yi
11594             zj=c(3,nres+j)-zi
11595             dxj=dc_norm(1,nres+j)
11596             dyj=dc_norm(2,nres+j)
11597             dzj=dc_norm(3,nres+j)
11598             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11599             rij=dsqrt(rrij)
11600             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11601
11602             if (sss.lt.1.0d0) then
11603
11604 ! Calculate angle-dependent terms of energy and contributions to their
11605 ! derivatives.
11606               call sc_angular
11607               sigsq=1.0D0/sigsq
11608               sig=sig0ij*dsqrt(sigsq)
11609               rij_shift=1.0D0/rij-sig+sig0ij
11610 ! for diagnostics; uncomment
11611 !              rij_shift=1.2*sig0ij
11612 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11613               if (rij_shift.le.0.0D0) then
11614                 evdw=1.0D20
11615 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11616 !d     &          restyp(itypi),i,restyp(itypj),j,
11617 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11618                 return
11619               endif
11620               sigder=-sig*sigsq
11621 !---------------------------------------------------------------
11622               rij_shift=1.0D0/rij_shift
11623               fac=rij_shift**expon
11624               e1=fac*fac*aa(itypi,itypj)
11625               e2=fac*bb(itypi,itypj)
11626               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11627               eps2der=evdwij*eps3rt
11628               eps3der=evdwij*eps2rt
11629 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11630 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11631               evdwij=evdwij*eps2rt*eps3rt
11632               evdw=evdw+evdwij*(1.0d0-sss)
11633               if (lprn) then
11634               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11635               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11636               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11637                 restyp(itypi),i,restyp(itypj),j,&
11638                 epsi,sigm,chi1,chi2,chip1,chip2,&
11639                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11640                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11641                 evdwij
11642               endif
11643
11644               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11645                               'evdw',i,j,evdwij
11646 !              if (energy_dec) write (iout,*) &
11647 !                              'evdw',i,j,evdwij,"egb_long"
11648
11649 ! Calculate gradient components.
11650               e1=e1*eps1*eps2rt**2*eps3rt**2
11651               fac=-expon*(e1+evdwij)*rij_shift
11652               sigder=fac*sigder
11653               fac=rij*fac
11654 !              fac=0.0d0
11655 ! Calculate the radial part of the gradient
11656               gg(1)=xj*fac
11657               gg(2)=yj*fac
11658               gg(3)=zj*fac
11659 ! Calculate angular part of the gradient.
11660               call sc_grad_scale(1.0d0-sss)
11661             endif
11662           enddo      ! j
11663         enddo        ! iint
11664       enddo          ! i
11665 !      write (iout,*) "Number of loop steps in EGB:",ind
11666 !ccc      energy_dec=.false.
11667       return
11668       end subroutine egb_long
11669 !-----------------------------------------------------------------------------
11670       subroutine egb_short(evdw)
11671 !
11672 ! This subroutine calculates the interaction energy of nonbonded side chains
11673 ! assuming the Gay-Berne potential of interaction.
11674 !
11675       use calc_data
11676 !      implicit real*8 (a-h,o-z)
11677 !      include 'DIMENSIONS'
11678 !      include 'COMMON.GEO'
11679 !      include 'COMMON.VAR'
11680 !      include 'COMMON.LOCAL'
11681 !      include 'COMMON.CHAIN'
11682 !      include 'COMMON.DERIV'
11683 !      include 'COMMON.NAMES'
11684 !      include 'COMMON.INTERACT'
11685 !      include 'COMMON.IOUNITS'
11686 !      include 'COMMON.CALC'
11687 !      include 'COMMON.CONTROL'
11688       logical :: lprn
11689 !el local variables
11690       integer :: iint,itypi,itypi1,itypj
11691       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11692       real(kind=8) :: sss,e1,e2,evdw,rij_shift
11693       evdw=0.0D0
11694 !cccc      energy_dec=.false.
11695 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11696       evdw=0.0D0
11697       lprn=.false.
11698 !     if (icall.eq.0) lprn=.false.
11699 !el      ind=0
11700       do i=iatsc_s,iatsc_e
11701         itypi=itype(i)
11702         if (itypi.eq.ntyp1) cycle
11703         itypi1=itype(i+1)
11704         xi=c(1,nres+i)
11705         yi=c(2,nres+i)
11706         zi=c(3,nres+i)
11707         dxi=dc_norm(1,nres+i)
11708         dyi=dc_norm(2,nres+i)
11709         dzi=dc_norm(3,nres+i)
11710 !        dsci_inv=dsc_inv(itypi)
11711         dsci_inv=vbld_inv(i+nres)
11712 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11713 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11714 !
11715 ! Calculate SC interaction energy.
11716 !
11717         do iint=1,nint_gr(i)
11718           do j=istart(i,iint),iend(i,iint)
11719 !el            ind=ind+1
11720             itypj=itype(j)
11721             if (itypj.eq.ntyp1) cycle
11722 !            dscj_inv=dsc_inv(itypj)
11723             dscj_inv=vbld_inv(j+nres)
11724 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11725 !     &       1.0d0/vbld(j+nres)
11726 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11727             sig0ij=sigma(itypi,itypj)
11728             chi1=chi(itypi,itypj)
11729             chi2=chi(itypj,itypi)
11730             chi12=chi1*chi2
11731             chip1=chip(itypi)
11732             chip2=chip(itypj)
11733             chip12=chip1*chip2
11734             alf1=alp(itypi)
11735             alf2=alp(itypj)
11736             alf12=0.5D0*(alf1+alf2)
11737             xj=c(1,nres+j)-xi
11738             yj=c(2,nres+j)-yi
11739             zj=c(3,nres+j)-zi
11740             dxj=dc_norm(1,nres+j)
11741             dyj=dc_norm(2,nres+j)
11742             dzj=dc_norm(3,nres+j)
11743             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11744             rij=dsqrt(rrij)
11745             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11746
11747             if (sss.gt.0.0d0) then
11748
11749 ! Calculate angle-dependent terms of energy and contributions to their
11750 ! derivatives.
11751               call sc_angular
11752               sigsq=1.0D0/sigsq
11753               sig=sig0ij*dsqrt(sigsq)
11754               rij_shift=1.0D0/rij-sig+sig0ij
11755 ! for diagnostics; uncomment
11756 !              rij_shift=1.2*sig0ij
11757 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11758               if (rij_shift.le.0.0D0) then
11759                 evdw=1.0D20
11760 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11761 !d     &          restyp(itypi),i,restyp(itypj),j,
11762 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11763                 return
11764               endif
11765               sigder=-sig*sigsq
11766 !---------------------------------------------------------------
11767               rij_shift=1.0D0/rij_shift
11768               fac=rij_shift**expon
11769               e1=fac*fac*aa(itypi,itypj)
11770               e2=fac*bb(itypi,itypj)
11771               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11772               eps2der=evdwij*eps3rt
11773               eps3der=evdwij*eps2rt
11774 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11775 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11776               evdwij=evdwij*eps2rt*eps3rt
11777               evdw=evdw+evdwij*sss
11778               if (lprn) then
11779               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11780               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11781               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11782                 restyp(itypi),i,restyp(itypj),j,&
11783                 epsi,sigm,chi1,chi2,chip1,chip2,&
11784                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11785                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11786                 evdwij
11787               endif
11788
11789               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11790                               'evdw',i,j,evdwij
11791 !              if (energy_dec) write (iout,*) &
11792 !                              'evdw',i,j,evdwij,"egb_short"
11793
11794 ! Calculate gradient components.
11795               e1=e1*eps1*eps2rt**2*eps3rt**2
11796               fac=-expon*(e1+evdwij)*rij_shift
11797               sigder=fac*sigder
11798               fac=rij*fac
11799 !              fac=0.0d0
11800 ! Calculate the radial part of the gradient
11801               gg(1)=xj*fac
11802               gg(2)=yj*fac
11803               gg(3)=zj*fac
11804 ! Calculate angular part of the gradient.
11805               call sc_grad_scale(sss)
11806             endif
11807           enddo      ! j
11808         enddo        ! iint
11809       enddo          ! i
11810 !      write (iout,*) "Number of loop steps in EGB:",ind
11811 !ccc      energy_dec=.false.
11812       return
11813       end subroutine egb_short
11814 !-----------------------------------------------------------------------------
11815       subroutine egbv_long(evdw)
11816 !
11817 ! This subroutine calculates the interaction energy of nonbonded side chains
11818 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11819 !
11820       use calc_data
11821 !      implicit real*8 (a-h,o-z)
11822 !      include 'DIMENSIONS'
11823 !      include 'COMMON.GEO'
11824 !      include 'COMMON.VAR'
11825 !      include 'COMMON.LOCAL'
11826 !      include 'COMMON.CHAIN'
11827 !      include 'COMMON.DERIV'
11828 !      include 'COMMON.NAMES'
11829 !      include 'COMMON.INTERACT'
11830 !      include 'COMMON.IOUNITS'
11831 !      include 'COMMON.CALC'
11832       use comm_srutu
11833 !el      integer :: icall
11834 !el      common /srutu/ icall
11835       logical :: lprn
11836 !el local variables
11837       integer :: iint,itypi,itypi1,itypj
11838       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
11839       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
11840       evdw=0.0D0
11841 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11842       evdw=0.0D0
11843       lprn=.false.
11844 !     if (icall.eq.0) lprn=.true.
11845 !el      ind=0
11846       do i=iatsc_s,iatsc_e
11847         itypi=itype(i)
11848         if (itypi.eq.ntyp1) cycle
11849         itypi1=itype(i+1)
11850         xi=c(1,nres+i)
11851         yi=c(2,nres+i)
11852         zi=c(3,nres+i)
11853         dxi=dc_norm(1,nres+i)
11854         dyi=dc_norm(2,nres+i)
11855         dzi=dc_norm(3,nres+i)
11856 !        dsci_inv=dsc_inv(itypi)
11857         dsci_inv=vbld_inv(i+nres)
11858 !
11859 ! Calculate SC interaction energy.
11860 !
11861         do iint=1,nint_gr(i)
11862           do j=istart(i,iint),iend(i,iint)
11863 !el            ind=ind+1
11864             itypj=itype(j)
11865             if (itypj.eq.ntyp1) cycle
11866 !            dscj_inv=dsc_inv(itypj)
11867             dscj_inv=vbld_inv(j+nres)
11868             sig0ij=sigma(itypi,itypj)
11869             r0ij=r0(itypi,itypj)
11870             chi1=chi(itypi,itypj)
11871             chi2=chi(itypj,itypi)
11872             chi12=chi1*chi2
11873             chip1=chip(itypi)
11874             chip2=chip(itypj)
11875             chip12=chip1*chip2
11876             alf1=alp(itypi)
11877             alf2=alp(itypj)
11878             alf12=0.5D0*(alf1+alf2)
11879             xj=c(1,nres+j)-xi
11880             yj=c(2,nres+j)-yi
11881             zj=c(3,nres+j)-zi
11882             dxj=dc_norm(1,nres+j)
11883             dyj=dc_norm(2,nres+j)
11884             dzj=dc_norm(3,nres+j)
11885             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11886             rij=dsqrt(rrij)
11887
11888             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11889
11890             if (sss.lt.1.0d0) then
11891
11892 ! Calculate angle-dependent terms of energy and contributions to their
11893 ! derivatives.
11894               call sc_angular
11895               sigsq=1.0D0/sigsq
11896               sig=sig0ij*dsqrt(sigsq)
11897               rij_shift=1.0D0/rij-sig+r0ij
11898 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11899               if (rij_shift.le.0.0D0) then
11900                 evdw=1.0D20
11901                 return
11902               endif
11903               sigder=-sig*sigsq
11904 !---------------------------------------------------------------
11905               rij_shift=1.0D0/rij_shift
11906               fac=rij_shift**expon
11907               e1=fac*fac*aa(itypi,itypj)
11908               e2=fac*bb(itypi,itypj)
11909               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11910               eps2der=evdwij*eps3rt
11911               eps3der=evdwij*eps2rt
11912               fac_augm=rrij**expon
11913               e_augm=augm(itypi,itypj)*fac_augm
11914               evdwij=evdwij*eps2rt*eps3rt
11915               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
11916               if (lprn) then
11917               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11918               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11919               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11920                 restyp(itypi),i,restyp(itypj),j,&
11921                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
11922                 chi1,chi2,chip1,chip2,&
11923                 eps1,eps2rt**2,eps3rt**2,&
11924                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11925                 evdwij+e_augm
11926               endif
11927 ! Calculate gradient components.
11928               e1=e1*eps1*eps2rt**2*eps3rt**2
11929               fac=-expon*(e1+evdwij)*rij_shift
11930               sigder=fac*sigder
11931               fac=rij*fac-2*expon*rrij*e_augm
11932 ! Calculate the radial part of the gradient
11933               gg(1)=xj*fac
11934               gg(2)=yj*fac
11935               gg(3)=zj*fac
11936 ! Calculate angular part of the gradient.
11937               call sc_grad_scale(1.0d0-sss)
11938             endif
11939           enddo      ! j
11940         enddo        ! iint
11941       enddo          ! i
11942       end subroutine egbv_long
11943 !-----------------------------------------------------------------------------
11944       subroutine egbv_short(evdw)
11945 !
11946 ! This subroutine calculates the interaction energy of nonbonded side chains
11947 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11948 !
11949       use calc_data
11950 !      implicit real*8 (a-h,o-z)
11951 !      include 'DIMENSIONS'
11952 !      include 'COMMON.GEO'
11953 !      include 'COMMON.VAR'
11954 !      include 'COMMON.LOCAL'
11955 !      include 'COMMON.CHAIN'
11956 !      include 'COMMON.DERIV'
11957 !      include 'COMMON.NAMES'
11958 !      include 'COMMON.INTERACT'
11959 !      include 'COMMON.IOUNITS'
11960 !      include 'COMMON.CALC'
11961       use comm_srutu
11962 !el      integer :: icall
11963 !el      common /srutu/ icall
11964       logical :: lprn
11965 !el local variables
11966       integer :: iint,itypi,itypi1,itypj
11967       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
11968       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
11969       evdw=0.0D0
11970 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11971       evdw=0.0D0
11972       lprn=.false.
11973 !     if (icall.eq.0) lprn=.true.
11974 !el      ind=0
11975       do i=iatsc_s,iatsc_e
11976         itypi=itype(i)
11977         if (itypi.eq.ntyp1) cycle
11978         itypi1=itype(i+1)
11979         xi=c(1,nres+i)
11980         yi=c(2,nres+i)
11981         zi=c(3,nres+i)
11982         dxi=dc_norm(1,nres+i)
11983         dyi=dc_norm(2,nres+i)
11984         dzi=dc_norm(3,nres+i)
11985 !        dsci_inv=dsc_inv(itypi)
11986         dsci_inv=vbld_inv(i+nres)
11987 !
11988 ! Calculate SC interaction energy.
11989 !
11990         do iint=1,nint_gr(i)
11991           do j=istart(i,iint),iend(i,iint)
11992 !el            ind=ind+1
11993             itypj=itype(j)
11994             if (itypj.eq.ntyp1) cycle
11995 !            dscj_inv=dsc_inv(itypj)
11996             dscj_inv=vbld_inv(j+nres)
11997             sig0ij=sigma(itypi,itypj)
11998             r0ij=r0(itypi,itypj)
11999             chi1=chi(itypi,itypj)
12000             chi2=chi(itypj,itypi)
12001             chi12=chi1*chi2
12002             chip1=chip(itypi)
12003             chip2=chip(itypj)
12004             chip12=chip1*chip2
12005             alf1=alp(itypi)
12006             alf2=alp(itypj)
12007             alf12=0.5D0*(alf1+alf2)
12008             xj=c(1,nres+j)-xi
12009             yj=c(2,nres+j)-yi
12010             zj=c(3,nres+j)-zi
12011             dxj=dc_norm(1,nres+j)
12012             dyj=dc_norm(2,nres+j)
12013             dzj=dc_norm(3,nres+j)
12014             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12015             rij=dsqrt(rrij)
12016
12017             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12018
12019             if (sss.gt.0.0d0) then
12020
12021 ! Calculate angle-dependent terms of energy and contributions to their
12022 ! derivatives.
12023               call sc_angular
12024               sigsq=1.0D0/sigsq
12025               sig=sig0ij*dsqrt(sigsq)
12026               rij_shift=1.0D0/rij-sig+r0ij
12027 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12028               if (rij_shift.le.0.0D0) then
12029                 evdw=1.0D20
12030                 return
12031               endif
12032               sigder=-sig*sigsq
12033 !---------------------------------------------------------------
12034               rij_shift=1.0D0/rij_shift
12035               fac=rij_shift**expon
12036               e1=fac*fac*aa(itypi,itypj)
12037               e2=fac*bb(itypi,itypj)
12038               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12039               eps2der=evdwij*eps3rt
12040               eps3der=evdwij*eps2rt
12041               fac_augm=rrij**expon
12042               e_augm=augm(itypi,itypj)*fac_augm
12043               evdwij=evdwij*eps2rt*eps3rt
12044               evdw=evdw+(evdwij+e_augm)*sss
12045               if (lprn) then
12046               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12047               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12048               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12049                 restyp(itypi),i,restyp(itypj),j,&
12050                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12051                 chi1,chi2,chip1,chip2,&
12052                 eps1,eps2rt**2,eps3rt**2,&
12053                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12054                 evdwij+e_augm
12055               endif
12056 ! Calculate gradient components.
12057               e1=e1*eps1*eps2rt**2*eps3rt**2
12058               fac=-expon*(e1+evdwij)*rij_shift
12059               sigder=fac*sigder
12060               fac=rij*fac-2*expon*rrij*e_augm
12061 ! Calculate the radial part of the gradient
12062               gg(1)=xj*fac
12063               gg(2)=yj*fac
12064               gg(3)=zj*fac
12065 ! Calculate angular part of the gradient.
12066               call sc_grad_scale(sss)
12067             endif
12068           enddo      ! j
12069         enddo        ! iint
12070       enddo          ! i
12071       end subroutine egbv_short
12072 !-----------------------------------------------------------------------------
12073       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
12074 !
12075 ! This subroutine calculates the average interaction energy and its gradient
12076 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
12077 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
12078 ! The potential depends both on the distance of peptide-group centers and on
12079 ! the orientation of the CA-CA virtual bonds.
12080 !
12081 !      implicit real*8 (a-h,o-z)
12082
12083       use comm_locel
12084 #ifdef MPI
12085       include 'mpif.h'
12086 #endif
12087 !      include 'DIMENSIONS'
12088 !      include 'COMMON.CONTROL'
12089 !      include 'COMMON.SETUP'
12090 !      include 'COMMON.IOUNITS'
12091 !      include 'COMMON.GEO'
12092 !      include 'COMMON.VAR'
12093 !      include 'COMMON.LOCAL'
12094 !      include 'COMMON.CHAIN'
12095 !      include 'COMMON.DERIV'
12096 !      include 'COMMON.INTERACT'
12097 !      include 'COMMON.CONTACTS'
12098 !      include 'COMMON.TORSION'
12099 !      include 'COMMON.VECTORS'
12100 !      include 'COMMON.FFIELD'
12101 !      include 'COMMON.TIME1'
12102       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
12103       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
12104       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12105 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12106       real(kind=8),dimension(4) :: muij
12107 !el      integer :: num_conti,j1,j2
12108 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12109 !el                   dz_normi,xmedi,ymedi,zmedi
12110 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12111 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12112 !el          num_conti,j1,j2
12113 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12114 #ifdef MOMENT
12115       real(kind=8) :: scal_el=1.0d0
12116 #else
12117       real(kind=8) :: scal_el=0.5d0
12118 #endif
12119 ! 12/13/98
12120 ! 13-go grudnia roku pamietnego...
12121       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12122                                              0.0d0,1.0d0,0.0d0,&
12123                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12124 !el local variables
12125       integer :: i,j,k
12126       real(kind=8) :: fac
12127       real(kind=8) :: dxj,dyj,dzj
12128       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
12129
12130 !      allocate(num_cont_hb(nres)) !(maxres)
12131 !d      write(iout,*) 'In EELEC'
12132 !d      do i=1,nloctyp
12133 !d        write(iout,*) 'Type',i
12134 !d        write(iout,*) 'B1',B1(:,i)
12135 !d        write(iout,*) 'B2',B2(:,i)
12136 !d        write(iout,*) 'CC',CC(:,:,i)
12137 !d        write(iout,*) 'DD',DD(:,:,i)
12138 !d        write(iout,*) 'EE',EE(:,:,i)
12139 !d      enddo
12140 !d      call check_vecgrad
12141 !d      stop
12142       if (icheckgrad.eq.1) then
12143         do i=1,nres-1
12144           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
12145           do k=1,3
12146             dc_norm(k,i)=dc(k,i)*fac
12147           enddo
12148 !          write (iout,*) 'i',i,' fac',fac
12149         enddo
12150       endif
12151       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12152           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
12153           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
12154 !        call vec_and_deriv
12155 #ifdef TIMING
12156         time01=MPI_Wtime()
12157 #endif
12158         call set_matrices
12159 #ifdef TIMING
12160         time_mat=time_mat+MPI_Wtime()-time01
12161 #endif
12162       endif
12163 !d      do i=1,nres-1
12164 !d        write (iout,*) 'i=',i
12165 !d        do k=1,3
12166 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
12167 !d        enddo
12168 !d        do k=1,3
12169 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
12170 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
12171 !d        enddo
12172 !d      enddo
12173       t_eelecij=0.0d0
12174       ees=0.0D0
12175       evdw1=0.0D0
12176       eel_loc=0.0d0
12177       eello_turn3=0.0d0
12178       eello_turn4=0.0d0
12179 !el      ind=0
12180       do i=1,nres
12181         num_cont_hb(i)=0
12182       enddo
12183 !d      print '(a)','Enter EELEC'
12184 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
12185 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
12186 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
12187       do i=1,nres
12188         gel_loc_loc(i)=0.0d0
12189         gcorr_loc(i)=0.0d0
12190       enddo
12191 !
12192 !
12193 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
12194 !
12195 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
12196 !
12197       do i=iturn3_start,iturn3_end
12198         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
12199         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
12200         dxi=dc(1,i)
12201         dyi=dc(2,i)
12202         dzi=dc(3,i)
12203         dx_normi=dc_norm(1,i)
12204         dy_normi=dc_norm(2,i)
12205         dz_normi=dc_norm(3,i)
12206         xmedi=c(1,i)+0.5d0*dxi
12207         ymedi=c(2,i)+0.5d0*dyi
12208         zmedi=c(3,i)+0.5d0*dzi
12209         num_conti=0
12210         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
12211         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
12212         num_cont_hb(i)=num_conti
12213       enddo
12214       do i=iturn4_start,iturn4_end
12215         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
12216           .or. itype(i+3).eq.ntyp1 &
12217           .or. itype(i+4).eq.ntyp1) cycle
12218         dxi=dc(1,i)
12219         dyi=dc(2,i)
12220         dzi=dc(3,i)
12221         dx_normi=dc_norm(1,i)
12222         dy_normi=dc_norm(2,i)
12223         dz_normi=dc_norm(3,i)
12224         xmedi=c(1,i)+0.5d0*dxi
12225         ymedi=c(2,i)+0.5d0*dyi
12226         zmedi=c(3,i)+0.5d0*dzi
12227         num_conti=num_cont_hb(i)
12228         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
12229         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
12230           call eturn4(i,eello_turn4)
12231         num_cont_hb(i)=num_conti
12232       enddo   ! i
12233 !
12234 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
12235 !
12236       do i=iatel_s,iatel_e
12237         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12238         dxi=dc(1,i)
12239         dyi=dc(2,i)
12240         dzi=dc(3,i)
12241         dx_normi=dc_norm(1,i)
12242         dy_normi=dc_norm(2,i)
12243         dz_normi=dc_norm(3,i)
12244         xmedi=c(1,i)+0.5d0*dxi
12245         ymedi=c(2,i)+0.5d0*dyi
12246         zmedi=c(3,i)+0.5d0*dzi
12247 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
12248         num_conti=num_cont_hb(i)
12249         do j=ielstart(i),ielend(i)
12250           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12251           call eelecij_scale(i,j,ees,evdw1,eel_loc)
12252         enddo ! j
12253         num_cont_hb(i)=num_conti
12254       enddo   ! i
12255 !      write (iout,*) "Number of loop steps in EELEC:",ind
12256 !d      do i=1,nres
12257 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12258 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12259 !d      enddo
12260 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12261 !cc      eel_loc=eel_loc+eello_turn3
12262 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12263       return
12264       end subroutine eelec_scale
12265 !-----------------------------------------------------------------------------
12266       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12267 !      implicit real*8 (a-h,o-z)
12268
12269       use comm_locel
12270 !      include 'DIMENSIONS'
12271 #ifdef MPI
12272       include "mpif.h"
12273 #endif
12274 !      include 'COMMON.CONTROL'
12275 !      include 'COMMON.IOUNITS'
12276 !      include 'COMMON.GEO'
12277 !      include 'COMMON.VAR'
12278 !      include 'COMMON.LOCAL'
12279 !      include 'COMMON.CHAIN'
12280 !      include 'COMMON.DERIV'
12281 !      include 'COMMON.INTERACT'
12282 !      include 'COMMON.CONTACTS'
12283 !      include 'COMMON.TORSION'
12284 !      include 'COMMON.VECTORS'
12285 !      include 'COMMON.FFIELD'
12286 !      include 'COMMON.TIME1'
12287       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12288       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12289       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12290 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12291       real(kind=8),dimension(4) :: muij
12292 !el      integer :: num_conti,j1,j2
12293 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12294 !el                   dz_normi,xmedi,ymedi,zmedi
12295 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12296 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12297 !el          num_conti,j1,j2
12298 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12299 #ifdef MOMENT
12300       real(kind=8) :: scal_el=1.0d0
12301 #else
12302       real(kind=8) :: scal_el=0.5d0
12303 #endif
12304 ! 12/13/98
12305 ! 13-go grudnia roku pamietnego...
12306       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12307                                              0.0d0,1.0d0,0.0d0,&
12308                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12309 !el local variables
12310       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12311       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12312       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12313       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12314       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12315       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12316       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12317                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12318                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12319                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12320                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12321                   ecosam,ecosbm,ecosgm,ghalf,time00
12322 !      integer :: maxconts
12323 !      maxconts = nres/4
12324 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12325 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12326 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12327 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12328 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12329 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12330 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12331 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12332 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12333 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12334 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12335 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12336 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12337
12338 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12339 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12340
12341 #ifdef MPI
12342           time00=MPI_Wtime()
12343 #endif
12344 !d      write (iout,*) "eelecij",i,j
12345 !el          ind=ind+1
12346           iteli=itel(i)
12347           itelj=itel(j)
12348           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12349           aaa=app(iteli,itelj)
12350           bbb=bpp(iteli,itelj)
12351           ael6i=ael6(iteli,itelj)
12352           ael3i=ael3(iteli,itelj)
12353           dxj=dc(1,j)
12354           dyj=dc(2,j)
12355           dzj=dc(3,j)
12356           dx_normj=dc_norm(1,j)
12357           dy_normj=dc_norm(2,j)
12358           dz_normj=dc_norm(3,j)
12359           xj=c(1,j)+0.5D0*dxj-xmedi
12360           yj=c(2,j)+0.5D0*dyj-ymedi
12361           zj=c(3,j)+0.5D0*dzj-zmedi
12362           rij=xj*xj+yj*yj+zj*zj
12363           rrmij=1.0D0/rij
12364           rij=dsqrt(rij)
12365           rmij=1.0D0/rij
12366 ! For extracting the short-range part of Evdwpp
12367           sss=sscale(rij/rpp(iteli,itelj))
12368
12369           r3ij=rrmij*rmij
12370           r6ij=r3ij*r3ij
12371           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12372           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12373           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12374           fac=cosa-3.0D0*cosb*cosg
12375           ev1=aaa*r6ij*r6ij
12376 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12377           if (j.eq.i+2) ev1=scal_el*ev1
12378           ev2=bbb*r6ij
12379           fac3=ael6i*r6ij
12380           fac4=ael3i*r3ij
12381           evdwij=ev1+ev2
12382           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12383           el2=fac4*fac
12384           eesij=el1+el2
12385 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12386           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12387           ees=ees+eesij
12388           evdw1=evdw1+evdwij*(1.0d0-sss)
12389 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12390 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12391 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12392 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12393
12394           if (energy_dec) then
12395               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12396               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12397           endif
12398
12399 !
12400 ! Calculate contributions to the Cartesian gradient.
12401 !
12402 #ifdef SPLITELE
12403           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12404           facel=-3*rrmij*(el1+eesij)
12405           fac1=fac
12406           erij(1)=xj*rmij
12407           erij(2)=yj*rmij
12408           erij(3)=zj*rmij
12409 !
12410 ! Radial derivatives. First process both termini of the fragment (i,j)
12411 !
12412           ggg(1)=facel*xj
12413           ggg(2)=facel*yj
12414           ggg(3)=facel*zj
12415 !          do k=1,3
12416 !            ghalf=0.5D0*ggg(k)
12417 !            gelc(k,i)=gelc(k,i)+ghalf
12418 !            gelc(k,j)=gelc(k,j)+ghalf
12419 !          enddo
12420 ! 9/28/08 AL Gradient compotents will be summed only at the end
12421           do k=1,3
12422             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12423             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12424           enddo
12425 !
12426 ! Loop over residues i+1 thru j-1.
12427 !
12428 !grad          do k=i+1,j-1
12429 !grad            do l=1,3
12430 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12431 !grad            enddo
12432 !grad          enddo
12433           ggg(1)=facvdw*xj
12434           ggg(2)=facvdw*yj
12435           ggg(3)=facvdw*zj
12436 !          do k=1,3
12437 !            ghalf=0.5D0*ggg(k)
12438 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12439 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12440 !          enddo
12441 ! 9/28/08 AL Gradient compotents will be summed only at the end
12442           do k=1,3
12443             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12444             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12445           enddo
12446 !
12447 ! Loop over residues i+1 thru j-1.
12448 !
12449 !grad          do k=i+1,j-1
12450 !grad            do l=1,3
12451 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12452 !grad            enddo
12453 !grad          enddo
12454 #else
12455           facvdw=ev1+evdwij*(1.0d0-sss)
12456           facel=el1+eesij
12457           fac1=fac
12458           fac=-3*rrmij*(facvdw+facvdw+facel)
12459           erij(1)=xj*rmij
12460           erij(2)=yj*rmij
12461           erij(3)=zj*rmij
12462 !
12463 ! Radial derivatives. First process both termini of the fragment (i,j)
12464 !
12465           ggg(1)=fac*xj
12466           ggg(2)=fac*yj
12467           ggg(3)=fac*zj
12468 !          do k=1,3
12469 !            ghalf=0.5D0*ggg(k)
12470 !            gelc(k,i)=gelc(k,i)+ghalf
12471 !            gelc(k,j)=gelc(k,j)+ghalf
12472 !          enddo
12473 ! 9/28/08 AL Gradient compotents will be summed only at the end
12474           do k=1,3
12475             gelc_long(k,j)=gelc(k,j)+ggg(k)
12476             gelc_long(k,i)=gelc(k,i)-ggg(k)
12477           enddo
12478 !
12479 ! Loop over residues i+1 thru j-1.
12480 !
12481 !grad          do k=i+1,j-1
12482 !grad            do l=1,3
12483 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12484 !grad            enddo
12485 !grad          enddo
12486 ! 9/28/08 AL Gradient compotents will be summed only at the end
12487           ggg(1)=facvdw*xj
12488           ggg(2)=facvdw*yj
12489           ggg(3)=facvdw*zj
12490           do k=1,3
12491             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12492             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12493           enddo
12494 #endif
12495 !
12496 ! Angular part
12497 !
12498           ecosa=2.0D0*fac3*fac1+fac4
12499           fac4=-3.0D0*fac4
12500           fac3=-6.0D0*fac3
12501           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12502           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12503           do k=1,3
12504             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12505             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12506           enddo
12507 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12508 !d   &          (dcosg(k),k=1,3)
12509           do k=1,3
12510             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12511           enddo
12512 !          do k=1,3
12513 !            ghalf=0.5D0*ggg(k)
12514 !            gelc(k,i)=gelc(k,i)+ghalf
12515 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12516 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12517 !            gelc(k,j)=gelc(k,j)+ghalf
12518 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12519 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12520 !          enddo
12521 !grad          do k=i+1,j-1
12522 !grad            do l=1,3
12523 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12524 !grad            enddo
12525 !grad          enddo
12526           do k=1,3
12527             gelc(k,i)=gelc(k,i) &
12528                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12529                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12530             gelc(k,j)=gelc(k,j) &
12531                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12532                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12533             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12534             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12535           enddo
12536           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12537               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12538               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12539 !
12540 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12541 !   energy of a peptide unit is assumed in the form of a second-order
12542 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12543 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12544 !   are computed for EVERY pair of non-contiguous peptide groups.
12545 !
12546           if (j.lt.nres-1) then
12547             j1=j+1
12548             j2=j-1
12549           else
12550             j1=j-1
12551             j2=j-2
12552           endif
12553           kkk=0
12554           do k=1,2
12555             do l=1,2
12556               kkk=kkk+1
12557               muij(kkk)=mu(k,i)*mu(l,j)
12558             enddo
12559           enddo
12560 !d         write (iout,*) 'EELEC: i',i,' j',j
12561 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12562 !d          write(iout,*) 'muij',muij
12563           ury=scalar(uy(1,i),erij)
12564           urz=scalar(uz(1,i),erij)
12565           vry=scalar(uy(1,j),erij)
12566           vrz=scalar(uz(1,j),erij)
12567           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12568           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12569           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12570           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12571           fac=dsqrt(-ael6i)*r3ij
12572           a22=a22*fac
12573           a23=a23*fac
12574           a32=a32*fac
12575           a33=a33*fac
12576 !d          write (iout,'(4i5,4f10.5)')
12577 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12578 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12579 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12580 !d     &      uy(:,j),uz(:,j)
12581 !d          write (iout,'(4f10.5)')
12582 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12583 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12584 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12585 !d           write (iout,'(9f10.5/)')
12586 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12587 ! Derivatives of the elements of A in virtual-bond vectors
12588           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12589           do k=1,3
12590             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12591             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12592             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12593             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12594             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12595             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12596             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12597             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12598             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12599             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12600             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12601             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12602           enddo
12603 ! Compute radial contributions to the gradient
12604           facr=-3.0d0*rrmij
12605           a22der=a22*facr
12606           a23der=a23*facr
12607           a32der=a32*facr
12608           a33der=a33*facr
12609           agg(1,1)=a22der*xj
12610           agg(2,1)=a22der*yj
12611           agg(3,1)=a22der*zj
12612           agg(1,2)=a23der*xj
12613           agg(2,2)=a23der*yj
12614           agg(3,2)=a23der*zj
12615           agg(1,3)=a32der*xj
12616           agg(2,3)=a32der*yj
12617           agg(3,3)=a32der*zj
12618           agg(1,4)=a33der*xj
12619           agg(2,4)=a33der*yj
12620           agg(3,4)=a33der*zj
12621 ! Add the contributions coming from er
12622           fac3=-3.0d0*fac
12623           do k=1,3
12624             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12625             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12626             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12627             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12628           enddo
12629           do k=1,3
12630 ! Derivatives in DC(i)
12631 !grad            ghalf1=0.5d0*agg(k,1)
12632 !grad            ghalf2=0.5d0*agg(k,2)
12633 !grad            ghalf3=0.5d0*agg(k,3)
12634 !grad            ghalf4=0.5d0*agg(k,4)
12635             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12636             -3.0d0*uryg(k,2)*vry)!+ghalf1
12637             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12638             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12639             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12640             -3.0d0*urzg(k,2)*vry)!+ghalf3
12641             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12642             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12643 ! Derivatives in DC(i+1)
12644             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12645             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12646             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12647             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12648             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
12649             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
12650             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
12651             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
12652 ! Derivatives in DC(j)
12653             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
12654             -3.0d0*vryg(k,2)*ury)!+ghalf1
12655             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
12656             -3.0d0*vrzg(k,2)*ury)!+ghalf2
12657             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
12658             -3.0d0*vryg(k,2)*urz)!+ghalf3
12659             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
12660             -3.0d0*vrzg(k,2)*urz)!+ghalf4
12661 ! Derivatives in DC(j+1) or DC(nres-1)
12662             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
12663             -3.0d0*vryg(k,3)*ury)
12664             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
12665             -3.0d0*vrzg(k,3)*ury)
12666             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
12667             -3.0d0*vryg(k,3)*urz)
12668             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
12669             -3.0d0*vrzg(k,3)*urz)
12670 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
12671 !grad              do l=1,4
12672 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
12673 !grad              enddo
12674 !grad            endif
12675           enddo
12676           acipa(1,1)=a22
12677           acipa(1,2)=a23
12678           acipa(2,1)=a32
12679           acipa(2,2)=a33
12680           a22=-a22
12681           a23=-a23
12682           do l=1,2
12683             do k=1,3
12684               agg(k,l)=-agg(k,l)
12685               aggi(k,l)=-aggi(k,l)
12686               aggi1(k,l)=-aggi1(k,l)
12687               aggj(k,l)=-aggj(k,l)
12688               aggj1(k,l)=-aggj1(k,l)
12689             enddo
12690           enddo
12691           if (j.lt.nres-1) then
12692             a22=-a22
12693             a32=-a32
12694             do l=1,3,2
12695               do k=1,3
12696                 agg(k,l)=-agg(k,l)
12697                 aggi(k,l)=-aggi(k,l)
12698                 aggi1(k,l)=-aggi1(k,l)
12699                 aggj(k,l)=-aggj(k,l)
12700                 aggj1(k,l)=-aggj1(k,l)
12701               enddo
12702             enddo
12703           else
12704             a22=-a22
12705             a23=-a23
12706             a32=-a32
12707             a33=-a33
12708             do l=1,4
12709               do k=1,3
12710                 agg(k,l)=-agg(k,l)
12711                 aggi(k,l)=-aggi(k,l)
12712                 aggi1(k,l)=-aggi1(k,l)
12713                 aggj(k,l)=-aggj(k,l)
12714                 aggj1(k,l)=-aggj1(k,l)
12715               enddo
12716             enddo
12717           endif
12718           ENDIF ! WCORR
12719           IF (wel_loc.gt.0.0d0) THEN
12720 ! Contribution to the local-electrostatic energy coming from the i-j pair
12721           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
12722            +a33*muij(4)
12723 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
12724
12725           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12726                   'eelloc',i,j,eel_loc_ij
12727 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
12728
12729           eel_loc=eel_loc+eel_loc_ij
12730 ! Partial derivatives in virtual-bond dihedral angles gamma
12731           if (i.gt.1) &
12732           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
12733                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
12734                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
12735           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
12736                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
12737                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
12738 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
12739           do l=1,3
12740             ggg(l)=agg(l,1)*muij(1)+ &
12741                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
12742             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
12743             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
12744 !grad            ghalf=0.5d0*ggg(l)
12745 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
12746 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
12747           enddo
12748 !grad          do k=i+1,j2
12749 !grad            do l=1,3
12750 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
12751 !grad            enddo
12752 !grad          enddo
12753 ! Remaining derivatives of eello
12754           do l=1,3
12755             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
12756                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
12757             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
12758                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
12759             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
12760                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
12761             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
12762                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
12763           enddo
12764           ENDIF
12765 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
12766 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
12767           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
12768              .and. num_conti.le.maxconts) then
12769 !            write (iout,*) i,j," entered corr"
12770 !
12771 ! Calculate the contact function. The ith column of the array JCONT will
12772 ! contain the numbers of atoms that make contacts with the atom I (of numbers
12773 ! greater than I). The arrays FACONT and GACONT will contain the values of
12774 ! the contact function and its derivative.
12775 !           r0ij=1.02D0*rpp(iteli,itelj)
12776 !           r0ij=1.11D0*rpp(iteli,itelj)
12777             r0ij=2.20D0*rpp(iteli,itelj)
12778 !           r0ij=1.55D0*rpp(iteli,itelj)
12779             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
12780 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12781             if (fcont.gt.0.0D0) then
12782               num_conti=num_conti+1
12783               if (num_conti.gt.maxconts) then
12784 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12785                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
12786                                ' will skip next contacts for this conf.',num_conti
12787               else
12788                 jcont_hb(num_conti,i)=j
12789 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
12790 !d     &           " jcont_hb",jcont_hb(num_conti,i)
12791                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
12792                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12793 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
12794 !  terms.
12795                 d_cont(num_conti,i)=rij
12796 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
12797 !     --- Electrostatic-interaction matrix ---
12798                 a_chuj(1,1,num_conti,i)=a22
12799                 a_chuj(1,2,num_conti,i)=a23
12800                 a_chuj(2,1,num_conti,i)=a32
12801                 a_chuj(2,2,num_conti,i)=a33
12802 !     --- Gradient of rij
12803                 do kkk=1,3
12804                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
12805                 enddo
12806                 kkll=0
12807                 do k=1,2
12808                   do l=1,2
12809                     kkll=kkll+1
12810                     do m=1,3
12811                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
12812                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
12813                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
12814                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
12815                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
12816                     enddo
12817                   enddo
12818                 enddo
12819                 ENDIF
12820                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
12821 ! Calculate contact energies
12822                 cosa4=4.0D0*cosa
12823                 wij=cosa-3.0D0*cosb*cosg
12824                 cosbg1=cosb+cosg
12825                 cosbg2=cosb-cosg
12826 !               fac3=dsqrt(-ael6i)/r0ij**3
12827                 fac3=dsqrt(-ael6i)*r3ij
12828 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
12829                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
12830                 if (ees0tmp.gt.0) then
12831                   ees0pij=dsqrt(ees0tmp)
12832                 else
12833                   ees0pij=0
12834                 endif
12835 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
12836                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
12837                 if (ees0tmp.gt.0) then
12838                   ees0mij=dsqrt(ees0tmp)
12839                 else
12840                   ees0mij=0
12841                 endif
12842 !               ees0mij=0.0D0
12843                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
12844                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
12845 ! Diagnostics. Comment out or remove after debugging!
12846 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
12847 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
12848 !               ees0m(num_conti,i)=0.0D0
12849 ! End diagnostics.
12850 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
12851 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
12852 ! Angular derivatives of the contact function
12853                 ees0pij1=fac3/ees0pij
12854                 ees0mij1=fac3/ees0mij
12855                 fac3p=-3.0D0*fac3*rrmij
12856                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
12857                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
12858 !               ees0mij1=0.0D0
12859                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
12860                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
12861                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
12862                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
12863                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
12864                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
12865                 ecosap=ecosa1+ecosa2
12866                 ecosbp=ecosb1+ecosb2
12867                 ecosgp=ecosg1+ecosg2
12868                 ecosam=ecosa1-ecosa2
12869                 ecosbm=ecosb1-ecosb2
12870                 ecosgm=ecosg1-ecosg2
12871 ! Diagnostics
12872 !               ecosap=ecosa1
12873 !               ecosbp=ecosb1
12874 !               ecosgp=ecosg1
12875 !               ecosam=0.0D0
12876 !               ecosbm=0.0D0
12877 !               ecosgm=0.0D0
12878 ! End diagnostics
12879                 facont_hb(num_conti,i)=fcont
12880                 fprimcont=fprimcont/rij
12881 !d              facont_hb(num_conti,i)=1.0D0
12882 ! Following line is for diagnostics.
12883 !d              fprimcont=0.0D0
12884                 do k=1,3
12885                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12886                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12887                 enddo
12888                 do k=1,3
12889                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
12890                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
12891                 enddo
12892                 gggp(1)=gggp(1)+ees0pijp*xj
12893                 gggp(2)=gggp(2)+ees0pijp*yj
12894                 gggp(3)=gggp(3)+ees0pijp*zj
12895                 gggm(1)=gggm(1)+ees0mijp*xj
12896                 gggm(2)=gggm(2)+ees0mijp*yj
12897                 gggm(3)=gggm(3)+ees0mijp*zj
12898 ! Derivatives due to the contact function
12899                 gacont_hbr(1,num_conti,i)=fprimcont*xj
12900                 gacont_hbr(2,num_conti,i)=fprimcont*yj
12901                 gacont_hbr(3,num_conti,i)=fprimcont*zj
12902                 do k=1,3
12903 !
12904 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
12905 !          following the change of gradient-summation algorithm.
12906 !
12907 !grad                  ghalfp=0.5D0*gggp(k)
12908 !grad                  ghalfm=0.5D0*gggm(k)
12909                   gacontp_hb1(k,num_conti,i)= & !ghalfp
12910                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12911                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12912                   gacontp_hb2(k,num_conti,i)= & !ghalfp
12913                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12914                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12915                   gacontp_hb3(k,num_conti,i)=gggp(k)
12916                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
12917                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12918                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12919                   gacontm_hb2(k,num_conti,i)= & !ghalfm
12920                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12921                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12922                   gacontm_hb3(k,num_conti,i)=gggm(k)
12923                 enddo
12924               ENDIF ! wcorr
12925               endif  ! num_conti.le.maxconts
12926             endif  ! fcont.gt.0
12927           endif    ! j.gt.i+1
12928           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
12929             do k=1,4
12930               do l=1,3
12931                 ghalf=0.5d0*agg(l,k)
12932                 aggi(l,k)=aggi(l,k)+ghalf
12933                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
12934                 aggj(l,k)=aggj(l,k)+ghalf
12935               enddo
12936             enddo
12937             if (j.eq.nres-1 .and. i.lt.j-2) then
12938               do k=1,4
12939                 do l=1,3
12940                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
12941                 enddo
12942               enddo
12943             endif
12944           endif
12945 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
12946       return
12947       end subroutine eelecij_scale
12948 !-----------------------------------------------------------------------------
12949       subroutine evdwpp_short(evdw1)
12950 !
12951 ! Compute Evdwpp
12952 !
12953 !      implicit real*8 (a-h,o-z)
12954 !      include 'DIMENSIONS'
12955 !      include 'COMMON.CONTROL'
12956 !      include 'COMMON.IOUNITS'
12957 !      include 'COMMON.GEO'
12958 !      include 'COMMON.VAR'
12959 !      include 'COMMON.LOCAL'
12960 !      include 'COMMON.CHAIN'
12961 !      include 'COMMON.DERIV'
12962 !      include 'COMMON.INTERACT'
12963 !      include 'COMMON.CONTACTS'
12964 !      include 'COMMON.TORSION'
12965 !      include 'COMMON.VECTORS'
12966 !      include 'COMMON.FFIELD'
12967       real(kind=8),dimension(3) :: ggg
12968 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12969 #ifdef MOMENT
12970       real(kind=8) :: scal_el=1.0d0
12971 #else
12972       real(kind=8) :: scal_el=0.5d0
12973 #endif
12974 !el local variables
12975       integer :: i,j,k,iteli,itelj,num_conti
12976       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
12977       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
12978                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12979                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
12980
12981       evdw1=0.0D0
12982 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
12983 !     & " iatel_e_vdw",iatel_e_vdw
12984       call flush(iout)
12985       do i=iatel_s_vdw,iatel_e_vdw
12986         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
12987         dxi=dc(1,i)
12988         dyi=dc(2,i)
12989         dzi=dc(3,i)
12990         dx_normi=dc_norm(1,i)
12991         dy_normi=dc_norm(2,i)
12992         dz_normi=dc_norm(3,i)
12993         xmedi=c(1,i)+0.5d0*dxi
12994         ymedi=c(2,i)+0.5d0*dyi
12995         zmedi=c(3,i)+0.5d0*dzi
12996         num_conti=0
12997 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
12998 !     &   ' ielend',ielend_vdw(i)
12999         call flush(iout)
13000         do j=ielstart_vdw(i),ielend_vdw(i)
13001           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13002 !el          ind=ind+1
13003           iteli=itel(i)
13004           itelj=itel(j)
13005           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13006           aaa=app(iteli,itelj)
13007           bbb=bpp(iteli,itelj)
13008           dxj=dc(1,j)
13009           dyj=dc(2,j)
13010           dzj=dc(3,j)
13011           dx_normj=dc_norm(1,j)
13012           dy_normj=dc_norm(2,j)
13013           dz_normj=dc_norm(3,j)
13014           xj=c(1,j)+0.5D0*dxj-xmedi
13015           yj=c(2,j)+0.5D0*dyj-ymedi
13016           zj=c(3,j)+0.5D0*dzj-zmedi
13017           rij=xj*xj+yj*yj+zj*zj
13018           rrmij=1.0D0/rij
13019           rij=dsqrt(rij)
13020           sss=sscale(rij/rpp(iteli,itelj))
13021           if (sss.gt.0.0d0) then
13022             rmij=1.0D0/rij
13023             r3ij=rrmij*rmij
13024             r6ij=r3ij*r3ij
13025             ev1=aaa*r6ij*r6ij
13026 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13027             if (j.eq.i+2) ev1=scal_el*ev1
13028             ev2=bbb*r6ij
13029             evdwij=ev1+ev2
13030             if (energy_dec) then
13031               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13032             endif
13033             evdw1=evdw1+evdwij*sss
13034 !
13035 ! Calculate contributions to the Cartesian gradient.
13036 !
13037             facvdw=-6*rrmij*(ev1+evdwij)*sss
13038             ggg(1)=facvdw*xj
13039             ggg(2)=facvdw*yj
13040             ggg(3)=facvdw*zj
13041             do k=1,3
13042               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13043               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13044             enddo
13045           endif
13046         enddo ! j
13047       enddo   ! i
13048       return
13049       end subroutine evdwpp_short
13050 !-----------------------------------------------------------------------------
13051       subroutine escp_long(evdw2,evdw2_14)
13052 !
13053 ! This subroutine calculates the excluded-volume interaction energy between
13054 ! peptide-group centers and side chains and its gradient in virtual-bond and
13055 ! side-chain vectors.
13056 !
13057 !      implicit real*8 (a-h,o-z)
13058 !      include 'DIMENSIONS'
13059 !      include 'COMMON.GEO'
13060 !      include 'COMMON.VAR'
13061 !      include 'COMMON.LOCAL'
13062 !      include 'COMMON.CHAIN'
13063 !      include 'COMMON.DERIV'
13064 !      include 'COMMON.INTERACT'
13065 !      include 'COMMON.FFIELD'
13066 !      include 'COMMON.IOUNITS'
13067 !      include 'COMMON.CONTROL'
13068       real(kind=8),dimension(3) :: ggg
13069 !el local variables
13070       integer :: i,iint,j,k,iteli,itypj
13071       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13072       real(kind=8) :: evdw2,evdw2_14,evdwij
13073       evdw2=0.0D0
13074       evdw2_14=0.0d0
13075 !d    print '(a)','Enter ESCP'
13076 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13077       do i=iatscp_s,iatscp_e
13078         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13079         iteli=itel(i)
13080         xi=0.5D0*(c(1,i)+c(1,i+1))
13081         yi=0.5D0*(c(2,i)+c(2,i+1))
13082         zi=0.5D0*(c(3,i)+c(3,i+1))
13083
13084         do iint=1,nscp_gr(i)
13085
13086         do j=iscpstart(i,iint),iscpend(i,iint)
13087           itypj=itype(j)
13088           if (itypj.eq.ntyp1) cycle
13089 ! Uncomment following three lines for SC-p interactions
13090 !         xj=c(1,nres+j)-xi
13091 !         yj=c(2,nres+j)-yi
13092 !         zj=c(3,nres+j)-zi
13093 ! Uncomment following three lines for Ca-p interactions
13094           xj=c(1,j)-xi
13095           yj=c(2,j)-yi
13096           zj=c(3,j)-zi
13097           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13098
13099           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13100
13101           if (sss.lt.1.0d0) then
13102
13103             fac=rrij**expon2
13104             e1=fac*fac*aad(itypj,iteli)
13105             e2=fac*bad(itypj,iteli)
13106             if (iabs(j-i) .le. 2) then
13107               e1=scal14*e1
13108               e2=scal14*e2
13109               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
13110             endif
13111             evdwij=e1+e2
13112             evdw2=evdw2+evdwij*(1.0d0-sss)
13113             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13114                 'evdw2',i,j,sss,evdwij
13115 !
13116 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13117 !
13118             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
13119             ggg(1)=xj*fac
13120             ggg(2)=yj*fac
13121             ggg(3)=zj*fac
13122 ! Uncomment following three lines for SC-p interactions
13123 !           do k=1,3
13124 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13125 !           enddo
13126 ! Uncomment following line for SC-p interactions
13127 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13128             do k=1,3
13129               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13130               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13131             enddo
13132           endif
13133         enddo
13134
13135         enddo ! iint
13136       enddo ! i
13137       do i=1,nct
13138         do j=1,3
13139           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13140           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13141           gradx_scp(j,i)=expon*gradx_scp(j,i)
13142         enddo
13143       enddo
13144 !******************************************************************************
13145 !
13146 !                              N O T E !!!
13147 !
13148 ! To save time the factor EXPON has been extracted from ALL components
13149 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13150 ! use!
13151 !
13152 !******************************************************************************
13153       return
13154       end subroutine escp_long
13155 !-----------------------------------------------------------------------------
13156       subroutine escp_short(evdw2,evdw2_14)
13157 !
13158 ! This subroutine calculates the excluded-volume interaction energy between
13159 ! peptide-group centers and side chains and its gradient in virtual-bond and
13160 ! side-chain vectors.
13161 !
13162 !      implicit real*8 (a-h,o-z)
13163 !      include 'DIMENSIONS'
13164 !      include 'COMMON.GEO'
13165 !      include 'COMMON.VAR'
13166 !      include 'COMMON.LOCAL'
13167 !      include 'COMMON.CHAIN'
13168 !      include 'COMMON.DERIV'
13169 !      include 'COMMON.INTERACT'
13170 !      include 'COMMON.FFIELD'
13171 !      include 'COMMON.IOUNITS'
13172 !      include 'COMMON.CONTROL'
13173       real(kind=8),dimension(3) :: ggg
13174 !el local variables
13175       integer :: i,iint,j,k,iteli,itypj
13176       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13177       real(kind=8) :: evdw2,evdw2_14,evdwij
13178       evdw2=0.0D0
13179       evdw2_14=0.0d0
13180 !d    print '(a)','Enter ESCP'
13181 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13182       do i=iatscp_s,iatscp_e
13183         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13184         iteli=itel(i)
13185         xi=0.5D0*(c(1,i)+c(1,i+1))
13186         yi=0.5D0*(c(2,i)+c(2,i+1))
13187         zi=0.5D0*(c(3,i)+c(3,i+1))
13188
13189         do iint=1,nscp_gr(i)
13190
13191         do j=iscpstart(i,iint),iscpend(i,iint)
13192           itypj=itype(j)
13193           if (itypj.eq.ntyp1) cycle
13194 ! Uncomment following three lines for SC-p interactions
13195 !         xj=c(1,nres+j)-xi
13196 !         yj=c(2,nres+j)-yi
13197 !         zj=c(3,nres+j)-zi
13198 ! Uncomment following three lines for Ca-p interactions
13199           xj=c(1,j)-xi
13200           yj=c(2,j)-yi
13201           zj=c(3,j)-zi
13202           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13203
13204           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13205
13206           if (sss.gt.0.0d0) then
13207
13208             fac=rrij**expon2
13209             e1=fac*fac*aad(itypj,iteli)
13210             e2=fac*bad(itypj,iteli)
13211             if (iabs(j-i) .le. 2) then
13212               e1=scal14*e1
13213               e2=scal14*e2
13214               evdw2_14=evdw2_14+(e1+e2)*sss
13215             endif
13216             evdwij=e1+e2
13217             evdw2=evdw2+evdwij*sss
13218             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13219                 'evdw2',i,j,sss,evdwij
13220 !
13221 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13222 !
13223             fac=-(evdwij+e1)*rrij*sss
13224             ggg(1)=xj*fac
13225             ggg(2)=yj*fac
13226             ggg(3)=zj*fac
13227 ! Uncomment following three lines for SC-p interactions
13228 !           do k=1,3
13229 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13230 !           enddo
13231 ! Uncomment following line for SC-p interactions
13232 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13233             do k=1,3
13234               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13235               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13236             enddo
13237           endif
13238         enddo
13239
13240         enddo ! iint
13241       enddo ! i
13242       do i=1,nct
13243         do j=1,3
13244           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13245           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13246           gradx_scp(j,i)=expon*gradx_scp(j,i)
13247         enddo
13248       enddo
13249 !******************************************************************************
13250 !
13251 !                              N O T E !!!
13252 !
13253 ! To save time the factor EXPON has been extracted from ALL components
13254 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13255 ! use!
13256 !
13257 !******************************************************************************
13258       return
13259       end subroutine escp_short
13260 !-----------------------------------------------------------------------------
13261 ! energy_p_new-sep_barrier.F
13262 !-----------------------------------------------------------------------------
13263       subroutine sc_grad_scale(scalfac)
13264 !      implicit real*8 (a-h,o-z)
13265       use calc_data
13266 !      include 'DIMENSIONS'
13267 !      include 'COMMON.CHAIN'
13268 !      include 'COMMON.DERIV'
13269 !      include 'COMMON.CALC'
13270 !      include 'COMMON.IOUNITS'
13271       real(kind=8),dimension(3) :: dcosom1,dcosom2
13272       real(kind=8) :: scalfac
13273 !el local variables
13274 !      integer :: i,j,k,l
13275
13276       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13277       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13278       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13279            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13280 ! diagnostics only
13281 !      eom1=0.0d0
13282 !      eom2=0.0d0
13283 !      eom12=evdwij*eps1_om12
13284 ! end diagnostics
13285 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13286 !     &  " sigder",sigder
13287 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13288 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13289       do k=1,3
13290         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13291         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13292       enddo
13293       do k=1,3
13294         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac
13295       enddo
13296 !      write (iout,*) "gg",(gg(k),k=1,3)
13297       do k=1,3
13298         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13299                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13300                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac
13301         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13302                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13303                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac
13304 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13305 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13306 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13307 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13308       enddo
13309 !
13310 ! Calculate the components of the gradient in DC and X
13311 !
13312       do l=1,3
13313         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13314         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13315       enddo
13316       return
13317       end subroutine sc_grad_scale
13318 !-----------------------------------------------------------------------------
13319 ! energy_split-sep.F
13320 !-----------------------------------------------------------------------------
13321       subroutine etotal_long(energia)
13322 !
13323 ! Compute the long-range slow-varying contributions to the energy
13324 !
13325 !      implicit real*8 (a-h,o-z)
13326 !      include 'DIMENSIONS'
13327       use MD_data, only: totT,usampl,eq_time
13328 #ifndef ISNAN
13329       external proc_proc
13330 #ifdef WINPGI
13331 !MS$ATTRIBUTES C ::  proc_proc
13332 #endif
13333 #endif
13334 #ifdef MPI
13335       include "mpif.h"
13336       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13337 #endif
13338 !      include 'COMMON.SETUP'
13339 !      include 'COMMON.IOUNITS'
13340 !      include 'COMMON.FFIELD'
13341 !      include 'COMMON.DERIV'
13342 !      include 'COMMON.INTERACT'
13343 !      include 'COMMON.SBRIDGE'
13344 !      include 'COMMON.CHAIN'
13345 !      include 'COMMON.VAR'
13346 !      include 'COMMON.LOCAL'
13347 !      include 'COMMON.MD'
13348       real(kind=8),dimension(0:n_ene) :: energia
13349 !el local variables
13350       integer :: i,n_corr,n_corr1,ierror,ierr
13351       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13352                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13353                   ecorr,ecorr5,ecorr6,eturn6,time00
13354 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13355 !elwrite(iout,*)"in etotal long"
13356
13357       if (modecalc.eq.12.or.modecalc.eq.14) then
13358 #ifdef MPI
13359 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13360 #else
13361         call int_from_cart1(.false.)
13362 #endif
13363       endif
13364 !elwrite(iout,*)"in etotal long"
13365
13366 #ifdef MPI
13367 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13368 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13369       call flush(iout)
13370       if (nfgtasks.gt.1) then
13371         time00=MPI_Wtime()
13372 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13373         if (fg_rank.eq.0) then
13374           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13375 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13376 !          call flush(iout)
13377 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13378 ! FG slaves as WEIGHTS array.
13379           weights_(1)=wsc
13380           weights_(2)=wscp
13381           weights_(3)=welec
13382           weights_(4)=wcorr
13383           weights_(5)=wcorr5
13384           weights_(6)=wcorr6
13385           weights_(7)=wel_loc
13386           weights_(8)=wturn3
13387           weights_(9)=wturn4
13388           weights_(10)=wturn6
13389           weights_(11)=wang
13390           weights_(12)=wscloc
13391           weights_(13)=wtor
13392           weights_(14)=wtor_d
13393           weights_(15)=wstrain
13394           weights_(16)=wvdwpp
13395           weights_(17)=wbond
13396           weights_(18)=scal14
13397           weights_(21)=wsccor
13398 ! FG Master broadcasts the WEIGHTS_ array
13399           call MPI_Bcast(weights_(1),n_ene,&
13400               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13401         else
13402 ! FG slaves receive the WEIGHTS array
13403           call MPI_Bcast(weights(1),n_ene,&
13404               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13405           wsc=weights(1)
13406           wscp=weights(2)
13407           welec=weights(3)
13408           wcorr=weights(4)
13409           wcorr5=weights(5)
13410           wcorr6=weights(6)
13411           wel_loc=weights(7)
13412           wturn3=weights(8)
13413           wturn4=weights(9)
13414           wturn6=weights(10)
13415           wang=weights(11)
13416           wscloc=weights(12)
13417           wtor=weights(13)
13418           wtor_d=weights(14)
13419           wstrain=weights(15)
13420           wvdwpp=weights(16)
13421           wbond=weights(17)
13422           scal14=weights(18)
13423           wsccor=weights(21)
13424         endif
13425         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13426           king,FG_COMM,IERR)
13427          time_Bcast=time_Bcast+MPI_Wtime()-time00
13428          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13429 !        call chainbuild_cart
13430 !        call int_from_cart1(.false.)
13431       endif
13432 !      write (iout,*) 'Processor',myrank,
13433 !     &  ' calling etotal_short ipot=',ipot
13434 !      call flush(iout)
13435 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13436 #endif
13437 !d    print *,'nnt=',nnt,' nct=',nct
13438 !
13439 !elwrite(iout,*)"in etotal long"
13440 ! Compute the side-chain and electrostatic interaction energy
13441 !
13442       goto (101,102,103,104,105,106) ipot
13443 ! Lennard-Jones potential.
13444   101 call elj_long(evdw)
13445 !d    print '(a)','Exit ELJ'
13446       goto 107
13447 ! Lennard-Jones-Kihara potential (shifted).
13448   102 call eljk_long(evdw)
13449       goto 107
13450 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13451   103 call ebp_long(evdw)
13452       goto 107
13453 ! Gay-Berne potential (shifted LJ, angular dependence).
13454   104 call egb_long(evdw)
13455       goto 107
13456 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13457   105 call egbv_long(evdw)
13458       goto 107
13459 ! Soft-sphere potential
13460   106 call e_softsphere(evdw)
13461 !
13462 ! Calculate electrostatic (H-bonding) energy of the main chain.
13463 !
13464   107 continue
13465       call vec_and_deriv
13466       if (ipot.lt.6) then
13467 #ifdef SPLITELE
13468          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13469              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13470              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13471              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13472 #else
13473          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13474              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13475              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13476              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13477 #endif
13478            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13479          else
13480             ees=0
13481             evdw1=0
13482             eel_loc=0
13483             eello_turn3=0
13484             eello_turn4=0
13485          endif
13486       else
13487 !        write (iout,*) "Soft-spheer ELEC potential"
13488         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13489          eello_turn4)
13490       endif
13491 !
13492 ! Calculate excluded-volume interaction energy between peptide groups
13493 ! and side chains.
13494 !
13495       if (ipot.lt.6) then
13496        if(wscp.gt.0d0) then
13497         call escp_long(evdw2,evdw2_14)
13498        else
13499         evdw2=0
13500         evdw2_14=0
13501        endif
13502       else
13503         call escp_soft_sphere(evdw2,evdw2_14)
13504       endif
13505 !
13506 ! 12/1/95 Multi-body terms
13507 !
13508       n_corr=0
13509       n_corr1=0
13510       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13511           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13512          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13513 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13514 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13515       else
13516          ecorr=0.0d0
13517          ecorr5=0.0d0
13518          ecorr6=0.0d0
13519          eturn6=0.0d0
13520       endif
13521       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13522          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13523       endif
13524 !
13525 ! If performing constraint dynamics, call the constraint energy
13526 !  after the equilibration time
13527       if(usampl.and.totT.gt.eq_time) then
13528          call EconstrQ
13529          call Econstr_back
13530       else
13531          Uconst=0.0d0
13532          Uconst_back=0.0d0
13533       endif
13534 !
13535 ! Sum the energies
13536 !
13537       do i=1,n_ene
13538         energia(i)=0.0d0
13539       enddo
13540       energia(1)=evdw
13541 #ifdef SCP14
13542       energia(2)=evdw2-evdw2_14
13543       energia(18)=evdw2_14
13544 #else
13545       energia(2)=evdw2
13546       energia(18)=0.0d0
13547 #endif
13548 #ifdef SPLITELE
13549       energia(3)=ees
13550       energia(16)=evdw1
13551 #else
13552       energia(3)=ees+evdw1
13553       energia(16)=0.0d0
13554 #endif
13555       energia(4)=ecorr
13556       energia(5)=ecorr5
13557       energia(6)=ecorr6
13558       energia(7)=eel_loc
13559       energia(8)=eello_turn3
13560       energia(9)=eello_turn4
13561       energia(10)=eturn6
13562       energia(20)=Uconst+Uconst_back
13563       call sum_energy(energia,.true.)
13564 !      write (iout,*) "Exit ETOTAL_LONG"
13565       call flush(iout)
13566       return
13567       end subroutine etotal_long
13568 !-----------------------------------------------------------------------------
13569       subroutine etotal_short(energia)
13570 !
13571 ! Compute the short-range fast-varying contributions to the energy
13572 !
13573 !      implicit real*8 (a-h,o-z)
13574 !      include 'DIMENSIONS'
13575 #ifndef ISNAN
13576       external proc_proc
13577 #ifdef WINPGI
13578 !MS$ATTRIBUTES C ::  proc_proc
13579 #endif
13580 #endif
13581 #ifdef MPI
13582       include "mpif.h"
13583       integer :: ierror,ierr
13584       real(kind=8),dimension(n_ene) :: weights_
13585       real(kind=8) :: time00
13586 #endif
13587 !      include 'COMMON.SETUP'
13588 !      include 'COMMON.IOUNITS'
13589 !      include 'COMMON.FFIELD'
13590 !      include 'COMMON.DERIV'
13591 !      include 'COMMON.INTERACT'
13592 !      include 'COMMON.SBRIDGE'
13593 !      include 'COMMON.CHAIN'
13594 !      include 'COMMON.VAR'
13595 !      include 'COMMON.LOCAL'
13596       real(kind=8),dimension(0:n_ene) :: energia
13597 !el local variables
13598       integer :: i,nres6
13599       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13600       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13601       nres6=6*nres
13602
13603 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13604 !      call flush(iout)
13605       if (modecalc.eq.12.or.modecalc.eq.14) then
13606 #ifdef MPI
13607         if (fg_rank.eq.0) call int_from_cart1(.false.)
13608 #else
13609         call int_from_cart1(.false.)
13610 #endif
13611       endif
13612 #ifdef MPI
13613 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13614 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13615 !      call flush(iout)
13616       if (nfgtasks.gt.1) then
13617         time00=MPI_Wtime()
13618 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13619         if (fg_rank.eq.0) then
13620           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13621 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13622 !          call flush(iout)
13623 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13624 ! FG slaves as WEIGHTS array.
13625           weights_(1)=wsc
13626           weights_(2)=wscp
13627           weights_(3)=welec
13628           weights_(4)=wcorr
13629           weights_(5)=wcorr5
13630           weights_(6)=wcorr6
13631           weights_(7)=wel_loc
13632           weights_(8)=wturn3
13633           weights_(9)=wturn4
13634           weights_(10)=wturn6
13635           weights_(11)=wang
13636           weights_(12)=wscloc
13637           weights_(13)=wtor
13638           weights_(14)=wtor_d
13639           weights_(15)=wstrain
13640           weights_(16)=wvdwpp
13641           weights_(17)=wbond
13642           weights_(18)=scal14
13643           weights_(21)=wsccor
13644 ! FG Master broadcasts the WEIGHTS_ array
13645           call MPI_Bcast(weights_(1),n_ene,&
13646               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13647         else
13648 ! FG slaves receive the WEIGHTS array
13649           call MPI_Bcast(weights(1),n_ene,&
13650               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13651           wsc=weights(1)
13652           wscp=weights(2)
13653           welec=weights(3)
13654           wcorr=weights(4)
13655           wcorr5=weights(5)
13656           wcorr6=weights(6)
13657           wel_loc=weights(7)
13658           wturn3=weights(8)
13659           wturn4=weights(9)
13660           wturn6=weights(10)
13661           wang=weights(11)
13662           wscloc=weights(12)
13663           wtor=weights(13)
13664           wtor_d=weights(14)
13665           wstrain=weights(15)
13666           wvdwpp=weights(16)
13667           wbond=weights(17)
13668           scal14=weights(18)
13669           wsccor=weights(21)
13670         endif
13671 !        write (iout,*),"Processor",myrank," BROADCAST weights"
13672         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
13673           king,FG_COMM,IERR)
13674 !        write (iout,*) "Processor",myrank," BROADCAST c"
13675         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
13676           king,FG_COMM,IERR)
13677 !        write (iout,*) "Processor",myrank," BROADCAST dc"
13678         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
13679           king,FG_COMM,IERR)
13680 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
13681         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
13682           king,FG_COMM,IERR)
13683 !        write (iout,*) "Processor",myrank," BROADCAST theta"
13684         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
13685           king,FG_COMM,IERR)
13686 !        write (iout,*) "Processor",myrank," BROADCAST phi"
13687         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
13688           king,FG_COMM,IERR)
13689 !        write (iout,*) "Processor",myrank," BROADCAST alph"
13690         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
13691           king,FG_COMM,IERR)
13692 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
13693         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
13694           king,FG_COMM,IERR)
13695 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
13696         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
13697           king,FG_COMM,IERR)
13698          time_Bcast=time_Bcast+MPI_Wtime()-time00
13699 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
13700       endif
13701 !      write (iout,*) 'Processor',myrank,
13702 !     &  ' calling etotal_short ipot=',ipot
13703 !      call flush(iout)
13704 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13705 #endif
13706 !      call int_from_cart1(.false.)
13707 !
13708 ! Compute the side-chain and electrostatic interaction energy
13709 !
13710       goto (101,102,103,104,105,106) ipot
13711 ! Lennard-Jones potential.
13712   101 call elj_short(evdw)
13713 !d    print '(a)','Exit ELJ'
13714       goto 107
13715 ! Lennard-Jones-Kihara potential (shifted).
13716   102 call eljk_short(evdw)
13717       goto 107
13718 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13719   103 call ebp_short(evdw)
13720       goto 107
13721 ! Gay-Berne potential (shifted LJ, angular dependence).
13722   104 call egb_short(evdw)
13723       goto 107
13724 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13725   105 call egbv_short(evdw)
13726       goto 107
13727 ! Soft-sphere potential - already dealt with in the long-range part
13728   106 evdw=0.0d0
13729 !  106 call e_softsphere_short(evdw)
13730 !
13731 ! Calculate electrostatic (H-bonding) energy of the main chain.
13732 !
13733   107 continue
13734 !
13735 ! Calculate the short-range part of Evdwpp
13736 !
13737       call evdwpp_short(evdw1)
13738 !
13739 ! Calculate the short-range part of ESCp
13740 !
13741       if (ipot.lt.6) then
13742         call escp_short(evdw2,evdw2_14)
13743       endif
13744 !
13745 ! Calculate the bond-stretching energy
13746 !
13747       call ebond(estr)
13748 !
13749 ! Calculate the disulfide-bridge and other energy and the contributions
13750 ! from other distance constraints.
13751       call edis(ehpb)
13752 !
13753 ! Calculate the virtual-bond-angle energy.
13754 !
13755       call ebend(ebe)
13756 !
13757 ! Calculate the SC local energy.
13758 !
13759       call vec_and_deriv
13760       call esc(escloc)
13761 !
13762 ! Calculate the virtual-bond torsional energy.
13763 !
13764       call etor(etors,edihcnstr)
13765 !
13766 ! 6/23/01 Calculate double-torsional energy
13767 !
13768       call etor_d(etors_d)
13769 !
13770 ! 21/5/07 Calculate local sicdechain correlation energy
13771 !
13772       if (wsccor.gt.0.0d0) then
13773         call eback_sc_corr(esccor)
13774       else
13775         esccor=0.0d0
13776       endif
13777 !
13778 ! Put energy components into an array
13779 !
13780       do i=1,n_ene
13781         energia(i)=0.0d0
13782       enddo
13783       energia(1)=evdw
13784 #ifdef SCP14
13785       energia(2)=evdw2-evdw2_14
13786       energia(18)=evdw2_14
13787 #else
13788       energia(2)=evdw2
13789       energia(18)=0.0d0
13790 #endif
13791 #ifdef SPLITELE
13792       energia(16)=evdw1
13793 #else
13794       energia(3)=evdw1
13795 #endif
13796       energia(11)=ebe
13797       energia(12)=escloc
13798       energia(13)=etors
13799       energia(14)=etors_d
13800       energia(15)=ehpb
13801       energia(17)=estr
13802       energia(19)=edihcnstr
13803       energia(21)=esccor
13804 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
13805       call flush(iout)
13806       call sum_energy(energia,.true.)
13807 !      write (iout,*) "Exit ETOTAL_SHORT"
13808       call flush(iout)
13809       return
13810       end subroutine etotal_short
13811 !-----------------------------------------------------------------------------
13812 ! gnmr1.f
13813 !-----------------------------------------------------------------------------
13814       real(kind=8) function gnmr1(y,ymin,ymax)
13815 !      implicit none
13816       real(kind=8) :: y,ymin,ymax
13817       real(kind=8) :: wykl=4.0d0
13818       if (y.lt.ymin) then
13819         gnmr1=(ymin-y)**wykl/wykl
13820       else if (y.gt.ymax) then
13821         gnmr1=(y-ymax)**wykl/wykl
13822       else
13823         gnmr1=0.0d0
13824       endif
13825       return
13826       end function gnmr1
13827 !-----------------------------------------------------------------------------
13828       real(kind=8) function gnmr1prim(y,ymin,ymax)
13829 !      implicit none
13830       real(kind=8) :: y,ymin,ymax
13831       real(kind=8) :: wykl=4.0d0
13832       if (y.lt.ymin) then
13833         gnmr1prim=-(ymin-y)**(wykl-1)
13834       else if (y.gt.ymax) then
13835         gnmr1prim=(y-ymax)**(wykl-1)
13836       else
13837         gnmr1prim=0.0d0
13838       endif
13839       return
13840       end function gnmr1prim
13841 !-----------------------------------------------------------------------------
13842       real(kind=8) function harmonic(y,ymax)
13843 !      implicit none
13844       real(kind=8) :: y,ymax
13845       real(kind=8) :: wykl=2.0d0
13846       harmonic=(y-ymax)**wykl
13847       return
13848       end function harmonic
13849 !-----------------------------------------------------------------------------
13850       real(kind=8) function harmonicprim(y,ymax)
13851       real(kind=8) :: y,ymin,ymax
13852       real(kind=8) :: wykl=2.0d0
13853       harmonicprim=(y-ymax)*wykl
13854       return
13855       end function harmonicprim
13856 !-----------------------------------------------------------------------------
13857 ! gradient_p.F
13858 !-----------------------------------------------------------------------------
13859       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
13860
13861       use io_base, only:intout,briefout
13862 !      implicit real*8 (a-h,o-z)
13863 !      include 'DIMENSIONS'
13864 !      include 'COMMON.CHAIN'
13865 !      include 'COMMON.DERIV'
13866 !      include 'COMMON.VAR'
13867 !      include 'COMMON.INTERACT'
13868 !      include 'COMMON.FFIELD'
13869 !      include 'COMMON.MD'
13870 !      include 'COMMON.IOUNITS'
13871       real(kind=8),external :: ufparm
13872       integer :: uiparm(1)
13873       real(kind=8) :: urparm(1)
13874       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13875       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
13876       integer :: n,nf,ind,ind1,i,k,j
13877 !
13878 ! This subroutine calculates total internal coordinate gradient.
13879 ! Depending on the number of function evaluations, either whole energy
13880 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
13881 ! internal coordinates are reevaluated or only the cartesian-in-internal
13882 ! coordinate derivatives are evaluated. The subroutine was designed to work
13883 ! with SUMSL.
13884 !
13885 !
13886       icg=mod(nf,2)+1
13887
13888 !d      print *,'grad',nf,icg
13889       if (nf-nfl+1) 20,30,40
13890    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
13891 !    write (iout,*) 'grad 20'
13892       if (nf.eq.0) return
13893       goto 40
13894    30 call var_to_geom(n,x)
13895       call chainbuild
13896 !    write (iout,*) 'grad 30'
13897 !
13898 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
13899 !
13900    40 call cartder
13901 !     write (iout,*) 'grad 40'
13902 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
13903 !
13904 ! Convert the Cartesian gradient into internal-coordinate gradient.
13905 !
13906       ind=0
13907       ind1=0
13908       do i=1,nres-2
13909         gthetai=0.0D0
13910         gphii=0.0D0
13911         do j=i+1,nres-1
13912           ind=ind+1
13913 !         ind=indmat(i,j)
13914 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
13915           do k=1,3
13916             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
13917           enddo
13918           do k=1,3
13919             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
13920           enddo
13921         enddo
13922         do j=i+1,nres-1
13923           ind1=ind1+1
13924 !         ind1=indmat(i,j)
13925 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
13926           do k=1,3
13927             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
13928             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
13929           enddo
13930         enddo
13931         if (i.gt.1) g(i-1)=gphii
13932         if (n.gt.nphi) g(nphi+i)=gthetai
13933       enddo
13934       if (n.le.nphi+ntheta) goto 10
13935       do i=2,nres-1
13936         if (itype(i).ne.10) then
13937           galphai=0.0D0
13938           gomegai=0.0D0
13939           do k=1,3
13940             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
13941           enddo
13942           do k=1,3
13943             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
13944           enddo
13945           g(ialph(i,1))=galphai
13946           g(ialph(i,1)+nside)=gomegai
13947         endif
13948       enddo
13949 !
13950 ! Add the components corresponding to local energy terms.
13951 !
13952    10 continue
13953       do i=1,nvar
13954 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
13955         g(i)=g(i)+gloc(i,icg)
13956       enddo
13957 ! Uncomment following three lines for diagnostics.
13958 !d    call intout
13959 !elwrite(iout,*) "in gradient after calling intout"
13960 !d    call briefout(0,0.0d0)
13961 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
13962       return
13963       end subroutine gradient
13964 !-----------------------------------------------------------------------------
13965       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
13966
13967       use comm_chu
13968 !      implicit real*8 (a-h,o-z)
13969 !      include 'DIMENSIONS'
13970 !      include 'COMMON.DERIV'
13971 !      include 'COMMON.IOUNITS'
13972 !      include 'COMMON.GEO'
13973       integer :: n,nf
13974 !el      integer :: jjj
13975 !el      common /chuju/ jjj
13976       real(kind=8) :: energia(0:n_ene)
13977       integer :: uiparm(1)
13978       real(kind=8) :: urparm(1)
13979       real(kind=8) :: f
13980       real(kind=8),external :: ufparm
13981       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
13982 !     if (jjj.gt.0) then
13983 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13984 !     endif
13985       nfl=nf
13986       icg=mod(nf,2)+1
13987 !d      print *,'func',nf,nfl,icg
13988       call var_to_geom(n,x)
13989       call zerograd
13990       call chainbuild
13991 !d    write (iout,*) 'ETOTAL called from FUNC'
13992       call etotal(energia)
13993       call sum_gradient
13994       f=energia(0)
13995 !     if (jjj.gt.0) then
13996 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13997 !       write (iout,*) 'f=',etot
13998 !       jjj=0
13999 !     endif
14000       return
14001       end subroutine func
14002 !-----------------------------------------------------------------------------
14003       subroutine cartgrad
14004 !      implicit real*8 (a-h,o-z)
14005 !      include 'DIMENSIONS'
14006       use energy_data
14007       use MD_data, only: totT,usampl,eq_time
14008 #ifdef MPI
14009       include 'mpif.h'
14010 #endif
14011 !      include 'COMMON.CHAIN'
14012 !      include 'COMMON.DERIV'
14013 !      include 'COMMON.VAR'
14014 !      include 'COMMON.INTERACT'
14015 !      include 'COMMON.FFIELD'
14016 !      include 'COMMON.MD'
14017 !      include 'COMMON.IOUNITS'
14018 !      include 'COMMON.TIME1'
14019 !
14020       integer :: i,j
14021
14022 ! This subrouting calculates total Cartesian coordinate gradient.
14023 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
14024 !
14025 !el#define DEBUG
14026 #ifdef TIMING
14027       time00=MPI_Wtime()
14028 #endif
14029       icg=1
14030       call sum_gradient
14031 #ifdef TIMING
14032 #endif
14033 !el      write (iout,*) "After sum_gradient"
14034 #ifdef DEBUG
14035 !el      write (iout,*) "After sum_gradient"
14036       do i=1,nres-1
14037         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
14038         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
14039       enddo
14040 #endif
14041 ! If performing constraint dynamics, add the gradients of the constraint energy
14042       if(usampl.and.totT.gt.eq_time) then
14043          do i=1,nct
14044            do j=1,3
14045              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
14046              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
14047            enddo
14048          enddo
14049          do i=1,nres-3
14050            gloc(i,icg)=gloc(i,icg)+dugamma(i)
14051          enddo
14052          do i=1,nres-2
14053            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
14054          enddo
14055       endif
14056 !elwrite (iout,*) "After sum_gradient"
14057 #ifdef TIMING
14058       time01=MPI_Wtime()
14059 #endif
14060       call intcartderiv
14061 !elwrite (iout,*) "After sum_gradient"
14062 #ifdef TIMING
14063       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
14064 #endif
14065 !     call checkintcartgrad
14066 !     write(iout,*) 'calling int_to_cart'
14067 #ifdef DEBUG
14068       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
14069 #endif
14070       do i=1,nct
14071         do j=1,3
14072           gcart(j,i)=gradc(j,i,icg)
14073           gxcart(j,i)=gradx(j,i,icg)
14074         enddo
14075 #ifdef DEBUG
14076         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
14077           (gxcart(j,i),j=1,3),gloc(i,icg)
14078 #endif
14079       enddo
14080 #ifdef TIMING
14081       time01=MPI_Wtime()
14082 #endif
14083       call int_to_cart
14084 #ifdef TIMING
14085       time_inttocart=time_inttocart+MPI_Wtime()-time01
14086 #endif
14087 #ifdef DEBUG
14088       write (iout,*) "gcart and gxcart after int_to_cart"
14089       do i=0,nres-1
14090         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
14091             (gxcart(j,i),j=1,3)
14092       enddo
14093 #endif
14094 #ifdef CARGRAD
14095 #ifdef DEBUG
14096       write (iout,*) "CARGRAD"
14097 #endif
14098       do i=nres,1,-1
14099         do j=1,3
14100           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14101 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14102         enddo
14103 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
14104 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
14105       enddo
14106 ! Correction: dummy residues
14107         if (nnt.gt.1) then
14108           do j=1,3
14109 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
14110             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
14111           enddo
14112         endif
14113         if (nct.lt.nres) then
14114           do j=1,3
14115 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
14116             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
14117           enddo
14118         endif
14119 #endif
14120 #ifdef TIMING
14121       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
14122 #endif
14123 !el#undef DEBUG
14124       return
14125       end subroutine cartgrad
14126 !-----------------------------------------------------------------------------
14127       subroutine zerograd
14128 !      implicit real*8 (a-h,o-z)
14129 !      include 'DIMENSIONS'
14130 !      include 'COMMON.DERIV'
14131 !      include 'COMMON.CHAIN'
14132 !      include 'COMMON.VAR'
14133 !      include 'COMMON.MD'
14134 !      include 'COMMON.SCCOR'
14135 !
14136 !el local variables
14137       integer :: i,j,intertyp
14138 ! Initialize Cartesian-coordinate gradient
14139 !
14140 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
14141 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
14142
14143 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
14144 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
14145 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
14146 !      allocate(gradcorr_long(3,nres))
14147 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
14148 !      allocate(gcorr6_turn_long(3,nres))
14149 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
14150
14151 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
14152
14153 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
14154 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
14155
14156 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
14157 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
14158
14159 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
14160 !      allocate(gscloc(3,nres)) !(3,maxres)
14161 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
14162
14163
14164
14165 !      common /deriv_scloc/
14166 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
14167 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
14168 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
14169 !      common /mpgrad/
14170 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
14171
14172
14173
14174 !          gradc(j,i,icg)=0.0d0
14175 !          gradx(j,i,icg)=0.0d0
14176
14177 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
14178 !elwrite(iout,*) "icg",icg
14179       do i=1,nres
14180         do j=1,3
14181           gvdwx(j,i)=0.0D0
14182           gradx_scp(j,i)=0.0D0
14183           gvdwc(j,i)=0.0D0
14184           gvdwc_scp(j,i)=0.0D0
14185           gvdwc_scpp(j,i)=0.0d0
14186           gelc(j,i)=0.0D0
14187           gelc_long(j,i)=0.0D0
14188           gradb(j,i)=0.0d0
14189           gradbx(j,i)=0.0d0
14190           gvdwpp(j,i)=0.0d0
14191           gel_loc(j,i)=0.0d0
14192           gel_loc_long(j,i)=0.0d0
14193           ghpbc(j,i)=0.0D0
14194           ghpbx(j,i)=0.0D0
14195           gcorr3_turn(j,i)=0.0d0
14196           gcorr4_turn(j,i)=0.0d0
14197           gradcorr(j,i)=0.0d0
14198           gradcorr_long(j,i)=0.0d0
14199           gradcorr5_long(j,i)=0.0d0
14200           gradcorr6_long(j,i)=0.0d0
14201           gcorr6_turn_long(j,i)=0.0d0
14202           gradcorr5(j,i)=0.0d0
14203           gradcorr6(j,i)=0.0d0
14204           gcorr6_turn(j,i)=0.0d0
14205           gsccorc(j,i)=0.0d0
14206           gsccorx(j,i)=0.0d0
14207           gradc(j,i,icg)=0.0d0
14208           gradx(j,i,icg)=0.0d0
14209           gscloc(j,i)=0.0d0
14210           gsclocx(j,i)=0.0d0
14211           do intertyp=1,3
14212            gloc_sc(intertyp,i,icg)=0.0d0
14213           enddo
14214         enddo
14215       enddo
14216 !
14217 ! Initialize the gradient of local energy terms.
14218 !
14219 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
14220 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14221 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14222 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
14223 !      allocate(gel_loc_turn3(nres))
14224 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
14225 !      allocate(gsccor_loc(nres))       !(maxres)
14226
14227       do i=1,4*nres
14228         gloc(i,icg)=0.0D0
14229       enddo
14230       do i=1,nres
14231         gel_loc_loc(i)=0.0d0
14232         gcorr_loc(i)=0.0d0
14233         g_corr5_loc(i)=0.0d0
14234         g_corr6_loc(i)=0.0d0
14235         gel_loc_turn3(i)=0.0d0
14236         gel_loc_turn4(i)=0.0d0
14237         gel_loc_turn6(i)=0.0d0
14238         gsccor_loc(i)=0.0d0
14239       enddo
14240 ! initialize gcart and gxcart
14241 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
14242       do i=0,nres
14243         do j=1,3
14244           gcart(j,i)=0.0d0
14245           gxcart(j,i)=0.0d0
14246         enddo
14247       enddo
14248       return
14249       end subroutine zerograd
14250 !-----------------------------------------------------------------------------
14251       real(kind=8) function fdum()
14252       fdum=0.0D0
14253       return
14254       end function fdum
14255 !-----------------------------------------------------------------------------
14256 ! intcartderiv.F
14257 !-----------------------------------------------------------------------------
14258       subroutine intcartderiv
14259 !      implicit real*8 (a-h,o-z)
14260 !      include 'DIMENSIONS'
14261 #ifdef MPI
14262       include 'mpif.h'
14263 #endif
14264 !      include 'COMMON.SETUP'
14265 !      include 'COMMON.CHAIN'
14266 !      include 'COMMON.VAR'
14267 !      include 'COMMON.GEO'
14268 !      include 'COMMON.INTERACT'
14269 !      include 'COMMON.DERIV'
14270 !      include 'COMMON.IOUNITS'
14271 !      include 'COMMON.LOCAL'
14272 !      include 'COMMON.SCCOR'
14273       real(kind=8) :: pi4,pi34
14274       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
14275       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
14276                     dcosomega,dsinomega !(3,3,maxres)
14277       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
14278
14279       integer :: i,j,k
14280       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
14281                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
14282                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
14283                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
14284       integer :: nres2
14285       nres2=2*nres
14286
14287 !el from module energy-------------
14288 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
14289 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
14290 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
14291
14292 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
14293 !el      allocate(dsintau(3,3,3,0:nres2))
14294 !el      allocate(dtauangle(3,3,3,0:nres2))
14295 !el      allocate(domicron(3,2,2,0:nres2))
14296 !el      allocate(dcosomicron(3,2,2,0:nres2))
14297
14298
14299
14300 #if defined(MPI) && defined(PARINTDER)
14301       if (nfgtasks.gt.1 .and. me.eq.king) &
14302         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14303 #endif
14304       pi4 = 0.5d0*pipol
14305       pi34 = 3*pi4
14306
14307 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14308 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14309
14310 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14311       do i=1,nres
14312         do j=1,3
14313           dtheta(j,1,i)=0.0d0
14314           dtheta(j,2,i)=0.0d0
14315           dphi(j,1,i)=0.0d0
14316           dphi(j,2,i)=0.0d0
14317           dphi(j,3,i)=0.0d0
14318         enddo
14319       enddo
14320 ! Derivatives of theta's
14321 #if defined(MPI) && defined(PARINTDER)
14322 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14323       do i=max0(ithet_start-1,3),ithet_end
14324 #else
14325       do i=3,nres
14326 #endif
14327         cost=dcos(theta(i))
14328         sint=sqrt(1-cost*cost)
14329         do j=1,3
14330           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14331           vbld(i-1)
14332           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14333           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14334           vbld(i)
14335           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14336         enddo
14337       enddo
14338 #if defined(MPI) && defined(PARINTDER)
14339 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14340       do i=max0(ithet_start-1,3),ithet_end
14341 #else
14342       do i=3,nres
14343 #endif
14344       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14345         cost1=dcos(omicron(1,i))
14346         sint1=sqrt(1-cost1*cost1)
14347         cost2=dcos(omicron(2,i))
14348         sint2=sqrt(1-cost2*cost2)
14349        do j=1,3
14350 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14351           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14352           cost1*dc_norm(j,i-2))/ &
14353           vbld(i-1)
14354           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14355           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14356           +cost1*(dc_norm(j,i-1+nres)))/ &
14357           vbld(i-1+nres)
14358           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14359 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14360 !C Looks messy but better than if in loop
14361           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14362           +cost2*dc_norm(j,i-1))/ &
14363           vbld(i)
14364           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14365           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14366            +cost2*(-dc_norm(j,i-1+nres)))/ &
14367           vbld(i-1+nres)
14368 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14369           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14370         enddo
14371        endif
14372       enddo
14373 !elwrite(iout,*) "after vbld write"
14374 ! Derivatives of phi:
14375 ! If phi is 0 or 180 degrees, then the formulas
14376 ! have to be derived by power series expansion of the
14377 ! conventional formulas around 0 and 180.
14378 #ifdef PARINTDER
14379       do i=iphi1_start,iphi1_end
14380 #else
14381       do i=4,nres
14382 #endif
14383 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14384 ! the conventional case
14385         sint=dsin(theta(i))
14386         sint1=dsin(theta(i-1))
14387         sing=dsin(phi(i))
14388         cost=dcos(theta(i))
14389         cost1=dcos(theta(i-1))
14390         cosg=dcos(phi(i))
14391         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14392         fac0=1.0d0/(sint1*sint)
14393         fac1=cost*fac0
14394         fac2=cost1*fac0
14395         fac3=cosg*cost1/(sint1*sint1)
14396         fac4=cosg*cost/(sint*sint)
14397 !    Obtaining the gamma derivatives from sine derivative
14398        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14399            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14400            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14401          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14402          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14403          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14404          do j=1,3
14405             ctgt=cost/sint
14406             ctgt1=cost1/sint1
14407             cosg_inv=1.0d0/cosg
14408             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14409             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14410               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14411             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14412             dsinphi(j,2,i)= &
14413               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14414               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14415             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14416             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14417               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14418 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14419             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14420             endif
14421 ! Bug fixed 3/24/05 (AL)
14422          enddo
14423 !   Obtaining the gamma derivatives from cosine derivative
14424         else
14425            do j=1,3
14426            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14427            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14428            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14429            dc_norm(j,i-3))/vbld(i-2)
14430            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14431            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14432            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14433            dcostheta(j,1,i)
14434            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14435            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14436            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14437            dc_norm(j,i-1))/vbld(i)
14438            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14439            endif
14440          enddo
14441         endif
14442       enddo
14443 !alculate derivative of Tauangle
14444 #ifdef PARINTDER
14445       do i=itau_start,itau_end
14446 #else
14447       do i=3,nres
14448 !elwrite(iout,*) " vecpr",i,nres
14449 #endif
14450        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14451 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14452 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14453 !c dtauangle(j,intertyp,dervityp,residue number)
14454 !c INTERTYP=1 SC...Ca...Ca..Ca
14455 ! the conventional case
14456         sint=dsin(theta(i))
14457         sint1=dsin(omicron(2,i-1))
14458         sing=dsin(tauangle(1,i))
14459         cost=dcos(theta(i))
14460         cost1=dcos(omicron(2,i-1))
14461         cosg=dcos(tauangle(1,i))
14462 !elwrite(iout,*) " vecpr5",i,nres
14463         do j=1,3
14464 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14465 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14466         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14467 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14468         enddo
14469         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14470         fac0=1.0d0/(sint1*sint)
14471         fac1=cost*fac0
14472         fac2=cost1*fac0
14473         fac3=cosg*cost1/(sint1*sint1)
14474         fac4=cosg*cost/(sint*sint)
14475 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14476 !    Obtaining the gamma derivatives from sine derivative
14477        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14478            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14479            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14480          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14481          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14482          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14483         do j=1,3
14484             ctgt=cost/sint
14485             ctgt1=cost1/sint1
14486             cosg_inv=1.0d0/cosg
14487             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14488        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14489        *vbld_inv(i-2+nres)
14490             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14491             dsintau(j,1,2,i)= &
14492               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14493               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14494 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14495             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14496 ! Bug fixed 3/24/05 (AL)
14497             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14498               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14499 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14500             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14501          enddo
14502 !   Obtaining the gamma derivatives from cosine derivative
14503         else
14504            do j=1,3
14505            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14506            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14507            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14508            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14509            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14510            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14511            dcostheta(j,1,i)
14512            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14513            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14514            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14515            dc_norm(j,i-1))/vbld(i)
14516            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14517 !         write (iout,*) "else",i
14518          enddo
14519         endif
14520 !        do k=1,3
14521 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14522 !        enddo
14523       enddo
14524 !C Second case Ca...Ca...Ca...SC
14525 #ifdef PARINTDER
14526       do i=itau_start,itau_end
14527 #else
14528       do i=4,nres
14529 #endif
14530        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14531           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14532 ! the conventional case
14533         sint=dsin(omicron(1,i))
14534         sint1=dsin(theta(i-1))
14535         sing=dsin(tauangle(2,i))
14536         cost=dcos(omicron(1,i))
14537         cost1=dcos(theta(i-1))
14538         cosg=dcos(tauangle(2,i))
14539 !        do j=1,3
14540 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14541 !        enddo
14542         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14543         fac0=1.0d0/(sint1*sint)
14544         fac1=cost*fac0
14545         fac2=cost1*fac0
14546         fac3=cosg*cost1/(sint1*sint1)
14547         fac4=cosg*cost/(sint*sint)
14548 !    Obtaining the gamma derivatives from sine derivative
14549        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14550            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14551            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14552          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14553          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14554          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14555         do j=1,3
14556             ctgt=cost/sint
14557             ctgt1=cost1/sint1
14558             cosg_inv=1.0d0/cosg
14559             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14560               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14561 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14562 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14563             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14564             dsintau(j,2,2,i)= &
14565               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14566               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14567 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14568 !     & sing*ctgt*domicron(j,1,2,i),
14569 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14570             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14571 ! Bug fixed 3/24/05 (AL)
14572             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14573              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14574 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14575             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14576          enddo
14577 !   Obtaining the gamma derivatives from cosine derivative
14578         else
14579            do j=1,3
14580            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14581            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14582            dc_norm(j,i-3))/vbld(i-2)
14583            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14584            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14585            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14586            dcosomicron(j,1,1,i)
14587            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14588            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14589            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14590            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14591            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14592 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14593          enddo
14594         endif
14595       enddo
14596
14597 !CC third case SC...Ca...Ca...SC
14598 #ifdef PARINTDER
14599
14600       do i=itau_start,itau_end
14601 #else
14602       do i=3,nres
14603 #endif
14604 ! the conventional case
14605       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14606       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14607         sint=dsin(omicron(1,i))
14608         sint1=dsin(omicron(2,i-1))
14609         sing=dsin(tauangle(3,i))
14610         cost=dcos(omicron(1,i))
14611         cost1=dcos(omicron(2,i-1))
14612         cosg=dcos(tauangle(3,i))
14613         do j=1,3
14614         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14615 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14616         enddo
14617         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14618         fac0=1.0d0/(sint1*sint)
14619         fac1=cost*fac0
14620         fac2=cost1*fac0
14621         fac3=cosg*cost1/(sint1*sint1)
14622         fac4=cosg*cost/(sint*sint)
14623 !    Obtaining the gamma derivatives from sine derivative
14624        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14625            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14626            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14627          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14628          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14629          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14630         do j=1,3
14631             ctgt=cost/sint
14632             ctgt1=cost1/sint1
14633             cosg_inv=1.0d0/cosg
14634             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14635               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14636               *vbld_inv(i-2+nres)
14637             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14638             dsintau(j,3,2,i)= &
14639               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14640               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14641             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14642 ! Bug fixed 3/24/05 (AL)
14643             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14644               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14645               *vbld_inv(i-1+nres)
14646 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14647             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
14648          enddo
14649 !   Obtaining the gamma derivatives from cosine derivative
14650         else
14651            do j=1,3
14652            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14653            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14654            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
14655            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
14656            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14657            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14658            dcosomicron(j,1,1,i)
14659            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
14660            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14661            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
14662            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14663            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
14664 !          write(iout,*) "else",i
14665          enddo
14666         endif
14667       enddo
14668
14669 #ifdef CRYST_SC
14670 !   Derivatives of side-chain angles alpha and omega
14671 #if defined(MPI) && defined(PARINTDER)
14672         do i=ibond_start,ibond_end
14673 #else
14674         do i=2,nres-1
14675 #endif
14676           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
14677              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
14678              fac6=fac5/vbld(i)
14679              fac7=fac5*fac5
14680              fac8=fac5/vbld(i+1)
14681              fac9=fac5/vbld(i+nres)
14682              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
14683              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
14684              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
14685              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
14686              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
14687              sina=sqrt(1-cosa*cosa)
14688              sino=dsin(omeg(i))
14689 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
14690              do j=1,3
14691                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
14692                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
14693                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
14694                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
14695                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
14696                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
14697                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
14698                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
14699                 vbld(i+nres))
14700                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
14701             enddo
14702 ! obtaining the derivatives of omega from sines
14703             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
14704                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
14705                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
14706                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
14707                dsin(theta(i+1)))
14708                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
14709                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
14710                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
14711                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
14712                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
14713                coso_inv=1.0d0/dcos(omeg(i))
14714                do j=1,3
14715                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
14716                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
14717                  (sino*dc_norm(j,i-1))/vbld(i)
14718                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
14719                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
14720                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
14721                  -sino*dc_norm(j,i)/vbld(i+1)
14722                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
14723                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
14724                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
14725                  vbld(i+nres)
14726                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
14727               enddo
14728            else
14729 !   obtaining the derivatives of omega from cosines
14730              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
14731              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
14732              fac12=fac10*sina
14733              fac13=fac12*fac12
14734              fac14=sina*sina
14735              do j=1,3
14736                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
14737                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
14738                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
14739                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
14740                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
14741                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
14742                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
14743                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
14744                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
14745                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
14746                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
14747                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
14748                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
14749                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
14750                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
14751             enddo
14752           endif
14753          else
14754            do j=1,3
14755              do k=1,3
14756                dalpha(k,j,i)=0.0d0
14757                domega(k,j,i)=0.0d0
14758              enddo
14759            enddo
14760          endif
14761        enddo
14762 #endif
14763 #if defined(MPI) && defined(PARINTDER)
14764       if (nfgtasks.gt.1) then
14765 #ifdef DEBUG
14766 !d      write (iout,*) "Gather dtheta"
14767 !d      call flush(iout)
14768       write (iout,*) "dtheta before gather"
14769       do i=1,nres
14770         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
14771       enddo
14772 #endif
14773       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
14774         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
14775         king,FG_COMM,IERROR)
14776 #ifdef DEBUG
14777 !d      write (iout,*) "Gather dphi"
14778 !d      call flush(iout)
14779       write (iout,*) "dphi before gather"
14780       do i=1,nres
14781         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
14782       enddo
14783 #endif
14784       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
14785         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
14786         king,FG_COMM,IERROR)
14787 !d      write (iout,*) "Gather dalpha"
14788 !d      call flush(iout)
14789 #ifdef CRYST_SC
14790       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
14791         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14792         king,FG_COMM,IERROR)
14793 !d      write (iout,*) "Gather domega"
14794 !d      call flush(iout)
14795       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
14796         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14797         king,FG_COMM,IERROR)
14798 #endif
14799       endif
14800 #endif
14801 #ifdef DEBUG
14802       write (iout,*) "dtheta after gather"
14803       do i=1,nres
14804         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
14805       enddo
14806       write (iout,*) "dphi after gather"
14807       do i=1,nres
14808         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
14809       enddo
14810       write (iout,*) "dalpha after gather"
14811       do i=1,nres
14812         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
14813       enddo
14814       write (iout,*) "domega after gather"
14815       do i=1,nres
14816         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
14817       enddo
14818 #endif
14819       return
14820       end subroutine intcartderiv
14821 !-----------------------------------------------------------------------------
14822       subroutine checkintcartgrad
14823 !      implicit real*8 (a-h,o-z)
14824 !      include 'DIMENSIONS'
14825 #ifdef MPI
14826       include 'mpif.h'
14827 #endif
14828 !      include 'COMMON.CHAIN'
14829 !      include 'COMMON.VAR'
14830 !      include 'COMMON.GEO'
14831 !      include 'COMMON.INTERACT'
14832 !      include 'COMMON.DERIV'
14833 !      include 'COMMON.IOUNITS'
14834 !      include 'COMMON.SETUP'
14835       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
14836       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
14837       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
14838       real(kind=8),dimension(3) :: dc_norm_s
14839       real(kind=8) :: aincr=1.0d-5
14840       integer :: i,j
14841       real(kind=8) :: dcji
14842       do i=1,nres
14843         phi_s(i)=phi(i)
14844         theta_s(i)=theta(i)
14845         alph_s(i)=alph(i)
14846         omeg_s(i)=omeg(i)
14847       enddo
14848 ! Check theta gradient
14849       write (iout,*) &
14850        "Analytical (upper) and numerical (lower) gradient of theta"
14851       write (iout,*)
14852       do i=3,nres
14853         do j=1,3
14854           dcji=dc(j,i-2)
14855           dc(j,i-2)=dcji+aincr
14856           call chainbuild_cart
14857           call int_from_cart1(.false.)
14858           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
14859           dc(j,i-2)=dcji
14860           dcji=dc(j,i-1)
14861           dc(j,i-1)=dc(j,i-1)+aincr
14862           call chainbuild_cart
14863           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
14864           dc(j,i-1)=dcji
14865         enddo
14866 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
14867 !el          (dtheta(j,2,i),j=1,3)
14868 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
14869 !el          (dthetanum(j,2,i),j=1,3)
14870 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
14871 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
14872 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
14873 !el        write (iout,*)
14874       enddo
14875 ! Check gamma gradient
14876       write (iout,*) &
14877        "Analytical (upper) and numerical (lower) gradient of gamma"
14878       do i=4,nres
14879         do j=1,3
14880           dcji=dc(j,i-3)
14881           dc(j,i-3)=dcji+aincr
14882           call chainbuild_cart
14883           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
14884           dc(j,i-3)=dcji
14885           dcji=dc(j,i-2)
14886           dc(j,i-2)=dcji+aincr
14887           call chainbuild_cart
14888           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
14889           dc(j,i-2)=dcji
14890           dcji=dc(j,i-1)
14891           dc(j,i-1)=dc(j,i-1)+aincr
14892           call chainbuild_cart
14893           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
14894           dc(j,i-1)=dcji
14895         enddo
14896 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
14897 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
14898 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
14899 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
14900 !el        write (iout,'(5x,3(3f10.5,5x))') &
14901 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
14902 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
14903 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
14904 !el        write (iout,*)
14905       enddo
14906 ! Check alpha gradient
14907       write (iout,*) &
14908        "Analytical (upper) and numerical (lower) gradient of alpha"
14909       do i=2,nres-1
14910        if(itype(i).ne.10) then
14911             do j=1,3
14912               dcji=dc(j,i-1)
14913               dc(j,i-1)=dcji+aincr
14914               call chainbuild_cart
14915               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
14916               /aincr
14917               dc(j,i-1)=dcji
14918               dcji=dc(j,i)
14919               dc(j,i)=dcji+aincr
14920               call chainbuild_cart
14921               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
14922               /aincr
14923               dc(j,i)=dcji
14924               dcji=dc(j,i+nres)
14925               dc(j,i+nres)=dc(j,i+nres)+aincr
14926               call chainbuild_cart
14927               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
14928               /aincr
14929              dc(j,i+nres)=dcji
14930             enddo
14931           endif
14932 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
14933 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
14934 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
14935 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
14936 !el        write (iout,'(5x,3(3f10.5,5x))') &
14937 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
14938 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
14939 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
14940 !el        write (iout,*)
14941       enddo
14942 !     Check omega gradient
14943       write (iout,*) &
14944        "Analytical (upper) and numerical (lower) gradient of omega"
14945       do i=2,nres-1
14946        if(itype(i).ne.10) then
14947             do j=1,3
14948               dcji=dc(j,i-1)
14949               dc(j,i-1)=dcji+aincr
14950               call chainbuild_cart
14951               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
14952               /aincr
14953               dc(j,i-1)=dcji
14954               dcji=dc(j,i)
14955               dc(j,i)=dcji+aincr
14956               call chainbuild_cart
14957               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
14958               /aincr
14959               dc(j,i)=dcji
14960               dcji=dc(j,i+nres)
14961               dc(j,i+nres)=dc(j,i+nres)+aincr
14962               call chainbuild_cart
14963               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
14964               /aincr
14965              dc(j,i+nres)=dcji
14966             enddo
14967           endif
14968 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
14969 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
14970 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
14971 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
14972 !el        write (iout,'(5x,3(3f10.5,5x))') &
14973 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
14974 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
14975 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
14976 !el        write (iout,*)
14977       enddo
14978       return
14979       end subroutine checkintcartgrad
14980 !-----------------------------------------------------------------------------
14981 ! q_measure.F
14982 !-----------------------------------------------------------------------------
14983       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
14984 !      implicit real*8 (a-h,o-z)
14985 !      include 'DIMENSIONS'
14986 !      include 'COMMON.IOUNITS'
14987 !      include 'COMMON.CHAIN'
14988 !      include 'COMMON.INTERACT'
14989 !      include 'COMMON.VAR'
14990       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
14991       integer :: kkk,nsep=3
14992       real(kind=8) :: qm        !dist,
14993       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
14994       logical :: lprn=.false.
14995       logical :: flag
14996 !      real(kind=8) :: sigm,x
14997
14998 !el      sigm(x)=0.25d0*x     ! local function
14999       qqmax=1.0d10
15000       do kkk=1,nperm
15001       qq = 0.0d0
15002       nl=0
15003        if(flag) then
15004         do il=seg1+nsep,seg2
15005           do jl=seg1,il-nsep
15006             nl=nl+1
15007             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
15008                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
15009                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15010             dij=dist(il,jl)
15011             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15012             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15013               nl=nl+1
15014               d0ijCM=dsqrt( &
15015                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15016                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15017                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15018               dijCM=dist(il+nres,jl+nres)
15019               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15020             endif
15021             qq = qq+qqij+qqijCM
15022           enddo
15023         enddo
15024         qq = qq/nl
15025       else
15026       do il=seg1,seg2
15027         if((seg3-il).lt.3) then
15028              secseg=il+3
15029         else
15030              secseg=seg3
15031         endif
15032           do jl=secseg,seg4
15033             nl=nl+1
15034             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15035                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15036                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15037             dij=dist(il,jl)
15038             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15039             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15040               nl=nl+1
15041               d0ijCM=dsqrt( &
15042                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15043                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15044                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15045               dijCM=dist(il+nres,jl+nres)
15046               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15047             endif
15048             qq = qq+qqij+qqijCM
15049           enddo
15050         enddo
15051       qq = qq/nl
15052       endif
15053       if (qqmax.le.qq) qqmax=qq
15054       enddo
15055       qwolynes=1.0d0-qqmax
15056       return
15057       end function qwolynes
15058 !-----------------------------------------------------------------------------
15059       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
15060 !      implicit real*8 (a-h,o-z)
15061 !      include 'DIMENSIONS'
15062 !      include 'COMMON.IOUNITS'
15063 !      include 'COMMON.CHAIN'
15064 !      include 'COMMON.INTERACT'
15065 !      include 'COMMON.VAR'
15066 !      include 'COMMON.MD'
15067       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
15068       integer :: nsep=3, kkk
15069 !el      real(kind=8) :: dist
15070       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
15071       logical :: lprn=.false.
15072       logical :: flag
15073       real(kind=8) :: sim,dd0,fac,ddqij
15074 !el      sigm(x)=0.25d0*x            ! local function
15075       do kkk=1,nperm
15076       do i=0,nres
15077         do j=1,3
15078           dqwol(j,i)=0.0d0
15079           dxqwol(j,i)=0.0d0
15080         enddo
15081       enddo
15082       nl=0
15083        if(flag) then
15084         do il=seg1+nsep,seg2
15085           do jl=seg1,il-nsep
15086             nl=nl+1
15087             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15088                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15089                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15090             dij=dist(il,jl)
15091             sim = 1.0d0/sigm(d0ij)
15092             sim = sim*sim
15093             dd0 = dij-d0ij
15094             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15095             do k=1,3
15096               ddqij = (c(k,il)-c(k,jl))*fac
15097               dqwol(k,il)=dqwol(k,il)+ddqij
15098               dqwol(k,jl)=dqwol(k,jl)-ddqij
15099             enddo
15100
15101             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15102               nl=nl+1
15103               d0ijCM=dsqrt( &
15104                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15105                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15106                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15107               dijCM=dist(il+nres,jl+nres)
15108               sim = 1.0d0/sigm(d0ijCM)
15109               sim = sim*sim
15110               dd0=dijCM-d0ijCM
15111               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15112               do k=1,3
15113                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15114                 dxqwol(k,il)=dxqwol(k,il)+ddqij
15115                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15116               enddo
15117             endif
15118           enddo
15119         enddo
15120        else
15121         do il=seg1,seg2
15122         if((seg3-il).lt.3) then
15123              secseg=il+3
15124         else
15125              secseg=seg3
15126         endif
15127           do jl=secseg,seg4
15128             nl=nl+1
15129             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15130                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15131                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15132             dij=dist(il,jl)
15133             sim = 1.0d0/sigm(d0ij)
15134             sim = sim*sim
15135             dd0 = dij-d0ij
15136             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15137             do k=1,3
15138               ddqij = (c(k,il)-c(k,jl))*fac
15139               dqwol(k,il)=dqwol(k,il)+ddqij
15140               dqwol(k,jl)=dqwol(k,jl)-ddqij
15141             enddo
15142             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15143               nl=nl+1
15144               d0ijCM=dsqrt( &
15145                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15146                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15147                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15148               dijCM=dist(il+nres,jl+nres)
15149               sim = 1.0d0/sigm(d0ijCM)
15150               sim=sim*sim
15151               dd0 = dijCM-d0ijCM
15152               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15153               do k=1,3
15154                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15155                dxqwol(k,il)=dxqwol(k,il)+ddqij
15156                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15157               enddo
15158             endif
15159           enddo
15160         enddo
15161       endif
15162       enddo
15163        do i=0,nres
15164          do j=1,3
15165            dqwol(j,i)=dqwol(j,i)/nl
15166            dxqwol(j,i)=dxqwol(j,i)/nl
15167          enddo
15168        enddo
15169       return
15170       end subroutine qwolynes_prim
15171 !-----------------------------------------------------------------------------
15172       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
15173 !      implicit real*8 (a-h,o-z)
15174 !      include 'DIMENSIONS'
15175 !      include 'COMMON.IOUNITS'
15176 !      include 'COMMON.CHAIN'
15177 !      include 'COMMON.INTERACT'
15178 !      include 'COMMON.VAR'
15179       integer :: seg1,seg2,seg3,seg4
15180       logical :: flag
15181       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
15182       real(kind=8),dimension(3,0:2*nres) :: cdummy
15183       real(kind=8) :: q1,q2
15184       real(kind=8) :: delta=1.0d-10
15185       integer :: i,j
15186
15187       do i=0,nres
15188         do j=1,3
15189           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15190           cdummy(j,i)=c(j,i)
15191           c(j,i)=c(j,i)+delta
15192           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15193           qwolan(j,i)=(q2-q1)/delta
15194           c(j,i)=cdummy(j,i)
15195         enddo
15196       enddo
15197       do i=0,nres
15198         do j=1,3
15199           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15200           cdummy(j,i+nres)=c(j,i+nres)
15201           c(j,i+nres)=c(j,i+nres)+delta
15202           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15203           qwolxan(j,i)=(q2-q1)/delta
15204           c(j,i+nres)=cdummy(j,i+nres)
15205         enddo
15206       enddo
15207 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
15208 !      do i=0,nct
15209 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
15210 !      enddo
15211 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
15212 !      do i=0,nct
15213 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
15214 !      enddo
15215       return
15216       end subroutine qwol_num
15217 !-----------------------------------------------------------------------------
15218       subroutine EconstrQ
15219 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
15220 !      implicit real*8 (a-h,o-z)
15221 !      include 'DIMENSIONS'
15222 !      include 'COMMON.CONTROL'
15223 !      include 'COMMON.VAR'
15224 !      include 'COMMON.MD'
15225       use MD_data
15226 !#ifndef LANG0
15227 !      include 'COMMON.LANGEVIN'
15228 !#else
15229 !      include 'COMMON.LANGEVIN.lang0'
15230 !#endif
15231 !      include 'COMMON.CHAIN'
15232 !      include 'COMMON.DERIV'
15233 !      include 'COMMON.GEO'
15234 !      include 'COMMON.LOCAL'
15235 !      include 'COMMON.INTERACT'
15236 !      include 'COMMON.IOUNITS'
15237 !      include 'COMMON.NAMES'
15238 !      include 'COMMON.TIME1'
15239       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
15240       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
15241                    duconst,duxconst
15242       integer :: kstart,kend,lstart,lend,idummy
15243       real(kind=8) :: delta=1.0d-7
15244       integer :: i,j,k,ii
15245       do i=0,nres
15246          do j=1,3
15247             duconst(j,i)=0.0d0
15248             dudconst(j,i)=0.0d0
15249             duxconst(j,i)=0.0d0
15250             dudxconst(j,i)=0.0d0
15251          enddo
15252       enddo
15253       Uconst=0.0d0
15254       do i=1,nfrag
15255          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15256            idummy,idummy)
15257          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
15258 ! Calculating the derivatives of Constraint energy with respect to Q
15259          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
15260            qinfrag(i,iset))
15261 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
15262 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
15263 !         hmnum=(hm2-hm1)/delta
15264 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
15265 !     &   qinfrag(i,iset))
15266 !         write(iout,*) "harmonicnum frag", hmnum
15267 ! Calculating the derivatives of Q with respect to cartesian coordinates
15268          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15269           idummy,idummy)
15270 !         write(iout,*) "dqwol "
15271 !         do ii=1,nres
15272 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15273 !         enddo
15274 !         write(iout,*) "dxqwol "
15275 !         do ii=1,nres
15276 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15277 !         enddo
15278 ! Calculating numerical gradients of dU/dQi and dQi/dxi
15279 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
15280 !     &  ,idummy,idummy)
15281 !  The gradients of Uconst in Cs
15282          do ii=0,nres
15283             do j=1,3
15284                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
15285                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
15286             enddo
15287          enddo
15288       enddo
15289       do i=1,npair
15290          kstart=ifrag(1,ipair(1,i,iset),iset)
15291          kend=ifrag(2,ipair(1,i,iset),iset)
15292          lstart=ifrag(1,ipair(2,i,iset),iset)
15293          lend=ifrag(2,ipair(2,i,iset),iset)
15294          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
15295          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
15296 !  Calculating dU/dQ
15297          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15298 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15299 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15300 !         hmnum=(hm2-hm1)/delta
15301 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15302 !     &   qinpair(i,iset))
15303 !         write(iout,*) "harmonicnum pair ", hmnum
15304 ! Calculating dQ/dXi
15305          call qwolynes_prim(kstart,kend,.false.,&
15306           lstart,lend)
15307 !         write(iout,*) "dqwol "
15308 !         do ii=1,nres
15309 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15310 !         enddo
15311 !         write(iout,*) "dxqwol "
15312 !         do ii=1,nres
15313 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15314 !        enddo
15315 ! Calculating numerical gradients
15316 !        call qwol_num(kstart,kend,.false.
15317 !     &  ,lstart,lend)
15318 ! The gradients of Uconst in Cs
15319          do ii=0,nres
15320             do j=1,3
15321                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15322                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15323             enddo
15324          enddo
15325       enddo
15326 !      write(iout,*) "Uconst inside subroutine ", Uconst
15327 ! Transforming the gradients from Cs to dCs for the backbone
15328       do i=0,nres
15329          do j=i+1,nres
15330            do k=1,3
15331              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15332            enddo
15333          enddo
15334       enddo
15335 !  Transforming the gradients from Cs to dCs for the side chains
15336       do i=1,nres
15337          do j=1,3
15338            dudxconst(j,i)=duxconst(j,i)
15339          enddo
15340       enddo
15341 !      write(iout,*) "dU/ddc backbone "
15342 !       do ii=0,nres
15343 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15344 !      enddo
15345 !      write(iout,*) "dU/ddX side chain "
15346 !      do ii=1,nres
15347 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15348 !      enddo
15349 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15350 !      call dEconstrQ_num
15351       return
15352       end subroutine EconstrQ
15353 !-----------------------------------------------------------------------------
15354       subroutine dEconstrQ_num
15355 ! Calculating numerical dUconst/ddc and dUconst/ddx
15356 !      implicit real*8 (a-h,o-z)
15357 !      include 'DIMENSIONS'
15358 !      include 'COMMON.CONTROL'
15359 !      include 'COMMON.VAR'
15360 !      include 'COMMON.MD'
15361       use MD_data
15362 !#ifndef LANG0
15363 !      include 'COMMON.LANGEVIN'
15364 !#else
15365 !      include 'COMMON.LANGEVIN.lang0'
15366 !#endif
15367 !      include 'COMMON.CHAIN'
15368 !      include 'COMMON.DERIV'
15369 !      include 'COMMON.GEO'
15370 !      include 'COMMON.LOCAL'
15371 !      include 'COMMON.INTERACT'
15372 !      include 'COMMON.IOUNITS'
15373 !      include 'COMMON.NAMES'
15374 !      include 'COMMON.TIME1'
15375       real(kind=8) :: uzap1,uzap2
15376       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15377       integer :: kstart,kend,lstart,lend,idummy
15378       real(kind=8) :: delta=1.0d-7
15379 !el local variables
15380       integer :: i,ii,j
15381 !     real(kind=8) ::
15382 !     For the backbone
15383       do i=0,nres-1
15384          do j=1,3
15385             dUcartan(j,i)=0.0d0
15386             cdummy(j,i)=dc(j,i)
15387             dc(j,i)=dc(j,i)+delta
15388             call chainbuild_cart
15389             uzap2=0.0d0
15390             do ii=1,nfrag
15391              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15392                 idummy,idummy)
15393                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15394                 qinfrag(ii,iset))
15395             enddo
15396             do ii=1,npair
15397                kstart=ifrag(1,ipair(1,ii,iset),iset)
15398                kend=ifrag(2,ipair(1,ii,iset),iset)
15399                lstart=ifrag(1,ipair(2,ii,iset),iset)
15400                lend=ifrag(2,ipair(2,ii,iset),iset)
15401                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15402                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15403                  qinpair(ii,iset))
15404             enddo
15405             dc(j,i)=cdummy(j,i)
15406             call chainbuild_cart
15407             uzap1=0.0d0
15408              do ii=1,nfrag
15409              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15410                 idummy,idummy)
15411                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15412                 qinfrag(ii,iset))
15413             enddo
15414             do ii=1,npair
15415                kstart=ifrag(1,ipair(1,ii,iset),iset)
15416                kend=ifrag(2,ipair(1,ii,iset),iset)
15417                lstart=ifrag(1,ipair(2,ii,iset),iset)
15418                lend=ifrag(2,ipair(2,ii,iset),iset)
15419                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15420                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15421                 qinpair(ii,iset))
15422             enddo
15423             ducartan(j,i)=(uzap2-uzap1)/(delta)
15424          enddo
15425       enddo
15426 ! Calculating numerical gradients for dU/ddx
15427       do i=0,nres-1
15428          duxcartan(j,i)=0.0d0
15429          do j=1,3
15430             cdummy(j,i)=dc(j,i+nres)
15431             dc(j,i+nres)=dc(j,i+nres)+delta
15432             call chainbuild_cart
15433             uzap2=0.0d0
15434             do ii=1,nfrag
15435              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15436                 idummy,idummy)
15437                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15438                 qinfrag(ii,iset))
15439             enddo
15440             do ii=1,npair
15441                kstart=ifrag(1,ipair(1,ii,iset),iset)
15442                kend=ifrag(2,ipair(1,ii,iset),iset)
15443                lstart=ifrag(1,ipair(2,ii,iset),iset)
15444                lend=ifrag(2,ipair(2,ii,iset),iset)
15445                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15446                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15447                 qinpair(ii,iset))
15448             enddo
15449             dc(j,i+nres)=cdummy(j,i)
15450             call chainbuild_cart
15451             uzap1=0.0d0
15452              do ii=1,nfrag
15453                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15454                 ifrag(2,ii,iset),.true.,idummy,idummy)
15455                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15456                 qinfrag(ii,iset))
15457             enddo
15458             do ii=1,npair
15459                kstart=ifrag(1,ipair(1,ii,iset),iset)
15460                kend=ifrag(2,ipair(1,ii,iset),iset)
15461                lstart=ifrag(1,ipair(2,ii,iset),iset)
15462                lend=ifrag(2,ipair(2,ii,iset),iset)
15463                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15464                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15465                 qinpair(ii,iset))
15466             enddo
15467             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15468          enddo
15469       enddo
15470       write(iout,*) "Numerical dUconst/ddc backbone "
15471       do ii=0,nres
15472         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15473       enddo
15474 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15475 !      do ii=1,nres
15476 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15477 !      enddo
15478       return
15479       end subroutine dEconstrQ_num
15480 !-----------------------------------------------------------------------------
15481 ! ssMD.F
15482 !-----------------------------------------------------------------------------
15483       subroutine check_energies
15484
15485 !      use random, only: ran_number
15486
15487 !      implicit none
15488 !     Includes
15489 !      include 'DIMENSIONS'
15490 !      include 'COMMON.CHAIN'
15491 !      include 'COMMON.VAR'
15492 !      include 'COMMON.IOUNITS'
15493 !      include 'COMMON.SBRIDGE'
15494 !      include 'COMMON.LOCAL'
15495 !      include 'COMMON.GEO'
15496
15497 !     External functions
15498 !EL      double precision ran_number
15499 !EL      external ran_number
15500
15501 !     Local variables
15502       integer :: i,j,k,l,lmax,p,pmax
15503       real(kind=8) :: rmin,rmax
15504       real(kind=8) :: eij
15505
15506       real(kind=8) :: d
15507       real(kind=8) :: wi,rij,tj,pj
15508 !      return
15509
15510       i=5
15511       j=14
15512
15513       d=dsc(1)
15514       rmin=2.0D0
15515       rmax=12.0D0
15516
15517       lmax=10000
15518       pmax=1
15519
15520       do k=1,3
15521         c(k,i)=0.0D0
15522         c(k,j)=0.0D0
15523         c(k,nres+i)=0.0D0
15524         c(k,nres+j)=0.0D0
15525       enddo
15526
15527       do l=1,lmax
15528
15529 !t        wi=ran_number(0.0D0,pi)
15530 !        wi=ran_number(0.0D0,pi/6.0D0)
15531 !        wi=0.0D0
15532 !t        tj=ran_number(0.0D0,pi)
15533 !t        pj=ran_number(0.0D0,pi)
15534 !        pj=ran_number(0.0D0,pi/6.0D0)
15535 !        pj=0.0D0
15536
15537         do p=1,pmax
15538 !t           rij=ran_number(rmin,rmax)
15539
15540            c(1,j)=d*sin(pj)*cos(tj)
15541            c(2,j)=d*sin(pj)*sin(tj)
15542            c(3,j)=d*cos(pj)
15543
15544            c(3,nres+i)=-rij
15545
15546            c(1,i)=d*sin(wi)
15547            c(3,i)=-rij-d*cos(wi)
15548
15549            do k=1,3
15550               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15551               dc_norm(k,nres+i)=dc(k,nres+i)/d
15552               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15553               dc_norm(k,nres+j)=dc(k,nres+j)/d
15554            enddo
15555
15556            call dyn_ssbond_ene(i,j,eij)
15557         enddo
15558       enddo
15559       call exit(1)
15560       return
15561       end subroutine check_energies
15562 !-----------------------------------------------------------------------------
15563       subroutine dyn_ssbond_ene(resi,resj,eij)
15564 !      implicit none
15565 !      Includes
15566       use calc_data
15567       use comm_sschecks
15568 !      include 'DIMENSIONS'
15569 !      include 'COMMON.SBRIDGE'
15570 !      include 'COMMON.CHAIN'
15571 !      include 'COMMON.DERIV'
15572 !      include 'COMMON.LOCAL'
15573 !      include 'COMMON.INTERACT'
15574 !      include 'COMMON.VAR'
15575 !      include 'COMMON.IOUNITS'
15576 !      include 'COMMON.CALC'
15577 #ifndef CLUST
15578 #ifndef WHAM
15579        use MD_data
15580 !      include 'COMMON.MD'
15581 !      use MD, only: totT,t_bath
15582 #endif
15583 #endif
15584 !     External functions
15585 !EL      double precision h_base
15586 !EL      external h_base
15587
15588 !     Input arguments
15589       integer :: resi,resj
15590
15591 !     Output arguments
15592       real(kind=8) :: eij
15593
15594 !     Local variables
15595       logical :: havebond
15596       integer itypi,itypj
15597       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15598       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15599       real(kind=8),dimension(3) :: dcosom1,dcosom2
15600       real(kind=8) :: ed
15601       real(kind=8) :: pom1,pom2
15602       real(kind=8) :: ljA,ljB,ljXs
15603       real(kind=8),dimension(1:3) :: d_ljB
15604       real(kind=8) :: ssA,ssB,ssC,ssXs
15605       real(kind=8) :: ssxm,ljxm,ssm,ljm
15606       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15607       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15608       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15609 !-------FIRST METHOD
15610       real(kind=8) :: xm
15611       real(kind=8),dimension(1:3) :: d_xm
15612 !-------END FIRST METHOD
15613 !-------SECOND METHOD
15614 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15615 !-------END SECOND METHOD
15616
15617 !-------TESTING CODE
15618 !el      logical :: checkstop,transgrad
15619 !el      common /sschecks/ checkstop,transgrad
15620
15621       integer :: icheck,nicheck,jcheck,njcheck
15622       real(kind=8),dimension(-1:1) :: echeck
15623       real(kind=8) :: deps,ssx0,ljx0
15624 !-------END TESTING CODE
15625
15626       eij=0.0d0
15627       i=resi
15628       j=resj
15629
15630 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15631 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15632
15633       itypi=itype(i)
15634       dxi=dc_norm(1,nres+i)
15635       dyi=dc_norm(2,nres+i)
15636       dzi=dc_norm(3,nres+i)
15637       dsci_inv=vbld_inv(i+nres)
15638
15639       itypj=itype(j)
15640       xj=c(1,nres+j)-c(1,nres+i)
15641       yj=c(2,nres+j)-c(2,nres+i)
15642       zj=c(3,nres+j)-c(3,nres+i)
15643       dxj=dc_norm(1,nres+j)
15644       dyj=dc_norm(2,nres+j)
15645       dzj=dc_norm(3,nres+j)
15646       dscj_inv=vbld_inv(j+nres)
15647
15648       chi1=chi(itypi,itypj)
15649       chi2=chi(itypj,itypi)
15650       chi12=chi1*chi2
15651       chip1=chip(itypi)
15652       chip2=chip(itypj)
15653       chip12=chip1*chip2
15654       alf1=alp(itypi)
15655       alf2=alp(itypj)
15656       alf12=0.5D0*(alf1+alf2)
15657
15658       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15659       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
15660 !     The following are set in sc_angular
15661 !      erij(1)=xj*rij
15662 !      erij(2)=yj*rij
15663 !      erij(3)=zj*rij
15664 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
15665 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
15666 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
15667       call sc_angular
15668       rij=1.0D0/rij  ! Reset this so it makes sense
15669
15670       sig0ij=sigma(itypi,itypj)
15671       sig=sig0ij*dsqrt(1.0D0/sigsq)
15672
15673       ljXs=sig-sig0ij
15674       ljA=eps1*eps2rt**2*eps3rt**2
15675       ljB=ljA*bb(itypi,itypj)
15676       ljA=ljA*aa(itypi,itypj)
15677       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15678
15679       ssXs=d0cm
15680       deltat1=1.0d0-om1
15681       deltat2=1.0d0+om2
15682       deltat12=om2-om1+2.0d0
15683       cosphi=om12-om1*om2
15684       ssA=akcm
15685       ssB=akct*deltat12
15686       ssC=ss_depth &
15687            +akth*(deltat1*deltat1+deltat2*deltat2) &
15688            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
15689       ssxm=ssXs-0.5D0*ssB/ssA
15690
15691 !-------TESTING CODE
15692 !$$$c     Some extra output
15693 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
15694 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15695 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
15696 !$$$      if (ssx0.gt.0.0d0) then
15697 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
15698 !$$$      else
15699 !$$$        ssx0=ssxm
15700 !$$$      endif
15701 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15702 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
15703 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
15704 !$$$      return
15705 !-------END TESTING CODE
15706
15707 !-------TESTING CODE
15708 !     Stop and plot energy and derivative as a function of distance
15709       if (checkstop) then
15710         ssm=ssC-0.25D0*ssB*ssB/ssA
15711         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15712         if (ssm.lt.ljm .and. &
15713              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
15714           nicheck=1000
15715           njcheck=1
15716           deps=0.5d-7
15717         else
15718           checkstop=.false.
15719         endif
15720       endif
15721       if (.not.checkstop) then
15722         nicheck=0
15723         njcheck=-1
15724       endif
15725
15726       do icheck=0,nicheck
15727       do jcheck=-1,njcheck
15728       if (checkstop) rij=(ssxm-1.0d0)+ &
15729              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
15730 !-------END TESTING CODE
15731
15732       if (rij.gt.ljxm) then
15733         havebond=.false.
15734         ljd=rij-ljXs
15735         fac=(1.0D0/ljd)**expon
15736         e1=fac*fac*aa(itypi,itypj)
15737         e2=fac*bb(itypi,itypj)
15738         eij=eps1*eps2rt*eps3rt*(e1+e2)
15739         eps2der=eij*eps3rt
15740         eps3der=eij*eps2rt
15741         eij=eij*eps2rt*eps3rt
15742
15743         sigder=-sig/sigsq
15744         e1=e1*eps1*eps2rt**2*eps3rt**2
15745         ed=-expon*(e1+eij)/ljd
15746         sigder=ed*sigder
15747         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15748         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15749         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
15750              -2.0D0*alf12*eps3der+sigder*sigsq_om12
15751       else if (rij.lt.ssxm) then
15752         havebond=.true.
15753         ssd=rij-ssXs
15754         eij=ssA*ssd*ssd+ssB*ssd+ssC
15755
15756         ed=2*akcm*ssd+akct*deltat12
15757         pom1=akct*ssd
15758         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
15759         eom1=-2*akth*deltat1-pom1-om2*pom2
15760         eom2= 2*akth*deltat2+pom1-om1*pom2
15761         eom12=pom2
15762       else
15763         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
15764
15765         d_ssxm(1)=0.5D0*akct/ssA
15766         d_ssxm(2)=-d_ssxm(1)
15767         d_ssxm(3)=0.0D0
15768
15769         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
15770         d_ljxm(2)=d_ljxm(1)*sigsq_om2
15771         d_ljxm(3)=d_ljxm(1)*sigsq_om12
15772         d_ljxm(1)=d_ljxm(1)*sigsq_om1
15773
15774 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15775         xm=0.5d0*(ssxm+ljxm)
15776         do k=1,3
15777           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
15778         enddo
15779         if (rij.lt.xm) then
15780           havebond=.true.
15781           ssm=ssC-0.25D0*ssB*ssB/ssA
15782           d_ssm(1)=0.5D0*akct*ssB/ssA
15783           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15784           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15785           d_ssm(3)=omega
15786           f1=(rij-xm)/(ssxm-xm)
15787           f2=(rij-ssxm)/(xm-ssxm)
15788           h1=h_base(f1,hd1)
15789           h2=h_base(f2,hd2)
15790           eij=ssm*h1+Ht*h2
15791           delta_inv=1.0d0/(xm-ssxm)
15792           deltasq_inv=delta_inv*delta_inv
15793           fac=ssm*hd1-Ht*hd2
15794           fac1=deltasq_inv*fac*(xm-rij)
15795           fac2=deltasq_inv*fac*(rij-ssxm)
15796           ed=delta_inv*(Ht*hd2-ssm*hd1)
15797           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
15798           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
15799           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
15800         else
15801           havebond=.false.
15802           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15803           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
15804           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
15805           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
15806                alf12/eps3rt)
15807           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
15808           f1=(rij-ljxm)/(xm-ljxm)
15809           f2=(rij-xm)/(ljxm-xm)
15810           h1=h_base(f1,hd1)
15811           h2=h_base(f2,hd2)
15812           eij=Ht*h1+ljm*h2
15813           delta_inv=1.0d0/(ljxm-xm)
15814           deltasq_inv=delta_inv*delta_inv
15815           fac=Ht*hd1-ljm*hd2
15816           fac1=deltasq_inv*fac*(ljxm-rij)
15817           fac2=deltasq_inv*fac*(rij-xm)
15818           ed=delta_inv*(ljm*hd2-Ht*hd1)
15819           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
15820           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
15821           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
15822         endif
15823 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15824
15825 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15826 !$$$        ssd=rij-ssXs
15827 !$$$        ljd=rij-ljXs
15828 !$$$        fac1=rij-ljxm
15829 !$$$        fac2=rij-ssxm
15830 !$$$
15831 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
15832 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
15833 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
15834 !$$$
15835 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
15836 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
15837 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15838 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15839 !$$$        d_ssm(3)=omega
15840 !$$$
15841 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
15842 !$$$        do k=1,3
15843 !$$$          d_ljm(k)=ljm*d_ljB(k)
15844 !$$$        enddo
15845 !$$$        ljm=ljm*ljB
15846 !$$$
15847 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
15848 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
15849 !$$$        d_ss(2)=akct*ssd
15850 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
15851 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
15852 !$$$        d_ss(3)=omega
15853 !$$$
15854 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
15855 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
15856 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
15857 !$$$        do k=1,3
15858 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
15859 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
15860 !$$$        enddo
15861 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
15862 !$$$
15863 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
15864 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
15865 !$$$        h1=h_base(f1,hd1)
15866 !$$$        h2=h_base(f2,hd2)
15867 !$$$        eij=ss*h1+ljf*h2
15868 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
15869 !$$$        deltasq_inv=delta_inv*delta_inv
15870 !$$$        fac=ljf*hd2-ss*hd1
15871 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
15872 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
15873 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
15874 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
15875 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
15876 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
15877 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
15878 !$$$
15879 !$$$        havebond=.false.
15880 !$$$        if (ed.gt.0.0d0) havebond=.true.
15881 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15882
15883       endif
15884
15885       if (havebond) then
15886 !#ifndef CLUST
15887 !#ifndef WHAM
15888 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
15889 !          write(iout,'(a15,f12.2,f8.1,2i5)')
15890 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
15891 !        endif
15892 !#endif
15893 !#endif
15894         dyn_ssbond_ij(i,j)=eij
15895       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
15896         dyn_ssbond_ij(i,j)=1.0d300
15897 !#ifndef CLUST
15898 !#ifndef WHAM
15899 !        write(iout,'(a15,f12.2,f8.1,2i5)')
15900 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
15901 !#endif
15902 !#endif
15903       endif
15904
15905 !-------TESTING CODE
15906 !el      if (checkstop) then
15907         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
15908              "CHECKSTOP",rij,eij,ed
15909         echeck(jcheck)=eij
15910 !el      endif
15911       enddo
15912       if (checkstop) then
15913         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
15914       endif
15915       enddo
15916       if (checkstop) then
15917         transgrad=.true.
15918         checkstop=.false.
15919       endif
15920 !-------END TESTING CODE
15921
15922       do k=1,3
15923         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
15924         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
15925       enddo
15926       do k=1,3
15927         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
15928       enddo
15929       do k=1,3
15930         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15931              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15932              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15933         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15934              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15935              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15936       enddo
15937 !grad      do k=i,j-1
15938 !grad        do l=1,3
15939 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
15940 !grad        enddo
15941 !grad      enddo
15942
15943       do l=1,3
15944         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15945         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15946       enddo
15947
15948       return
15949       end subroutine dyn_ssbond_ene
15950 !-----------------------------------------------------------------------------
15951       real(kind=8) function h_base(x,deriv)
15952 !     A smooth function going 0->1 in range [0,1]
15953 !     It should NOT be called outside range [0,1], it will not work there.
15954       implicit none
15955
15956 !     Input arguments
15957       real(kind=8) :: x
15958
15959 !     Output arguments
15960       real(kind=8) :: deriv
15961
15962 !     Local variables
15963       real(kind=8) :: xsq
15964
15965
15966 !     Two parabolas put together.  First derivative zero at extrema
15967 !$$$      if (x.lt.0.5D0) then
15968 !$$$        h_base=2.0D0*x*x
15969 !$$$        deriv=4.0D0*x
15970 !$$$      else
15971 !$$$        deriv=1.0D0-x
15972 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
15973 !$$$        deriv=4.0D0*deriv
15974 !$$$      endif
15975
15976 !     Third degree polynomial.  First derivative zero at extrema
15977       h_base=x*x*(3.0d0-2.0d0*x)
15978       deriv=6.0d0*x*(1.0d0-x)
15979
15980 !     Fifth degree polynomial.  First and second derivatives zero at extrema
15981 !$$$      xsq=x*x
15982 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
15983 !$$$      deriv=x-1.0d0
15984 !$$$      deriv=deriv*deriv
15985 !$$$      deriv=30.0d0*xsq*deriv
15986
15987       return
15988       end function h_base
15989 !-----------------------------------------------------------------------------
15990       subroutine dyn_set_nss
15991 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
15992 !      implicit none
15993       use MD_data, only: totT,t_bath
15994 !     Includes
15995 !      include 'DIMENSIONS'
15996 #ifdef MPI
15997       include "mpif.h"
15998 #endif
15999 !      include 'COMMON.SBRIDGE'
16000 !      include 'COMMON.CHAIN'
16001 !      include 'COMMON.IOUNITS'
16002 !      include 'COMMON.SETUP'
16003 !      include 'COMMON.MD'
16004 !     Local variables
16005       real(kind=8) :: emin
16006       integer :: i,j,imin,ierr
16007       integer :: diff,allnss,newnss
16008       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16009                 newihpb,newjhpb
16010       logical :: found
16011       integer,dimension(0:nfgtasks) :: i_newnss
16012       integer,dimension(0:nfgtasks) :: displ
16013       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16014       integer :: g_newnss
16015
16016       allnss=0
16017       do i=1,nres-1
16018         do j=i+1,nres
16019           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
16020             allnss=allnss+1
16021             allflag(allnss)=0
16022             allihpb(allnss)=i
16023             alljhpb(allnss)=j
16024           endif
16025         enddo
16026       enddo
16027
16028 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16029
16030  1    emin=1.0d300
16031       do i=1,allnss
16032         if (allflag(i).eq.0 .and. &
16033              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
16034           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
16035           imin=i
16036         endif
16037       enddo
16038       if (emin.lt.1.0d300) then
16039         allflag(imin)=1
16040         do i=1,allnss
16041           if (allflag(i).eq.0 .and. &
16042                (allihpb(i).eq.allihpb(imin) .or. &
16043                alljhpb(i).eq.allihpb(imin) .or. &
16044                allihpb(i).eq.alljhpb(imin) .or. &
16045                alljhpb(i).eq.alljhpb(imin))) then
16046             allflag(i)=-1
16047           endif
16048         enddo
16049         goto 1
16050       endif
16051
16052 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16053
16054       newnss=0
16055       do i=1,allnss
16056         if (allflag(i).eq.1) then
16057           newnss=newnss+1
16058           newihpb(newnss)=allihpb(i)
16059           newjhpb(newnss)=alljhpb(i)
16060         endif
16061       enddo
16062
16063 #ifdef MPI
16064       if (nfgtasks.gt.1)then
16065
16066         call MPI_Reduce(newnss,g_newnss,1,&
16067           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
16068         call MPI_Gather(newnss,1,MPI_INTEGER,&
16069                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
16070         displ(0)=0
16071         do i=1,nfgtasks-1,1
16072           displ(i)=i_newnss(i-1)+displ(i-1)
16073         enddo
16074         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
16075                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
16076                          king,FG_COMM,IERR)
16077         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
16078                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
16079                          king,FG_COMM,IERR)
16080         if(fg_rank.eq.0) then
16081 !         print *,'g_newnss',g_newnss
16082 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
16083 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
16084          newnss=g_newnss
16085          do i=1,newnss
16086           newihpb(i)=g_newihpb(i)
16087           newjhpb(i)=g_newjhpb(i)
16088          enddo
16089         endif
16090       endif
16091 #endif
16092
16093       diff=newnss-nss
16094
16095 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
16096
16097       do i=1,nss
16098         found=.false.
16099         do j=1,newnss
16100           if (idssb(i).eq.newihpb(j) .and. &
16101                jdssb(i).eq.newjhpb(j)) found=.true.
16102         enddo
16103 #ifndef CLUST
16104 #ifndef WHAM
16105         if (.not.found.and.fg_rank.eq.0) &
16106             write(iout,'(a15,f12.2,f8.1,2i5)') &
16107              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
16108 #endif
16109 #endif
16110       enddo
16111
16112       do i=1,newnss
16113         found=.false.
16114         do j=1,nss
16115           if (newihpb(i).eq.idssb(j) .and. &
16116                newjhpb(i).eq.jdssb(j)) found=.true.
16117         enddo
16118 #ifndef CLUST
16119 #ifndef WHAM
16120         if (.not.found.and.fg_rank.eq.0) &
16121             write(iout,'(a15,f12.2,f8.1,2i5)') &
16122              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
16123 #endif
16124 #endif
16125       enddo
16126
16127       nss=newnss
16128       do i=1,nss
16129         idssb(i)=newihpb(i)
16130         jdssb(i)=newjhpb(i)
16131       enddo
16132
16133       return
16134       end subroutine dyn_set_nss
16135 !-----------------------------------------------------------------------------
16136 #ifdef WHAM
16137       subroutine read_ssHist
16138 !      implicit none
16139 !      Includes
16140 !      include 'DIMENSIONS'
16141 !      include "DIMENSIONS.FREE"
16142 !      include 'COMMON.FREE'
16143 !     Local variables
16144       integer :: i,j
16145       character(len=80) :: controlcard
16146
16147       do i=1,dyn_nssHist
16148         call card_concat(controlcard,.true.)
16149         read(controlcard,*) &
16150              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
16151       enddo
16152
16153       return
16154       end subroutine read_ssHist
16155 #endif
16156 !-----------------------------------------------------------------------------
16157       integer function indmat(i,j)
16158 !el
16159 ! get the position of the jth ijth fragment of the chain coordinate system
16160 ! in the fromto array.
16161         integer :: i,j
16162
16163         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
16164       return
16165       end function indmat
16166 !-----------------------------------------------------------------------------
16167       real(kind=8) function sigm(x)
16168 !el
16169        real(kind=8) :: x
16170         sigm=0.25d0*x
16171       return
16172       end function sigm
16173 !-----------------------------------------------------------------------------
16174 !-----------------------------------------------------------------------------
16175       subroutine alloc_ener_arrays
16176 !EL Allocation of arrays used by module energy
16177       use MD_data, only: mset
16178 !el local variables
16179       integer :: i,j
16180
16181       if(nres.lt.100) then
16182         maxconts=nres
16183       elseif(nres.lt.200) then
16184         maxconts=0.8*nres       ! Max. number of contacts per residue
16185       else
16186         maxconts=0.6*nres ! (maxconts=maxres/4)
16187       endif
16188       maxcont=12*nres   ! Max. number of SC contacts
16189       maxvar=6*nres     ! Max. number of variables
16190 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16191       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16192 !----------------------
16193 ! arrays in subroutine init_int_table
16194 !el#ifdef MPI
16195 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
16196 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
16197 !el#endif
16198       allocate(nint_gr(nres))
16199       allocate(nscp_gr(nres))
16200       allocate(ielstart(nres))
16201       allocate(ielend(nres))
16202 !(maxres)
16203       allocate(istart(nres,maxint_gr))
16204       allocate(iend(nres,maxint_gr))
16205 !(maxres,maxint_gr)
16206       allocate(iscpstart(nres,maxint_gr))
16207       allocate(iscpend(nres,maxint_gr))
16208 !(maxres,maxint_gr)
16209       allocate(ielstart_vdw(nres))
16210       allocate(ielend_vdw(nres))
16211 !(maxres)
16212
16213       allocate(lentyp(0:nfgtasks-1))
16214 !(0:maxprocs-1)
16215 !----------------------
16216 ! commom.contacts
16217 !      common /contacts/
16218       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
16219       allocate(icont(2,maxcont))
16220 !(2,maxcont)
16221 !      common /contacts1/
16222       allocate(num_cont(0:nres+4))
16223 !(maxres)
16224       allocate(jcont(maxconts,nres))
16225 !(maxconts,maxres)
16226       allocate(facont(maxconts,nres))
16227 !(maxconts,maxres)
16228       allocate(gacont(3,maxconts,nres))
16229 !(3,maxconts,maxres)
16230 !      common /contacts_hb/
16231       allocate(gacontp_hb1(3,maxconts,nres))
16232       allocate(gacontp_hb2(3,maxconts,nres))
16233       allocate(gacontp_hb3(3,maxconts,nres))
16234       allocate(gacontm_hb1(3,maxconts,nres))
16235       allocate(gacontm_hb2(3,maxconts,nres))
16236       allocate(gacontm_hb3(3,maxconts,nres))
16237       allocate(gacont_hbr(3,maxconts,nres))
16238       allocate(grij_hb_cont(3,maxconts,nres))
16239 !(3,maxconts,maxres)
16240       allocate(facont_hb(maxconts,nres))
16241       allocate(ees0p(maxconts,nres))
16242       allocate(ees0m(maxconts,nres))
16243       allocate(d_cont(maxconts,nres))
16244 !(maxconts,maxres)
16245       allocate(num_cont_hb(nres))
16246 !(maxres)
16247       allocate(jcont_hb(maxconts,nres))
16248 !(maxconts,maxres)
16249 !      common /rotat/
16250       allocate(Ug(2,2,nres))
16251       allocate(Ugder(2,2,nres))
16252       allocate(Ug2(2,2,nres))
16253       allocate(Ug2der(2,2,nres))
16254 !(2,2,maxres)
16255       allocate(obrot(2,nres))
16256       allocate(obrot2(2,nres))
16257       allocate(obrot_der(2,nres))
16258       allocate(obrot2_der(2,nres))
16259 !(2,maxres)
16260 !      common /precomp1/
16261       allocate(mu(2,nres))
16262       allocate(muder(2,nres))
16263       allocate(Ub2(2,nres))
16264       Ub2(1,:)=0.0d0
16265       Ub2(2,:)=0.0d0
16266       allocate(Ub2der(2,nres))
16267       allocate(Ctobr(2,nres))
16268       allocate(Ctobrder(2,nres))
16269       allocate(Dtobr2(2,nres))
16270       allocate(Dtobr2der(2,nres))
16271 !(2,maxres)
16272       allocate(EUg(2,2,nres))
16273       allocate(EUgder(2,2,nres))
16274       allocate(CUg(2,2,nres))
16275       allocate(CUgder(2,2,nres))
16276       allocate(DUg(2,2,nres))
16277       allocate(Dugder(2,2,nres))
16278       allocate(DtUg2(2,2,nres))
16279       allocate(DtUg2der(2,2,nres))
16280 !(2,2,maxres)
16281 !      common /precomp2/
16282       allocate(Ug2Db1t(2,nres))
16283       allocate(Ug2Db1tder(2,nres))
16284       allocate(CUgb2(2,nres))
16285       allocate(CUgb2der(2,nres))
16286 !(2,maxres)
16287       allocate(EUgC(2,2,nres))
16288       allocate(EUgCder(2,2,nres))
16289       allocate(EUgD(2,2,nres))
16290       allocate(EUgDder(2,2,nres))
16291       allocate(DtUg2EUg(2,2,nres))
16292       allocate(Ug2DtEUg(2,2,nres))
16293 !(2,2,maxres)
16294       allocate(Ug2DtEUgder(2,2,2,nres))
16295       allocate(DtUg2EUgder(2,2,2,nres))
16296 !(2,2,2,maxres)
16297 !      common /rotat_old/
16298       allocate(costab(nres))
16299       allocate(sintab(nres))
16300       allocate(costab2(nres))
16301       allocate(sintab2(nres))
16302 !(maxres)
16303 !      common /dipmat/
16304       allocate(a_chuj(2,2,maxconts,nres))
16305 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16306       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16307 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16308 !      common /contdistrib/
16309       allocate(ncont_sent(nres))
16310       allocate(ncont_recv(nres))
16311
16312       allocate(iat_sent(nres))
16313 !(maxres)
16314       allocate(iint_sent(4,nres,nres))
16315       allocate(iint_sent_local(4,nres,nres))
16316 !(4,maxres,maxres)
16317       allocate(iturn3_sent(4,0:nres+4))
16318       allocate(iturn4_sent(4,0:nres+4))
16319       allocate(iturn3_sent_local(4,nres))
16320       allocate(iturn4_sent_local(4,nres))
16321 !(4,maxres)
16322       allocate(itask_cont_from(0:nfgtasks-1))
16323       allocate(itask_cont_to(0:nfgtasks-1))
16324 !(0:max_fg_procs-1)
16325
16326
16327
16328 !----------------------
16329 ! commom.deriv;
16330 !      common /derivat/
16331       allocate(dcdv(6,maxdim))
16332       allocate(dxdv(6,maxdim))
16333 !(6,maxdim)
16334       allocate(dxds(6,nres))
16335 !(6,maxres)
16336       allocate(gradx(3,nres,0:2))
16337       allocate(gradc(3,nres,0:2))
16338 !(3,maxres,2)
16339       allocate(gvdwx(3,nres))
16340       allocate(gvdwc(3,nres))
16341       allocate(gelc(3,nres))
16342       allocate(gelc_long(3,nres))
16343       allocate(gvdwpp(3,nres))
16344       allocate(gvdwc_scpp(3,nres))
16345       allocate(gradx_scp(3,nres))
16346       allocate(gvdwc_scp(3,nres))
16347       allocate(ghpbx(3,nres))
16348       allocate(ghpbc(3,nres))
16349       allocate(gradcorr(3,nres))
16350       allocate(gradcorr_long(3,nres))
16351       allocate(gradcorr5_long(3,nres))
16352       allocate(gradcorr6_long(3,nres))
16353       allocate(gcorr6_turn_long(3,nres))
16354       allocate(gradxorr(3,nres))
16355       allocate(gradcorr5(3,nres))
16356       allocate(gradcorr6(3,nres))
16357 !(3,maxres)
16358       allocate(gloc(0:maxvar,0:2))
16359       allocate(gloc_x(0:maxvar,2))
16360 !(maxvar,2)
16361       allocate(gel_loc(3,nres))
16362       allocate(gel_loc_long(3,nres))
16363       allocate(gcorr3_turn(3,nres))
16364       allocate(gcorr4_turn(3,nres))
16365       allocate(gcorr6_turn(3,nres))
16366       allocate(gradb(3,nres))
16367       allocate(gradbx(3,nres))
16368 !(3,maxres)
16369       allocate(gel_loc_loc(maxvar))
16370       allocate(gel_loc_turn3(maxvar))
16371       allocate(gel_loc_turn4(maxvar))
16372       allocate(gel_loc_turn6(maxvar))
16373       allocate(gcorr_loc(maxvar))
16374       allocate(g_corr5_loc(maxvar))
16375       allocate(g_corr6_loc(maxvar))
16376 !(maxvar)
16377       allocate(gsccorc(3,nres))
16378       allocate(gsccorx(3,nres))
16379 !(3,maxres)
16380       allocate(gsccor_loc(nres))
16381 !(maxres)
16382       allocate(dtheta(3,2,nres))
16383 !(3,2,maxres)
16384       allocate(gscloc(3,nres))
16385       allocate(gsclocx(3,nres))
16386 !(3,maxres)
16387       allocate(dphi(3,3,nres))
16388       allocate(dalpha(3,3,nres))
16389       allocate(domega(3,3,nres))
16390 !(3,3,maxres)
16391 !      common /deriv_scloc/
16392       allocate(dXX_C1tab(3,nres))
16393       allocate(dYY_C1tab(3,nres))
16394       allocate(dZZ_C1tab(3,nres))
16395       allocate(dXX_Ctab(3,nres))
16396       allocate(dYY_Ctab(3,nres))
16397       allocate(dZZ_Ctab(3,nres))
16398       allocate(dXX_XYZtab(3,nres))
16399       allocate(dYY_XYZtab(3,nres))
16400       allocate(dZZ_XYZtab(3,nres))
16401 !(3,maxres)
16402 !      common /mpgrad/
16403       allocate(jgrad_start(nres))
16404       allocate(jgrad_end(nres))
16405 !(maxres)
16406 !----------------------
16407
16408 !      common /indices/
16409       allocate(ibond_displ(0:nfgtasks-1))
16410       allocate(ibond_count(0:nfgtasks-1))
16411       allocate(ithet_displ(0:nfgtasks-1))
16412       allocate(ithet_count(0:nfgtasks-1))
16413       allocate(iphi_displ(0:nfgtasks-1))
16414       allocate(iphi_count(0:nfgtasks-1))
16415       allocate(iphi1_displ(0:nfgtasks-1))
16416       allocate(iphi1_count(0:nfgtasks-1))
16417       allocate(ivec_displ(0:nfgtasks-1))
16418       allocate(ivec_count(0:nfgtasks-1))
16419       allocate(iset_displ(0:nfgtasks-1))
16420       allocate(iset_count(0:nfgtasks-1))
16421       allocate(iint_count(0:nfgtasks-1))
16422       allocate(iint_displ(0:nfgtasks-1))
16423 !(0:max_fg_procs-1)
16424 !----------------------
16425 ! common.MD
16426 !      common /mdgrad/
16427       allocate(gcart(3,0:nres))
16428       allocate(gxcart(3,0:nres))
16429 !(3,0:MAXRES)
16430       allocate(gradcag(3,nres))
16431       allocate(gradxag(3,nres))
16432 !(3,MAXRES)
16433 !      common /back_constr/
16434 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16435       allocate(dutheta(nres))
16436       allocate(dugamma(nres))
16437 !(maxres)
16438       allocate(duscdiff(3,nres))
16439       allocate(duscdiffx(3,nres))
16440 !(3,maxres)
16441 !el i io:read_fragments
16442 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16443 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16444 !      common /qmeas/
16445 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16446 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16447       allocate(mset(0:nprocs))  !(maxprocs/20)
16448       mset(:)=0
16449 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16450 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16451       allocate(dUdconst(3,0:nres))
16452       allocate(dUdxconst(3,0:nres))
16453       allocate(dqwol(3,0:nres))
16454       allocate(dxqwol(3,0:nres))
16455 !(3,0:MAXRES)
16456 !----------------------
16457 ! common.sbridge
16458 !      common /sbridge/ in io_common: read_bridge
16459 !el    allocate((:),allocatable :: iss  !(maxss)
16460 !      common /links/  in io_common: read_bridge
16461 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16462 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16463 !      common /dyn_ssbond/
16464 ! and side-chain vectors in theta or phi.
16465       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16466 !(maxres,maxres)
16467 !      do i=1,nres
16468 !        do j=i+1,nres
16469       dyn_ssbond_ij(:,:)=1.0d300
16470 !        enddo
16471 !      enddo
16472
16473       if (nss.gt.0) then
16474         allocate(idssb(nss),jdssb(nss))
16475 !(maxdim)
16476       endif
16477       allocate(dyn_ss_mask(nres))
16478 !(maxres)
16479       dyn_ss_mask(:)=.false.
16480 !----------------------
16481 ! common.sccor
16482 ! Parameters of the SCCOR term
16483 !      common/sccor/
16484 !el in io_conf: parmread
16485 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16486 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16487 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16488 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16489 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16490 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16491 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16492 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16493 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16494 !----------------
16495       allocate(gloc_sc(3,0:2*nres,0:10))
16496 !(3,0:maxres2,10)maxres2=2*maxres
16497       allocate(dcostau(3,3,3,2*nres))
16498       allocate(dsintau(3,3,3,2*nres))
16499       allocate(dtauangle(3,3,3,2*nres))
16500       allocate(dcosomicron(3,3,3,2*nres))
16501       allocate(domicron(3,3,3,2*nres))
16502 !(3,3,3,maxres2)maxres2=2*maxres
16503 !----------------------
16504 ! common.var
16505 !      common /restr/
16506       allocate(varall(maxvar))
16507 !(maxvar)(maxvar=6*maxres)
16508       allocate(mask_theta(nres))
16509       allocate(mask_phi(nres))
16510       allocate(mask_side(nres))
16511 !(maxres)
16512 !----------------------
16513 ! common.vectors
16514 !      common /vectors/
16515       allocate(uy(3,nres))
16516       allocate(uz(3,nres))
16517 !(3,maxres)
16518       allocate(uygrad(3,3,2,nres))
16519       allocate(uzgrad(3,3,2,nres))
16520 !(3,3,2,maxres)
16521
16522       return
16523       end subroutine alloc_ener_arrays
16524 !-----------------------------------------------------------------------------
16525 !-----------------------------------------------------------------------------
16526       end module energy