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 variables
  15       integer :: maxvar
  16 !-----------------------------------------------------------------------------
  17 ! Max number of torsional terms in SCCOR
  18       integer,parameter :: maxterm_sccor=6
  19 !-----------------------------------------------------------------------------
  20 ! Maximum number of SC local term fitting function coefficiants
  21       integer,parameter :: maxsccoef=65
  22 !-----------------------------------------------------------------------------
  23 ! commom.contacts
  24 !      common /contacts/
  25 ! Change 12/1/95 - common block CONTACTS1 included.
  26 !      common /contacts1/
  27       integer,dimension(:),allocatable :: num_cont      !(maxres)
  28       integer,dimension(:,:),allocatable :: jcont       !(maxconts,maxres)
  29       real(kind=8),dimension(:,:),allocatable :: facont !(maxconts,maxres)
  30       real(kind=8),dimension(:,:,:),allocatable :: gacont       !(3,maxconts,maxres)
  31 !
  32 ! 12/26/95 - H-bonding contacts
  33 !      common /contacts_hb/
  34       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  35        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont  !(3,maxconts,maxres)
  36       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  37         ees0m,d_cont    !(maxconts,maxres)
  38       integer,dimension(:),allocatable :: num_cont_hb   !(maxres)
  39       integer,dimension(:,:),allocatable :: jcont_hb    !(maxconts,maxres)
  40 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  41 !         interactions
  42 ! 7/25/08 commented out; not needed when cumulants used
  43 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  44 !  common /dipint/
  45       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  46          dipderg        !(4,maxconts,maxres)
  47       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  48 ! 10/30/99 Added other pre-computed vectors and matrices needed
  49 !          to calculate three - six-order el-loc correlation terms
  50 ! common /rotat/
  51       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der  !(2,2,maxres)
  52       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  53        obrot2_der       !(2,maxres)
  54 !
  55 ! This common block contains vectors and matrices dependent on a single
  56 ! amino-acid residue.
  57 !      common /precomp1/
  58       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  59        Ctobr,Ctobrder,Dtobr2,Dtobr2der  !(2,maxres)
  60       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  61        CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres)
  62 ! This common block contains vectors and matrices dependent on two
  63 ! consecutive amino-acid residues.
  64 !      common /precomp2/
  65       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  66        CUgb2,CUgb2der   !(2,maxres)
  67       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  68        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg   !(2,2,maxres)
  69       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  70        DtUg2EUgder      !(2,2,2,maxres)
  71 !      common /rotat_old/
  72       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  73        costab2,sintab2  !(maxres)
  74 ! This common block contains dipole-interaction matrices and their
  75 ! Cartesian derivatives.
  76 !      common /dipmat/
  77       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj     !(2,2,maxconts,maxres)
  78       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der     !(2,2,3,5,maxconts,maxres)
  79 !      common /diploc/
  80       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  81        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
  82       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
  83        ADtEA1derg,AEAb2derg
  84       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
  85        AECAderx,ADtEAderx,ADtEA1derx
  86       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
  87       real(kind=8),dimension(3,2) :: g_contij
  88       real(kind=8) :: ekont
  89 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
  90 !   RE: Parallelization of 4th and higher order loc-el correlations
  91 !      common /contdistrib/
  92       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
  93 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
  94 !-----------------------------------------------------------------------------
  95 ! commom.deriv;
  96 !      common /derivat/
  97 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
  98 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
  99 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 100       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 101         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 102         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 103         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6 !(3,maxres)
 104 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 105       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 106         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 107       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 108         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 109         g_corr6_loc     !(maxvar)
 110       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 111       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 112 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 113       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 114 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 115 !      integer :: nfl,icg
 116 !      common /deriv_loc/
 117       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 118 !      common /deriv_scloc/
 119       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 120        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 121        dZZ_XYZtab       !(3,maxres)
 122 !-----------------------------------------------------------------------------
 123 ! common.maxgrad
 124 !      common /maxgrad/
 125       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 126        gradb_max,ghpbc_max,&
 127        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 128        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 129        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 130        gsccorx_max,gsclocx_max
 131 !-----------------------------------------------------------------------------
 132 ! common.MD
 133 !      common /back_constr/
 134       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 135       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 136 !      common /qmeas/
 137       real(kind=8) :: Ucdfrag,Ucdpair
 138       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 139        dqwol,dxqwol     !(3,0:MAXRES)
 140 !-----------------------------------------------------------------------------
 141 ! common.sbridge
 142 !      common /dyn_ssbond/
 143       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 144 !-----------------------------------------------------------------------------
 145 ! common.sccor
 146 ! Parameters of the SCCOR term
 147 !      common/sccor/
 148       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 149        dcosomicron,domicron     !(3,3,3,maxres2)
 150 !-----------------------------------------------------------------------------
 151 ! common.vectors
 152 !      common /vectors/
 153       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 154       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 155 !-----------------------------------------------------------------------------
 156 ! common /przechowalnia/
 157       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 158       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 159 !-----------------------------------------------------------------------------
 160 !-----------------------------------------------------------------------------
 161 !
 162 !
 163 !-----------------------------------------------------------------------------
 164       contains
 165 !-----------------------------------------------------------------------------
 166 ! energy_p_new_barrier.F
 167 !-----------------------------------------------------------------------------
 168       subroutine etotal(energia)
 169 !      implicit real*8 (a-h,o-z)
 170 !      include 'DIMENSIONS'
 171       use MD_data, only: totT
 172 #ifndef ISNAN
 173       external proc_proc
 174 #ifdef WINPGI
 175 !MS$ATTRIBUTES C ::  proc_proc
 176 #endif
 177 #endif
 178 #ifdef MPI
 179       include "mpif.h"
 180 #endif
 181 !      include 'COMMON.SETUP'
 182 !      include 'COMMON.IOUNITS'
 183       real(kind=8),dimension(0:n_ene) :: energia
 184 !      include 'COMMON.LOCAL'
 185 !      include 'COMMON.FFIELD'
 186 !      include 'COMMON.DERIV'
 187 !      include 'COMMON.INTERACT'
 188 !      include 'COMMON.SBRIDGE'
 189 !      include 'COMMON.CHAIN'
 190 !      include 'COMMON.VAR'
 191 !      include 'COMMON.MD'
 192 !      include 'COMMON.CONTROL'
 193 !      include 'COMMON.TIME1'
 194       real(kind=8) :: time00
 195 !el local variables
 196       integer :: n_corr,n_corr1,ierror
 197       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 198       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 199       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe
 200       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 201
 202 #ifdef MPI
 203       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 204 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 205 !     & " nfgtasks",nfgtasks
 206       if (nfgtasks.gt.1) then
 207         time00=MPI_Wtime()
 208 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 209         if (fg_rank.eq.0) then
 210           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 211 !          print *,"Processor",myrank," BROADCAST iorder"
 212 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 213 ! FG slaves as WEIGHTS array.
 214           weights_(1)=wsc
 215           weights_(2)=wscp
 216           weights_(3)=welec
 217           weights_(4)=wcorr
 218           weights_(5)=wcorr5
 219           weights_(6)=wcorr6
 220           weights_(7)=wel_loc
 221           weights_(8)=wturn3
 222           weights_(9)=wturn4
 223           weights_(10)=wturn6
 224           weights_(11)=wang
 225           weights_(12)=wscloc
 226           weights_(13)=wtor
 227           weights_(14)=wtor_d
 228           weights_(15)=wstrain
 229           weights_(16)=wvdwpp
 230           weights_(17)=wbond
 231           weights_(18)=scal14
 232           weights_(21)=wsccor
 233 ! FG Master broadcasts the WEIGHTS_ array
 234           call MPI_Bcast(weights_(1),n_ene,&
 235              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 236         else
 237 ! FG slaves receive the WEIGHTS array
 238           call MPI_Bcast(weights(1),n_ene,&
 239               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 240           wsc=weights(1)
 241           wscp=weights(2)
 242           welec=weights(3)
 243           wcorr=weights(4)
 244           wcorr5=weights(5)
 245           wcorr6=weights(6)
 246           wel_loc=weights(7)
 247           wturn3=weights(8)
 248           wturn4=weights(9)
 249           wturn6=weights(10)
 250           wang=weights(11)
 251           wscloc=weights(12)
 252           wtor=weights(13)
 253           wtor_d=weights(14)
 254           wstrain=weights(15)
 255           wvdwpp=weights(16)
 256           wbond=weights(17)
 257           scal14=weights(18)
 258           wsccor=weights(21)
 259         endif
 260         time_Bcast=time_Bcast+MPI_Wtime()-time00
 261         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 262 !        call chainbuild_cart
 263       endif
 264 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 265 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 266 #else
 267 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 268 !        call int_from_cart1(.false.)
 269 !      endif
 270 #endif
 271 #ifdef TIMING
 272       time00=MPI_Wtime()
 273 #endif
 274 !
 275 ! Compute the side-chain and electrostatic interaction energy
 276 !
 277       goto (101,102,103,104,105,106) ipot
 278 ! Lennard-Jones potential.
 279   101 call elj(evdw)
 280 !d    print '(a)','Exit ELJcall el'
 281       goto 107
 282 ! Lennard-Jones-Kihara potential (shifted).
 283   102 call eljk(evdw)
 284       goto 107
 285 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 286   103 call ebp(evdw)
 287       goto 107
 288 ! Gay-Berne potential (shifted LJ, angular dependence).
 289   104 call egb(evdw)
 290       goto 107
 291 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 292   105 call egbv(evdw)
 293       goto 107
 294 ! Soft-sphere potential
 295   106 call e_softsphere(evdw)
 296 !
 297 ! Calculate electrostatic (H-bonding) energy of the main chain.
 298 !
 299   107 continue
 300
 301 !mc
 302 !mc Sep-06: egb takes care of dynamic ss bonds too
 303 !mc
 304 !      if (dyn_ss) call dyn_set_nss
 305 !      print *,"Processor",myrank," computed USCSC"
 306 #ifdef TIMING
 307       time01=MPI_Wtime()
 308 #endif
 309       call vec_and_deriv
 310 #ifdef TIMING
 311       time_vec=time_vec+MPI_Wtime()-time01
 312 #endif
 313 !      print *,"Processor",myrank," left VEC_AND_DERIV"
 314       if (ipot.lt.6) then
 315 #ifdef SPLITELE
 316          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 317              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 318              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 319              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 320 #else
 321          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 322              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 323              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 324              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 325 #endif
 326             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 327          else
 328             ees=0.0d0
 329             evdw1=0.0d0
 330             eel_loc=0.0d0
 331             eello_turn3=0.0d0
 332             eello_turn4=0.0d0
 333          endif
 334       else
 335 !        write (iout,*) "Soft-spheer ELEC potential"
 336         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 337          eello_turn4)
 338       endif
 339 !      print *,"Processor",myrank," computed UELEC"
 340 !
 341 ! Calculate excluded-volume interaction energy between peptide groups
 342 ! and side chains.
 343 !
 344
 345       if (ipot.lt.6) then
 346        if(wscp.gt.0d0) then
 347         call escp(evdw2,evdw2_14)
 348        else
 349         evdw2=0
 350         evdw2_14=0
 351        endif
 352       else
 353 !        write (iout,*) "Soft-sphere SCP potential"
 354         call escp_soft_sphere(evdw2,evdw2_14)
 355       endif
 356
 357 !
 358 ! Calculate the bond-stretching energy
 359 !
 360       call ebond(estr)
 361 !
 362 ! Calculate the disulfide-bridge and other energy and the contributions
 363 ! from other distance constraints.
 364       print *,'Calling EHPB'
 365       call edis(ehpb)
 366 !      print *,'EHPB exitted succesfully.'
 367 !
 368 ! Calculate the virtual-bond-angle energy.
 369 !
 370       if (wang.gt.0d0) then
 371         call ebend(ebe)
 372       else
 373         ebe=0
 374       endif
 375 !      print *,"Processor",myrank," computed UB"
 376 !
 377 ! Calculate the SC local energy.
 378 !
 379       call esc(escloc)
 380 !      print *,"Processor",myrank," computed USC"
 381 !
 382 ! Calculate the virtual-bond torsional energy.
 383 !
 384 !d    print *,'nterm=',nterm
 385       if (wtor.gt.0) then
 386        call etor(etors,edihcnstr)
 387       else
 388        etors=0
 389        edihcnstr=0
 390       endif
 391 !      print *,"Processor",myrank," computed Utor"
 392 !
 393 ! 6/23/01 Calculate double-torsional energy
 394 !
 395       if (wtor_d.gt.0) then
 396        call etor_d(etors_d)
 397       else
 398        etors_d=0
 399       endif
 400 !      print *,"Processor",myrank," computed Utord"
 401 !
 402 ! 21/5/07 Calculate local sicdechain correlation energy
 403 !
 404       if (wsccor.gt.0.0d0) then
 405         call eback_sc_corr(esccor)
 406       else
 407         esccor=0.0d0
 408       endif
 409 !      print *,"Processor",myrank," computed Usccorr"
 410 !
 411 ! 12/1/95 Multi-body terms
 412 !
 413       n_corr=0
 414       n_corr1=0
 415       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 416           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 417          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 418 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 419 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 420       else
 421          ecorr=0.0d0
 422          ecorr5=0.0d0
 423          ecorr6=0.0d0
 424          eturn6=0.0d0
 425       endif
 426       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 427          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 428 !d         write (iout,*) "multibody_hb ecorr",ecorr
 429       endif
 430
 431 !      print *,"Processor",myrank," computed Ucorr"
 432 !
 433 ! If performing constraint dynamics, call the constraint energy
 434 !  after the equilibration time
 435       if(usampl.and.totT.gt.eq_time) then
 436          call EconstrQ
 437          call Econstr_back
 438       else
 439          Uconst=0.0d0
 440          Uconst_back=0.0d0
 441       endif
 442
 443 #ifdef TIMING
 444       time_enecalc=time_enecalc+MPI_Wtime()-time00
 445 #endif
 446 !      print *,"Processor",myrank," computed Uconstr"
 447 #ifdef TIMING
 448       time00=MPI_Wtime()
 449 #endif
 450 !
 451 ! Sum the energies
 452 !
 453       energia(1)=evdw
 454 #ifdef SCP14
 455       energia(2)=evdw2-evdw2_14
 456       energia(18)=evdw2_14
 457 #else
 458       energia(2)=evdw2
 459       energia(18)=0.0d0
 460 #endif
 461 #ifdef SPLITELE
 462       energia(3)=ees
 463       energia(16)=evdw1
 464 #else
 465       energia(3)=ees+evdw1
 466       energia(16)=0.0d0
 467 #endif
 468       energia(4)=ecorr
 469       energia(5)=ecorr5
 470       energia(6)=ecorr6
 471       energia(7)=eel_loc
 472       energia(8)=eello_turn3
 473       energia(9)=eello_turn4
 474       energia(10)=eturn6
 475       energia(11)=ebe
 476       energia(12)=escloc
 477       energia(13)=etors
 478       energia(14)=etors_d
 479       energia(15)=ehpb
 480       energia(19)=edihcnstr
 481       energia(17)=estr
 482       energia(20)=Uconst+Uconst_back
 483       energia(21)=esccor
 484 !    Here are the energies showed per procesor if the are more processors
 485 !    per molecule then we sum it up in sum_energy subroutine
 486 !      print *," Processor",myrank," calls SUM_ENERGY"
 487       call sum_energy(energia,.true.)
 488       if (dyn_ss) call dyn_set_nss
 489 !      print *," Processor",myrank," left SUM_ENERGY"
 490 #ifdef TIMING
 491       time_sumene=time_sumene+MPI_Wtime()-time00
 492 #endif
 493       return
 494       end subroutine etotal
 495 !-----------------------------------------------------------------------------
 496       subroutine sum_energy(energia,reduce)
 497 !      implicit real*8 (a-h,o-z)
 498 !      include 'DIMENSIONS'
 499 #ifndef ISNAN
 500       external proc_proc
 501 #ifdef WINPGI
 502 !MS$ATTRIBUTES C ::  proc_proc
 503 #endif
 504 #endif
 505 #ifdef MPI
 506       include "mpif.h"
 507 #endif
 508 !      include 'COMMON.SETUP'
 509 !      include 'COMMON.IOUNITS'
 510       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 511 !      include 'COMMON.FFIELD'
 512 !      include 'COMMON.DERIV'
 513 !      include 'COMMON.INTERACT'
 514 !      include 'COMMON.SBRIDGE'
 515 !      include 'COMMON.CHAIN'
 516 !      include 'COMMON.VAR'
 517 !      include 'COMMON.CONTROL'
 518 !      include 'COMMON.TIME1'
 519       logical :: reduce
 520       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 521       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 522       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot
 523       integer :: i
 524 #ifdef MPI
 525       integer :: ierr
 526       real(kind=8) :: time00
 527       if (nfgtasks.gt.1 .and. reduce) then
 528 !el #define DEBUG
 529 #ifdef DEBUG
 530         write (iout,*) "energies before REDUCE"
 531         call enerprint(energia)
 532         call flush(iout)
 533 #endif
 534         do i=0,n_ene
 535           enebuff(i)=energia(i)
 536         enddo
 537         time00=MPI_Wtime()
 538         call MPI_Barrier(FG_COMM,IERR)
 539         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 540         time00=MPI_Wtime()
 541         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 542           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 543 #ifdef DEBUG
 544         write (iout,*) "energies after REDUCE"
 545         call enerprint(energia)
 546         call flush(iout)
 547 #endif
 548         time_Reduce=time_Reduce+MPI_Wtime()-time00
 549       endif
 550       if (fg_rank.eq.0) then
 551 #endif
 552       evdw=energia(1)
 553 #ifdef SCP14
 554       evdw2=energia(2)+energia(18)
 555       evdw2_14=energia(18)
 556 #else
 557       evdw2=energia(2)
 558 #endif
 559 #ifdef SPLITELE
 560       ees=energia(3)
 561       evdw1=energia(16)
 562 #else
 563       ees=energia(3)
 564       evdw1=0.0d0
 565 #endif
 566       ecorr=energia(4)
 567       ecorr5=energia(5)
 568       ecorr6=energia(6)
 569       eel_loc=energia(7)
 570       eello_turn3=energia(8)
 571       eello_turn4=energia(9)
 572       eturn6=energia(10)
 573       ebe=energia(11)
 574       escloc=energia(12)
 575       etors=energia(13)
 576       etors_d=energia(14)
 577       ehpb=energia(15)
 578       edihcnstr=energia(19)
 579       estr=energia(17)
 580       Uconst=energia(20)
 581       esccor=energia(21)
 582 #ifdef SPLITELE
 583       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 584        +wang*ebe+wtor*etors+wscloc*escloc &
 585        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 586        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 587        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 588        +wbond*estr+Uconst+wsccor*esccor
 589 #else
 590       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 591        +wang*ebe+wtor*etors+wscloc*escloc &
 592        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 593        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 594        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 595        +wbond*estr+Uconst+wsccor*esccor
 596 #endif
 597       energia(0)=etot
 598 ! detecting NaNQ
 599 #ifdef ISNAN
 600 #ifdef AIX
 601       if (isnan(etot).ne.0) energia(0)=1.0d+99
 602 #else
 603       if (isnan(etot)) energia(0)=1.0d+99
 604 #endif
 605 #else
 606       i=0
 607 #ifdef WINPGI
 608       idumm=proc_proc(etot,i)
 609 #else
 610       call proc_proc(etot,i)
 611 #endif
 612       if(i.eq.1)energia(0)=1.0d+99
 613 #endif
 614 #ifdef MPI
 615       endif
 616 #endif
 617 !el #undef DUBUG
 618       call flush(iout)
 619       return
 620       end subroutine sum_energy
 621 !-----------------------------------------------------------------------------
 622       subroutine rescale_weights(t_bath)
 623 !      implicit real*8 (a-h,o-z)
 624 #ifdef MPI
 625       include 'mpif.h'
 626 #endif
 627 !      include 'DIMENSIONS'
 628 !      include 'COMMON.IOUNITS'
 629 !      include 'COMMON.FFIELD'
 630 !      include 'COMMON.SBRIDGE'
 631       real(kind=8) :: kfac=2.4d0
 632       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 633 !el local variables
 634       real(kind=8) :: t_bath,facT,facT2,facT3,facT4,facT5
 635       integer :: ierror
 636 !      facT=temp0/t_bath
 637 !      facT=2*temp0/(t_bath+temp0)
 638       if (rescale_mode.eq.0) then
 639         facT=1.0d0
 640         facT2=1.0d0
 641         facT3=1.0d0
 642         facT4=1.0d0
 643         facT5=1.0d0
 644       else if (rescale_mode.eq.1) then
 645         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 646         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 647         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 648         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 649         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 650       else if (rescale_mode.eq.2) then
 651         x=t_bath/temp0
 652         x2=x*x
 653         x3=x2*x
 654         x4=x3*x
 655         x5=x4*x
 656         facT=licznik/dlog(dexp(x)+dexp(-x))
 657         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 658         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 659         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 660         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 661       else
 662         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 663         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 664 #ifdef MPI
 665        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 666 #endif
 667        stop 555
 668       endif
 669       welec=weights(3)*fact
 670       wcorr=weights(4)*fact3
 671       wcorr5=weights(5)*fact4
 672       wcorr6=weights(6)*fact5
 673       wel_loc=weights(7)*fact2
 674       wturn3=weights(8)*fact2
 675       wturn4=weights(9)*fact3
 676       wturn6=weights(10)*fact5
 677       wtor=weights(13)*fact
 678       wtor_d=weights(14)*fact2
 679       wsccor=weights(21)*fact
 680
 681       return
 682       end subroutine rescale_weights
 683 !-----------------------------------------------------------------------------
 684       subroutine enerprint(energia)
 685 !      implicit real*8 (a-h,o-z)
 686 !      include 'DIMENSIONS'
 687 !      include 'COMMON.IOUNITS'
 688 !      include 'COMMON.FFIELD'
 689 !      include 'COMMON.SBRIDGE'
 690 !      include 'COMMON.MD'
 691       real(kind=8) :: energia(0:n_ene)
 692 !el local variables
 693       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 694       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 695       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor
 696
 697       etot=energia(0)
 698       evdw=energia(1)
 699       evdw2=energia(2)
 700 #ifdef SCP14
 701       evdw2=energia(2)+energia(18)
 702 #else
 703       evdw2=energia(2)
 704 #endif
 705       ees=energia(3)
 706 #ifdef SPLITELE
 707       evdw1=energia(16)
 708 #endif
 709       ecorr=energia(4)
 710       ecorr5=energia(5)
 711       ecorr6=energia(6)
 712       eel_loc=energia(7)
 713       eello_turn3=energia(8)
 714       eello_turn4=energia(9)
 715       eello_turn6=energia(10)
 716       ebe=energia(11)
 717       escloc=energia(12)
 718       etors=energia(13)
 719       etors_d=energia(14)
 720       ehpb=energia(15)
 721       edihcnstr=energia(19)
 722       estr=energia(17)
 723       Uconst=energia(20)
 724       esccor=energia(21)
 725 #ifdef SPLITELE
 726       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 727         estr,wbond,ebe,wang,&
 728         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 729         ecorr,wcorr,&
 730         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 731         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 732         edihcnstr,ebr*nss,&
 733         Uconst,etot
 734    10 format (/'Virtual-chain energies:'// &
 735        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 736        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 737        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 738        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 739        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 740        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 741        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 742        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 743        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 744        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 745        ' (SS bridges & dist. cnstr.)'/ &
 746        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 747        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 748        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 749        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 750        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 751        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 752        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 753        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 754        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 755        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 756        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 757        'ETOT=  ',1pE16.6,' (total)')
 758 #else
 759       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 760         estr,wbond,ebe,wang,&
 761         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 762         ecorr,wcorr,&
 763         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 764         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 765         ebr*nss,Uconst,etot
 766    10 format (/'Virtual-chain energies:'// &
 767        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 768        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 769        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 770        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 771        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 772        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 773        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 774        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 775        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 776        ' (SS bridges & dist. cnstr.)'/ &
 777        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 778        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 779        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 780        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 781        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 782        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 783        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 784        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 785        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 786        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 787        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 788        'ETOT=  ',1pE16.6,' (total)')
 789 #endif
 790       return
 791       end subroutine enerprint
 792 !-----------------------------------------------------------------------------
 793       subroutine elj(evdw)
 794 !
 795 ! This subroutine calculates the interaction energy of nonbonded side chains
 796 ! assuming the LJ potential of interaction.
 797 !
 798 !      implicit real*8 (a-h,o-z)
 799 !      include 'DIMENSIONS'
 800       real(kind=8),parameter :: accur=1.0d-10
 801 !      include 'COMMON.GEO'
 802 !      include 'COMMON.VAR'
 803 !      include 'COMMON.LOCAL'
 804 !      include 'COMMON.CHAIN'
 805 !      include 'COMMON.DERIV'
 806 !      include 'COMMON.INTERACT'
 807 !      include 'COMMON.TORSION'
 808 !      include 'COMMON.SBRIDGE'
 809 !      include 'COMMON.NAMES'
 810 !      include 'COMMON.IOUNITS'
 811 !      include 'COMMON.CONTACTS'
 812       real(kind=8),dimension(3) :: gg
 813       integer :: num_conti
 814 !el local variables
 815       integer :: i,itypi,iint,j,itypi1,itypj,k
 816       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 817       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 818       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 819
 820 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 821       evdw=0.0D0
 822 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 823 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 824 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 825 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 826
 827       do i=iatsc_s,iatsc_e
 828         itypi=iabs(itype(i))
 829         if (itypi.eq.ntyp1) cycle
 830         itypi1=iabs(itype(i+1))
 831         xi=c(1,nres+i)
 832         yi=c(2,nres+i)
 833         zi=c(3,nres+i)
 834 ! Change 12/1/95
 835         num_conti=0
 836 !
 837 ! Calculate SC interaction energy.
 838 !
 839         do iint=1,nint_gr(i)
 840 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 841 !d   &                  'iend=',iend(i,iint)
 842           do j=istart(i,iint),iend(i,iint)
 843             itypj=iabs(itype(j))
 844             if (itypj.eq.ntyp1) cycle
 845             xj=c(1,nres+j)-xi
 846             yj=c(2,nres+j)-yi
 847             zj=c(3,nres+j)-zi
 848 ! Change 12/1/95 to calculate four-body interactions
 849             rij=xj*xj+yj*yj+zj*zj
 850             rrij=1.0D0/rij
 851 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 852             eps0ij=eps(itypi,itypj)
 853             fac=rrij**expon2
 854             e1=fac*fac*aa(itypi,itypj)
 855             e2=fac*bb(itypi,itypj)
 856             evdwij=e1+e2
 857 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 858 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 859 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 860 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 861 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 862 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 863             evdw=evdw+evdwij
 864 !
 865 ! Calculate the components of the gradient in DC and X
 866 !
 867             fac=-rrij*(e1+evdwij)
 868             gg(1)=xj*fac
 869             gg(2)=yj*fac
 870             gg(3)=zj*fac
 871             do k=1,3
 872               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 873               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 874               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 875               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 876             enddo
 877 !grad            do k=i,j-1
 878 !grad              do l=1,3
 879 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 880 !grad              enddo
 881 !grad            enddo
 882 !
 883 ! 12/1/95, revised on 5/20/97
 884 !
 885 ! Calculate the contact function. The ith column of the array JCONT will
 886 ! contain the numbers of atoms that make contacts with the atom I (of numbers
 887 ! greater than I). The arrays FACONT and GACONT will contain the values of
 888 ! the contact function and its derivative.
 889 !
 890 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
 891 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 892 ! Uncomment next line, if the correlation interactions are contact function only
 893             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 894               rij=dsqrt(rij)
 895               sigij=sigma(itypi,itypj)
 896               r0ij=rs0(itypi,itypj)
 897 !
 898 ! Check whether the SC's are not too far to make a contact.
 899 !
 900               rcut=1.5d0*r0ij
 901               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 902 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 903 !
 904               if (fcont.gt.0.0D0) then
 905 ! If the SC-SC distance if close to sigma, apply spline.
 906 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 907 !Adam &             fcont1,fprimcont1)
 908 !Adam           fcont1=1.0d0-fcont1
 909 !Adam           if (fcont1.gt.0.0d0) then
 910 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 911 !Adam             fcont=fcont*fcont1
 912 !Adam           endif
 913 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
 914 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
 915 !ga             do k=1,3
 916 !ga               gg(k)=gg(k)*eps0ij
 917 !ga             enddo
 918 !ga             eps0ij=-evdwij*eps0ij
 919 ! Uncomment for AL's type of SC correlation interactions.
 920 !adam           eps0ij=-evdwij
 921                 num_conti=num_conti+1
 922                 jcont(num_conti,i)=j
 923                 facont(num_conti,i)=fcont*eps0ij
 924                 fprimcont=eps0ij*fprimcont/rij
 925                 fcont=expon*fcont
 926 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 927 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 928 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 929 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
 930                 gacont(1,num_conti,i)=-fprimcont*xj
 931                 gacont(2,num_conti,i)=-fprimcont*yj
 932                 gacont(3,num_conti,i)=-fprimcont*zj
 933 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 934 !d              write (iout,'(2i3,3f10.5)')
 935 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 936               endif
 937             endif
 938           enddo      ! j
 939         enddo        ! iint
 940 ! Change 12/1/95
 941         num_cont(i)=num_conti
 942       enddo          ! i
 943       do i=1,nct
 944         do j=1,3
 945           gvdwc(j,i)=expon*gvdwc(j,i)
 946           gvdwx(j,i)=expon*gvdwx(j,i)
 947         enddo
 948       enddo
 949 !******************************************************************************
 950 !
 951 !                              N O T E !!!
 952 !
 953 ! To save time, the factor of EXPON has been extracted from ALL components
 954 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
 955 ! use!
 956 !
 957 !******************************************************************************
 958       return
 959       end subroutine elj
 960 !-----------------------------------------------------------------------------
 961       subroutine eljk(evdw)
 962 !
 963 ! This subroutine calculates the interaction energy of nonbonded side chains
 964 ! assuming the LJK potential of interaction.
 965 !
 966 !      implicit real*8 (a-h,o-z)
 967 !      include 'DIMENSIONS'
 968 !      include 'COMMON.GEO'
 969 !      include 'COMMON.VAR'
 970 !      include 'COMMON.LOCAL'
 971 !      include 'COMMON.CHAIN'
 972 !      include 'COMMON.DERIV'
 973 !      include 'COMMON.INTERACT'
 974 !      include 'COMMON.IOUNITS'
 975 !      include 'COMMON.NAMES'
 976       real(kind=8),dimension(3) :: gg
 977       logical :: scheck
 978 !el local variables
 979       integer :: i,iint,j,itypi,itypi1,k,itypj
 980       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
 981       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
 982
 983 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 984       evdw=0.0D0
 985       do i=iatsc_s,iatsc_e
 986         itypi=iabs(itype(i))
 987         if (itypi.eq.ntyp1) cycle
 988         itypi1=iabs(itype(i+1))
 989         xi=c(1,nres+i)
 990         yi=c(2,nres+i)
 991         zi=c(3,nres+i)
 992 !
 993 ! Calculate SC interaction energy.
 994 !
 995         do iint=1,nint_gr(i)
 996           do j=istart(i,iint),iend(i,iint)
 997             itypj=iabs(itype(j))
 998             if (itypj.eq.ntyp1) cycle
 999             xj=c(1,nres+j)-xi
1000             yj=c(2,nres+j)-yi
1001             zj=c(3,nres+j)-zi
1002             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1003             fac_augm=rrij**expon
1004             e_augm=augm(itypi,itypj)*fac_augm
1005             r_inv_ij=dsqrt(rrij)
1006             rij=1.0D0/r_inv_ij
1007             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1008             fac=r_shift_inv**expon
1009             e1=fac*fac*aa(itypi,itypj)
1010             e2=fac*bb(itypi,itypj)
1011             evdwij=e_augm+e1+e2
1012 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1013 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1014 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1015 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1016 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1017 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1018 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1019             evdw=evdw+evdwij
1020 !
1021 ! Calculate the components of the gradient in DC and X
1022 !
1023             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1024             gg(1)=xj*fac
1025             gg(2)=yj*fac
1026             gg(3)=zj*fac
1027             do k=1,3
1028               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1029               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1030               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1031               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1032             enddo
1033 !grad            do k=i,j-1
1034 !grad              do l=1,3
1035 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1036 !grad              enddo
1037 !grad            enddo
1038           enddo      ! j
1039         enddo        ! iint
1040       enddo          ! i
1041       do i=1,nct
1042         do j=1,3
1043           gvdwc(j,i)=expon*gvdwc(j,i)
1044           gvdwx(j,i)=expon*gvdwx(j,i)
1045         enddo
1046       enddo
1047       return
1048       end subroutine eljk
1049 !-----------------------------------------------------------------------------
1050       subroutine ebp(evdw)
1051 !
1052 ! This subroutine calculates the interaction energy of nonbonded side chains
1053 ! assuming the Berne-Pechukas potential of interaction.
1054 !
1055       use comm_srutu
1056       use calc_data
1057 !      implicit real*8 (a-h,o-z)
1058 !      include 'DIMENSIONS'
1059 !      include 'COMMON.GEO'
1060 !      include 'COMMON.VAR'
1061 !      include 'COMMON.LOCAL'
1062 !      include 'COMMON.CHAIN'
1063 !      include 'COMMON.DERIV'
1064 !      include 'COMMON.NAMES'
1065 !      include 'COMMON.INTERACT'
1066 !      include 'COMMON.IOUNITS'
1067 !      include 'COMMON.CALC'
1068       use comm_srutu
1069 !el      integer :: icall
1070 !el      common /srutu/ icall
1071 !     double precision rrsave(maxdim)
1072       logical :: lprn
1073 !el local variables
1074       integer :: iint,itypi,itypi1,itypj
1075       real(kind=8) :: rrij,xi,yi,zi
1076       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1077
1078 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1079       evdw=0.0D0
1080 !     if (icall.eq.0) then
1081 !       lprn=.true.
1082 !     else
1083         lprn=.false.
1084 !     endif
1085 !el      ind=0
1086       do i=iatsc_s,iatsc_e
1087         itypi=iabs(itype(i))
1088         if (itypi.eq.ntyp1) cycle
1089         itypi1=iabs(itype(i+1))
1090         xi=c(1,nres+i)
1091         yi=c(2,nres+i)
1092         zi=c(3,nres+i)
1093         dxi=dc_norm(1,nres+i)
1094         dyi=dc_norm(2,nres+i)
1095         dzi=dc_norm(3,nres+i)
1096 !        dsci_inv=dsc_inv(itypi)
1097         dsci_inv=vbld_inv(i+nres)
1098 !
1099 ! Calculate SC interaction energy.
1100 !
1101         do iint=1,nint_gr(i)
1102           do j=istart(i,iint),iend(i,iint)
1103 !el            ind=ind+1
1104             itypj=iabs(itype(j))
1105             if (itypj.eq.ntyp1) cycle
1106 !            dscj_inv=dsc_inv(itypj)
1107             dscj_inv=vbld_inv(j+nres)
1108             chi1=chi(itypi,itypj)
1109             chi2=chi(itypj,itypi)
1110             chi12=chi1*chi2
1111             chip1=chip(itypi)
1112             chip2=chip(itypj)
1113             chip12=chip1*chip2
1114             alf1=alp(itypi)
1115             alf2=alp(itypj)
1116             alf12=0.5D0*(alf1+alf2)
1117 ! For diagnostics only!!!
1118 !           chi1=0.0D0
1119 !           chi2=0.0D0
1120 !           chi12=0.0D0
1121 !           chip1=0.0D0
1122 !           chip2=0.0D0
1123 !           chip12=0.0D0
1124 !           alf1=0.0D0
1125 !           alf2=0.0D0
1126 !           alf12=0.0D0
1127             xj=c(1,nres+j)-xi
1128             yj=c(2,nres+j)-yi
1129             zj=c(3,nres+j)-zi
1130             dxj=dc_norm(1,nres+j)
1131             dyj=dc_norm(2,nres+j)
1132             dzj=dc_norm(3,nres+j)
1133             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1134 !d          if (icall.eq.0) then
1135 !d            rrsave(ind)=rrij
1136 !d          else
1137 !d            rrij=rrsave(ind)
1138 !d          endif
1139             rij=dsqrt(rrij)
1140 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1141             call sc_angular
1142 ! Calculate whole angle-dependent part of epsilon and contributions
1143 ! to its derivatives
1144             fac=(rrij*sigsq)**expon2
1145             e1=fac*fac*aa(itypi,itypj)
1146             e2=fac*bb(itypi,itypj)
1147             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1148             eps2der=evdwij*eps3rt
1149             eps3der=evdwij*eps2rt
1150             evdwij=evdwij*eps2rt*eps3rt
1151             evdw=evdw+evdwij
1152             if (lprn) then
1153             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1154             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1155 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1156 !d     &        restyp(itypi),i,restyp(itypj),j,
1157 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1158 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1159 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1160 !d     &        evdwij
1161             endif
1162 ! Calculate gradient components.
1163             e1=e1*eps1*eps2rt**2*eps3rt**2
1164             fac=-expon*(e1+evdwij)
1165             sigder=fac/sigsq
1166             fac=rrij*fac
1167 ! Calculate radial part of the gradient
1168             gg(1)=xj*fac
1169             gg(2)=yj*fac
1170             gg(3)=zj*fac
1171 ! Calculate the angular part of the gradient and sum add the contributions
1172 ! to the appropriate components of the Cartesian gradient.
1173             call sc_grad
1174           enddo      ! j
1175         enddo        ! iint
1176       enddo          ! i
1177 !     stop
1178       return
1179       end subroutine ebp
1180 !-----------------------------------------------------------------------------
1181       subroutine egb(evdw)
1182 !
1183 ! This subroutine calculates the interaction energy of nonbonded side chains
1184 ! assuming the Gay-Berne potential of interaction.
1185 !
1186       use calc_data
1187 !      implicit real*8 (a-h,o-z)
1188 !      include 'DIMENSIONS'
1189 !      include 'COMMON.GEO'
1190 !      include 'COMMON.VAR'
1191 !      include 'COMMON.LOCAL'
1192 !      include 'COMMON.CHAIN'
1193 !      include 'COMMON.DERIV'
1194 !      include 'COMMON.NAMES'
1195 !      include 'COMMON.INTERACT'
1196 !      include 'COMMON.IOUNITS'
1197 !      include 'COMMON.CALC'
1198 !      include 'COMMON.CONTROL'
1199 !      include 'COMMON.SBRIDGE'
1200       logical :: lprn
1201 !el local variables
1202       integer :: iint,itypi,itypi1,itypj
1203       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1204       real(kind=8) :: evdw,sig0ij
1205
1206 !cccc      energy_dec=.false.
1207 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1208       evdw=0.0D0
1209       lprn=.false.
1210 !     if (icall.eq.0) lprn=.false.
1211 !el      ind=0
1212       do i=iatsc_s,iatsc_e
1213         itypi=iabs(itype(i))
1214         if (itypi.eq.ntyp1) cycle
1215         itypi1=iabs(itype(i+1))
1216         xi=c(1,nres+i)
1217         yi=c(2,nres+i)
1218         zi=c(3,nres+i)
1219         dxi=dc_norm(1,nres+i)
1220         dyi=dc_norm(2,nres+i)
1221         dzi=dc_norm(3,nres+i)
1222 !        dsci_inv=dsc_inv(itypi)
1223         dsci_inv=vbld_inv(i+nres)
1224 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1225 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1226 !
1227 ! Calculate SC interaction energy.
1228 !
1229         do iint=1,nint_gr(i)
1230           do j=istart(i,iint),iend(i,iint)
1231             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1232               call dyn_ssbond_ene(i,j,evdwij)
1233               evdw=evdw+evdwij
1234               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1235                               'evdw',i,j,evdwij,' ss'
1236             ELSE
1237 !el            ind=ind+1
1238             itypj=iabs(itype(j))
1239             if (itypj.eq.ntyp1) cycle
1240 !            dscj_inv=dsc_inv(itypj)
1241             dscj_inv=vbld_inv(j+nres)
1242 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1243 !     &       1.0d0/vbld(j+nres)
1244 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1245             sig0ij=sigma(itypi,itypj)
1246             chi1=chi(itypi,itypj)
1247             chi2=chi(itypj,itypi)
1248             chi12=chi1*chi2
1249             chip1=chip(itypi)
1250             chip2=chip(itypj)
1251             chip12=chip1*chip2
1252             alf1=alp(itypi)
1253             alf2=alp(itypj)
1254             alf12=0.5D0*(alf1+alf2)
1255 ! For diagnostics only!!!
1256 !           chi1=0.0D0
1257 !           chi2=0.0D0
1258 !           chi12=0.0D0
1259 !           chip1=0.0D0
1260 !           chip2=0.0D0
1261 !           chip12=0.0D0
1262 !           alf1=0.0D0
1263 !           alf2=0.0D0
1264 !           alf12=0.0D0
1265             xj=c(1,nres+j)-xi
1266             yj=c(2,nres+j)-yi
1267             zj=c(3,nres+j)-zi
1268             dxj=dc_norm(1,nres+j)
1269             dyj=dc_norm(2,nres+j)
1270             dzj=dc_norm(3,nres+j)
1271 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1272 !            write (iout,*) "j",j," dc_norm",
1273 !     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1274             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1275             rij=dsqrt(rrij)
1276 ! Calculate angle-dependent terms of energy and contributions to their
1277 ! derivatives.
1278             call sc_angular
1279             sigsq=1.0D0/sigsq
1280             sig=sig0ij*dsqrt(sigsq)
1281             rij_shift=1.0D0/rij-sig+sig0ij
1282 ! for diagnostics; uncomment
1283 !            rij_shift=1.2*sig0ij
1284 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1285             if (rij_shift.le.0.0D0) then
1286               evdw=1.0D20
1287 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1288 !d     &        restyp(itypi),i,restyp(itypj),j,
1289 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1290               return
1291             endif
1292             sigder=-sig*sigsq
1293 !---------------------------------------------------------------
1294             rij_shift=1.0D0/rij_shift
1295             fac=rij_shift**expon
1296             e1=fac*fac*aa(itypi,itypj)
1297             e2=fac*bb(itypi,itypj)
1298             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1299             eps2der=evdwij*eps3rt
1300             eps3der=evdwij*eps2rt
1301 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,&
1302 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1303             evdwij=evdwij*eps2rt*eps3rt
1304             evdw=evdw+evdwij
1305             if (lprn) then
1306             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1307             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1308             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1309               restyp(itypi),i,restyp(itypj),j, &
1310               epsi,sigm,chi1,chi2,chip1,chip2, &
1311               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1312               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1313               evdwij
1314             endif
1315
1316             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
1317                              'evdw',i,j,evdwij
1318
1319 ! Calculate gradient components.
1320             e1=e1*eps1*eps2rt**2*eps3rt**2
1321             fac=-expon*(e1+evdwij)*rij_shift
1322             sigder=fac*sigder
1323             fac=rij*fac
1324 !            fac=0.0d0
1325 ! Calculate the radial part of the gradient
1326             gg(1)=xj*fac
1327             gg(2)=yj*fac
1328             gg(3)=zj*fac
1329 ! Calculate angular part of the gradient.
1330             call sc_grad
1331             ENDIF    ! dyn_ss
1332           enddo      ! j
1333         enddo        ! iint
1334       enddo          ! i
1335 !      write (iout,*) "Number of loop steps in EGB:",ind
1336 !ccc      energy_dec=.false.
1337       return
1338       end subroutine egb
1339 !-----------------------------------------------------------------------------
1340       subroutine egbv(evdw)
1341 !
1342 ! This subroutine calculates the interaction energy of nonbonded side chains
1343 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1344 !
1345       use comm_srutu
1346       use calc_data
1347 !      implicit real*8 (a-h,o-z)
1348 !      include 'DIMENSIONS'
1349 !      include 'COMMON.GEO'
1350 !      include 'COMMON.VAR'
1351 !      include 'COMMON.LOCAL'
1352 !      include 'COMMON.CHAIN'
1353 !      include 'COMMON.DERIV'
1354 !      include 'COMMON.NAMES'
1355 !      include 'COMMON.INTERACT'
1356 !      include 'COMMON.IOUNITS'
1357 !      include 'COMMON.CALC'
1358       use comm_srutu
1359 !el      integer :: icall
1360 !el      common /srutu/ icall
1361       logical :: lprn
1362 !el local variables
1363       integer :: iint,itypi,itypi1,itypj
1364       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1365       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1366
1367 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1368       evdw=0.0D0
1369       lprn=.false.
1370 !     if (icall.eq.0) lprn=.true.
1371 !el      ind=0
1372       do i=iatsc_s,iatsc_e
1373         itypi=iabs(itype(i))
1374         if (itypi.eq.ntyp1) cycle
1375         itypi1=iabs(itype(i+1))
1376         xi=c(1,nres+i)
1377         yi=c(2,nres+i)
1378         zi=c(3,nres+i)
1379         dxi=dc_norm(1,nres+i)
1380         dyi=dc_norm(2,nres+i)
1381         dzi=dc_norm(3,nres+i)
1382 !        dsci_inv=dsc_inv(itypi)
1383         dsci_inv=vbld_inv(i+nres)
1384 !
1385 ! Calculate SC interaction energy.
1386 !
1387         do iint=1,nint_gr(i)
1388           do j=istart(i,iint),iend(i,iint)
1389 !el            ind=ind+1
1390             itypj=iabs(itype(j))
1391             if (itypj.eq.ntyp1) cycle
1392 !            dscj_inv=dsc_inv(itypj)
1393             dscj_inv=vbld_inv(j+nres)
1394             sig0ij=sigma(itypi,itypj)
1395             r0ij=r0(itypi,itypj)
1396             chi1=chi(itypi,itypj)
1397             chi2=chi(itypj,itypi)
1398             chi12=chi1*chi2
1399             chip1=chip(itypi)
1400             chip2=chip(itypj)
1401             chip12=chip1*chip2
1402             alf1=alp(itypi)
1403             alf2=alp(itypj)
1404             alf12=0.5D0*(alf1+alf2)
1405 ! For diagnostics only!!!
1406 !           chi1=0.0D0
1407 !           chi2=0.0D0
1408 !           chi12=0.0D0
1409 !           chip1=0.0D0
1410 !           chip2=0.0D0
1411 !           chip12=0.0D0
1412 !           alf1=0.0D0
1413 !           alf2=0.0D0
1414 !           alf12=0.0D0
1415             xj=c(1,nres+j)-xi
1416             yj=c(2,nres+j)-yi
1417             zj=c(3,nres+j)-zi
1418             dxj=dc_norm(1,nres+j)
1419             dyj=dc_norm(2,nres+j)
1420             dzj=dc_norm(3,nres+j)
1421             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1422             rij=dsqrt(rrij)
1423 ! Calculate angle-dependent terms of energy and contributions to their
1424 ! derivatives.
1425             call sc_angular
1426             sigsq=1.0D0/sigsq
1427             sig=sig0ij*dsqrt(sigsq)
1428             rij_shift=1.0D0/rij-sig+r0ij
1429 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1430             if (rij_shift.le.0.0D0) then
1431               evdw=1.0D20
1432               return
1433             endif
1434             sigder=-sig*sigsq
1435 !---------------------------------------------------------------
1436             rij_shift=1.0D0/rij_shift
1437             fac=rij_shift**expon
1438             e1=fac*fac*aa(itypi,itypj)
1439             e2=fac*bb(itypi,itypj)
1440             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1441             eps2der=evdwij*eps3rt
1442             eps3der=evdwij*eps2rt
1443             fac_augm=rrij**expon
1444             e_augm=augm(itypi,itypj)*fac_augm
1445             evdwij=evdwij*eps2rt*eps3rt
1446             evdw=evdw+evdwij+e_augm
1447             if (lprn) then
1448             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1449             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1450             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1451               restyp(itypi),i,restyp(itypj),j,&
1452               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1453               chi1,chi2,chip1,chip2,&
1454               eps1,eps2rt**2,eps3rt**2,&
1455               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1456               evdwij+e_augm
1457             endif
1458 ! Calculate gradient components.
1459             e1=e1*eps1*eps2rt**2*eps3rt**2
1460             fac=-expon*(e1+evdwij)*rij_shift
1461             sigder=fac*sigder
1462             fac=rij*fac-2*expon*rrij*e_augm
1463 ! Calculate the radial part of the gradient
1464             gg(1)=xj*fac
1465             gg(2)=yj*fac
1466             gg(3)=zj*fac
1467 ! Calculate angular part of the gradient.
1468             call sc_grad
1469           enddo      ! j
1470         enddo        ! iint
1471       enddo          ! i
1472       end subroutine egbv
1473 !-----------------------------------------------------------------------------
1474 !el      subroutine sc_angular in module geometry
1475 !-----------------------------------------------------------------------------
1476       subroutine e_softsphere(evdw)
1477 !
1478 ! This subroutine calculates the interaction energy of nonbonded side chains
1479 ! assuming the LJ potential of interaction.
1480 !
1481 !      implicit real*8 (a-h,o-z)
1482 !      include 'DIMENSIONS'
1483       real(kind=8),parameter :: accur=1.0d-10
1484 !      include 'COMMON.GEO'
1485 !      include 'COMMON.VAR'
1486 !      include 'COMMON.LOCAL'
1487 !      include 'COMMON.CHAIN'
1488 !      include 'COMMON.DERIV'
1489 !      include 'COMMON.INTERACT'
1490 !      include 'COMMON.TORSION'
1491 !      include 'COMMON.SBRIDGE'
1492 !      include 'COMMON.NAMES'
1493 !      include 'COMMON.IOUNITS'
1494 !      include 'COMMON.CONTACTS'
1495       real(kind=8),dimension(3) :: gg
1496 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1497 !el local variables
1498       integer :: i,iint,j,itypi,itypi1,itypj,k
1499       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1500       real(kind=8) :: fac
1501
1502       evdw=0.0D0
1503       do i=iatsc_s,iatsc_e
1504         itypi=iabs(itype(i))
1505         if (itypi.eq.ntyp1) cycle
1506         itypi1=iabs(itype(i+1))
1507         xi=c(1,nres+i)
1508         yi=c(2,nres+i)
1509         zi=c(3,nres+i)
1510 !
1511 ! Calculate SC interaction energy.
1512 !
1513         do iint=1,nint_gr(i)
1514 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1515 !d   &                  'iend=',iend(i,iint)
1516           do j=istart(i,iint),iend(i,iint)
1517             itypj=iabs(itype(j))
1518             if (itypj.eq.ntyp1) cycle
1519             xj=c(1,nres+j)-xi
1520             yj=c(2,nres+j)-yi
1521             zj=c(3,nres+j)-zi
1522             rij=xj*xj+yj*yj+zj*zj
1523 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1524             r0ij=r0(itypi,itypj)
1525             r0ijsq=r0ij*r0ij
1526 !            print *,i,j,r0ij,dsqrt(rij)
1527             if (rij.lt.r0ijsq) then
1528               evdwij=0.25d0*(rij-r0ijsq)**2
1529               fac=rij-r0ijsq
1530             else
1531               evdwij=0.0d0
1532               fac=0.0d0
1533             endif
1534             evdw=evdw+evdwij
1535 !
1536 ! Calculate the components of the gradient in DC and X
1537 !
1538             gg(1)=xj*fac
1539             gg(2)=yj*fac
1540             gg(3)=zj*fac
1541             do k=1,3
1542               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1543               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1544               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1545               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1546             enddo
1547 !grad            do k=i,j-1
1548 !grad              do l=1,3
1549 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1550 !grad              enddo
1551 !grad            enddo
1552           enddo ! j
1553         enddo ! iint
1554       enddo ! i
1555       return
1556       end subroutine e_softsphere
1557 !-----------------------------------------------------------------------------
1558       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1559 !
1560 ! Soft-sphere potential of p-p interaction
1561 !
1562 !      implicit real*8 (a-h,o-z)
1563 !      include 'DIMENSIONS'
1564 !      include 'COMMON.CONTROL'
1565 !      include 'COMMON.IOUNITS'
1566 !      include 'COMMON.GEO'
1567 !      include 'COMMON.VAR'
1568 !      include 'COMMON.LOCAL'
1569 !      include 'COMMON.CHAIN'
1570 !      include 'COMMON.DERIV'
1571 !      include 'COMMON.INTERACT'
1572 !      include 'COMMON.CONTACTS'
1573 !      include 'COMMON.TORSION'
1574 !      include 'COMMON.VECTORS'
1575 !      include 'COMMON.FFIELD'
1576       real(kind=8),dimension(3) :: ggg
1577 !d      write(iout,*) 'In EELEC_soft_sphere'
1578 !el local variables
1579       integer :: i,j,k,num_conti,iteli,itelj
1580       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1581       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1582       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1583
1584       ees=0.0D0
1585       evdw1=0.0D0
1586       eel_loc=0.0d0
1587       eello_turn3=0.0d0
1588       eello_turn4=0.0d0
1589 !el      ind=0
1590       do i=iatel_s,iatel_e
1591         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1592         dxi=dc(1,i)
1593         dyi=dc(2,i)
1594         dzi=dc(3,i)
1595         xmedi=c(1,i)+0.5d0*dxi
1596         ymedi=c(2,i)+0.5d0*dyi
1597         zmedi=c(3,i)+0.5d0*dzi
1598         num_conti=0
1599 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1600         do j=ielstart(i),ielend(i)
1601           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1602 !el          ind=ind+1
1603           iteli=itel(i)
1604           itelj=itel(j)
1605           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1606           r0ij=rpp(iteli,itelj)
1607           r0ijsq=r0ij*r0ij
1608           dxj=dc(1,j)
1609           dyj=dc(2,j)
1610           dzj=dc(3,j)
1611           xj=c(1,j)+0.5D0*dxj-xmedi
1612           yj=c(2,j)+0.5D0*dyj-ymedi
1613           zj=c(3,j)+0.5D0*dzj-zmedi
1614           rij=xj*xj+yj*yj+zj*zj
1615           if (rij.lt.r0ijsq) then
1616             evdw1ij=0.25d0*(rij-r0ijsq)**2
1617             fac=rij-r0ijsq
1618           else
1619             evdw1ij=0.0d0
1620             fac=0.0d0
1621           endif
1622           evdw1=evdw1+evdw1ij
1623 !
1624 ! Calculate contributions to the Cartesian gradient.
1625 !
1626           ggg(1)=fac*xj
1627           ggg(2)=fac*yj
1628           ggg(3)=fac*zj
1629           do k=1,3
1630             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1631             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1632           enddo
1633 !
1634 ! Loop over residues i+1 thru j-1.
1635 !
1636 !grad          do k=i+1,j-1
1637 !grad            do l=1,3
1638 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1639 !grad            enddo
1640 !grad          enddo
1641         enddo ! j
1642       enddo   ! i
1643 !grad      do i=nnt,nct-1
1644 !grad        do k=1,3
1645 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1646 !grad        enddo
1647 !grad        do j=i+1,nct-1
1648 !grad          do k=1,3
1649 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1650 !grad          enddo
1651 !grad        enddo
1652 !grad      enddo
1653       return
1654       end subroutine eelec_soft_sphere
1655 !-----------------------------------------------------------------------------
1656       subroutine vec_and_deriv
1657 !      implicit real*8 (a-h,o-z)
1658 !      include 'DIMENSIONS'
1659 #ifdef MPI
1660       include 'mpif.h'
1661 #endif
1662 !      include 'COMMON.IOUNITS'
1663 !      include 'COMMON.GEO'
1664 !      include 'COMMON.VAR'
1665 !      include 'COMMON.LOCAL'
1666 !      include 'COMMON.CHAIN'
1667 !      include 'COMMON.VECTORS'
1668 !      include 'COMMON.SETUP'
1669 !      include 'COMMON.TIME1'
1670       real(kind=8),dimension(3,3,2) :: uyder,uzder
1671       real(kind=8),dimension(2) :: vbld_inv_temp
1672 ! Compute the local reference systems. For reference system (i), the
1673 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1674 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1675 !el local variables
1676       integer :: i,j,k,l
1677       real(kind=8) :: facy,fac,costh
1678
1679 #ifdef PARVEC
1680       do i=ivec_start,ivec_end
1681 #else
1682       do i=1,nres-1
1683 #endif
1684           if (i.eq.nres-1) then
1685 ! Case of the last full residue
1686 ! Compute the Z-axis
1687             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1688             costh=dcos(pi-theta(nres))
1689             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1690             do k=1,3
1691               uz(k,i)=fac*uz(k,i)
1692             enddo
1693 ! Compute the derivatives of uz
1694             uzder(1,1,1)= 0.0d0
1695             uzder(2,1,1)=-dc_norm(3,i-1)
1696             uzder(3,1,1)= dc_norm(2,i-1)
1697             uzder(1,2,1)= dc_norm(3,i-1)
1698             uzder(2,2,1)= 0.0d0
1699             uzder(3,2,1)=-dc_norm(1,i-1)
1700             uzder(1,3,1)=-dc_norm(2,i-1)
1701             uzder(2,3,1)= dc_norm(1,i-1)
1702             uzder(3,3,1)= 0.0d0
1703             uzder(1,1,2)= 0.0d0
1704             uzder(2,1,2)= dc_norm(3,i)
1705             uzder(3,1,2)=-dc_norm(2,i)
1706             uzder(1,2,2)=-dc_norm(3,i)
1707             uzder(2,2,2)= 0.0d0
1708             uzder(3,2,2)= dc_norm(1,i)
1709             uzder(1,3,2)= dc_norm(2,i)
1710             uzder(2,3,2)=-dc_norm(1,i)
1711             uzder(3,3,2)= 0.0d0
1712 ! Compute the Y-axis
1713             facy=fac
1714             do k=1,3
1715               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1716             enddo
1717 ! Compute the derivatives of uy
1718             do j=1,3
1719               do k=1,3
1720                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
1721                               -dc_norm(k,i)*dc_norm(j,i-1)
1722                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1723               enddo
1724               uyder(j,j,1)=uyder(j,j,1)-costh
1725               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1726             enddo
1727             do j=1,2
1728               do k=1,3
1729                 do l=1,3
1730                   uygrad(l,k,j,i)=uyder(l,k,j)
1731                   uzgrad(l,k,j,i)=uzder(l,k,j)
1732                 enddo
1733               enddo
1734             enddo
1735             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1736             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1737             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1738             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1739           else
1740 ! Other residues
1741 ! Compute the Z-axis
1742             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1743             costh=dcos(pi-theta(i+2))
1744             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1745             do k=1,3
1746               uz(k,i)=fac*uz(k,i)
1747             enddo
1748 ! Compute the derivatives of uz
1749             uzder(1,1,1)= 0.0d0
1750             uzder(2,1,1)=-dc_norm(3,i+1)
1751             uzder(3,1,1)= dc_norm(2,i+1)
1752             uzder(1,2,1)= dc_norm(3,i+1)
1753             uzder(2,2,1)= 0.0d0
1754             uzder(3,2,1)=-dc_norm(1,i+1)
1755             uzder(1,3,1)=-dc_norm(2,i+1)
1756             uzder(2,3,1)= dc_norm(1,i+1)
1757             uzder(3,3,1)= 0.0d0
1758             uzder(1,1,2)= 0.0d0
1759             uzder(2,1,2)= dc_norm(3,i)
1760             uzder(3,1,2)=-dc_norm(2,i)
1761             uzder(1,2,2)=-dc_norm(3,i)
1762             uzder(2,2,2)= 0.0d0
1763             uzder(3,2,2)= dc_norm(1,i)
1764             uzder(1,3,2)= dc_norm(2,i)
1765             uzder(2,3,2)=-dc_norm(1,i)
1766             uzder(3,3,2)= 0.0d0
1767 ! Compute the Y-axis
1768             facy=fac
1769             do k=1,3
1770               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1771             enddo
1772 ! Compute the derivatives of uy
1773             do j=1,3
1774               do k=1,3
1775                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
1776                               -dc_norm(k,i)*dc_norm(j,i+1)
1777                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1778               enddo
1779               uyder(j,j,1)=uyder(j,j,1)-costh
1780               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1781             enddo
1782             do j=1,2
1783               do k=1,3
1784                 do l=1,3
1785                   uygrad(l,k,j,i)=uyder(l,k,j)
1786                   uzgrad(l,k,j,i)=uzder(l,k,j)
1787                 enddo
1788               enddo
1789             enddo
1790             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1791             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1792             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1793             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1794           endif
1795       enddo
1796       do i=1,nres-1
1797         vbld_inv_temp(1)=vbld_inv(i+1)
1798         if (i.lt.nres-1) then
1799           vbld_inv_temp(2)=vbld_inv(i+2)
1800           else
1801           vbld_inv_temp(2)=vbld_inv(i)
1802           endif
1803         do j=1,2
1804           do k=1,3
1805             do l=1,3
1806               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1807               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1808             enddo
1809           enddo
1810         enddo
1811       enddo
1812 #if defined(PARVEC) && defined(MPI)
1813       if (nfgtasks1.gt.1) then
1814         time00=MPI_Wtime()
1815 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
1816 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
1817 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
1818         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
1819          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1820          FG_COMM1,IERR)
1821         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
1822          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1823          FG_COMM1,IERR)
1824         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
1825          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
1826          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1827         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
1828          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
1829          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1830         time_gather=time_gather+MPI_Wtime()-time00
1831       endif
1832 !      if (fg_rank.eq.0) then
1833 !        write (iout,*) "Arrays UY and UZ"
1834 !        do i=1,nres-1
1835 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1836 !     &     (uz(k,i),k=1,3)
1837 !        enddo
1838 !      endif
1839 #endif
1840       return
1841       end subroutine vec_and_deriv
1842 !-----------------------------------------------------------------------------
1843       subroutine check_vecgrad
1844 !      implicit real*8 (a-h,o-z)
1845 !      include 'DIMENSIONS'
1846 !      include 'COMMON.IOUNITS'
1847 !      include 'COMMON.GEO'
1848 !      include 'COMMON.VAR'
1849 !      include 'COMMON.LOCAL'
1850 !      include 'COMMON.CHAIN'
1851 !      include 'COMMON.VECTORS'
1852       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
1853       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
1854       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
1855       real(kind=8),dimension(3) :: erij
1856       real(kind=8) :: delta=1.0d-7
1857 !el local variables
1858       integer :: i,j,k,l
1859
1860       call vec_and_deriv
1861 !d      do i=1,nres
1862 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1863 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1864 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1865 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1866 !d     &     (dc_norm(if90,i),if90=1,3)
1867 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1868 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1869 !d          write(iout,'(a)')
1870 !d      enddo
1871       do i=1,nres
1872         do j=1,2
1873           do k=1,3
1874             do l=1,3
1875               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1876               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1877             enddo
1878           enddo
1879         enddo
1880       enddo
1881       call vec_and_deriv
1882       do i=1,nres
1883         do j=1,3
1884           uyt(j,i)=uy(j,i)
1885           uzt(j,i)=uz(j,i)
1886         enddo
1887       enddo
1888       do i=1,nres
1889 !d        write (iout,*) 'i=',i
1890         do k=1,3
1891           erij(k)=dc_norm(k,i)
1892         enddo
1893         do j=1,3
1894           do k=1,3
1895             dc_norm(k,i)=erij(k)
1896           enddo
1897           dc_norm(j,i)=dc_norm(j,i)+delta
1898 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1899 !          do k=1,3
1900 !            dc_norm(k,i)=dc_norm(k,i)/fac
1901 !          enddo
1902 !          write (iout,*) (dc_norm(k,i),k=1,3)
1903 !          write (iout,*) (erij(k),k=1,3)
1904           call vec_and_deriv
1905           do k=1,3
1906             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1907             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1908             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1909             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1910           enddo
1911 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1912 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1913 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1914         enddo
1915         do k=1,3
1916           dc_norm(k,i)=erij(k)
1917         enddo
1918 !d        do k=1,3
1919 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1920 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1921 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1922 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1923 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1924 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1925 !d          write (iout,'(a)')
1926 !d        enddo
1927       enddo
1928       return
1929       end subroutine check_vecgrad
1930 !-----------------------------------------------------------------------------
1931       subroutine set_matrices
1932 !      implicit real*8 (a-h,o-z)
1933 !      include 'DIMENSIONS'
1934 #ifdef MPI
1935       include "mpif.h"
1936 !      include "COMMON.SETUP"
1937       integer :: IERR
1938       integer :: status(MPI_STATUS_SIZE)
1939 #endif
1940 !      include 'COMMON.IOUNITS'
1941 !      include 'COMMON.GEO'
1942 !      include 'COMMON.VAR'
1943 !      include 'COMMON.LOCAL'
1944 !      include 'COMMON.CHAIN'
1945 !      include 'COMMON.DERIV'
1946 !      include 'COMMON.INTERACT'
1947 !      include 'COMMON.CONTACTS'
1948 !      include 'COMMON.TORSION'
1949 !      include 'COMMON.VECTORS'
1950 !      include 'COMMON.FFIELD'
1951       real(kind=8) :: auxvec(2),auxmat(2,2)
1952       integer :: i,iti1,iti,k,l
1953       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
1954
1955 !      allocate(Ug(2,2,nres))           !(2,2,maxres)
1956 !      allocate(Ug2(2,2,nres))          !(2,2,maxres)
1957 !      allocate(Ugder(2,2,nres))        !(2,2,maxres)
1958 !      allocate(Ug2der(2,2,nres))       !(2,2,maxres)
1959 !      allocate(obrot(2,nres))          !(2,maxres)
1960 !      allocate(obrot2(2,nres))                 !(2,maxres)
1961 !      allocate(obrot_der(2,nres))      !(2,maxres)
1962 !      allocate(obrot2_der(2,nres))     !(2,maxres)
1963 !      allocate(costab2(nres))          !(maxres)
1964 !      allocate(sintab2(nres))          !(maxres)
1965 !      allocate(costab(nres))           !(maxres)
1966 !      allocate(sintab(nres))           !(maxres)
1967
1968 !      allocate(Ub2(2,nres))            !(2,maxres)
1969 !      allocate(Ctobr(2,nres))          !(2,maxres)
1970 !      allocate(Dtobr2(2,nres))         !(2,maxres)
1971 !      allocate(mu(2,nres))             !(2,maxres)
1972 !      allocate(muder(2,nres))          !(2,maxres)
1973 !      allocate(Ub2der(2,nres))         !(2,maxres)
1974 !      allocate(Ctobrder(2,nres))       !(2,maxres)
1975 !      allocate(Dtobr2der(2,nres))      !(2,maxres)
1976
1977 !      allocate(EUg(2,2,nres))          !(2,2,maxres)
1978 !      allocate(CUg(2,2,nres))          !(2,2,maxres)
1979 !      allocate(DUg(2,2,nres))          !(2,2,maxres)
1980 !      allocate(DtUg2(2,2,nres))                !(2,2,maxres)
1981 !      allocate(EUgder(2,2,nres))       !(2,2,maxres)
1982 !      allocate(CUgder(2,2,nres))       !(2,2,maxres)
1983 !      allocate(DUgder(2,2,nres))       !(2,2,maxres)
1984 !      allocate(Dtug2der(2,2,nres))     !(2,2,maxres)
1985
1986 !      allocate(Ug2Db1t(2,nres))                !(2,maxres)
1987 !      allocate(Ug2Db1tder(2,nres))     !(2,maxres)
1988 !      allocate(CUgb2(2,nres))          !(2,maxres)
1989 !      allocate(CUgb2der(2,nres))       !(2,maxres)
1990
1991 !      allocate(EUgC(2,2,nres))         !(2,2,maxres)
1992 !      allocate(EUgCder(2,2,nres))      !(2,2,maxres)
1993 !      allocate(EUgD(2,2,nres))         !(2,2,maxres)
1994 !      allocate(EUgDder(2,2,nres))      !(2,2,maxres)
1995 !      allocate(DtUg2EUg(2,2,nres))     !(2,2,maxres)
1996 !      allocate(Ug2DtEUg(2,2,nres))     !(2,2,maxres)
1997
1998 !      allocate(Ug2DtEUgder(2,2,2,nres))        !(2,2,2,maxres)
1999 !      allocate(DtUg2EUgder(2,2,2,nres))        !(2,2,2,maxres)
2000
2001 !
2002 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2003 ! to calculate the el-loc multibody terms of various order.
2004 !
2005 #ifdef PARMAT
2006       do i=ivec_start+2,ivec_end+2
2007 #else
2008       do i=3,nres+1
2009 #endif
2010         if (i .lt. nres+1) then
2011           sin1=dsin(phi(i))
2012           cos1=dcos(phi(i))
2013           sintab(i-2)=sin1
2014           costab(i-2)=cos1
2015           obrot(1,i-2)=cos1
2016           obrot(2,i-2)=sin1
2017           sin2=dsin(2*phi(i))
2018           cos2=dcos(2*phi(i))
2019           sintab2(i-2)=sin2
2020           costab2(i-2)=cos2
2021           obrot2(1,i-2)=cos2
2022           obrot2(2,i-2)=sin2
2023           Ug(1,1,i-2)=-cos1
2024           Ug(1,2,i-2)=-sin1
2025           Ug(2,1,i-2)=-sin1
2026           Ug(2,2,i-2)= cos1
2027           Ug2(1,1,i-2)=-cos2
2028           Ug2(1,2,i-2)=-sin2
2029           Ug2(2,1,i-2)=-sin2
2030           Ug2(2,2,i-2)= cos2
2031         else
2032           costab(i-2)=1.0d0
2033           sintab(i-2)=0.0d0
2034           obrot(1,i-2)=1.0d0
2035           obrot(2,i-2)=0.0d0
2036           obrot2(1,i-2)=0.0d0
2037           obrot2(2,i-2)=0.0d0
2038           Ug(1,1,i-2)=1.0d0
2039           Ug(1,2,i-2)=0.0d0
2040           Ug(2,1,i-2)=0.0d0
2041           Ug(2,2,i-2)=1.0d0
2042           Ug2(1,1,i-2)=0.0d0
2043           Ug2(1,2,i-2)=0.0d0
2044           Ug2(2,1,i-2)=0.0d0
2045           Ug2(2,2,i-2)=0.0d0
2046         endif
2047         if (i .gt. 3 .and. i .lt. nres+1) then
2048           obrot_der(1,i-2)=-sin1
2049           obrot_der(2,i-2)= cos1
2050           Ugder(1,1,i-2)= sin1
2051           Ugder(1,2,i-2)=-cos1
2052           Ugder(2,1,i-2)=-cos1
2053           Ugder(2,2,i-2)=-sin1
2054           dwacos2=cos2+cos2
2055           dwasin2=sin2+sin2
2056           obrot2_der(1,i-2)=-dwasin2
2057           obrot2_der(2,i-2)= dwacos2
2058           Ug2der(1,1,i-2)= dwasin2
2059           Ug2der(1,2,i-2)=-dwacos2
2060           Ug2der(2,1,i-2)=-dwacos2
2061           Ug2der(2,2,i-2)=-dwasin2
2062         else
2063           obrot_der(1,i-2)=0.0d0
2064           obrot_der(2,i-2)=0.0d0
2065           Ugder(1,1,i-2)=0.0d0
2066           Ugder(1,2,i-2)=0.0d0
2067           Ugder(2,1,i-2)=0.0d0
2068           Ugder(2,2,i-2)=0.0d0
2069           obrot2_der(1,i-2)=0.0d0
2070           obrot2_der(2,i-2)=0.0d0
2071           Ug2der(1,1,i-2)=0.0d0
2072           Ug2der(1,2,i-2)=0.0d0
2073           Ug2der(2,1,i-2)=0.0d0
2074           Ug2der(2,2,i-2)=0.0d0
2075         endif
2076 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2077         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2078           iti = itortyp(itype(i-2))
2079         else
2080           iti=ntortyp+1
2081         endif
2082 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2083         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2084           iti1 = itortyp(itype(i-1))
2085         else
2086           iti1=ntortyp+1
2087         endif
2088 !d        write (iout,*) '*******i',i,' iti1',iti
2089 !d        write (iout,*) 'b1',b1(:,iti)
2090 !d        write (iout,*) 'b2',b2(:,iti)
2091 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2092 !        if (i .gt. iatel_s+2) then
2093         if (i .gt. nnt+2) then
2094           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2095           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2096           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2097           then
2098           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2099           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2100           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2101           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2102           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2103           endif
2104         else
2105           do k=1,2
2106             Ub2(k,i-2)=0.0d0
2107             Ctobr(k,i-2)=0.0d0
2108             Dtobr2(k,i-2)=0.0d0
2109             do l=1,2
2110               EUg(l,k,i-2)=0.0d0
2111               CUg(l,k,i-2)=0.0d0
2112               DUg(l,k,i-2)=0.0d0
2113               DtUg2(l,k,i-2)=0.0d0
2114             enddo
2115           enddo
2116         endif
2117         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2118         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2119         do k=1,2
2120           muder(k,i-2)=Ub2der(k,i-2)
2121         enddo
2122 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2123         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2124           if (itype(i-1).le.ntyp) then
2125             iti1 = itortyp(itype(i-1))
2126           else
2127             iti1=ntortyp+1
2128           endif
2129         else
2130           iti1=ntortyp+1
2131         endif
2132         do k=1,2
2133           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2134         enddo
2135 !d        write (iout,*) 'mu ',mu(:,i-2)
2136 !d        write (iout,*) 'mu1',mu1(:,i-2)
2137 !d        write (iout,*) 'mu2',mu2(:,i-2)
2138         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2139         then
2140         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2141         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2142         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2143         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2144         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2145 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2146         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2147         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2148         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2149         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2150         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2151         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2152         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2153         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2154         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2155         endif
2156       enddo
2157 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2158 ! The order of matrices is from left to right.
2159       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2160       then
2161 !      do i=max0(ivec_start,2),ivec_end
2162       do i=2,nres-1
2163         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2164         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2165         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2166         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2167         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2168         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2169         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2170         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2171       enddo
2172       endif
2173 #if defined(MPI) && defined(PARMAT)
2174 !el #define DUBUG
2175 #ifdef DEBUG
2176 !      if (fg_rank.eq.0) then
2177         write (iout,*) "Arrays UG and UGDER before GATHER"
2178         do i=1,nres-1
2179           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2180            ((ug(l,k,i),l=1,2),k=1,2),&
2181            ((ugder(l,k,i),l=1,2),k=1,2)
2182         enddo
2183         write (iout,*) "Arrays UG2 and UG2DER"
2184         do i=1,nres-1
2185           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2186            ((ug2(l,k,i),l=1,2),k=1,2),&
2187            ((ug2der(l,k,i),l=1,2),k=1,2)
2188         enddo
2189         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2190         do i=1,nres-1
2191           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2192            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2193            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2194         enddo
2195         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2196         do i=1,nres-1
2197           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2198            costab(i),sintab(i),costab2(i),sintab2(i)
2199         enddo
2200         write (iout,*) "Array MUDER"
2201         do i=1,nres-1
2202           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2203         enddo
2204 !      endif
2205 #endif
2206       if (nfgtasks.gt.1) then
2207         time00=MPI_Wtime()
2208 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2209 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2210 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2211 #ifdef MATGATHER
2212         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2213          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2214          FG_COMM1,IERR)
2215         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2216          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2217          FG_COMM1,IERR)
2218         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2219          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2220          FG_COMM1,IERR)
2221         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2222          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2223          FG_COMM1,IERR)
2224         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2225          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2226          FG_COMM1,IERR)
2227         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2228          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2229          FG_COMM1,IERR)
2230         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2231          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2232          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2233         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2234          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2235          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2236         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2237          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2238          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2239         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2240          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2241          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2242         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2243         then
2244         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2245          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2246          FG_COMM1,IERR)
2247         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2248          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2249          FG_COMM1,IERR)
2250         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2251          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2252          FG_COMM1,IERR)
2253        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2254          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2255          FG_COMM1,IERR)
2256         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2257          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2258          FG_COMM1,IERR)
2259         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2260          ivec_count(fg_rank1),&
2261          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2262          FG_COMM1,IERR)
2263         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2264          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2265          FG_COMM1,IERR)
2266         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2267          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2268          FG_COMM1,IERR)
2269         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2270          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2271          FG_COMM1,IERR)
2272         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2273          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2274          FG_COMM1,IERR)
2275         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2276          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2277          FG_COMM1,IERR)
2278         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2279          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2280          FG_COMM1,IERR)
2281         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2282          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2283          FG_COMM1,IERR)
2284         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2285          ivec_count(fg_rank1),&
2286          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2287          FG_COMM1,IERR)
2288         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2289          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2290          FG_COMM1,IERR)
2291        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2292          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2293          FG_COMM1,IERR)
2294         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2295          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2296          FG_COMM1,IERR)
2297        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2298          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2299          FG_COMM1,IERR)
2300         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2301          ivec_count(fg_rank1),&
2302          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2303          FG_COMM1,IERR)
2304         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2305          ivec_count(fg_rank1),&
2306          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2307          FG_COMM1,IERR)
2308         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2309          ivec_count(fg_rank1),&
2310          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2311          MPI_MAT2,FG_COMM1,IERR)
2312         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2313          ivec_count(fg_rank1),&
2314          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2315          MPI_MAT2,FG_COMM1,IERR)
2316         endif
2317 #else
2318 ! Passes matrix info through the ring
2319       isend=fg_rank1
2320       irecv=fg_rank1-1
2321       if (irecv.lt.0) irecv=nfgtasks1-1
2322       iprev=irecv
2323       inext=fg_rank1+1
2324       if (inext.ge.nfgtasks1) inext=0
2325       do i=1,nfgtasks1-1
2326 !        write (iout,*) "isend",isend," irecv",irecv
2327 !        call flush(iout)
2328         lensend=lentyp(isend)
2329         lenrecv=lentyp(irecv)
2330 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2331 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2332 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2333 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2334 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2335 !        write (iout,*) "Gather ROTAT1"
2336 !        call flush(iout)
2337 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2338 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2339 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2340 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2341 !        write (iout,*) "Gather ROTAT2"
2342 !        call flush(iout)
2343         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2344          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2345          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2346          iprev,4400+irecv,FG_COMM,status,IERR)
2347 !        write (iout,*) "Gather ROTAT_OLD"
2348 !        call flush(iout)
2349         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2350          MPI_PRECOMP11(lensend),inext,5500+isend,&
2351          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2352          iprev,5500+irecv,FG_COMM,status,IERR)
2353 !        write (iout,*) "Gather PRECOMP11"
2354 !        call flush(iout)
2355         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2356          MPI_PRECOMP12(lensend),inext,6600+isend,&
2357          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2358          iprev,6600+irecv,FG_COMM,status,IERR)
2359 !        write (iout,*) "Gather PRECOMP12"
2360 !        call flush(iout)
2361         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2362         then
2363         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2364          MPI_ROTAT2(lensend),inext,7700+isend,&
2365          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2366          iprev,7700+irecv,FG_COMM,status,IERR)
2367 !        write (iout,*) "Gather PRECOMP21"
2368 !        call flush(iout)
2369         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2370          MPI_PRECOMP22(lensend),inext,8800+isend,&
2371          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2372          iprev,8800+irecv,FG_COMM,status,IERR)
2373 !        write (iout,*) "Gather PRECOMP22"
2374 !        call flush(iout)
2375         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2376          MPI_PRECOMP23(lensend),inext,9900+isend,&
2377          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2378          MPI_PRECOMP23(lenrecv),&
2379          iprev,9900+irecv,FG_COMM,status,IERR)
2380 !        write (iout,*) "Gather PRECOMP23"
2381 !        call flush(iout)
2382         endif
2383         isend=irecv
2384         irecv=irecv-1
2385         if (irecv.lt.0) irecv=nfgtasks1-1
2386       enddo
2387 #endif
2388         time_gather=time_gather+MPI_Wtime()-time00
2389       endif
2390 #ifdef DEBUG
2391 !      if (fg_rank.eq.0) then
2392         write (iout,*) "Arrays UG and UGDER"
2393         do i=1,nres-1
2394           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2395            ((ug(l,k,i),l=1,2),k=1,2),&
2396            ((ugder(l,k,i),l=1,2),k=1,2)
2397         enddo
2398         write (iout,*) "Arrays UG2 and UG2DER"
2399         do i=1,nres-1
2400           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2401            ((ug2(l,k,i),l=1,2),k=1,2),&
2402            ((ug2der(l,k,i),l=1,2),k=1,2)
2403         enddo
2404         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2405         do i=1,nres-1
2406           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2407            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2408            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2409         enddo
2410         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2411         do i=1,nres-1
2412           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2413            costab(i),sintab(i),costab2(i),sintab2(i)
2414         enddo
2415         write (iout,*) "Array MUDER"
2416         do i=1,nres-1
2417           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2418         enddo
2419 !      endif
2420 #endif
2421 #endif
2422 !d      do i=1,nres
2423 !d        iti = itortyp(itype(i))
2424 !d        write (iout,*) i
2425 !d        do j=1,2
2426 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2427 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2428 !d        enddo
2429 !d      enddo
2430       return
2431 !el #undef DUBUG
2432       end subroutine set_matrices
2433 !-----------------------------------------------------------------------------
2434       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2435 !
2436 ! This subroutine calculates the average interaction energy and its gradient
2437 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2438 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2439 ! The potential depends both on the distance of peptide-group centers and on
2440 ! the orientation of the CA-CA virtual bonds.
2441 !
2442       use comm_locel
2443 !      implicit real*8 (a-h,o-z)
2444 #ifdef MPI
2445       include 'mpif.h'
2446 #endif
2447 !      include 'DIMENSIONS'
2448 !      include 'COMMON.CONTROL'
2449 !      include 'COMMON.SETUP'
2450 !      include 'COMMON.IOUNITS'
2451 !      include 'COMMON.GEO'
2452 !      include 'COMMON.VAR'
2453 !      include 'COMMON.LOCAL'
2454 !      include 'COMMON.CHAIN'
2455 !      include 'COMMON.DERIV'
2456 !      include 'COMMON.INTERACT'
2457 !      include 'COMMON.CONTACTS'
2458 !      include 'COMMON.TORSION'
2459 !      include 'COMMON.VECTORS'
2460 !      include 'COMMON.FFIELD'
2461 !      include 'COMMON.TIME1'
2462       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2463       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2464       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2465 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2466       real(kind=8),dimension(4) :: muij
2467 !el      integer :: num_conti,j1,j2
2468 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2469 !el        dz_normi,xmedi,ymedi,zmedi
2470
2471 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2472 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2473 !el          num_conti,j1,j2
2474
2475 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2476 #ifdef MOMENT
2477       real(kind=8) :: scal_el=1.0d0
2478 #else
2479       real(kind=8) :: scal_el=0.5d0
2480 #endif
2481 ! 12/13/98
2482 ! 13-go grudnia roku pamietnego...
2483       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2484                                              0.0d0,1.0d0,0.0d0,&
2485                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2486 !el local variables
2487       integer :: i,k,j
2488       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2489       real(kind=8) :: fac,t_eelecij
2490
2491
2492 !d      write(iout,*) 'In EELEC'
2493 !d      do i=1,nloctyp
2494 !d        write(iout,*) 'Type',i
2495 !d        write(iout,*) 'B1',B1(:,i)
2496 !d        write(iout,*) 'B2',B2(:,i)
2497 !d        write(iout,*) 'CC',CC(:,:,i)
2498 !d        write(iout,*) 'DD',DD(:,:,i)
2499 !d        write(iout,*) 'EE',EE(:,:,i)
2500 !d      enddo
2501 !d      call check_vecgrad
2502 !d      stop
2503       if (icheckgrad.eq.1) then
2504         do i=1,nres-1
2505           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2506           do k=1,3
2507             dc_norm(k,i)=dc(k,i)*fac
2508           enddo
2509 !          write (iout,*) 'i',i,' fac',fac
2510         enddo
2511       endif
2512       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2513           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2514           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2515 !        call vec_and_deriv
2516 #ifdef TIMING
2517         time01=MPI_Wtime()
2518 #endif
2519         call set_matrices
2520 #ifdef TIMING
2521         time_mat=time_mat+MPI_Wtime()-time01
2522 #endif
2523       endif
2524 !d      do i=1,nres-1
2525 !d        write (iout,*) 'i=',i
2526 !d        do k=1,3
2527 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2528 !d        enddo
2529 !d        do k=1,3
2530 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2531 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2532 !d        enddo
2533 !d      enddo
2534       t_eelecij=0.0d0
2535       ees=0.0D0
2536       evdw1=0.0D0
2537       eel_loc=0.0d0
2538       eello_turn3=0.0d0
2539       eello_turn4=0.0d0
2540 !el      ind=0
2541       do i=1,nres
2542         num_cont_hb(i)=0
2543       enddo
2544 !d      print '(a)','Enter EELEC'
2545 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2546 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2547 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2548       do i=1,nres
2549         gel_loc_loc(i)=0.0d0
2550         gcorr_loc(i)=0.0d0
2551       enddo
2552 !
2553 !
2554 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2555 !
2556 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2557 !
2558
2559
2560
2561       do i=iturn3_start,iturn3_end
2562         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2563         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2564         dxi=dc(1,i)
2565         dyi=dc(2,i)
2566         dzi=dc(3,i)
2567         dx_normi=dc_norm(1,i)
2568         dy_normi=dc_norm(2,i)
2569         dz_normi=dc_norm(3,i)
2570         xmedi=c(1,i)+0.5d0*dxi
2571         ymedi=c(2,i)+0.5d0*dyi
2572         zmedi=c(3,i)+0.5d0*dzi
2573         num_conti=0
2574         call eelecij(i,i+2,ees,evdw1,eel_loc)
2575         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2576         num_cont_hb(i)=num_conti
2577       enddo
2578       do i=iturn4_start,iturn4_end
2579         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2580           .or. itype(i+3).eq.ntyp1 &
2581           .or. itype(i+4).eq.ntyp1) cycle
2582         dxi=dc(1,i)
2583         dyi=dc(2,i)
2584         dzi=dc(3,i)
2585         dx_normi=dc_norm(1,i)
2586         dy_normi=dc_norm(2,i)
2587         dz_normi=dc_norm(3,i)
2588         xmedi=c(1,i)+0.5d0*dxi
2589         ymedi=c(2,i)+0.5d0*dyi
2590         zmedi=c(3,i)+0.5d0*dzi
2591         num_conti=num_cont_hb(i)
2592         call eelecij(i,i+3,ees,evdw1,eel_loc)
2593         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2594          call eturn4(i,eello_turn4)
2595         num_cont_hb(i)=num_conti
2596       enddo   ! i
2597 !
2598 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2599 !
2600       do i=iatel_s,iatel_e
2601         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2602         dxi=dc(1,i)
2603         dyi=dc(2,i)
2604         dzi=dc(3,i)
2605         dx_normi=dc_norm(1,i)
2606         dy_normi=dc_norm(2,i)
2607         dz_normi=dc_norm(3,i)
2608         xmedi=c(1,i)+0.5d0*dxi
2609         ymedi=c(2,i)+0.5d0*dyi
2610         zmedi=c(3,i)+0.5d0*dzi
2611 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2612         num_conti=num_cont_hb(i)
2613         do j=ielstart(i),ielend(i)
2614 !          write (iout,*) i,j,itype(i),itype(j)
2615           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2616           call eelecij(i,j,ees,evdw1,eel_loc)
2617         enddo ! j
2618         num_cont_hb(i)=num_conti
2619       enddo   ! i
2620 !      write (iout,*) "Number of loop steps in EELEC:",ind
2621 !d      do i=1,nres
2622 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2623 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2624 !d      enddo
2625 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2626 !cc      eel_loc=eel_loc+eello_turn3
2627 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2628       return
2629       end subroutine eelec
2630 !-----------------------------------------------------------------------------
2631       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2632
2633       use comm_locel
2634 !      implicit real*8 (a-h,o-z)
2635 !      include 'DIMENSIONS'
2636 #ifdef MPI
2637       include "mpif.h"
2638 #endif
2639 !      include 'COMMON.CONTROL'
2640 !      include 'COMMON.IOUNITS'
2641 !      include 'COMMON.GEO'
2642 !      include 'COMMON.VAR'
2643 !      include 'COMMON.LOCAL'
2644 !      include 'COMMON.CHAIN'
2645 !      include 'COMMON.DERIV'
2646 !      include 'COMMON.INTERACT'
2647 !      include 'COMMON.CONTACTS'
2648 !      include 'COMMON.TORSION'
2649 !      include 'COMMON.VECTORS'
2650 !      include 'COMMON.FFIELD'
2651 !      include 'COMMON.TIME1'
2652       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2653       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2654       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2655 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2656       real(kind=8),dimension(4) :: muij
2657 !el      integer :: num_conti,j1,j2
2658 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2659 !el        dz_normi,xmedi,ymedi,zmedi
2660
2661 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2662 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2663 !el          num_conti,j1,j2
2664
2665 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2666 #ifdef MOMENT
2667       real(kind=8) :: scal_el=1.0d0
2668 #else
2669       real(kind=8) :: scal_el=0.5d0
2670 #endif
2671 ! 12/13/98
2672 ! 13-go grudnia roku pamietnego...
2673       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2674                                              0.0d0,1.0d0,0.0d0,&
2675                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2676 !      integer :: maxconts=nres/4
2677 !el local variables
2678       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m
2679       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
2680       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
2681       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
2682                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
2683                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
2684                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
2685                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
2686                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
2687                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
2688                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
2689 !      maxconts=nres/4
2690 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
2691 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
2692
2693 !          time00=MPI_Wtime()
2694 !d      write (iout,*) "eelecij",i,j
2695 !          ind=ind+1
2696           iteli=itel(i)
2697           itelj=itel(j)
2698           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2699           aaa=app(iteli,itelj)
2700           bbb=bpp(iteli,itelj)
2701           ael6i=ael6(iteli,itelj)
2702           ael3i=ael3(iteli,itelj)
2703           dxj=dc(1,j)
2704           dyj=dc(2,j)
2705           dzj=dc(3,j)
2706           dx_normj=dc_norm(1,j)
2707           dy_normj=dc_norm(2,j)
2708           dz_normj=dc_norm(3,j)
2709           xj=c(1,j)+0.5D0*dxj-xmedi
2710           yj=c(2,j)+0.5D0*dyj-ymedi
2711           zj=c(3,j)+0.5D0*dzj-zmedi
2712           rij=xj*xj+yj*yj+zj*zj
2713           rrmij=1.0D0/rij
2714           rij=dsqrt(rij)
2715           rmij=1.0D0/rij
2716           r3ij=rrmij*rmij
2717           r6ij=r3ij*r3ij
2718           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2719           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2720           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2721           fac=cosa-3.0D0*cosb*cosg
2722           ev1=aaa*r6ij*r6ij
2723 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2724           if (j.eq.i+2) ev1=scal_el*ev1
2725           ev2=bbb*r6ij
2726           fac3=ael6i*r6ij
2727           fac4=ael3i*r3ij
2728           evdwij=ev1+ev2
2729           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2730           el2=fac4*fac
2731           eesij=el1+el2
2732 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
2733           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2734           ees=ees+eesij
2735           evdw1=evdw1+evdwij
2736 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2737 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2738 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2739 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
2740
2741           if (energy_dec) then
2742               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
2743                   'evdw1',i,j,evdwij,&
2744                   iteli,itelj,aaa,evdw1
2745               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2746           endif
2747 !
2748 ! Calculate contributions to the Cartesian gradient.
2749 !
2750 #ifdef SPLITELE
2751           facvdw=-6*rrmij*(ev1+evdwij)
2752           facel=-3*rrmij*(el1+eesij)
2753           fac1=fac
2754           erij(1)=xj*rmij
2755           erij(2)=yj*rmij
2756           erij(3)=zj*rmij
2757 !
2758 ! Radial derivatives. First process both termini of the fragment (i,j)
2759 !
2760           ggg(1)=facel*xj
2761           ggg(2)=facel*yj
2762           ggg(3)=facel*zj
2763 !          do k=1,3
2764 !            ghalf=0.5D0*ggg(k)
2765 !            gelc(k,i)=gelc(k,i)+ghalf
2766 !            gelc(k,j)=gelc(k,j)+ghalf
2767 !          enddo
2768 ! 9/28/08 AL Gradient compotents will be summed only at the end
2769           do k=1,3
2770             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2771             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2772           enddo
2773 !
2774 ! Loop over residues i+1 thru j-1.
2775 !
2776 !grad          do k=i+1,j-1
2777 !grad            do l=1,3
2778 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2779 !grad            enddo
2780 !grad          enddo
2781           ggg(1)=facvdw*xj
2782           ggg(2)=facvdw*yj
2783           ggg(3)=facvdw*zj
2784 !          do k=1,3
2785 !            ghalf=0.5D0*ggg(k)
2786 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2787 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2788 !          enddo
2789 ! 9/28/08 AL Gradient compotents will be summed only at the end
2790           do k=1,3
2791             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2792             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2793           enddo
2794 !
2795 ! Loop over residues i+1 thru j-1.
2796 !
2797 !grad          do k=i+1,j-1
2798 !grad            do l=1,3
2799 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2800 !grad            enddo
2801 !grad          enddo
2802 #else
2803           facvdw=ev1+evdwij
2804           facel=el1+eesij
2805           fac1=fac
2806           fac=-3*rrmij*(facvdw+facvdw+facel)
2807           erij(1)=xj*rmij
2808           erij(2)=yj*rmij
2809           erij(3)=zj*rmij
2810 !
2811 ! Radial derivatives. First process both termini of the fragment (i,j)
2812 !
2813           ggg(1)=fac*xj
2814           ggg(2)=fac*yj
2815           ggg(3)=fac*zj
2816 !          do k=1,3
2817 !            ghalf=0.5D0*ggg(k)
2818 !            gelc(k,i)=gelc(k,i)+ghalf
2819 !            gelc(k,j)=gelc(k,j)+ghalf
2820 !          enddo
2821 ! 9/28/08 AL Gradient compotents will be summed only at the end
2822           do k=1,3
2823             gelc_long(k,j)=gelc(k,j)+ggg(k)
2824             gelc_long(k,i)=gelc(k,i)-ggg(k)
2825           enddo
2826 !
2827 ! Loop over residues i+1 thru j-1.
2828 !
2829 !grad          do k=i+1,j-1
2830 !grad            do l=1,3
2831 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2832 !grad            enddo
2833 !grad          enddo
2834 ! 9/28/08 AL Gradient compotents will be summed only at the end
2835           ggg(1)=facvdw*xj
2836           ggg(2)=facvdw*yj
2837           ggg(3)=facvdw*zj
2838           do k=1,3
2839             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2840             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2841           enddo
2842 #endif
2843 !
2844 ! Angular part
2845 !
2846           ecosa=2.0D0*fac3*fac1+fac4
2847           fac4=-3.0D0*fac4
2848           fac3=-6.0D0*fac3
2849           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2850           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2851           do k=1,3
2852             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2853             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2854           enddo
2855 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2856 !d   &          (dcosg(k),k=1,3)
2857           do k=1,3
2858             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2859           enddo
2860 !          do k=1,3
2861 !            ghalf=0.5D0*ggg(k)
2862 !            gelc(k,i)=gelc(k,i)+ghalf
2863 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2864 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2865 !            gelc(k,j)=gelc(k,j)+ghalf
2866 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2867 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2868 !          enddo
2869 !grad          do k=i+1,j-1
2870 !grad            do l=1,3
2871 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2872 !grad            enddo
2873 !grad          enddo
2874           do k=1,3
2875             gelc(k,i)=gelc(k,i) &
2876                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
2877                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2878             gelc(k,j)=gelc(k,j) &
2879                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
2880                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2881             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2882             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2883           enddo
2884           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2885               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
2886               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2887 !
2888 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2889 !   energy of a peptide unit is assumed in the form of a second-order
2890 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2891 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2892 !   are computed for EVERY pair of non-contiguous peptide groups.
2893 !
2894           if (j.lt.nres-1) then
2895             j1=j+1
2896             j2=j-1
2897           else
2898             j1=j-1
2899             j2=j-2
2900           endif
2901           kkk=0
2902           do k=1,2
2903             do l=1,2
2904               kkk=kkk+1
2905               muij(kkk)=mu(k,i)*mu(l,j)
2906             enddo
2907           enddo
2908 !d         write (iout,*) 'EELEC: i',i,' j',j
2909 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
2910 !d          write(iout,*) 'muij',muij
2911           ury=scalar(uy(1,i),erij)
2912           urz=scalar(uz(1,i),erij)
2913           vry=scalar(uy(1,j),erij)
2914           vrz=scalar(uz(1,j),erij)
2915           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2916           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2917           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2918           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2919           fac=dsqrt(-ael6i)*r3ij
2920           a22=a22*fac
2921           a23=a23*fac
2922           a32=a32*fac
2923           a33=a33*fac
2924 !d          write (iout,'(4i5,4f10.5)')
2925 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2926 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2927 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2928 !d     &      uy(:,j),uz(:,j)
2929 !d          write (iout,'(4f10.5)')
2930 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2931 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2932 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
2933 !d           write (iout,'(9f10.5/)')
2934 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2935 ! Derivatives of the elements of A in virtual-bond vectors
2936           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2937           do k=1,3
2938             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2939             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2940             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2941             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2942             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2943             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2944             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2945             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2946             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2947             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2948             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2949             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2950           enddo
2951 ! Compute radial contributions to the gradient
2952           facr=-3.0d0*rrmij
2953           a22der=a22*facr
2954           a23der=a23*facr
2955           a32der=a32*facr
2956           a33der=a33*facr
2957           agg(1,1)=a22der*xj
2958           agg(2,1)=a22der*yj
2959           agg(3,1)=a22der*zj
2960           agg(1,2)=a23der*xj
2961           agg(2,2)=a23der*yj
2962           agg(3,2)=a23der*zj
2963           agg(1,3)=a32der*xj
2964           agg(2,3)=a32der*yj
2965           agg(3,3)=a32der*zj
2966           agg(1,4)=a33der*xj
2967           agg(2,4)=a33der*yj
2968           agg(3,4)=a33der*zj
2969 ! Add the contributions coming from er
2970           fac3=-3.0d0*fac
2971           do k=1,3
2972             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2973             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2974             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2975             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2976           enddo
2977           do k=1,3
2978 ! Derivatives in DC(i)
2979 !grad            ghalf1=0.5d0*agg(k,1)
2980 !grad            ghalf2=0.5d0*agg(k,2)
2981 !grad            ghalf3=0.5d0*agg(k,3)
2982 !grad            ghalf4=0.5d0*agg(k,4)
2983             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
2984             -3.0d0*uryg(k,2)*vry)!+ghalf1
2985             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
2986             -3.0d0*uryg(k,2)*vrz)!+ghalf2
2987             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
2988             -3.0d0*urzg(k,2)*vry)!+ghalf3
2989             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
2990             -3.0d0*urzg(k,2)*vrz)!+ghalf4
2991 ! Derivatives in DC(i+1)
2992             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
2993             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2994             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
2995             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2996             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
2997             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2998             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
2999             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3000 ! Derivatives in DC(j)
3001             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3002             -3.0d0*vryg(k,2)*ury)!+ghalf1
3003             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3004             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3005             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3006             -3.0d0*vryg(k,2)*urz)!+ghalf3
3007             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3008             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3009 ! Derivatives in DC(j+1) or DC(nres-1)
3010             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3011             -3.0d0*vryg(k,3)*ury)
3012             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3013             -3.0d0*vrzg(k,3)*ury)
3014             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3015             -3.0d0*vryg(k,3)*urz)
3016             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3017             -3.0d0*vrzg(k,3)*urz)
3018 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3019 !grad              do l=1,4
3020 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3021 !grad              enddo
3022 !grad            endif
3023           enddo
3024           acipa(1,1)=a22
3025           acipa(1,2)=a23
3026           acipa(2,1)=a32
3027           acipa(2,2)=a33
3028           a22=-a22
3029           a23=-a23
3030           do l=1,2
3031             do k=1,3
3032               agg(k,l)=-agg(k,l)
3033               aggi(k,l)=-aggi(k,l)
3034               aggi1(k,l)=-aggi1(k,l)
3035               aggj(k,l)=-aggj(k,l)
3036               aggj1(k,l)=-aggj1(k,l)
3037             enddo
3038           enddo
3039           if (j.lt.nres-1) then
3040             a22=-a22
3041             a32=-a32
3042             do l=1,3,2
3043               do k=1,3
3044                 agg(k,l)=-agg(k,l)
3045                 aggi(k,l)=-aggi(k,l)
3046                 aggi1(k,l)=-aggi1(k,l)
3047                 aggj(k,l)=-aggj(k,l)
3048                 aggj1(k,l)=-aggj1(k,l)
3049               enddo
3050             enddo
3051           else
3052             a22=-a22
3053             a23=-a23
3054             a32=-a32
3055             a33=-a33
3056             do l=1,4
3057               do k=1,3
3058                 agg(k,l)=-agg(k,l)
3059                 aggi(k,l)=-aggi(k,l)
3060                 aggi1(k,l)=-aggi1(k,l)
3061                 aggj(k,l)=-aggj(k,l)
3062                 aggj1(k,l)=-aggj1(k,l)
3063               enddo
3064             enddo
3065           endif
3066           ENDIF ! WCORR
3067           IF (wel_loc.gt.0.0d0) THEN
3068 ! Contribution to the local-electrostatic energy coming from the i-j pair
3069           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3070            +a33*muij(4)
3071 !d          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3072
3073           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3074                   'eelloc',i,j,eel_loc_ij
3075 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3076
3077           eel_loc=eel_loc+eel_loc_ij
3078 ! Partial derivatives in virtual-bond dihedral angles gamma
3079           if (i.gt.1) &
3080           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3081                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3082                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3083           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3084                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3085                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3086 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3087           do l=1,3
3088             ggg(l)=agg(l,1)*muij(1)+ &
3089                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3090             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3091             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3092 !grad            ghalf=0.5d0*ggg(l)
3093 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3094 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3095           enddo
3096 !grad          do k=i+1,j2
3097 !grad            do l=1,3
3098 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3099 !grad            enddo
3100 !grad          enddo
3101 ! Remaining derivatives of eello
3102           do l=1,3
3103             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
3104                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3105             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
3106                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3107             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
3108                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3109             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
3110                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3111           enddo
3112           ENDIF
3113 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3114 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3115           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3116              .and. num_conti.le.maxconts) then
3117 !            write (iout,*) i,j," entered corr"
3118 !
3119 ! Calculate the contact function. The ith column of the array JCONT will
3120 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3121 ! greater than I). The arrays FACONT and GACONT will contain the values of
3122 ! the contact function and its derivative.
3123 !           r0ij=1.02D0*rpp(iteli,itelj)
3124 !           r0ij=1.11D0*rpp(iteli,itelj)
3125             r0ij=2.20D0*rpp(iteli,itelj)
3126 !           r0ij=1.55D0*rpp(iteli,itelj)
3127             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3128             if (fcont.gt.0.0D0) then
3129               num_conti=num_conti+1
3130               if (num_conti.gt.maxconts) then
3131 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3132 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3133                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3134                                ' will skip next contacts for this conf.', num_conti
3135               else
3136                 jcont_hb(num_conti,i)=j
3137 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3138 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3139                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3140                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3141 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3142 !  terms.
3143                 d_cont(num_conti,i)=rij
3144 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3145 !     --- Electrostatic-interaction matrix ---
3146                 a_chuj(1,1,num_conti,i)=a22
3147                 a_chuj(1,2,num_conti,i)=a23
3148                 a_chuj(2,1,num_conti,i)=a32
3149                 a_chuj(2,2,num_conti,i)=a33
3150 !     --- Gradient of rij
3151                 do kkk=1,3
3152                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3153                 enddo
3154                 kkll=0
3155                 do k=1,2
3156                   do l=1,2
3157                     kkll=kkll+1
3158                     do m=1,3
3159                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3160                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3161                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3162                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3163                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3164                     enddo
3165                   enddo
3166                 enddo
3167                 ENDIF
3168                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3169 ! Calculate contact energies
3170                 cosa4=4.0D0*cosa
3171                 wij=cosa-3.0D0*cosb*cosg
3172                 cosbg1=cosb+cosg
3173                 cosbg2=cosb-cosg
3174 !               fac3=dsqrt(-ael6i)/r0ij**3
3175                 fac3=dsqrt(-ael6i)*r3ij
3176 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3177                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3178                 if (ees0tmp.gt.0) then
3179                   ees0pij=dsqrt(ees0tmp)
3180                 else
3181                   ees0pij=0
3182                 endif
3183 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3184                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3185                 if (ees0tmp.gt.0) then
3186                   ees0mij=dsqrt(ees0tmp)
3187                 else
3188                   ees0mij=0
3189                 endif
3190 !               ees0mij=0.0D0
3191                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3192                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3193 ! Diagnostics. Comment out or remove after debugging!
3194 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3195 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3196 !               ees0m(num_conti,i)=0.0D0
3197 ! End diagnostics.
3198 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3199 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3200 ! Angular derivatives of the contact function
3201                 ees0pij1=fac3/ees0pij
3202                 ees0mij1=fac3/ees0mij
3203                 fac3p=-3.0D0*fac3*rrmij
3204                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3205                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3206 !               ees0mij1=0.0D0
3207                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3208                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3209                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3210                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3211                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3212                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3213                 ecosap=ecosa1+ecosa2
3214                 ecosbp=ecosb1+ecosb2
3215                 ecosgp=ecosg1+ecosg2
3216                 ecosam=ecosa1-ecosa2
3217                 ecosbm=ecosb1-ecosb2
3218                 ecosgm=ecosg1-ecosg2
3219 ! Diagnostics
3220 !               ecosap=ecosa1
3221 !               ecosbp=ecosb1
3222 !               ecosgp=ecosg1
3223 !               ecosam=0.0D0
3224 !               ecosbm=0.0D0
3225 !               ecosgm=0.0D0
3226 ! End diagnostics
3227                 facont_hb(num_conti,i)=fcont
3228                 fprimcont=fprimcont/rij
3229 !d              facont_hb(num_conti,i)=1.0D0
3230 ! Following line is for diagnostics.
3231 !d              fprimcont=0.0D0
3232                 do k=1,3
3233                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3234                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3235                 enddo
3236                 do k=1,3
3237                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3238                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3239                 enddo
3240                 gggp(1)=gggp(1)+ees0pijp*xj
3241                 gggp(2)=gggp(2)+ees0pijp*yj
3242                 gggp(3)=gggp(3)+ees0pijp*zj
3243                 gggm(1)=gggm(1)+ees0mijp*xj
3244                 gggm(2)=gggm(2)+ees0mijp*yj
3245                 gggm(3)=gggm(3)+ees0mijp*zj
3246 ! Derivatives due to the contact function
3247                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3248                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3249                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3250                 do k=1,3
3251 !
3252 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3253 !          following the change of gradient-summation algorithm.
3254 !
3255 !grad                  ghalfp=0.5D0*gggp(k)
3256 !grad                  ghalfm=0.5D0*gggm(k)
3257                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3258                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3259                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3260                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3261                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3262                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3263                   gacontp_hb3(k,num_conti,i)=gggp(k)
3264                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3265                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3266                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3267                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3268                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3269                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3270                   gacontm_hb3(k,num_conti,i)=gggm(k)
3271                 enddo
3272 ! Diagnostics. Comment out or remove after debugging!
3273 !diag           do k=1,3
3274 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3275 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3276 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3277 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3278 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3279 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3280 !diag           enddo
3281               ENDIF ! wcorr
3282               endif  ! num_conti.le.maxconts
3283             endif  ! fcont.gt.0
3284           endif    ! j.gt.i+1
3285           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3286             do k=1,4
3287               do l=1,3
3288                 ghalf=0.5d0*agg(l,k)
3289                 aggi(l,k)=aggi(l,k)+ghalf
3290                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3291                 aggj(l,k)=aggj(l,k)+ghalf
3292               enddo
3293             enddo
3294             if (j.eq.nres-1 .and. i.lt.j-2) then
3295               do k=1,4
3296                 do l=1,3
3297                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3298                 enddo
3299               enddo
3300             endif
3301           endif
3302 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3303       return
3304       end subroutine eelecij
3305 !-----------------------------------------------------------------------------
3306       subroutine eturn3(i,eello_turn3)
3307 ! Third- and fourth-order contributions from turns
3308
3309       use comm_locel
3310 !      implicit real*8 (a-h,o-z)
3311 !      include 'DIMENSIONS'
3312 !      include 'COMMON.IOUNITS'
3313 !      include 'COMMON.GEO'
3314 !      include 'COMMON.VAR'
3315 !      include 'COMMON.LOCAL'
3316 !      include 'COMMON.CHAIN'
3317 !      include 'COMMON.DERIV'
3318 !      include 'COMMON.INTERACT'
3319 !      include 'COMMON.CONTACTS'
3320 !      include 'COMMON.TORSION'
3321 !      include 'COMMON.VECTORS'
3322 !      include 'COMMON.FFIELD'
3323 !      include 'COMMON.CONTROL'
3324       real(kind=8),dimension(3) :: ggg
3325       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3326         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3327       real(kind=8),dimension(2) :: auxvec,auxvec1
3328 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3329       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3330 !el      integer :: num_conti,j1,j2
3331 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3332 !el        dz_normi,xmedi,ymedi,zmedi
3333
3334 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3335 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3336 !el         num_conti,j1,j2
3337 !el local variables
3338       integer :: i,j,l
3339       real(kind=8) :: eello_turn3
3340
3341       j=i+2
3342 !      write (iout,*) "eturn3",i,j,j1,j2
3343       a_temp(1,1)=a22
3344       a_temp(1,2)=a23
3345       a_temp(2,1)=a32
3346       a_temp(2,2)=a33
3347 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3348 !
3349 !               Third-order contributions
3350 !
3351 !                 (i+2)o----(i+3)
3352 !                      | |
3353 !                      | |
3354 !                 (i+1)o----i
3355 !
3356 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3357 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3358         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3359         call transpose2(auxmat(1,1),auxmat1(1,1))
3360         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3361         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3362         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3363                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3364 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3365 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3366 !d     &    ' eello_turn3_num',4*eello_turn3_num
3367 ! Derivatives in gamma(i)
3368         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3369         call transpose2(auxmat2(1,1),auxmat3(1,1))
3370         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3371         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3372 ! Derivatives in gamma(i+1)
3373         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3374         call transpose2(auxmat2(1,1),auxmat3(1,1))
3375         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3376         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3377           +0.5d0*(pizda(1,1)+pizda(2,2))
3378 ! Cartesian derivatives
3379         do l=1,3
3380 !            ghalf1=0.5d0*agg(l,1)
3381 !            ghalf2=0.5d0*agg(l,2)
3382 !            ghalf3=0.5d0*agg(l,3)
3383 !            ghalf4=0.5d0*agg(l,4)
3384           a_temp(1,1)=aggi(l,1)!+ghalf1
3385           a_temp(1,2)=aggi(l,2)!+ghalf2
3386           a_temp(2,1)=aggi(l,3)!+ghalf3
3387           a_temp(2,2)=aggi(l,4)!+ghalf4
3388           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3389           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3390             +0.5d0*(pizda(1,1)+pizda(2,2))
3391           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3392           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3393           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3394           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3395           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3396           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3397             +0.5d0*(pizda(1,1)+pizda(2,2))
3398           a_temp(1,1)=aggj(l,1)!+ghalf1
3399           a_temp(1,2)=aggj(l,2)!+ghalf2
3400           a_temp(2,1)=aggj(l,3)!+ghalf3
3401           a_temp(2,2)=aggj(l,4)!+ghalf4
3402           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3403           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3404             +0.5d0*(pizda(1,1)+pizda(2,2))
3405           a_temp(1,1)=aggj1(l,1)
3406           a_temp(1,2)=aggj1(l,2)
3407           a_temp(2,1)=aggj1(l,3)
3408           a_temp(2,2)=aggj1(l,4)
3409           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3410           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3411             +0.5d0*(pizda(1,1)+pizda(2,2))
3412         enddo
3413       return
3414       end subroutine eturn3
3415 !-----------------------------------------------------------------------------
3416       subroutine eturn4(i,eello_turn4)
3417 ! Third- and fourth-order contributions from turns
3418
3419       use comm_locel
3420 !      implicit real*8 (a-h,o-z)
3421 !      include 'DIMENSIONS'
3422 !      include 'COMMON.IOUNITS'
3423 !      include 'COMMON.GEO'
3424 !      include 'COMMON.VAR'
3425 !      include 'COMMON.LOCAL'
3426 !      include 'COMMON.CHAIN'
3427 !      include 'COMMON.DERIV'
3428 !      include 'COMMON.INTERACT'
3429 !      include 'COMMON.CONTACTS'
3430 !      include 'COMMON.TORSION'
3431 !      include 'COMMON.VECTORS'
3432 !      include 'COMMON.FFIELD'
3433 !      include 'COMMON.CONTROL'
3434       real(kind=8),dimension(3) :: ggg
3435       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3436         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3437       real(kind=8),dimension(2) :: auxvec,auxvec1
3438 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3439       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3440 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3441 !el        dz_normi,xmedi,ymedi,zmedi
3442 !el      integer :: num_conti,j1,j2
3443 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3444 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3445 !el          num_conti,j1,j2
3446 !el local variables
3447       integer :: i,j,iti1,iti2,iti3,l
3448       real(kind=8) :: eello_turn4,s1,s2,s3
3449
3450       j=i+3
3451 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3452 !
3453 !               Fourth-order contributions
3454 !
3455 !                 (i+3)o----(i+4)
3456 !                     /  |
3457 !               (i+2)o   |
3458 !                     \  |
3459 !                 (i+1)o----i
3460 !
3461 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3462 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3463 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3464         a_temp(1,1)=a22
3465         a_temp(1,2)=a23
3466         a_temp(2,1)=a32
3467         a_temp(2,2)=a33
3468         iti1=itortyp(itype(i+1))
3469         iti2=itortyp(itype(i+2))
3470         iti3=itortyp(itype(i+3))
3471 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3472         call transpose2(EUg(1,1,i+1),e1t(1,1))
3473         call transpose2(Eug(1,1,i+2),e2t(1,1))
3474         call transpose2(Eug(1,1,i+3),e3t(1,1))
3475         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3476         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3477         s1=scalar2(b1(1,iti2),auxvec(1))
3478         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3479         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3480         s2=scalar2(b1(1,iti1),auxvec(1))
3481         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3482         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3483         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3484         eello_turn4=eello_turn4-(s1+s2+s3)
3485         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3486            'eturn4',i,j,-(s1+s2+s3)
3487 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3488 !d     &    ' eello_turn4_num',8*eello_turn4_num
3489 ! Derivatives in gamma(i)
3490         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3491         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3492         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3493         s1=scalar2(b1(1,iti2),auxvec(1))
3494         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3495         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3496         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3497 ! Derivatives in gamma(i+1)
3498         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3499         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3500         s2=scalar2(b1(1,iti1),auxvec(1))
3501         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3502         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3503         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3504         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3505 ! Derivatives in gamma(i+2)
3506         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3507         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3508         s1=scalar2(b1(1,iti2),auxvec(1))
3509         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3510         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3511         s2=scalar2(b1(1,iti1),auxvec(1))
3512         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3513         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3514         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3515         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3516 ! Cartesian derivatives
3517 ! Derivatives of this turn contributions in DC(i+2)
3518         if (j.lt.nres-1) then
3519           do l=1,3
3520             a_temp(1,1)=agg(l,1)
3521             a_temp(1,2)=agg(l,2)
3522             a_temp(2,1)=agg(l,3)
3523             a_temp(2,2)=agg(l,4)
3524             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3525             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3526             s1=scalar2(b1(1,iti2),auxvec(1))
3527             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3528             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3529             s2=scalar2(b1(1,iti1),auxvec(1))
3530             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3531             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3532             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3533             ggg(l)=-(s1+s2+s3)
3534             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3535           enddo
3536         endif
3537 ! Remaining derivatives of this turn contribution
3538         do l=1,3
3539           a_temp(1,1)=aggi(l,1)
3540           a_temp(1,2)=aggi(l,2)
3541           a_temp(2,1)=aggi(l,3)
3542           a_temp(2,2)=aggi(l,4)
3543           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3544           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3545           s1=scalar2(b1(1,iti2),auxvec(1))
3546           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3547           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3548           s2=scalar2(b1(1,iti1),auxvec(1))
3549           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3550           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3551           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3552           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3553           a_temp(1,1)=aggi1(l,1)
3554           a_temp(1,2)=aggi1(l,2)
3555           a_temp(2,1)=aggi1(l,3)
3556           a_temp(2,2)=aggi1(l,4)
3557           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3558           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3559           s1=scalar2(b1(1,iti2),auxvec(1))
3560           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3561           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3562           s2=scalar2(b1(1,iti1),auxvec(1))
3563           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3564           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3565           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3566           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3567           a_temp(1,1)=aggj(l,1)
3568           a_temp(1,2)=aggj(l,2)
3569           a_temp(2,1)=aggj(l,3)
3570           a_temp(2,2)=aggj(l,4)
3571           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3572           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3573           s1=scalar2(b1(1,iti2),auxvec(1))
3574           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3575           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3576           s2=scalar2(b1(1,iti1),auxvec(1))
3577           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3578           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3579           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3580           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3581           a_temp(1,1)=aggj1(l,1)
3582           a_temp(1,2)=aggj1(l,2)
3583           a_temp(2,1)=aggj1(l,3)
3584           a_temp(2,2)=aggj1(l,4)
3585           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3586           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3587           s1=scalar2(b1(1,iti2),auxvec(1))
3588           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3589           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3590           s2=scalar2(b1(1,iti1),auxvec(1))
3591           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3592           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3593           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3594 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3595           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3596         enddo
3597       return
3598       end subroutine eturn4
3599 !-----------------------------------------------------------------------------
3600       subroutine unormderiv(u,ugrad,unorm,ungrad)
3601 ! This subroutine computes the derivatives of a normalized vector u, given
3602 ! the derivatives computed without normalization conditions, ugrad. Returns
3603 ! ungrad.
3604 !      implicit none
3605       real(kind=8),dimension(3) :: u,vec
3606       real(kind=8),dimension(3,3) ::ugrad,ungrad
3607       real(kind=8) :: unorm     !,scalar
3608       integer :: i,j
3609 !      write (2,*) 'ugrad',ugrad
3610 !      write (2,*) 'u',u
3611       do i=1,3
3612         vec(i)=scalar(ugrad(1,i),u(1))
3613       enddo
3614 !      write (2,*) 'vec',vec
3615       do i=1,3
3616         do j=1,3
3617           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3618         enddo
3619       enddo
3620 !      write (2,*) 'ungrad',ungrad
3621       return
3622       end subroutine unormderiv
3623 !-----------------------------------------------------------------------------
3624       subroutine escp_soft_sphere(evdw2,evdw2_14)
3625 !
3626 ! This subroutine calculates the excluded-volume interaction energy between
3627 ! peptide-group centers and side chains and its gradient in virtual-bond and
3628 ! side-chain vectors.
3629 !
3630 !      implicit real*8 (a-h,o-z)
3631 !      include 'DIMENSIONS'
3632 !      include 'COMMON.GEO'
3633 !      include 'COMMON.VAR'
3634 !      include 'COMMON.LOCAL'
3635 !      include 'COMMON.CHAIN'
3636 !      include 'COMMON.DERIV'
3637 !      include 'COMMON.INTERACT'
3638 !      include 'COMMON.FFIELD'
3639 !      include 'COMMON.IOUNITS'
3640 !      include 'COMMON.CONTROL'
3641       real(kind=8),dimension(3) :: ggg
3642 !el local variables
3643       integer :: i,iint,j,k,iteli,itypj
3644       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3645                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3646
3647       evdw2=0.0D0
3648       evdw2_14=0.0d0
3649       r0_scp=4.5d0
3650 !d    print '(a)','Enter ESCP'
3651 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3652       do i=iatscp_s,iatscp_e
3653         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3654         iteli=itel(i)
3655         xi=0.5D0*(c(1,i)+c(1,i+1))
3656         yi=0.5D0*(c(2,i)+c(2,i+1))
3657         zi=0.5D0*(c(3,i)+c(3,i+1))
3658
3659         do iint=1,nscp_gr(i)
3660
3661         do j=iscpstart(i,iint),iscpend(i,iint)
3662           if (itype(j).eq.ntyp1) cycle
3663           itypj=iabs(itype(j))
3664 ! Uncomment following three lines for SC-p interactions
3665 !         xj=c(1,nres+j)-xi
3666 !         yj=c(2,nres+j)-yi
3667 !         zj=c(3,nres+j)-zi
3668 ! Uncomment following three lines for Ca-p interactions
3669           xj=c(1,j)-xi
3670           yj=c(2,j)-yi
3671           zj=c(3,j)-zi
3672           rij=xj*xj+yj*yj+zj*zj
3673           r0ij=r0_scp
3674           r0ijsq=r0ij*r0ij
3675           if (rij.lt.r0ijsq) then
3676             evdwij=0.25d0*(rij-r0ijsq)**2
3677             fac=rij-r0ijsq
3678           else
3679             evdwij=0.0d0
3680             fac=0.0d0
3681           endif
3682           evdw2=evdw2+evdwij
3683 !
3684 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3685 !
3686           ggg(1)=xj*fac
3687           ggg(2)=yj*fac
3688           ggg(3)=zj*fac
3689 !grad          if (j.lt.i) then
3690 !d          write (iout,*) 'j<i'
3691 ! Uncomment following three lines for SC-p interactions
3692 !           do k=1,3
3693 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3694 !           enddo
3695 !grad          else
3696 !d          write (iout,*) 'j>i'
3697 !grad            do k=1,3
3698 !grad              ggg(k)=-ggg(k)
3699 ! Uncomment following line for SC-p interactions
3700 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3701 !grad            enddo
3702 !grad          endif
3703 !grad          do k=1,3
3704 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3705 !grad          enddo
3706 !grad          kstart=min0(i+1,j)
3707 !grad          kend=max0(i-1,j-1)
3708 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3709 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3710 !grad          do k=kstart,kend
3711 !grad            do l=1,3
3712 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3713 !grad            enddo
3714 !grad          enddo
3715           do k=1,3
3716             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3717             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3718           enddo
3719         enddo
3720
3721         enddo ! iint
3722       enddo ! i
3723       return
3724       end subroutine escp_soft_sphere
3725 !-----------------------------------------------------------------------------
3726       subroutine escp(evdw2,evdw2_14)
3727 !
3728 ! This subroutine calculates the excluded-volume interaction energy between
3729 ! peptide-group centers and side chains and its gradient in virtual-bond and
3730 ! side-chain vectors.
3731 !
3732 !      implicit real*8 (a-h,o-z)
3733 !      include 'DIMENSIONS'
3734 !      include 'COMMON.GEO'
3735 !      include 'COMMON.VAR'
3736 !      include 'COMMON.LOCAL'
3737 !      include 'COMMON.CHAIN'
3738 !      include 'COMMON.DERIV'
3739 !      include 'COMMON.INTERACT'
3740 !      include 'COMMON.FFIELD'
3741 !      include 'COMMON.IOUNITS'
3742 !      include 'COMMON.CONTROL'
3743       real(kind=8),dimension(3) :: ggg
3744 !el local variables
3745       integer :: i,iint,j,k,iteli,itypj
3746       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
3747                    e1,e2,evdwij
3748
3749       evdw2=0.0D0
3750       evdw2_14=0.0d0
3751 !d    print '(a)','Enter ESCP'
3752 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3753       do i=iatscp_s,iatscp_e
3754         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3755         iteli=itel(i)
3756         xi=0.5D0*(c(1,i)+c(1,i+1))
3757         yi=0.5D0*(c(2,i)+c(2,i+1))
3758         zi=0.5D0*(c(3,i)+c(3,i+1))
3759
3760         do iint=1,nscp_gr(i)
3761
3762         do j=iscpstart(i,iint),iscpend(i,iint)
3763           itypj=iabs(itype(j))
3764           if (itypj.eq.ntyp1) cycle
3765 ! Uncomment following three lines for SC-p interactions
3766 !         xj=c(1,nres+j)-xi
3767 !         yj=c(2,nres+j)-yi
3768 !         zj=c(3,nres+j)-zi
3769 ! Uncomment following three lines for Ca-p interactions
3770           xj=c(1,j)-xi
3771           yj=c(2,j)-yi
3772           zj=c(3,j)-zi
3773           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3774           fac=rrij**expon2
3775           e1=fac*fac*aad(itypj,iteli)
3776           e2=fac*bad(itypj,iteli)
3777           if (iabs(j-i) .le. 2) then
3778             e1=scal14*e1
3779             e2=scal14*e2
3780             evdw2_14=evdw2_14+e1+e2
3781           endif
3782           evdwij=e1+e2
3783           evdw2=evdw2+evdwij
3784           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
3785              'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
3786             bad(itypj,iteli)
3787 !
3788 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3789 !
3790           fac=-(evdwij+e1)*rrij
3791           ggg(1)=xj*fac
3792           ggg(2)=yj*fac
3793           ggg(3)=zj*fac
3794 !grad          if (j.lt.i) then
3795 !d          write (iout,*) 'j<i'
3796 ! Uncomment following three lines for SC-p interactions
3797 !           do k=1,3
3798 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3799 !           enddo
3800 !grad          else
3801 !d          write (iout,*) 'j>i'
3802 !grad            do k=1,3
3803 !grad              ggg(k)=-ggg(k)
3804 ! Uncomment following line for SC-p interactions
3805 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3806 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3807 !grad            enddo
3808 !grad          endif
3809 !grad          do k=1,3
3810 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3811 !grad          enddo
3812 !grad          kstart=min0(i+1,j)
3813 !grad          kend=max0(i-1,j-1)
3814 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3815 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3816 !grad          do k=kstart,kend
3817 !grad            do l=1,3
3818 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3819 !grad            enddo
3820 !grad          enddo
3821           do k=1,3
3822             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3823             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3824           enddo
3825         enddo
3826
3827         enddo ! iint
3828       enddo ! i
3829       do i=1,nct
3830         do j=1,3
3831           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3832           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3833           gradx_scp(j,i)=expon*gradx_scp(j,i)
3834         enddo
3835       enddo
3836 !******************************************************************************
3837 !
3838 !                              N O T E !!!
3839 !
3840 ! To save time the factor EXPON has been extracted from ALL components
3841 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
3842 ! use!
3843 !
3844 !******************************************************************************
3845       return
3846       end subroutine escp
3847 !-----------------------------------------------------------------------------
3848       subroutine edis(ehpb)
3849 !
3850 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3851 !
3852 !      implicit real*8 (a-h,o-z)
3853 !      include 'DIMENSIONS'
3854 !      include 'COMMON.SBRIDGE'
3855 !      include 'COMMON.CHAIN'
3856 !      include 'COMMON.DERIV'
3857 !      include 'COMMON.VAR'
3858 !      include 'COMMON.INTERACT'
3859 !      include 'COMMON.IOUNITS'
3860       real(kind=8),dimension(3) :: ggg
3861 !el local variables
3862       integer :: i,j,ii,jj,iii,jjj,k
3863       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
3864
3865       ehpb=0.0D0
3866 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3867 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
3868       if (link_end.eq.0) return
3869       do i=link_start,link_end
3870 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3871 ! CA-CA distance used in regularization of structure.
3872         ii=ihpb(i)
3873         jj=jhpb(i)
3874 ! iii and jjj point to the residues for which the distance is assigned.
3875         if (ii.gt.nres) then
3876           iii=ii-nres
3877           jjj=jj-nres
3878         else
3879           iii=ii
3880           jjj=jj
3881         endif
3882 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
3883 !     &    dhpb(i),dhpb1(i),forcon(i)
3884 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
3885 !    distance and angle dependent SS bond potential.
3886 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3887 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
3888         if (.not.dyn_ss .and. i.le.nss) then
3889 ! 15/02/13 CC dynamic SSbond - additional check
3890          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
3891         iabs(itype(jjj)).eq.1) then
3892           call ssbond_ene(iii,jjj,eij)
3893           ehpb=ehpb+2*eij
3894 !d          write (iout,*) "eij",eij
3895          endif
3896         else
3897 ! Calculate the distance between the two points and its difference from the
3898 ! target distance.
3899         dd=dist(ii,jj)
3900         rdis=dd-dhpb(i)
3901 ! Get the force constant corresponding to this distance.
3902         waga=forcon(i)
3903 ! Calculate the contribution to energy.
3904         ehpb=ehpb+waga*rdis*rdis
3905 !
3906 ! Evaluate gradient.
3907 !
3908         fac=waga*rdis/dd
3909 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3910 !d   &   ' waga=',waga,' fac=',fac
3911         do j=1,3
3912           ggg(j)=fac*(c(j,jj)-c(j,ii))
3913         enddo
3914 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3915 ! If this is a SC-SC distance, we need to calculate the contributions to the
3916 ! Cartesian gradient in the SC vectors (ghpbx).
3917         if (iii.lt.ii) then
3918           do j=1,3
3919             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3920             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3921           enddo
3922         endif
3923 !grad        do j=iii,jjj-1
3924 !grad          do k=1,3
3925 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3926 !grad          enddo
3927 !grad        enddo
3928         do k=1,3
3929           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3930           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3931         enddo
3932         endif
3933       enddo
3934       ehpb=0.5D0*ehpb
3935       return
3936       end subroutine edis
3937 !-----------------------------------------------------------------------------
3938       subroutine ssbond_ene(i,j,eij)
3939 !
3940 ! Calculate the distance and angle dependent SS-bond potential energy
3941 ! using a free-energy function derived based on RHF/6-31G** ab initio
3942 ! calculations of diethyl disulfide.
3943 !
3944 ! A. Liwo and U. Kozlowska, 11/24/03
3945 !
3946 !      implicit real*8 (a-h,o-z)
3947 !      include 'DIMENSIONS'
3948 !      include 'COMMON.SBRIDGE'
3949 !      include 'COMMON.CHAIN'
3950 !      include 'COMMON.DERIV'
3951 !      include 'COMMON.LOCAL'
3952 !      include 'COMMON.INTERACT'
3953 !      include 'COMMON.VAR'
3954 !      include 'COMMON.IOUNITS'
3955       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
3956 !el local variables
3957       integer :: i,j,itypi,itypj,k
3958       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
3959                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
3960                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
3961                    cosphi,ggk
3962
3963       itypi=iabs(itype(i))
3964       xi=c(1,nres+i)
3965       yi=c(2,nres+i)
3966       zi=c(3,nres+i)
3967       dxi=dc_norm(1,nres+i)
3968       dyi=dc_norm(2,nres+i)
3969       dzi=dc_norm(3,nres+i)
3970 !      dsci_inv=dsc_inv(itypi)
3971       dsci_inv=vbld_inv(nres+i)
3972       itypj=iabs(itype(j))
3973 !      dscj_inv=dsc_inv(itypj)
3974       dscj_inv=vbld_inv(nres+j)
3975       xj=c(1,nres+j)-xi
3976       yj=c(2,nres+j)-yi
3977       zj=c(3,nres+j)-zi
3978       dxj=dc_norm(1,nres+j)
3979       dyj=dc_norm(2,nres+j)
3980       dzj=dc_norm(3,nres+j)
3981       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3982       rij=dsqrt(rrij)
3983       erij(1)=xj*rij
3984       erij(2)=yj*rij
3985       erij(3)=zj*rij
3986       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3987       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3988       om12=dxi*dxj+dyi*dyj+dzi*dzj
3989       do k=1,3
3990         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3991         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3992       enddo
3993       rij=1.0d0/rij
3994       deltad=rij-d0cm
3995       deltat1=1.0d0-om1
3996       deltat2=1.0d0+om2
3997       deltat12=om2-om1+2.0d0
3998       cosphi=om12-om1*om2
3999       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4000         +akct*deltad*deltat12 &
4001         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4002 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4003 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4004 !     &  " deltat12",deltat12," eij",eij
4005       ed=2*akcm*deltad+akct*deltat12
4006       pom1=akct*deltad
4007       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4008       eom1=-2*akth*deltat1-pom1-om2*pom2
4009       eom2= 2*akth*deltat2+pom1-om1*pom2
4010       eom12=pom2
4011       do k=1,3
4012         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4013         ghpbx(k,i)=ghpbx(k,i)-ggk &
4014                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4015                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4016         ghpbx(k,j)=ghpbx(k,j)+ggk &
4017                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4018                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4019         ghpbc(k,i)=ghpbc(k,i)-ggk
4020         ghpbc(k,j)=ghpbc(k,j)+ggk
4021       enddo
4022 !
4023 ! Calculate the components of the gradient in DC and X
4024 !
4025 !grad      do k=i,j-1
4026 !grad        do l=1,3
4027 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4028 !grad        enddo
4029 !grad      enddo
4030       return
4031       end subroutine ssbond_ene
4032 !-----------------------------------------------------------------------------
4033       subroutine ebond(estr)
4034 !
4035 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4036 !
4037 !      implicit real*8 (a-h,o-z)
4038 !      include 'DIMENSIONS'
4039 !      include 'COMMON.LOCAL'
4040 !      include 'COMMON.GEO'
4041 !      include 'COMMON.INTERACT'
4042 !      include 'COMMON.DERIV'
4043 !      include 'COMMON.VAR'
4044 !      include 'COMMON.CHAIN'
4045 !      include 'COMMON.IOUNITS'
4046 !      include 'COMMON.NAMES'
4047 !      include 'COMMON.FFIELD'
4048 !      include 'COMMON.CONTROL'
4049 !      include 'COMMON.SETUP'
4050       real(kind=8),dimension(3) :: u,ud
4051 !el local variables
4052       integer :: i,j,iti,nbi,k
4053       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4054                    uprod1,uprod2
4055
4056       estr=0.0d0
4057       estr1=0.0d0
4058 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4059 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4060
4061       do i=ibondp_start,ibondp_end
4062         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4063           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4064           do j=1,3
4065           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4066             *dc(j,i-1)/vbld(i)
4067           enddo
4068           if (energy_dec) write(iout,*) &
4069              "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4070         else
4071         diff = vbld(i)-vbldp0
4072         if (energy_dec) write (iout,*) &
4073            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4074         estr=estr+diff*diff
4075         do j=1,3
4076           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4077         enddo
4078 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4079         endif
4080       enddo
4081       estr=0.5d0*AKP*estr+estr1
4082 !
4083 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4084 !
4085       do i=ibond_start,ibond_end
4086         iti=iabs(itype(i))
4087         if (iti.ne.10 .and. iti.ne.ntyp1) then
4088           nbi=nbondterm(iti)
4089           if (nbi.eq.1) then
4090             diff=vbld(i+nres)-vbldsc0(1,iti)
4091             if (energy_dec) write (iout,*) &
4092             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4093             AKSC(1,iti),AKSC(1,iti)*diff*diff
4094             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4095             do j=1,3
4096               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4097             enddo
4098           else
4099             do j=1,nbi
4100               diff=vbld(i+nres)-vbldsc0(j,iti)
4101               ud(j)=aksc(j,iti)*diff
4102               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4103             enddo
4104             uprod=u(1)
4105             do j=2,nbi
4106               uprod=uprod*u(j)
4107             enddo
4108             usum=0.0d0
4109             usumsqder=0.0d0
4110             do j=1,nbi
4111               uprod1=1.0d0
4112               uprod2=1.0d0
4113               do k=1,nbi
4114                 if (k.ne.j) then
4115                   uprod1=uprod1*u(k)
4116                   uprod2=uprod2*u(k)*u(k)
4117                 endif
4118               enddo
4119               usum=usum+uprod1
4120               usumsqder=usumsqder+ud(j)*uprod2
4121             enddo
4122             estr=estr+uprod/usum
4123             do j=1,3
4124              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4125             enddo
4126           endif
4127         endif
4128       enddo
4129       return
4130       end subroutine ebond
4131 #ifdef CRYST_THETA
4132 !-----------------------------------------------------------------------------
4133       subroutine ebend(etheta)
4134 !
4135 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4136 ! angles gamma and its derivatives in consecutive thetas and gammas.
4137 !
4138       use comm_calcthet
4139 !      implicit real*8 (a-h,o-z)
4140 !      include 'DIMENSIONS'
4141 !      include 'COMMON.LOCAL'
4142 !      include 'COMMON.GEO'
4143 !      include 'COMMON.INTERACT'
4144 !      include 'COMMON.DERIV'
4145 !      include 'COMMON.VAR'
4146 !      include 'COMMON.CHAIN'
4147 !      include 'COMMON.IOUNITS'
4148 !      include 'COMMON.NAMES'
4149 !      include 'COMMON.FFIELD'
4150 !      include 'COMMON.CONTROL'
4151 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4152 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4153 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4154 !el      integer :: it
4155 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4156 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4157 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4158 !el local variables
4159       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4160        ichir21,ichir22
4161       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4162        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4163        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4164       real(kind=8),dimension(2) :: y,z
4165
4166       delta=0.02d0*pi
4167 !      time11=dexp(-2*time)
4168 !      time12=1.0d0
4169       etheta=0.0D0
4170 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4171       do i=ithet_start,ithet_end
4172         if (itype(i-1).eq.ntyp1) cycle
4173 ! Zero the energy function and its derivative at 0 or pi.
4174         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4175         it=itype(i-1)
4176         ichir1=isign(1,itype(i-2))
4177         ichir2=isign(1,itype(i))
4178          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4179          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4180          if (itype(i-1).eq.10) then
4181           itype1=isign(10,itype(i-2))
4182           ichir11=isign(1,itype(i-2))
4183           ichir12=isign(1,itype(i-2))
4184           itype2=isign(10,itype(i))
4185           ichir21=isign(1,itype(i))
4186           ichir22=isign(1,itype(i))
4187          endif
4188
4189         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4190 #ifdef OSF
4191           phii=phi(i)
4192           if (phii.ne.phii) phii=150.0
4193 #else
4194           phii=phi(i)
4195 #endif
4196           y(1)=dcos(phii)
4197           y(2)=dsin(phii)
4198         else
4199           y(1)=0.0D0
4200           y(2)=0.0D0
4201         endif
4202         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4203 #ifdef OSF
4204           phii1=phi(i+1)
4205           if (phii1.ne.phii1) phii1=150.0
4206           phii1=pinorm(phii1)
4207           z(1)=cos(phii1)
4208 #else
4209           phii1=phi(i+1)
4210           z(1)=dcos(phii1)
4211 #endif
4212           z(2)=dsin(phii1)
4213         else
4214           z(1)=0.0D0
4215           z(2)=0.0D0
4216         endif
4217 ! Calculate the "mean" value of theta from the part of the distribution
4218 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4219 ! In following comments this theta will be referred to as t_c.
4220         thet_pred_mean=0.0d0
4221         do k=1,2
4222             athetk=athet(k,it,ichir1,ichir2)
4223             bthetk=bthet(k,it,ichir1,ichir2)
4224           if (it.eq.10) then
4225              athetk=athet(k,itype1,ichir11,ichir12)
4226              bthetk=bthet(k,itype2,ichir21,ichir22)
4227           endif
4228          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4229         enddo
4230         dthett=thet_pred_mean*ssd
4231         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4232 ! Derivatives of the "mean" values in gamma1 and gamma2.
4233         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4234                +athet(2,it,ichir1,ichir2)*y(1))*ss
4235         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4236                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4237          if (it.eq.10) then
4238         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4239              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4240         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4241                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4242          endif
4243         if (theta(i).gt.pi-delta) then
4244           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4245                E_tc0)
4246           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4247           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4248           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4249               E_theta)
4250           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4251               E_tc)
4252         else if (theta(i).lt.delta) then
4253           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4254           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4255           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4256               E_theta)
4257           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4258           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4259               E_tc)
4260         else
4261           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4262               E_theta,E_tc)
4263         endif
4264         etheta=etheta+ethetai
4265         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4266             'ebend',i,ethetai
4267         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4268         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4269         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4270       enddo
4271 ! Ufff.... We've done all this!!!
4272       return
4273       end subroutine ebend
4274 !-----------------------------------------------------------------------------
4275       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4276
4277       use comm_calcthet
4278 !      implicit real*8 (a-h,o-z)
4279 !      include 'DIMENSIONS'
4280 !      include 'COMMON.LOCAL'
4281 !      include 'COMMON.IOUNITS'
4282 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4283 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4284 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4285       integer :: i,j,k
4286       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4287 !el      integer :: it
4288 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4289 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4290 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4291 !el local variables
4292       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4293        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4294
4295 ! Calculate the contributions to both Gaussian lobes.
4296 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4297 ! The "polynomial part" of the "standard deviation" of this part of
4298 ! the distribution.
4299         sig=polthet(3,it)
4300         do j=2,0,-1
4301           sig=sig*thet_pred_mean+polthet(j,it)
4302         enddo
4303 ! Derivative of the "interior part" of the "standard deviation of the"
4304 ! gamma-dependent Gaussian lobe in t_c.
4305         sigtc=3*polthet(3,it)
4306         do j=2,1,-1
4307           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4308         enddo
4309         sigtc=sig*sigtc
4310 ! Set the parameters of both Gaussian lobes of the distribution.
4311 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4312         fac=sig*sig+sigc0(it)
4313         sigcsq=fac+fac
4314         sigc=1.0D0/sigcsq
4315 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4316         sigsqtc=-4.0D0*sigcsq*sigtc
4317 !       print *,i,sig,sigtc,sigsqtc
4318 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4319         sigtc=-sigtc/(fac*fac)
4320 ! Following variable is sigma(t_c)**(-2)
4321         sigcsq=sigcsq*sigcsq
4322         sig0i=sig0(it)
4323         sig0inv=1.0D0/sig0i**2
4324         delthec=thetai-thet_pred_mean
4325         delthe0=thetai-theta0i
4326         term1=-0.5D0*sigcsq*delthec*delthec
4327         term2=-0.5D0*sig0inv*delthe0*delthe0
4328 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4329 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4330 ! to the energy (this being the log of the distribution) at the end of energy
4331 ! term evaluation for this virtual-bond angle.
4332         if (term1.gt.term2) then
4333           termm=term1
4334           term2=dexp(term2-termm)
4335           term1=1.0d0
4336         else
4337           termm=term2
4338           term1=dexp(term1-termm)
4339           term2=1.0d0
4340         endif
4341 ! The ratio between the gamma-independent and gamma-dependent lobes of
4342 ! the distribution is a Gaussian function of thet_pred_mean too.
4343         diffak=gthet(2,it)-thet_pred_mean
4344         ratak=diffak/gthet(3,it)**2
4345         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4346 ! Let's differentiate it in thet_pred_mean NOW.
4347         aktc=ak*ratak
4348 ! Now put together the distribution terms to make complete distribution.
4349         termexp=term1+ak*term2
4350         termpre=sigc+ak*sig0i
4351 ! Contribution of the bending energy from this theta is just the -log of
4352 ! the sum of the contributions from the two lobes and the pre-exponential
4353 ! factor. Simple enough, isn't it?
4354         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4355 ! NOW the derivatives!!!
4356 ! 6/6/97 Take into account the deformation.
4357         E_theta=(delthec*sigcsq*term1 &
4358              +ak*delthe0*sig0inv*term2)/termexp
4359         E_tc=((sigtc+aktc*sig0i)/termpre &
4360             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4361              aktc*term2)/termexp)
4362       return
4363       end subroutine theteng
4364 #else
4365 !-----------------------------------------------------------------------------
4366       subroutine ebend(etheta)
4367 !
4368 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4369 ! angles gamma and its derivatives in consecutive thetas and gammas.
4370 ! ab initio-derived potentials from
4371 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4372 !
4373 !      implicit real*8 (a-h,o-z)
4374 !      include 'DIMENSIONS'
4375 !      include 'COMMON.LOCAL'
4376 !      include 'COMMON.GEO'
4377 !      include 'COMMON.INTERACT'
4378 !      include 'COMMON.DERIV'
4379 !      include 'COMMON.VAR'
4380 !      include 'COMMON.CHAIN'
4381 !      include 'COMMON.IOUNITS'
4382 !      include 'COMMON.NAMES'
4383 !      include 'COMMON.FFIELD'
4384 !      include 'COMMON.CONTROL'
4385       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4386       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4387       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4388       logical :: lprn=.false., lprn1=.false.
4389 !el local variables
4390       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4391       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4392       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4393
4394       etheta=0.0D0
4395       do i=ithet_start,ithet_end
4396         if (itype(i-1).eq.ntyp1) cycle
4397         if (iabs(itype(i+1)).eq.20) iblock=2
4398         if (iabs(itype(i+1)).ne.20) iblock=1
4399         dethetai=0.0d0
4400         dephii=0.0d0
4401         dephii1=0.0d0
4402         theti2=0.5d0*theta(i)
4403         ityp2=ithetyp((itype(i-1)))
4404         do k=1,nntheterm
4405           coskt(k)=dcos(k*theti2)
4406           sinkt(k)=dsin(k*theti2)
4407         enddo
4408         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4409 #ifdef OSF
4410           phii=phi(i)
4411           if (phii.ne.phii) phii=150.0
4412 #else
4413           phii=phi(i)
4414 #endif
4415           ityp1=ithetyp((itype(i-2)))
4416 ! propagation of chirality for glycine type
4417           do k=1,nsingle
4418             cosph1(k)=dcos(k*phii)
4419             sinph1(k)=dsin(k*phii)
4420           enddo
4421         else
4422           phii=0.0d0
4423           ityp1=nthetyp+1
4424           do k=1,nsingle
4425             cosph1(k)=0.0d0
4426             sinph1(k)=0.0d0
4427           enddo
4428         endif
4429         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4430 #ifdef OSF
4431           phii1=phi(i+1)
4432           if (phii1.ne.phii1) phii1=150.0
4433           phii1=pinorm(phii1)
4434 #else
4435           phii1=phi(i+1)
4436 #endif
4437           ityp3=ithetyp((itype(i)))
4438           do k=1,nsingle
4439             cosph2(k)=dcos(k*phii1)
4440             sinph2(k)=dsin(k*phii1)
4441           enddo
4442         else
4443           phii1=0.0d0
4444           ityp3=nthetyp+1
4445           do k=1,nsingle
4446             cosph2(k)=0.0d0
4447             sinph2(k)=0.0d0
4448           enddo
4449         endif
4450         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4451         do k=1,ndouble
4452           do l=1,k-1
4453             ccl=cosph1(l)*cosph2(k-l)
4454             ssl=sinph1(l)*sinph2(k-l)
4455             scl=sinph1(l)*cosph2(k-l)
4456             csl=cosph1(l)*sinph2(k-l)
4457             cosph1ph2(l,k)=ccl-ssl
4458             cosph1ph2(k,l)=ccl+ssl
4459             sinph1ph2(l,k)=scl+csl
4460             sinph1ph2(k,l)=scl-csl
4461           enddo
4462         enddo
4463         if (lprn) then
4464         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4465           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4466         write (iout,*) "coskt and sinkt"
4467         do k=1,nntheterm
4468           write (iout,*) k,coskt(k),sinkt(k)
4469         enddo
4470         endif
4471         do k=1,ntheterm
4472           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4473           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4474             *coskt(k)
4475           if (lprn) &
4476           write (iout,*) "k",k,&
4477            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4478            " ethetai",ethetai
4479         enddo
4480         if (lprn) then
4481         write (iout,*) "cosph and sinph"
4482         do k=1,nsingle
4483           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4484         enddo
4485         write (iout,*) "cosph1ph2 and sinph2ph2"
4486         do k=2,ndouble
4487           do l=1,k-1
4488             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4489                sinph1ph2(l,k),sinph1ph2(k,l)
4490           enddo
4491         enddo
4492         write(iout,*) "ethetai",ethetai
4493         endif
4494         do m=1,ntheterm2
4495           do k=1,nsingle
4496             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4497                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4498                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4499                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4500             ethetai=ethetai+sinkt(m)*aux
4501             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4502             dephii=dephii+k*sinkt(m)* &
4503                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4504                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4505             dephii1=dephii1+k*sinkt(m)* &
4506                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4507                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4508             if (lprn) &
4509             write (iout,*) "m",m," k",k," bbthet", &
4510                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4511                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4512                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4513                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4514           enddo
4515         enddo
4516         if (lprn) &
4517         write(iout,*) "ethetai",ethetai
4518         do m=1,ntheterm3
4519           do k=2,ndouble
4520             do l=1,k-1
4521               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4522                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4523                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4524                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4525               ethetai=ethetai+sinkt(m)*aux
4526               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4527               dephii=dephii+l*sinkt(m)* &
4528                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4529                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4530                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4531                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4532               dephii1=dephii1+(k-l)*sinkt(m)* &
4533                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4534                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4535                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4536                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4537               if (lprn) then
4538               write (iout,*) "m",m," k",k," l",l," ffthet",&
4539                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4540                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4541                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4542                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4543                   " ethetai",ethetai
4544               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4545                   cosph1ph2(k,l)*sinkt(m),&
4546                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4547               endif
4548             enddo
4549           enddo
4550         enddo
4551 10      continue
4552 !        lprn1=.true.
4553         if (lprn1) &
4554           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4555          i,theta(i)*rad2deg,phii*rad2deg,&
4556          phii1*rad2deg,ethetai
4557 !        lprn1=.false.
4558         etheta=etheta+ethetai
4559         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4560         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4561         gloc(nphi+i-2,icg)=wang*dethetai
4562       enddo
4563       return
4564       end subroutine ebend
4565 #endif
4566 #ifdef CRYST_SC
4567 !-----------------------------------------------------------------------------
4568       subroutine esc(escloc)
4569 ! Calculate the local energy of a side chain and its derivatives in the
4570 ! corresponding virtual-bond valence angles THETA and the spherical angles
4571 ! ALPHA and OMEGA.
4572 !
4573       use comm_sccalc
4574 !      implicit real*8 (a-h,o-z)
4575 !      include 'DIMENSIONS'
4576 !      include 'COMMON.GEO'
4577 !      include 'COMMON.LOCAL'
4578 !      include 'COMMON.VAR'
4579 !      include 'COMMON.INTERACT'
4580 !      include 'COMMON.DERIV'
4581 !      include 'COMMON.CHAIN'
4582 !      include 'COMMON.IOUNITS'
4583 !      include 'COMMON.NAMES'
4584 !      include 'COMMON.FFIELD'
4585 !      include 'COMMON.CONTROL'
4586       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4587          ddersc0,ddummy,xtemp,temp
4588 !el      real(kind=8) :: time11,time12,time112,theti
4589       real(kind=8) :: escloc,delta
4590 !el      integer :: it,nlobit
4591 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4592 !el local variables
4593       integer :: i,k
4594       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4595        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4596       delta=0.02d0*pi
4597       escloc=0.0D0
4598 !     write (iout,'(a)') 'ESC'
4599       do i=loc_start,loc_end
4600         it=itype(i)
4601         if (it.eq.ntyp1) cycle
4602         if (it.eq.10) goto 1
4603         nlobit=nlob(iabs(it))
4604 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4605 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4606         theti=theta(i+1)-pipol
4607         x(1)=dtan(theti)
4608         x(2)=alph(i)
4609         x(3)=omeg(i)
4610
4611         if (x(2).gt.pi-delta) then
4612           xtemp(1)=x(1)
4613           xtemp(2)=pi-delta
4614           xtemp(3)=x(3)
4615           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4616           xtemp(2)=pi
4617           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4618           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4619               escloci,dersc(2))
4620           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4621               ddersc0(1),dersc(1))
4622           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4623               ddersc0(3),dersc(3))
4624           xtemp(2)=pi-delta
4625           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4626           xtemp(2)=pi
4627           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4628           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4629                   dersc0(2),esclocbi,dersc02)
4630           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4631                   dersc12,dersc01)
4632           call splinthet(x(2),0.5d0*delta,ss,ssd)
4633           dersc0(1)=dersc01
4634           dersc0(2)=dersc02
4635           dersc0(3)=0.0d0
4636           do k=1,3
4637             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4638           enddo
4639           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4640 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4641 !    &             esclocbi,ss,ssd
4642           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4643 !         escloci=esclocbi
4644 !         write (iout,*) escloci
4645         else if (x(2).lt.delta) then
4646           xtemp(1)=x(1)
4647           xtemp(2)=delta
4648           xtemp(3)=x(3)
4649           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4650           xtemp(2)=0.0d0
4651           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4652           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4653               escloci,dersc(2))
4654           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4655               ddersc0(1),dersc(1))
4656           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4657               ddersc0(3),dersc(3))
4658           xtemp(2)=delta
4659           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4660           xtemp(2)=0.0d0
4661           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4662           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4663                   dersc0(2),esclocbi,dersc02)
4664           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4665                   dersc12,dersc01)
4666           dersc0(1)=dersc01
4667           dersc0(2)=dersc02
4668           dersc0(3)=0.0d0
4669           call splinthet(x(2),0.5d0*delta,ss,ssd)
4670           do k=1,3
4671             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4672           enddo
4673           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4674 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4675 !    &             esclocbi,ss,ssd
4676           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4677 !         write (iout,*) escloci
4678         else
4679           call enesc(x,escloci,dersc,ddummy,.false.)
4680         endif
4681
4682         escloc=escloc+escloci
4683         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4684            'escloc',i,escloci
4685 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4686
4687         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
4688          wscloc*dersc(1)
4689         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4690         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4691     1   continue
4692       enddo
4693       return
4694       end subroutine esc
4695 !-----------------------------------------------------------------------------
4696       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4697
4698       use comm_sccalc
4699 !      implicit real*8 (a-h,o-z)
4700 !      include 'DIMENSIONS'
4701 !      include 'COMMON.GEO'
4702 !      include 'COMMON.LOCAL'
4703 !      include 'COMMON.IOUNITS'
4704 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4705       real(kind=8),dimension(3) :: x,z,dersc,ddersc
4706       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
4707       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
4708       real(kind=8) :: escloci
4709       logical :: mixed
4710 !el local variables
4711       integer :: j,iii,l,k !el,it,nlobit
4712       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
4713 !el       time11,time12,time112
4714 !       write (iout,*) 'it=',it,' nlobit=',nlobit
4715         escloc_i=0.0D0
4716         do j=1,3
4717           dersc(j)=0.0D0
4718           if (mixed) ddersc(j)=0.0d0
4719         enddo
4720         x3=x(3)
4721
4722 ! Because of periodicity of the dependence of the SC energy in omega we have
4723 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4724 ! To avoid underflows, first compute & store the exponents.
4725
4726         do iii=-1,1
4727
4728           x(3)=x3+iii*dwapi
4729
4730           do j=1,nlobit
4731             do k=1,3
4732               z(k)=x(k)-censc(k,j,it)
4733             enddo
4734             do k=1,3
4735               Axk=0.0D0
4736               do l=1,3
4737                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4738               enddo
4739               Ax(k,j,iii)=Axk
4740             enddo
4741             expfac=0.0D0
4742             do k=1,3
4743               expfac=expfac+Ax(k,j,iii)*z(k)
4744             enddo
4745             contr(j,iii)=expfac
4746           enddo ! j
4747
4748         enddo ! iii
4749
4750         x(3)=x3
4751 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4752 ! subsequent NaNs and INFs in energy calculation.
4753 ! Find the largest exponent
4754         emin=contr(1,-1)
4755         do iii=-1,1
4756           do j=1,nlobit
4757             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4758           enddo
4759         enddo
4760         emin=0.5D0*emin
4761 !d      print *,'it=',it,' emin=',emin
4762
4763 ! Compute the contribution to SC energy and derivatives
4764         do iii=-1,1
4765
4766           do j=1,nlobit
4767 #ifdef OSF
4768             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4769             if(adexp.ne.adexp) adexp=1.0
4770             expfac=dexp(adexp)
4771 #else
4772             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4773 #endif
4774 !d          print *,'j=',j,' expfac=',expfac
4775             escloc_i=escloc_i+expfac
4776             do k=1,3
4777               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4778             enddo
4779             if (mixed) then
4780               do k=1,3,2
4781                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
4782                   +gaussc(k,2,j,it))*expfac
4783               enddo
4784             endif
4785           enddo
4786
4787         enddo ! iii
4788
4789         dersc(1)=dersc(1)/cos(theti)**2
4790         ddersc(1)=ddersc(1)/cos(theti)**2
4791         ddersc(3)=ddersc(3)
4792
4793         escloci=-(dlog(escloc_i)-emin)
4794         do j=1,3
4795           dersc(j)=dersc(j)/escloc_i
4796         enddo
4797         if (mixed) then
4798           do j=1,3,2
4799             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4800           enddo
4801         endif
4802       return
4803       end subroutine enesc
4804 !-----------------------------------------------------------------------------
4805       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4806
4807       use comm_sccalc
4808 !      implicit real*8 (a-h,o-z)
4809 !      include 'DIMENSIONS'
4810 !      include 'COMMON.GEO'
4811 !      include 'COMMON.LOCAL'
4812 !      include 'COMMON.IOUNITS'
4813 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4814       real(kind=8),dimension(3) :: x,z,dersc
4815       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
4816       real(kind=8),dimension(nlobit) :: contr !(maxlob)
4817       real(kind=8) :: escloci,dersc12,emin
4818       logical :: mixed
4819 !el local varables
4820       integer :: j,k,l !el,it,nlobit
4821       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
4822
4823       escloc_i=0.0D0
4824
4825       do j=1,3
4826         dersc(j)=0.0D0
4827       enddo
4828
4829       do j=1,nlobit
4830         do k=1,2
4831           z(k)=x(k)-censc(k,j,it)
4832         enddo
4833         z(3)=dwapi
4834         do k=1,3
4835           Axk=0.0D0
4836           do l=1,3
4837             Axk=Axk+gaussc(l,k,j,it)*z(l)
4838           enddo
4839           Ax(k,j)=Axk
4840         enddo
4841         expfac=0.0D0
4842         do k=1,3
4843           expfac=expfac+Ax(k,j)*z(k)
4844         enddo
4845         contr(j)=expfac
4846       enddo ! j
4847
4848 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4849 ! subsequent NaNs and INFs in energy calculation.
4850 ! Find the largest exponent
4851       emin=contr(1)
4852       do j=1,nlobit
4853         if (emin.gt.contr(j)) emin=contr(j)
4854       enddo
4855       emin=0.5D0*emin
4856
4857 ! Compute the contribution to SC energy and derivatives
4858
4859       dersc12=0.0d0
4860       do j=1,nlobit
4861         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4862         escloc_i=escloc_i+expfac
4863         do k=1,2
4864           dersc(k)=dersc(k)+Ax(k,j)*expfac
4865         enddo
4866         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
4867                   +gaussc(1,2,j,it))*expfac
4868         dersc(3)=0.0d0
4869       enddo
4870
4871       dersc(1)=dersc(1)/cos(theti)**2
4872       dersc12=dersc12/cos(theti)**2
4873       escloci=-(dlog(escloc_i)-emin)
4874       do j=1,2
4875         dersc(j)=dersc(j)/escloc_i
4876       enddo
4877       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4878       return
4879       end subroutine enesc_bound
4880 #else
4881 !-----------------------------------------------------------------------------
4882       subroutine esc(escloc)
4883 ! Calculate the local energy of a side chain and its derivatives in the
4884 ! corresponding virtual-bond valence angles THETA and the spherical angles
4885 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
4886 ! added by Urszula Kozlowska. 07/11/2007
4887 !
4888       use comm_sccalc
4889 !      implicit real*8 (a-h,o-z)
4890 !      include 'DIMENSIONS'
4891 !      include 'COMMON.GEO'
4892 !      include 'COMMON.LOCAL'
4893 !      include 'COMMON.VAR'
4894 !      include 'COMMON.SCROT'
4895 !      include 'COMMON.INTERACT'
4896 !      include 'COMMON.DERIV'
4897 !      include 'COMMON.CHAIN'
4898 !      include 'COMMON.IOUNITS'
4899 !      include 'COMMON.NAMES'
4900 !      include 'COMMON.FFIELD'
4901 !      include 'COMMON.CONTROL'
4902 !      include 'COMMON.VECTORS'
4903       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
4904       real(kind=8),dimension(65) :: x
4905       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
4906          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
4907       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
4908       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
4909          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
4910 !el local variables
4911       integer :: i,j,k !el,it,nlobit
4912       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
4913 !el      real(kind=8) :: time11,time12,time112,theti
4914 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4915       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
4916                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
4917                    sumene1x,sumene2x,sumene3x,sumene4x,&
4918                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
4919                    cosfac2xx,sinfac2yy
4920 !el #define DEBUG
4921 #ifdef DEBUG
4922       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
4923                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
4924                    de_dt_num
4925 #endif
4926 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
4927
4928       delta=0.02d0*pi
4929       escloc=0.0D0
4930       do i=loc_start,loc_end
4931         if (itype(i).eq.ntyp1) cycle
4932         costtab(i+1) =dcos(theta(i+1))
4933         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4934         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4935         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4936         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4937         cosfac=dsqrt(cosfac2)
4938         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4939         sinfac=dsqrt(sinfac2)
4940         it=iabs(itype(i))
4941         if (it.eq.10) goto 1
4942 !
4943 !  Compute the axes of tghe local cartesian coordinates system; store in
4944 !   x_prime, y_prime and z_prime
4945 !
4946         do j=1,3
4947           x_prime(j) = 0.00
4948           y_prime(j) = 0.00
4949           z_prime(j) = 0.00
4950         enddo
4951 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4952 !     &   dc_norm(3,i+nres)
4953         do j = 1,3
4954           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4955           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4956         enddo
4957         do j = 1,3
4958           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4959         enddo
4960 !       write (2,*) "i",i
4961 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
4962 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
4963 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
4964 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4965 !      & " xy",scalar(x_prime(1),y_prime(1)),
4966 !      & " xz",scalar(x_prime(1),z_prime(1)),
4967 !      & " yy",scalar(y_prime(1),y_prime(1)),
4968 !      & " yz",scalar(y_prime(1),z_prime(1)),
4969 !      & " zz",scalar(z_prime(1),z_prime(1))
4970 !
4971 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4972 ! to local coordinate system. Store in xx, yy, zz.
4973 !
4974         xx=0.0d0
4975         yy=0.0d0
4976         zz=0.0d0
4977         do j = 1,3
4978           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4979           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4980           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4981         enddo
4982
4983         xxtab(i)=xx
4984         yytab(i)=yy
4985         zztab(i)=zz
4986 !
4987 ! Compute the energy of the ith side cbain
4988 !
4989 !        write (2,*) "xx",xx," yy",yy," zz",zz
4990         it=iabs(itype(i))
4991         do j = 1,65
4992           x(j) = sc_parmin(j,it)
4993         enddo
4994 #ifdef CHECK_COORD
4995 !c diagnostics - remove later
4996         xx1 = dcos(alph(2))
4997         yy1 = dsin(alph(2))*dcos(omeg(2))
4998         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
4999         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5000           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5001           xx1,yy1,zz1
5002 !,"  --- ", xx_w,yy_w,zz_w
5003 ! end diagnostics
5004 #endif
5005         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5006          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5007          + x(10)*yy*zz
5008         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5009          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5010          + x(20)*yy*zz
5011         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5012          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5013          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5014          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5015          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5016          +x(40)*xx*yy*zz
5017         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5018          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5019          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5020          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5021          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5022          +x(60)*xx*yy*zz
5023         dsc_i   = 0.743d0+x(61)
5024         dp2_i   = 1.9d0+x(62)
5025         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5026                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5027         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5028                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5029         s1=(1+x(63))/(0.1d0 + dscp1)
5030         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5031         s2=(1+x(65))/(0.1d0 + dscp2)
5032         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5033         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5034       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5035 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5036 !     &   sumene4,
5037 !     &   dscp1,dscp2,sumene
5038 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5039         escloc = escloc + sumene
5040 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5041 !     & ,zz,xx,yy
5042 !#define DEBUG
5043 #ifdef DEBUG
5044 !
5045 ! This section to check the numerical derivatives of the energy of ith side
5046 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5047 ! #define DEBUG in the code to turn it on.
5048 !
5049         write (2,*) "sumene               =",sumene
5050         aincr=1.0d-7
5051         xxsave=xx
5052         xx=xx+aincr
5053         write (2,*) xx,yy,zz
5054         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5055         de_dxx_num=(sumenep-sumene)/aincr
5056         xx=xxsave
5057         write (2,*) "xx+ sumene from enesc=",sumenep
5058         yysave=yy
5059         yy=yy+aincr
5060         write (2,*) xx,yy,zz
5061         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5062         de_dyy_num=(sumenep-sumene)/aincr
5063         yy=yysave
5064         write (2,*) "yy+ sumene from enesc=",sumenep
5065         zzsave=zz
5066         zz=zz+aincr
5067         write (2,*) xx,yy,zz
5068         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5069         de_dzz_num=(sumenep-sumene)/aincr
5070         zz=zzsave
5071         write (2,*) "zz+ sumene from enesc=",sumenep
5072         costsave=cost2tab(i+1)
5073         sintsave=sint2tab(i+1)
5074         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5075         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5076         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5077         de_dt_num=(sumenep-sumene)/aincr
5078         write (2,*) " t+ sumene from enesc=",sumenep
5079         cost2tab(i+1)=costsave
5080         sint2tab(i+1)=sintsave
5081 ! End of diagnostics section.
5082 #endif
5083 !
5084 ! Compute the gradient of esc
5085 !
5086 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5087         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5088         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5089         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5090         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5091         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5092         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5093         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5094         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5095         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5096            *(pom_s1/dscp1+pom_s16*dscp1**4)
5097         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5098            *(pom_s2/dscp2+pom_s26*dscp2**4)
5099         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5100         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5101         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5102         +x(40)*yy*zz
5103         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5104         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5105         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5106         +x(60)*yy*zz
5107         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5108               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5109               +(pom1+pom2)*pom_dx
5110 #ifdef DEBUG
5111         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5112 #endif
5113 !
5114         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5115         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5116         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5117         +x(40)*xx*zz
5118         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5119         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5120         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5121         +x(59)*zz**2 +x(60)*xx*zz
5122         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5123               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5124               +(pom1-pom2)*pom_dy
5125 #ifdef DEBUG
5126         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5127 #endif
5128 !
5129         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5130         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5131         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5132         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5133         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5134         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5135         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5136         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5137 #ifdef DEBUG
5138         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5139 #endif
5140 !
5141         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5142         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5143         +pom1*pom_dt1+pom2*pom_dt2
5144 #ifdef DEBUG
5145         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5146 #endif
5147 !#undef DEBUG
5148 !
5149 !
5150        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5151        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5152        cosfac2xx=cosfac2*xx
5153        sinfac2yy=sinfac2*yy
5154        do k = 1,3
5155          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5156             vbld_inv(i+1)
5157          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5158             vbld_inv(i)
5159          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5160          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5161 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5162 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5163 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5164 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5165          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5166          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5167          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5168          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5169          dZZ_Ci1(k)=0.0d0
5170          dZZ_Ci(k)=0.0d0
5171          do j=1,3
5172            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5173            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5174            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5175            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5176          enddo
5177
5178          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5179          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5180          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5181          (z_prime(k)-zz*dC_norm(k,i+nres))
5182 !
5183          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5184          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5185        enddo
5186
5187        do k=1,3
5188          dXX_Ctab(k,i)=dXX_Ci(k)
5189          dXX_C1tab(k,i)=dXX_Ci1(k)
5190          dYY_Ctab(k,i)=dYY_Ci(k)
5191          dYY_C1tab(k,i)=dYY_Ci1(k)
5192          dZZ_Ctab(k,i)=dZZ_Ci(k)
5193          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5194          dXX_XYZtab(k,i)=dXX_XYZ(k)
5195          dYY_XYZtab(k,i)=dYY_XYZ(k)
5196          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5197        enddo
5198
5199        do k = 1,3
5200 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5201 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5202 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5203 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5204 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5205 !     &    dt_dci(k)
5206 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5207 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5208          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5209           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5210          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5211           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5212          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5213           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5214        enddo
5215 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5216 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5217
5218 ! to check gradient call subroutine check_grad
5219
5220     1 continue
5221       enddo
5222 !el #undef DUBUG
5223       return
5224       end subroutine esc
5225 !-----------------------------------------------------------------------------
5226       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5227 !      implicit none
5228       real(kind=8),dimension(65) :: x
5229       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5230         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5231
5232       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5233         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5234         + x(10)*yy*zz
5235       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5236         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5237         + x(20)*yy*zz
5238       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5239         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5240         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5241         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5242         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5243         +x(40)*xx*yy*zz
5244       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5245         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5246         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5247         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5248         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5249         +x(60)*xx*yy*zz
5250       dsc_i   = 0.743d0+x(61)
5251       dp2_i   = 1.9d0+x(62)
5252       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5253                 *(xx*cost2+yy*sint2))
5254       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5255                 *(xx*cost2-yy*sint2))
5256       s1=(1+x(63))/(0.1d0 + dscp1)
5257       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5258       s2=(1+x(65))/(0.1d0 + dscp2)
5259       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5260       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5261        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5262       enesc=sumene
5263       return
5264       end function enesc
5265 #endif
5266 !-----------------------------------------------------------------------------
5267       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5268 !
5269 ! This procedure calculates two-body contact function g(rij) and its derivative:
5270 !
5271 !           eps0ij                                     !       x < -1
5272 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5273 !            0                                         !       x > 1
5274 !
5275 ! where x=(rij-r0ij)/delta
5276 !
5277 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5278 !
5279 !      implicit none
5280       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5281       real(kind=8) :: x,x2,x4,delta
5282 !     delta=0.02D0*r0ij
5283 !      delta=0.2D0*r0ij
5284       x=(rij-r0ij)/delta
5285       if (x.lt.-1.0D0) then
5286         fcont=eps0ij
5287         fprimcont=0.0D0
5288       else if (x.le.1.0D0) then
5289         x2=x*x
5290         x4=x2*x2
5291         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5292         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5293       else
5294         fcont=0.0D0
5295         fprimcont=0.0D0
5296       endif
5297       return
5298       end subroutine gcont
5299 !-----------------------------------------------------------------------------
5300       subroutine splinthet(theti,delta,ss,ssder)
5301 !      implicit real*8 (a-h,o-z)
5302 !      include 'DIMENSIONS'
5303 !      include 'COMMON.VAR'
5304 !      include 'COMMON.GEO'
5305       real(kind=8) :: theti,delta,ss,ssder
5306       real(kind=8) :: thetup,thetlow
5307       thetup=pi-delta
5308       thetlow=delta
5309       if (theti.gt.pipol) then
5310         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5311       else
5312         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5313         ssder=-ssder
5314       endif
5315       return
5316       end subroutine splinthet
5317 !-----------------------------------------------------------------------------
5318       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5319 !      implicit none
5320       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5321       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5322       a1=fprim0*delta/(f1-f0)
5323       a2=3.0d0-2.0d0*a1
5324       a3=a1-2.0d0
5325       ksi=(x-x0)/delta
5326       ksi2=ksi*ksi
5327       ksi3=ksi2*ksi
5328       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5329       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5330       return
5331       end subroutine spline1
5332 !-----------------------------------------------------------------------------
5333       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5334 !      implicit none
5335       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5336       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5337       ksi=(x-x0)/delta
5338       ksi2=ksi*ksi
5339       ksi3=ksi2*ksi
5340       a1=fprim0x*delta
5341       a2=3*(f1x-f0x)-2*fprim0x*delta
5342       a3=fprim0x*delta-2*(f1x-f0x)
5343       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5344       return
5345       end subroutine spline2
5346 !-----------------------------------------------------------------------------
5347 #ifdef CRYST_TOR
5348 !-----------------------------------------------------------------------------
5349       subroutine etor(etors,edihcnstr)
5350 !      implicit real*8 (a-h,o-z)
5351 !      include 'DIMENSIONS'
5352 !      include 'COMMON.VAR'
5353 !      include 'COMMON.GEO'
5354 !      include 'COMMON.LOCAL'
5355 !      include 'COMMON.TORSION'
5356 !      include 'COMMON.INTERACT'
5357 !      include 'COMMON.DERIV'
5358 !      include 'COMMON.CHAIN'
5359 !      include 'COMMON.NAMES'
5360 !      include 'COMMON.IOUNITS'
5361 !      include 'COMMON.FFIELD'
5362 !      include 'COMMON.TORCNSTR'
5363 !      include 'COMMON.CONTROL'
5364       real(kind=8) :: etors,edihcnstr
5365       logical :: lprn
5366 !el local variables
5367       integer :: i,j,
5368       real(kind=8) :: phii,fac,etors_ii
5369
5370 ! Set lprn=.true. for debugging
5371       lprn=.false.
5372 !      lprn=.true.
5373       etors=0.0D0
5374       do i=iphi_start,iphi_end
5375       etors_ii=0.0D0
5376         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5377             .or. itype(i).eq.ntyp1) cycle
5378         itori=itortyp(itype(i-2))
5379         itori1=itortyp(itype(i-1))
5380         phii=phi(i)
5381         gloci=0.0D0
5382 ! Proline-Proline pair is a special case...
5383         if (itori.eq.3 .and. itori1.eq.3) then
5384           if (phii.gt.-dwapi3) then
5385             cosphi=dcos(3*phii)
5386             fac=1.0D0/(1.0D0-cosphi)
5387             etorsi=v1(1,3,3)*fac
5388             etorsi=etorsi+etorsi
5389             etors=etors+etorsi-v1(1,3,3)
5390             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5391             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5392           endif
5393           do j=1,3
5394             v1ij=v1(j+1,itori,itori1)
5395             v2ij=v2(j+1,itori,itori1)
5396             cosphi=dcos(j*phii)
5397             sinphi=dsin(j*phii)
5398             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5399             if (energy_dec) etors_ii=etors_ii+ &
5400                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5401             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5402           enddo
5403         else
5404           do j=1,nterm_old
5405             v1ij=v1(j,itori,itori1)
5406             v2ij=v2(j,itori,itori1)
5407             cosphi=dcos(j*phii)
5408             sinphi=dsin(j*phii)
5409             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5410             if (energy_dec) etors_ii=etors_ii+ &
5411                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5412             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5413           enddo
5414         endif
5415         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5416              'etor',i,etors_ii
5417         if (lprn) &
5418         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5419         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5420         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5421         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5422 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5423       enddo
5424 ! 6/20/98 - dihedral angle constraints
5425       edihcnstr=0.0d0
5426       do i=1,ndih_constr
5427         itori=idih_constr(i)
5428         phii=phi(itori)
5429         difi=phii-phi0(i)
5430         if (difi.gt.drange(i)) then
5431           difi=difi-drange(i)
5432           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5433           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5434         else if (difi.lt.-drange(i)) then
5435           difi=difi+drange(i)
5436           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5437           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5438         endif
5439 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5440 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5441       enddo
5442 !      write (iout,*) 'edihcnstr',edihcnstr
5443       return
5444       end subroutine etor
5445 !-----------------------------------------------------------------------------
5446       subroutine etor_d(etors_d)
5447       real(kind=8) :: etors_d
5448       etors_d=0.0d0
5449       return
5450       end subroutine etor_d
5451 #else
5452 !-----------------------------------------------------------------------------
5453       subroutine etor(etors,edihcnstr)
5454 !      implicit real*8 (a-h,o-z)
5455 !      include 'DIMENSIONS'
5456 !      include 'COMMON.VAR'
5457 !      include 'COMMON.GEO'
5458 !      include 'COMMON.LOCAL'
5459 !      include 'COMMON.TORSION'
5460 !      include 'COMMON.INTERACT'
5461 !      include 'COMMON.DERIV'
5462 !      include 'COMMON.CHAIN'
5463 !      include 'COMMON.NAMES'
5464 !      include 'COMMON.IOUNITS'
5465 !      include 'COMMON.FFIELD'
5466 !      include 'COMMON.TORCNSTR'
5467 !      include 'COMMON.CONTROL'
5468       real(kind=8) :: etors,edihcnstr
5469       logical :: lprn
5470 !el local variables
5471       integer :: i,j,iblock,itori,itori1
5472       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5473                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5474 ! Set lprn=.true. for debugging
5475       lprn=.false.
5476 !     lprn=.true.
5477       etors=0.0D0
5478       do i=iphi_start,iphi_end
5479         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5480              .or. itype(i).eq.ntyp1) cycle
5481         etors_ii=0.0D0
5482          if (iabs(itype(i)).eq.20) then
5483          iblock=2
5484          else
5485          iblock=1
5486          endif
5487         itori=itortyp(itype(i-2))
5488         itori1=itortyp(itype(i-1))
5489         phii=phi(i)
5490         gloci=0.0D0
5491 ! Regular cosine and sine terms
5492         do j=1,nterm(itori,itori1,iblock)
5493           v1ij=v1(j,itori,itori1,iblock)
5494           v2ij=v2(j,itori,itori1,iblock)
5495           cosphi=dcos(j*phii)
5496           sinphi=dsin(j*phii)
5497           etors=etors+v1ij*cosphi+v2ij*sinphi
5498           if (energy_dec) etors_ii=etors_ii+ &
5499                      v1ij*cosphi+v2ij*sinphi
5500           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5501         enddo
5502 ! Lorentz terms
5503 !                         v1
5504 !  E = SUM ----------------------------------- - v1
5505 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5506 !
5507         cosphi=dcos(0.5d0*phii)
5508         sinphi=dsin(0.5d0*phii)
5509         do j=1,nlor(itori,itori1,iblock)
5510           vl1ij=vlor1(j,itori,itori1)
5511           vl2ij=vlor2(j,itori,itori1)
5512           vl3ij=vlor3(j,itori,itori1)
5513           pom=vl2ij*cosphi+vl3ij*sinphi
5514           pom1=1.0d0/(pom*pom+1.0d0)
5515           etors=etors+vl1ij*pom1
5516           if (energy_dec) etors_ii=etors_ii+ &
5517                      vl1ij*pom1
5518           pom=-pom*pom1*pom1
5519           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5520         enddo
5521 ! Subtract the constant term
5522         etors=etors-v0(itori,itori1,iblock)
5523           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5524                'etor',i,etors_ii-v0(itori,itori1,iblock)
5525         if (lprn) &
5526         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5527         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5528         (v1(j,itori,itori1,iblock),j=1,6),&
5529         (v2(j,itori,itori1,iblock),j=1,6)
5530         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5531 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5532       enddo
5533 ! 6/20/98 - dihedral angle constraints
5534       edihcnstr=0.0d0
5535 !      do i=1,ndih_constr
5536       do i=idihconstr_start,idihconstr_end
5537         itori=idih_constr(i)
5538         phii=phi(itori)
5539         difi=pinorm(phii-phi0(i))
5540         if (difi.gt.drange(i)) then
5541           difi=difi-drange(i)
5542           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5543           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5544         else if (difi.lt.-drange(i)) then
5545           difi=difi+drange(i)
5546           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5547           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5548         else
5549           difi=0.0
5550         endif
5551 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5552 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5553 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5554       enddo
5555 !d       write (iout,*) 'edihcnstr',edihcnstr
5556       return
5557       end subroutine etor
5558 !-----------------------------------------------------------------------------
5559       subroutine etor_d(etors_d)
5560 ! 6/23/01 Compute double torsional energy
5561 !      implicit real*8 (a-h,o-z)
5562 !      include 'DIMENSIONS'
5563 !      include 'COMMON.VAR'
5564 !      include 'COMMON.GEO'
5565 !      include 'COMMON.LOCAL'
5566 !      include 'COMMON.TORSION'
5567 !      include 'COMMON.INTERACT'
5568 !      include 'COMMON.DERIV'
5569 !      include 'COMMON.CHAIN'
5570 !      include 'COMMON.NAMES'
5571 !      include 'COMMON.IOUNITS'
5572 !      include 'COMMON.FFIELD'
5573 !      include 'COMMON.TORCNSTR'
5574       real(kind=8) :: etors_d
5575       logical :: lprn
5576 !el local variables
5577       integer :: i,j,k,l,itori,itori1,itori2,iblock
5578       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5579                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5580                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5581                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5582 ! Set lprn=.true. for debugging
5583       lprn=.false.
5584 !     lprn=.true.
5585       etors_d=0.0D0
5586 !      write(iout,*) "a tu??"
5587       do i=iphid_start,iphid_end
5588         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5589             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5590         itori=itortyp(itype(i-2))
5591         itori1=itortyp(itype(i-1))
5592         itori2=itortyp(itype(i))
5593         phii=phi(i)
5594         phii1=phi(i+1)
5595         gloci1=0.0D0
5596         gloci2=0.0D0
5597         iblock=1
5598         if (iabs(itype(i+1)).eq.20) iblock=2
5599
5600 ! Regular cosine and sine terms
5601         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5602           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5603           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5604           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5605           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5606           cosphi1=dcos(j*phii)
5607           sinphi1=dsin(j*phii)
5608           cosphi2=dcos(j*phii1)
5609           sinphi2=dsin(j*phii1)
5610           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5611            v2cij*cosphi2+v2sij*sinphi2
5612           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5613           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5614         enddo
5615         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5616           do l=1,k-1
5617             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5618             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5619             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5620             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5621             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5622             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5623             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5624             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5625             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5626               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5627             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5628               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5629             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5630               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5631           enddo
5632         enddo
5633         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5634         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5635       enddo
5636       return
5637       end subroutine etor_d
5638 #endif
5639 !-----------------------------------------------------------------------------
5640       subroutine eback_sc_corr(esccor)
5641 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5642 !        conformational states; temporarily implemented as differences
5643 !        between UNRES torsional potentials (dependent on three types of
5644 !        residues) and the torsional potentials dependent on all 20 types
5645 !        of residues computed from AM1  energy surfaces of terminally-blocked
5646 !        amino-acid residues.
5647 !      implicit real*8 (a-h,o-z)
5648 !      include 'DIMENSIONS'
5649 !      include 'COMMON.VAR'
5650 !      include 'COMMON.GEO'
5651 !      include 'COMMON.LOCAL'
5652 !      include 'COMMON.TORSION'
5653 !      include 'COMMON.SCCOR'
5654 !      include 'COMMON.INTERACT'
5655 !      include 'COMMON.DERIV'
5656 !      include 'COMMON.CHAIN'
5657 !      include 'COMMON.NAMES'
5658 !      include 'COMMON.IOUNITS'
5659 !      include 'COMMON.FFIELD'
5660 !      include 'COMMON.CONTROL'
5661       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5662                    cosphi,sinphi
5663       logical :: lprn
5664       integer :: i,interty,j,isccori,isccori1,intertyp
5665 ! Set lprn=.true. for debugging
5666       lprn=.false.
5667 !      lprn=.true.
5668 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5669       esccor=0.0D0
5670       do i=itau_start,itau_end
5671         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5672         esccor_ii=0.0D0
5673         isccori=isccortyp(itype(i-2))
5674         isccori1=isccortyp(itype(i-1))
5675 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5676         phii=phi(i)
5677         do intertyp=1,3 !intertyp
5678 !c Added 09 May 2012 (Adasko)
5679 !c  Intertyp means interaction type of backbone mainchain correlation:
5680 !   1 = SC...Ca...Ca...Ca
5681 !   2 = Ca...Ca...Ca...SC
5682 !   3 = SC...Ca...Ca...SCi
5683         gloci=0.0D0
5684         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5685             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5686             (itype(i-1).eq.ntyp1))) &
5687           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5688            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5689            .or.(itype(i).eq.ntyp1))) &
5690           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5691             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5692             (itype(i-3).eq.ntyp1)))) cycle
5693         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5694         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5695        cycle
5696        do j=1,nterm_sccor(isccori,isccori1)
5697           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5698           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5699           cosphi=dcos(j*tauangle(intertyp,i))
5700           sinphi=dsin(j*tauangle(intertyp,i))
5701           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5702           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5703         enddo
5704 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5705         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5706         if (lprn) &
5707         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5708         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5709         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5710         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5711         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5712        enddo !intertyp
5713       enddo
5714
5715       return
5716       end subroutine eback_sc_corr
5717 !-----------------------------------------------------------------------------
5718       subroutine multibody(ecorr)
5719 ! This subroutine calculates multi-body contributions to energy following
5720 ! the idea of Skolnick et al. If side chains I and J make a contact and
5721 ! at the same time side chains I+1 and J+1 make a contact, an extra
5722 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5723 !      implicit real*8 (a-h,o-z)
5724 !      include 'DIMENSIONS'
5725 !      include 'COMMON.IOUNITS'
5726 !      include 'COMMON.DERIV'
5727 !      include 'COMMON.INTERACT'
5728 !      include 'COMMON.CONTACTS'
5729       real(kind=8),dimension(3) :: gx,gx1
5730       logical :: lprn
5731       real(kind=8) :: ecorr
5732       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5733 ! Set lprn=.true. for debugging
5734       lprn=.false.
5735
5736       if (lprn) then
5737         write (iout,'(a)') 'Contact function values:'
5738         do i=nnt,nct-2
5739           write (iout,'(i2,20(1x,i2,f10.5))') &
5740               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5741         enddo
5742       endif
5743       ecorr=0.0D0
5744
5745 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
5746 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
5747       do i=nnt,nct
5748         do j=1,3
5749           gradcorr(j,i)=0.0D0
5750           gradxorr(j,i)=0.0D0
5751         enddo
5752       enddo
5753       do i=nnt,nct-2
5754
5755         DO ISHIFT = 3,4
5756
5757         i1=i+ishift
5758         num_conti=num_cont(i)
5759         num_conti1=num_cont(i1)
5760         do jj=1,num_conti
5761           j=jcont(jj,i)
5762           do kk=1,num_conti1
5763             j1=jcont(kk,i1)
5764             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5765 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5766 !d   &                   ' ishift=',ishift
5767 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5768 ! The system gains extra energy.
5769               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5770             endif   ! j1==j+-ishift
5771           enddo     ! kk
5772         enddo       ! jj
5773
5774         ENDDO ! ISHIFT
5775
5776       enddo         ! i
5777       return
5778       end subroutine multibody
5779 !-----------------------------------------------------------------------------
5780       real(kind=8) function esccorr(i,j,k,l,jj,kk)
5781 !      implicit real*8 (a-h,o-z)
5782 !      include 'DIMENSIONS'
5783 !      include 'COMMON.IOUNITS'
5784 !      include 'COMMON.DERIV'
5785 !      include 'COMMON.INTERACT'
5786 !      include 'COMMON.CONTACTS'
5787       real(kind=8),dimension(3) :: gx,gx1
5788       logical :: lprn
5789       integer :: i,j,k,l,jj,kk,m,ll
5790       real(kind=8) :: eij,ekl
5791       lprn=.false.
5792       eij=facont(jj,i)
5793       ekl=facont(kk,k)
5794 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5795 ! Calculate the multi-body contribution to energy.
5796 ! Calculate multi-body contributions to the gradient.
5797 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5798 !d   & k,l,(gacont(m,kk,k),m=1,3)
5799       do m=1,3
5800         gx(m) =ekl*gacont(m,jj,i)
5801         gx1(m)=eij*gacont(m,kk,k)
5802         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5803         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5804         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5805         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5806       enddo
5807       do m=i,j-1
5808         do ll=1,3
5809           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5810         enddo
5811       enddo
5812       do m=k,l-1
5813         do ll=1,3
5814           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5815         enddo
5816       enddo
5817       esccorr=-eij*ekl
5818       return
5819       end function esccorr
5820 !-----------------------------------------------------------------------------
5821       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5822 ! This subroutine calculates multi-body contributions to hydrogen-bonding
5823 !      implicit real*8 (a-h,o-z)
5824 !      include 'DIMENSIONS'
5825 !      include 'COMMON.IOUNITS'
5826 #ifdef MPI
5827       include "mpif.h"
5828 !      integer :: maxconts !max_cont=maxconts  =nres/4
5829       integer,parameter :: max_dim=26
5830       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5831       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
5832 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
5833 !el      common /przechowalnia/ zapas
5834       integer :: status(MPI_STATUS_SIZE)
5835       integer,dimension((nres/4)*2) :: req !maxconts*2
5836       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
5837 #endif
5838 !      include 'COMMON.SETUP'
5839 !      include 'COMMON.FFIELD'
5840 !      include 'COMMON.DERIV'
5841 !      include 'COMMON.INTERACT'
5842 !      include 'COMMON.CONTACTS'
5843 !      include 'COMMON.CONTROL'
5844 !      include 'COMMON.LOCAL'
5845       real(kind=8),dimension(3) :: gx,gx1
5846       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
5847       logical :: lprn,ldone
5848 !el local variables
5849       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
5850               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
5851
5852 ! Set lprn=.true. for debugging
5853       lprn=.false.
5854 #ifdef MPI
5855 !      maxconts=nres/4
5856       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
5857       n_corr=0
5858       n_corr1=0
5859       if (nfgtasks.le.1) goto 30
5860       if (lprn) then
5861         write (iout,'(a)') 'Contact function values before RECEIVE:'
5862         do i=nnt,nct-2
5863           write (iout,'(2i3,50(1x,i2,f5.2))') &
5864           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
5865           j=1,num_cont_hb(i))
5866         enddo
5867       endif
5868       call flush(iout)
5869       do i=1,ntask_cont_from
5870         ncont_recv(i)=0
5871       enddo
5872       do i=1,ntask_cont_to
5873         ncont_sent(i)=0
5874       enddo
5875 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5876 !     & ntask_cont_to
5877 ! Make the list of contacts to send to send to other procesors
5878 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5879 !      call flush(iout)
5880       do i=iturn3_start,iturn3_end
5881 !        write (iout,*) "make contact list turn3",i," num_cont",
5882 !     &    num_cont_hb(i)
5883         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5884       enddo
5885       do i=iturn4_start,iturn4_end
5886 !        write (iout,*) "make contact list turn4",i," num_cont",
5887 !     &   num_cont_hb(i)
5888         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5889       enddo
5890       do ii=1,nat_sent
5891         i=iat_sent(ii)
5892 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
5893 !     &    num_cont_hb(i)
5894         do j=1,num_cont_hb(i)
5895         do k=1,4
5896           jjc=jcont_hb(j,i)
5897           iproc=iint_sent_local(k,jjc,ii)
5898 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5899           if (iproc.gt.0) then
5900             ncont_sent(iproc)=ncont_sent(iproc)+1
5901             nn=ncont_sent(iproc)
5902             zapas(1,nn,iproc)=i
5903             zapas(2,nn,iproc)=jjc
5904             zapas(3,nn,iproc)=facont_hb(j,i)
5905             zapas(4,nn,iproc)=ees0p(j,i)
5906             zapas(5,nn,iproc)=ees0m(j,i)
5907             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5908             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5909             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5910             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5911             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5912             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5913             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5914             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5915             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5916             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5917             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5918             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5919             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5920             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5921             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5922             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5923             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5924             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5925             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5926             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5927             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5928           endif
5929         enddo
5930         enddo
5931       enddo
5932       if (lprn) then
5933       write (iout,*) &
5934         "Numbers of contacts to be sent to other processors",&
5935         (ncont_sent(i),i=1,ntask_cont_to)
5936       write (iout,*) "Contacts sent"
5937       do ii=1,ntask_cont_to
5938         nn=ncont_sent(ii)
5939         iproc=itask_cont_to(ii)
5940         write (iout,*) nn," contacts to processor",iproc,&
5941          " of CONT_TO_COMM group"
5942         do i=1,nn
5943           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5944         enddo
5945       enddo
5946       call flush(iout)
5947       endif
5948       CorrelType=477
5949       CorrelID=fg_rank+1
5950       CorrelType1=478
5951       CorrelID1=nfgtasks+fg_rank+1
5952       ireq=0
5953 ! Receive the numbers of needed contacts from other processors
5954       do ii=1,ntask_cont_from
5955         iproc=itask_cont_from(ii)
5956         ireq=ireq+1
5957         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
5958           FG_COMM,req(ireq),IERR)
5959       enddo
5960 !      write (iout,*) "IRECV ended"
5961 !      call flush(iout)
5962 ! Send the number of contacts needed by other processors
5963       do ii=1,ntask_cont_to
5964         iproc=itask_cont_to(ii)
5965         ireq=ireq+1
5966         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
5967           FG_COMM,req(ireq),IERR)
5968       enddo
5969 !      write (iout,*) "ISEND ended"
5970 !      write (iout,*) "number of requests (nn)",ireq
5971       call flush(iout)
5972       if (ireq.gt.0) &
5973         call MPI_Waitall(ireq,req,status_array,ierr)
5974 !      write (iout,*)
5975 !     &  "Numbers of contacts to be received from other processors",
5976 !     &  (ncont_recv(i),i=1,ntask_cont_from)
5977 !      call flush(iout)
5978 ! Receive contacts
5979       ireq=0
5980       do ii=1,ntask_cont_from
5981         iproc=itask_cont_from(ii)
5982         nn=ncont_recv(ii)
5983 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
5984 !     &   " of CONT_TO_COMM group"
5985         call flush(iout)
5986         if (nn.gt.0) then
5987           ireq=ireq+1
5988           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
5989           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5990 !          write (iout,*) "ireq,req",ireq,req(ireq)
5991         endif
5992       enddo
5993 ! Send the contacts to processors that need them
5994       do ii=1,ntask_cont_to
5995         iproc=itask_cont_to(ii)
5996         nn=ncont_sent(ii)
5997 !        write (iout,*) nn," contacts to processor",iproc,
5998 !     &   " of CONT_TO_COMM group"
5999         if (nn.gt.0) then
6000           ireq=ireq+1
6001           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6002             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6003 !          write (iout,*) "ireq,req",ireq,req(ireq)
6004 !          do i=1,nn
6005 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6006 !          enddo
6007         endif
6008       enddo
6009 !      write (iout,*) "number of requests (contacts)",ireq
6010 !      write (iout,*) "req",(req(i),i=1,4)
6011 !      call flush(iout)
6012       if (ireq.gt.0) &
6013        call MPI_Waitall(ireq,req,status_array,ierr)
6014       do iii=1,ntask_cont_from
6015         iproc=itask_cont_from(iii)
6016         nn=ncont_recv(iii)
6017         if (lprn) then
6018         write (iout,*) "Received",nn," contacts from processor",iproc,&
6019          " of CONT_FROM_COMM group"
6020         call flush(iout)
6021         do i=1,nn
6022           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6023         enddo
6024         call flush(iout)
6025         endif
6026         do i=1,nn
6027           ii=zapas_recv(1,i,iii)
6028 ! Flag the received contacts to prevent double-counting
6029           jj=-zapas_recv(2,i,iii)
6030 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6031 !          call flush(iout)
6032           nnn=num_cont_hb(ii)+1
6033           num_cont_hb(ii)=nnn
6034           jcont_hb(nnn,ii)=jj
6035           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6036           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6037           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6038           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6039           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6040           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6041           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6042           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6043           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6044           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6045           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6046           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6047           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6048           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6049           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6050           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6051           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6052           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6053           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6054           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6055           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6056           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6057           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6058           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6059         enddo
6060       enddo
6061       call flush(iout)
6062       if (lprn) then
6063         write (iout,'(a)') 'Contact function values after receive:'
6064         do i=nnt,nct-2
6065           write (iout,'(2i3,50(1x,i3,f5.2))') &
6066           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6067           j=1,num_cont_hb(i))
6068         enddo
6069         call flush(iout)
6070       endif
6071    30 continue
6072 #endif
6073       if (lprn) then
6074         write (iout,'(a)') 'Contact function values:'
6075         do i=nnt,nct-2
6076           write (iout,'(2i3,50(1x,i3,f5.2))') &
6077           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6078           j=1,num_cont_hb(i))
6079         enddo
6080       endif
6081       ecorr=0.0D0
6082
6083 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6084 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6085 ! Remove the loop below after debugging !!!
6086       do i=nnt,nct
6087         do j=1,3
6088           gradcorr(j,i)=0.0D0
6089           gradxorr(j,i)=0.0D0
6090         enddo
6091       enddo
6092 ! Calculate the local-electrostatic correlation terms
6093       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6094         i1=i+1
6095         num_conti=num_cont_hb(i)
6096         num_conti1=num_cont_hb(i+1)
6097         do jj=1,num_conti
6098           j=jcont_hb(jj,i)
6099           jp=iabs(j)
6100           do kk=1,num_conti1
6101             j1=jcont_hb(kk,i1)
6102             jp1=iabs(j1)
6103 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6104 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6105             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6106                 .or. j.lt.0 .and. j1.gt.0) .and. &
6107                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6108 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6109 ! The system gains extra energy.
6110               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6111               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6112                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6113               n_corr=n_corr+1
6114             else if (j1.eq.j) then
6115 ! Contacts I-J and I-(J+1) occur simultaneously.
6116 ! The system loses extra energy.
6117 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6118             endif
6119           enddo ! kk
6120           do kk=1,num_conti
6121             j1=jcont_hb(kk,i)
6122 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6123 !    &         ' jj=',jj,' kk=',kk
6124             if (j1.eq.j+1) then
6125 ! Contacts I-J and (I+1)-J occur simultaneously.
6126 ! The system loses extra energy.
6127 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6128             endif ! j1==j+1
6129           enddo ! kk
6130         enddo ! jj
6131       enddo ! i
6132       return
6133       end subroutine multibody_hb
6134 !-----------------------------------------------------------------------------
6135       subroutine add_hb_contact(ii,jj,itask)
6136 !      implicit real*8 (a-h,o-z)
6137 !      include "DIMENSIONS"
6138 !      include "COMMON.IOUNITS"
6139 !      include "COMMON.CONTACTS"
6140 !      integer,parameter :: maxconts=nres/4
6141       integer,parameter :: max_dim=26
6142       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6143 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6144 !      common /przechowalnia/ zapas
6145       integer :: i,j,ii,jj,iproc,nn,jjc
6146       integer,dimension(4) :: itask
6147 !      write (iout,*) "itask",itask
6148       do i=1,2
6149         iproc=itask(i)
6150         if (iproc.gt.0) then
6151           do j=1,num_cont_hb(ii)
6152             jjc=jcont_hb(j,ii)
6153 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6154             if (jjc.eq.jj) then
6155               ncont_sent(iproc)=ncont_sent(iproc)+1
6156               nn=ncont_sent(iproc)
6157               zapas(1,nn,iproc)=ii
6158               zapas(2,nn,iproc)=jjc
6159               zapas(3,nn,iproc)=facont_hb(j,ii)
6160               zapas(4,nn,iproc)=ees0p(j,ii)
6161               zapas(5,nn,iproc)=ees0m(j,ii)
6162               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6163               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6164               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6165               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6166               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6167               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6168               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6169               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6170               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6171               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6172               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6173               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6174               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6175               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6176               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6177               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6178               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6179               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6180               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6181               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6182               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6183               exit
6184             endif
6185           enddo
6186         endif
6187       enddo
6188       return
6189       end subroutine add_hb_contact
6190 !-----------------------------------------------------------------------------
6191       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6192 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6193 !      implicit real*8 (a-h,o-z)
6194 !      include 'DIMENSIONS'
6195 !      include 'COMMON.IOUNITS'
6196       integer,parameter :: max_dim=70
6197 #ifdef MPI
6198       include "mpif.h"
6199 !      integer :: maxconts !max_cont=maxconts=nres/4
6200       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6201       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6202 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6203 !      common /przechowalnia/ zapas
6204       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6205         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6206         ierr,iii,nnn
6207 #endif
6208 !      include 'COMMON.SETUP'
6209 !      include 'COMMON.FFIELD'
6210 !      include 'COMMON.DERIV'
6211 !      include 'COMMON.LOCAL'
6212 !      include 'COMMON.INTERACT'
6213 !      include 'COMMON.CONTACTS'
6214 !      include 'COMMON.CHAIN'
6215 !      include 'COMMON.CONTROL'
6216       real(kind=8),dimension(3) :: gx,gx1
6217       integer,dimension(nres) :: num_cont_hb_old
6218       logical :: lprn,ldone
6219 !EL      double precision eello4,eello5,eelo6,eello_turn6
6220 !EL      external eello4,eello5,eello6,eello_turn6
6221 !el local variables
6222       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6223               j1,jp1,i1,num_conti1
6224       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6225       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6226
6227 ! Set lprn=.true. for debugging
6228       lprn=.false.
6229       eturn6=0.0d0
6230 #ifdef MPI
6231 !      maxconts=nres/4
6232       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6233       do i=1,nres
6234         num_cont_hb_old(i)=num_cont_hb(i)
6235       enddo
6236       n_corr=0
6237       n_corr1=0
6238       if (nfgtasks.le.1) goto 30
6239       if (lprn) then
6240         write (iout,'(a)') 'Contact function values before RECEIVE:'
6241         do i=nnt,nct-2
6242           write (iout,'(2i3,50(1x,i2,f5.2))') &
6243           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6244           j=1,num_cont_hb(i))
6245         enddo
6246       endif
6247       call flush(iout)
6248       do i=1,ntask_cont_from
6249         ncont_recv(i)=0
6250       enddo
6251       do i=1,ntask_cont_to
6252         ncont_sent(i)=0
6253       enddo
6254 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6255 !     & ntask_cont_to
6256 ! Make the list of contacts to send to send to other procesors
6257       do i=iturn3_start,iturn3_end
6258 !        write (iout,*) "make contact list turn3",i," num_cont",
6259 !     &    num_cont_hb(i)
6260         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6261       enddo
6262       do i=iturn4_start,iturn4_end
6263 !        write (iout,*) "make contact list turn4",i," num_cont",
6264 !     &   num_cont_hb(i)
6265         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6266       enddo
6267       do ii=1,nat_sent
6268         i=iat_sent(ii)
6269 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6270 !     &    num_cont_hb(i)
6271         do j=1,num_cont_hb(i)
6272         do k=1,4
6273           jjc=jcont_hb(j,i)
6274           iproc=iint_sent_local(k,jjc,ii)
6275 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6276           if (iproc.ne.0) then
6277             ncont_sent(iproc)=ncont_sent(iproc)+1
6278             nn=ncont_sent(iproc)
6279             zapas(1,nn,iproc)=i
6280             zapas(2,nn,iproc)=jjc
6281             zapas(3,nn,iproc)=d_cont(j,i)
6282             ind=3
6283             do kk=1,3
6284               ind=ind+1
6285               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6286             enddo
6287             do kk=1,2
6288               do ll=1,2
6289                 ind=ind+1
6290                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6291               enddo
6292             enddo
6293             do jj=1,5
6294               do kk=1,3
6295                 do ll=1,2
6296                   do mm=1,2
6297                     ind=ind+1
6298                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6299                   enddo
6300                 enddo
6301               enddo
6302             enddo
6303           endif
6304         enddo
6305         enddo
6306       enddo
6307       if (lprn) then
6308       write (iout,*) &
6309         "Numbers of contacts to be sent to other processors",&
6310         (ncont_sent(i),i=1,ntask_cont_to)
6311       write (iout,*) "Contacts sent"
6312       do ii=1,ntask_cont_to
6313         nn=ncont_sent(ii)
6314         iproc=itask_cont_to(ii)
6315         write (iout,*) nn," contacts to processor",iproc,&
6316          " of CONT_TO_COMM group"
6317         do i=1,nn
6318           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6319         enddo
6320       enddo
6321       call flush(iout)
6322       endif
6323       CorrelType=477
6324       CorrelID=fg_rank+1
6325       CorrelType1=478
6326       CorrelID1=nfgtasks+fg_rank+1
6327       ireq=0
6328 ! Receive the numbers of needed contacts from other processors
6329       do ii=1,ntask_cont_from
6330         iproc=itask_cont_from(ii)
6331         ireq=ireq+1
6332         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6333           FG_COMM,req(ireq),IERR)
6334       enddo
6335 !      write (iout,*) "IRECV ended"
6336 !      call flush(iout)
6337 ! Send the number of contacts needed by other processors
6338       do ii=1,ntask_cont_to
6339         iproc=itask_cont_to(ii)
6340         ireq=ireq+1
6341         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6342           FG_COMM,req(ireq),IERR)
6343       enddo
6344 !      write (iout,*) "ISEND ended"
6345 !      write (iout,*) "number of requests (nn)",ireq
6346       call flush(iout)
6347       if (ireq.gt.0) &
6348         call MPI_Waitall(ireq,req,status_array,ierr)
6349 !      write (iout,*)
6350 !     &  "Numbers of contacts to be received from other processors",
6351 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6352 !      call flush(iout)
6353 ! Receive contacts
6354       ireq=0
6355       do ii=1,ntask_cont_from
6356         iproc=itask_cont_from(ii)
6357         nn=ncont_recv(ii)
6358 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6359 !     &   " of CONT_TO_COMM group"
6360         call flush(iout)
6361         if (nn.gt.0) then
6362           ireq=ireq+1
6363           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6364           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6365 !          write (iout,*) "ireq,req",ireq,req(ireq)
6366         endif
6367       enddo
6368 ! Send the contacts to processors that need them
6369       do ii=1,ntask_cont_to
6370         iproc=itask_cont_to(ii)
6371         nn=ncont_sent(ii)
6372 !        write (iout,*) nn," contacts to processor",iproc,
6373 !     &   " of CONT_TO_COMM group"
6374         if (nn.gt.0) then
6375           ireq=ireq+1
6376           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6377             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6378 !          write (iout,*) "ireq,req",ireq,req(ireq)
6379 !          do i=1,nn
6380 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6381 !          enddo
6382         endif
6383       enddo
6384 !      write (iout,*) "number of requests (contacts)",ireq
6385 !      write (iout,*) "req",(req(i),i=1,4)
6386 !      call flush(iout)
6387       if (ireq.gt.0) &
6388        call MPI_Waitall(ireq,req,status_array,ierr)
6389       do iii=1,ntask_cont_from
6390         iproc=itask_cont_from(iii)
6391         nn=ncont_recv(iii)
6392         if (lprn) then
6393         write (iout,*) "Received",nn," contacts from processor",iproc,&
6394          " of CONT_FROM_COMM group"
6395         call flush(iout)
6396         do i=1,nn
6397           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6398         enddo
6399         call flush(iout)
6400         endif
6401         do i=1,nn
6402           ii=zapas_recv(1,i,iii)
6403 ! Flag the received contacts to prevent double-counting
6404           jj=-zapas_recv(2,i,iii)
6405 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6406 !          call flush(iout)
6407           nnn=num_cont_hb(ii)+1
6408           num_cont_hb(ii)=nnn
6409           jcont_hb(nnn,ii)=jj
6410           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6411           ind=3
6412           do kk=1,3
6413             ind=ind+1
6414             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6415           enddo
6416           do kk=1,2
6417             do ll=1,2
6418               ind=ind+1
6419               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6420             enddo
6421           enddo
6422           do jj=1,5
6423             do kk=1,3
6424               do ll=1,2
6425                 do mm=1,2
6426                   ind=ind+1
6427                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6428                 enddo
6429               enddo
6430             enddo
6431           enddo
6432         enddo
6433       enddo
6434       call flush(iout)
6435       if (lprn) then
6436         write (iout,'(a)') 'Contact function values after receive:'
6437         do i=nnt,nct-2
6438           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6439           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6440           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6441         enddo
6442         call flush(iout)
6443       endif
6444    30 continue
6445 #endif
6446       if (lprn) then
6447         write (iout,'(a)') 'Contact function values:'
6448         do i=nnt,nct-2
6449           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6450           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6451           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6452         enddo
6453       endif
6454       ecorr=0.0D0
6455       ecorr5=0.0d0
6456       ecorr6=0.0d0
6457
6458 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6459 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6460 ! Remove the loop below after debugging !!!
6461       do i=nnt,nct
6462         do j=1,3
6463           gradcorr(j,i)=0.0D0
6464           gradxorr(j,i)=0.0D0
6465         enddo
6466       enddo
6467 ! Calculate the dipole-dipole interaction energies
6468       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6469       do i=iatel_s,iatel_e+1
6470         num_conti=num_cont_hb(i)
6471         do jj=1,num_conti
6472           j=jcont_hb(jj,i)
6473 #ifdef MOMENT
6474           call dipole(i,j,jj)
6475 #endif
6476         enddo
6477       enddo
6478       endif
6479 ! Calculate the local-electrostatic correlation terms
6480 !                write (iout,*) "gradcorr5 in eello5 before loop"
6481 !                do iii=1,nres
6482 !                  write (iout,'(i5,3f10.5)')
6483 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6484 !                enddo
6485       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6486 !        write (iout,*) "corr loop i",i
6487         i1=i+1
6488         num_conti=num_cont_hb(i)
6489         num_conti1=num_cont_hb(i+1)
6490         do jj=1,num_conti
6491           j=jcont_hb(jj,i)
6492           jp=iabs(j)
6493           do kk=1,num_conti1
6494             j1=jcont_hb(kk,i1)
6495             jp1=iabs(j1)
6496 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6497 !     &         ' jj=',jj,' kk=',kk
6498 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6499             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6500                 .or. j.lt.0 .and. j1.gt.0) .and. &
6501                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6502 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6503 ! The system gains extra energy.
6504               n_corr=n_corr+1
6505               sqd1=dsqrt(d_cont(jj,i))
6506               sqd2=dsqrt(d_cont(kk,i1))
6507               sred_geom = sqd1*sqd2
6508               IF (sred_geom.lt.cutoff_corr) THEN
6509                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6510                   ekont,fprimcont)
6511 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6512 !d     &         ' jj=',jj,' kk=',kk
6513                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6514                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6515                 do l=1,3
6516                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6517                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6518                 enddo
6519                 n_corr1=n_corr1+1
6520 !d               write (iout,*) 'sred_geom=',sred_geom,
6521 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6522 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6523 !d               write (iout,*) "g_contij",g_contij
6524 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6525 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6526                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6527                 if (wcorr4.gt.0.0d0) &
6528                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6529                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6530                        write (iout,'(a6,4i5,0pf7.3)') &
6531                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6532 !                write (iout,*) "gradcorr5 before eello5"
6533 !                do iii=1,nres
6534 !                  write (iout,'(i5,3f10.5)')
6535 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6536 !                enddo
6537                 if (wcorr5.gt.0.0d0) &
6538                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6539 !                write (iout,*) "gradcorr5 after eello5"
6540 !                do iii=1,nres
6541 !                  write (iout,'(i5,3f10.5)')
6542 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6543 !                enddo
6544                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6545                        write (iout,'(a6,4i5,0pf7.3)') &
6546                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6547 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6548 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6549                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6550                      .or. wturn6.eq.0.0d0))then
6551 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6552                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6553                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6554                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6555 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6556 !d     &            'ecorr6=',ecorr6
6557 !d                write (iout,'(4e15.5)') sred_geom,
6558 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6559 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6560 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6561                 else if (wturn6.gt.0.0d0 &
6562                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6563 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6564                   eturn6=eturn6+eello_turn6(i,jj,kk)
6565                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6566                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6567 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6568                 endif
6569               ENDIF
6570 1111          continue
6571             endif
6572           enddo ! kk
6573         enddo ! jj
6574       enddo ! i
6575       do i=1,nres
6576         num_cont_hb(i)=num_cont_hb_old(i)
6577       enddo
6578 !                write (iout,*) "gradcorr5 in eello5"
6579 !                do iii=1,nres
6580 !                  write (iout,'(i5,3f10.5)')
6581 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6582 !                enddo
6583       return
6584       end subroutine multibody_eello
6585 !-----------------------------------------------------------------------------
6586       subroutine add_hb_contact_eello(ii,jj,itask)
6587 !      implicit real*8 (a-h,o-z)
6588 !      include "DIMENSIONS"
6589 !      include "COMMON.IOUNITS"
6590 !      include "COMMON.CONTACTS"
6591 !      integer,parameter :: maxconts=nres/4
6592       integer,parameter :: max_dim=70
6593       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6594 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6595 !      common /przechowalnia/ zapas
6596
6597       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6598       integer,dimension(4) ::itask
6599 !      write (iout,*) "itask",itask
6600       do i=1,2
6601         iproc=itask(i)
6602         if (iproc.gt.0) then
6603           do j=1,num_cont_hb(ii)
6604             jjc=jcont_hb(j,ii)
6605 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6606             if (jjc.eq.jj) then
6607               ncont_sent(iproc)=ncont_sent(iproc)+1
6608               nn=ncont_sent(iproc)
6609               zapas(1,nn,iproc)=ii
6610               zapas(2,nn,iproc)=jjc
6611               zapas(3,nn,iproc)=d_cont(j,ii)
6612               ind=3
6613               do kk=1,3
6614                 ind=ind+1
6615                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6616               enddo
6617               do kk=1,2
6618                 do ll=1,2
6619                   ind=ind+1
6620                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6621                 enddo
6622               enddo
6623               do jj=1,5
6624                 do kk=1,3
6625                   do ll=1,2
6626                     do mm=1,2
6627                       ind=ind+1
6628                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6629                     enddo
6630                   enddo
6631                 enddo
6632               enddo
6633               exit
6634             endif
6635           enddo
6636         endif
6637       enddo
6638       return
6639       end subroutine add_hb_contact_eello
6640 !-----------------------------------------------------------------------------
6641       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6642 !      implicit real*8 (a-h,o-z)
6643 !      include 'DIMENSIONS'
6644 !      include 'COMMON.IOUNITS'
6645 !      include 'COMMON.DERIV'
6646 !      include 'COMMON.INTERACT'
6647 !      include 'COMMON.CONTACTS'
6648       real(kind=8),dimension(3) :: gx,gx1
6649       logical :: lprn
6650 !el local variables
6651       integer :: i,j,k,l,jj,kk,ll
6652       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6653                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6654                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6655
6656       lprn=.false.
6657       eij=facont_hb(jj,i)
6658       ekl=facont_hb(kk,k)
6659       ees0pij=ees0p(jj,i)
6660       ees0pkl=ees0p(kk,k)
6661       ees0mij=ees0m(jj,i)
6662       ees0mkl=ees0m(kk,k)
6663       ekont=eij*ekl
6664       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6665 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6666 ! Following 4 lines for diagnostics.
6667 !d    ees0pkl=0.0D0
6668 !d    ees0pij=1.0D0
6669 !d    ees0mkl=0.0D0
6670 !d    ees0mij=1.0D0
6671 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6672 !     & 'Contacts ',i,j,
6673 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6674 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6675 !     & 'gradcorr_long'
6676 ! Calculate the multi-body contribution to energy.
6677 !      ecorr=ecorr+ekont*ees
6678 ! Calculate multi-body contributions to the gradient.
6679       coeffpees0pij=coeffp*ees0pij
6680       coeffmees0mij=coeffm*ees0mij
6681       coeffpees0pkl=coeffp*ees0pkl
6682       coeffmees0mkl=coeffm*ees0mkl
6683       do ll=1,3
6684 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6685         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6686         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6687         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6688         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6689         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6690         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6691 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6692         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6693         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6694         coeffmees0mij*gacontm_hb1(ll,kk,k))
6695         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6696         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6697         coeffmees0mij*gacontm_hb2(ll,kk,k))
6698         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6699            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6700            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6701         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6702         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6703         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6704            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6705            coeffmees0mij*gacontm_hb3(ll,kk,k))
6706         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6707         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6708 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6709       enddo
6710 !      write (iout,*)
6711 !grad      do m=i+1,j-1
6712 !grad        do ll=1,3
6713 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6714 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6715 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6716 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6717 !grad        enddo
6718 !grad      enddo
6719 !grad      do m=k+1,l-1
6720 !grad        do ll=1,3
6721 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6722 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6723 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6724 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6725 !grad        enddo
6726 !grad      enddo
6727 !      write (iout,*) "ehbcorr",ekont*ees
6728       ehbcorr=ekont*ees
6729       return
6730       end function ehbcorr
6731 #ifdef MOMENT
6732 !-----------------------------------------------------------------------------
6733       subroutine dipole(i,j,jj)
6734 !      implicit real*8 (a-h,o-z)
6735 !      include 'DIMENSIONS'
6736 !      include 'COMMON.IOUNITS'
6737 !      include 'COMMON.CHAIN'
6738 !      include 'COMMON.FFIELD'
6739 !      include 'COMMON.DERIV'
6740 !      include 'COMMON.INTERACT'
6741 !      include 'COMMON.CONTACTS'
6742 !      include 'COMMON.TORSION'
6743 !      include 'COMMON.VAR'
6744 !      include 'COMMON.GEO'
6745       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
6746       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
6747       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
6748
6749       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
6750       allocate(dipderx(3,5,4,maxconts,nres))
6751 !
6752
6753       iti1 = itortyp(itype(i+1))
6754       if (j.lt.nres-1) then
6755         itj1 = itortyp(itype(j+1))
6756       else
6757         itj1=ntortyp+1
6758       endif
6759       do iii=1,2
6760         dipi(iii,1)=Ub2(iii,i)
6761         dipderi(iii)=Ub2der(iii,i)
6762         dipi(iii,2)=b1(iii,iti1)
6763         dipj(iii,1)=Ub2(iii,j)
6764         dipderj(iii)=Ub2der(iii,j)
6765         dipj(iii,2)=b1(iii,itj1)
6766       enddo
6767       kkk=0
6768       do iii=1,2
6769         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6770         do jjj=1,2
6771           kkk=kkk+1
6772           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6773         enddo
6774       enddo
6775       do kkk=1,5
6776         do lll=1,3
6777           mmm=0
6778           do iii=1,2
6779             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
6780               auxvec(1))
6781             do jjj=1,2
6782               mmm=mmm+1
6783               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6784             enddo
6785           enddo
6786         enddo
6787       enddo
6788       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6789       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6790       do iii=1,2
6791         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6792       enddo
6793       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6794       do iii=1,2
6795         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6796       enddo
6797       return
6798       end subroutine dipole
6799 #endif
6800 !-----------------------------------------------------------------------------
6801       subroutine calc_eello(i,j,k,l,jj,kk)
6802 !
6803 ! This subroutine computes matrices and vectors needed to calculate
6804 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
6805 !
6806       use comm_kut
6807 !      implicit real*8 (a-h,o-z)
6808 !      include 'DIMENSIONS'
6809 !      include 'COMMON.IOUNITS'
6810 !      include 'COMMON.CHAIN'
6811 !      include 'COMMON.DERIV'
6812 !      include 'COMMON.INTERACT'
6813 !      include 'COMMON.CONTACTS'
6814 !      include 'COMMON.TORSION'
6815 !      include 'COMMON.VAR'
6816 !      include 'COMMON.GEO'
6817 !      include 'COMMON.FFIELD'
6818       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
6819       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
6820       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
6821               itj1
6822 !el      logical :: lprn
6823 !el      common /kutas/ lprn
6824 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6825 !d     & ' jj=',jj,' kk=',kk
6826 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6827 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6828 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6829       do iii=1,2
6830         do jjj=1,2
6831           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6832           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6833         enddo
6834       enddo
6835       call transpose2(aa1(1,1),aa1t(1,1))
6836       call transpose2(aa2(1,1),aa2t(1,1))
6837       do kkk=1,5
6838         do lll=1,3
6839           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
6840             aa1tder(1,1,lll,kkk))
6841           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
6842             aa2tder(1,1,lll,kkk))
6843         enddo
6844       enddo
6845       if (l.eq.j+1) then
6846 ! parallel orientation of the two CA-CA-CA frames.
6847         if (i.gt.1) then
6848           iti=itortyp(itype(i))
6849         else
6850           iti=ntortyp+1
6851         endif
6852         itk1=itortyp(itype(k+1))
6853         itj=itortyp(itype(j))
6854         if (l.lt.nres-1) then
6855           itl1=itortyp(itype(l+1))
6856         else
6857           itl1=ntortyp+1
6858         endif
6859 ! A1 kernel(j+1) A2T
6860 !d        do iii=1,2
6861 !d          write (iout,'(3f10.5,5x,3f10.5)')
6862 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6863 !d        enddo
6864         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6865          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
6866          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6867 ! Following matrices are needed only for 6-th order cumulants
6868         IF (wcorr6.gt.0.0d0) THEN
6869         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6870          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
6871          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6872         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6873          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
6874          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
6875          ADtEAderx(1,1,1,1,1,1))
6876         lprn=.false.
6877         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
6878          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
6879          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
6880          ADtEA1derx(1,1,1,1,1,1))
6881         ENDIF
6882 ! End 6-th order cumulants
6883 !d        lprn=.false.
6884 !d        if (lprn) then
6885 !d        write (2,*) 'In calc_eello6'
6886 !d        do iii=1,2
6887 !d          write (2,*) 'iii=',iii
6888 !d          do kkk=1,5
6889 !d            write (2,*) 'kkk=',kkk
6890 !d            do jjj=1,2
6891 !d              write (2,'(3(2f10.5),5x)')
6892 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6893 !d            enddo
6894 !d          enddo
6895 !d        enddo
6896 !d        endif
6897         call transpose2(EUgder(1,1,k),auxmat(1,1))
6898         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6899         call transpose2(EUg(1,1,k),auxmat(1,1))
6900         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6901         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6902         do iii=1,2
6903           do kkk=1,5
6904             do lll=1,3
6905               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
6906                 EAEAderx(1,1,lll,kkk,iii,1))
6907             enddo
6908           enddo
6909         enddo
6910 ! A1T kernel(i+1) A2
6911         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6912          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
6913          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6914 ! Following matrices are needed only for 6-th order cumulants
6915         IF (wcorr6.gt.0.0d0) THEN
6916         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6917          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
6918          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6919         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6920          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
6921          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
6922          ADtEAderx(1,1,1,1,1,2))
6923         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
6924          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
6925          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
6926          ADtEA1derx(1,1,1,1,1,2))
6927         ENDIF
6928 ! End 6-th order cumulants
6929         call transpose2(EUgder(1,1,l),auxmat(1,1))
6930         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6931         call transpose2(EUg(1,1,l),auxmat(1,1))
6932         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6933         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6934         do iii=1,2
6935           do kkk=1,5
6936             do lll=1,3
6937               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
6938                 EAEAderx(1,1,lll,kkk,iii,2))
6939             enddo
6940           enddo
6941         enddo
6942 ! AEAb1 and AEAb2
6943 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6944 ! They are needed only when the fifth- or the sixth-order cumulants are
6945 ! indluded.
6946         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6947         call transpose2(AEA(1,1,1),auxmat(1,1))
6948         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6949         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6950         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6951         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6952         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6953         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6954         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6955         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6956         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6957         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6958         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6959         call transpose2(AEA(1,1,2),auxmat(1,1))
6960         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6961         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6962         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6963         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6964         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6965         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6966         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6967         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6968         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6969         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6970         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6971 ! Calculate the Cartesian derivatives of the vectors.
6972         do iii=1,2
6973           do kkk=1,5
6974             do lll=1,3
6975               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6976               call matvec2(auxmat(1,1),b1(1,iti),&
6977                 AEAb1derx(1,lll,kkk,iii,1,1))
6978               call matvec2(auxmat(1,1),Ub2(1,i),&
6979                 AEAb2derx(1,lll,kkk,iii,1,1))
6980               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
6981                 AEAb1derx(1,lll,kkk,iii,2,1))
6982               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
6983                 AEAb2derx(1,lll,kkk,iii,2,1))
6984               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6985               call matvec2(auxmat(1,1),b1(1,itj),&
6986                 AEAb1derx(1,lll,kkk,iii,1,2))
6987               call matvec2(auxmat(1,1),Ub2(1,j),&
6988                 AEAb2derx(1,lll,kkk,iii,1,2))
6989               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
6990                 AEAb1derx(1,lll,kkk,iii,2,2))
6991               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
6992                 AEAb2derx(1,lll,kkk,iii,2,2))
6993             enddo
6994           enddo
6995         enddo
6996         ENDIF
6997 ! End vectors
6998       else
6999 ! Antiparallel orientation of the two CA-CA-CA frames.
7000         if (i.gt.1) then
7001           iti=itortyp(itype(i))
7002         else
7003           iti=ntortyp+1
7004         endif
7005         itk1=itortyp(itype(k+1))
7006         itl=itortyp(itype(l))
7007         itj=itortyp(itype(j))
7008         if (j.lt.nres-1) then
7009           itj1=itortyp(itype(j+1))
7010         else
7011           itj1=ntortyp+1
7012         endif
7013 ! A2 kernel(j-1)T A1T
7014         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7015          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7016          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7017 ! Following matrices are needed only for 6-th order cumulants
7018         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7019            j.eq.i+4 .and. l.eq.i+3)) THEN
7020         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7021          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7022          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7023         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7024          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7025          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7026          ADtEAderx(1,1,1,1,1,1))
7027         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7028          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7029          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7030          ADtEA1derx(1,1,1,1,1,1))
7031         ENDIF
7032 ! End 6-th order cumulants
7033         call transpose2(EUgder(1,1,k),auxmat(1,1))
7034         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7035         call transpose2(EUg(1,1,k),auxmat(1,1))
7036         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7037         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7038         do iii=1,2
7039           do kkk=1,5
7040             do lll=1,3
7041               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7042                 EAEAderx(1,1,lll,kkk,iii,1))
7043             enddo
7044           enddo
7045         enddo
7046 ! A2T kernel(i+1)T A1
7047         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7048          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7049          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7050 ! Following matrices are needed only for 6-th order cumulants
7051         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7052            j.eq.i+4 .and. l.eq.i+3)) THEN
7053         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7054          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7055          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7056         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7057          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7058          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7059          ADtEAderx(1,1,1,1,1,2))
7060         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7061          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7062          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7063          ADtEA1derx(1,1,1,1,1,2))
7064         ENDIF
7065 ! End 6-th order cumulants
7066         call transpose2(EUgder(1,1,j),auxmat(1,1))
7067         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7068         call transpose2(EUg(1,1,j),auxmat(1,1))
7069         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7070         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7071         do iii=1,2
7072           do kkk=1,5
7073             do lll=1,3
7074               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7075                 EAEAderx(1,1,lll,kkk,iii,2))
7076             enddo
7077           enddo
7078         enddo
7079 ! AEAb1 and AEAb2
7080 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7081 ! They are needed only when the fifth- or the sixth-order cumulants are
7082 ! indluded.
7083         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7084           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7085         call transpose2(AEA(1,1,1),auxmat(1,1))
7086         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7087         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7088         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7089         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7090         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7091         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7092         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7093         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7094         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7095         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7096         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7097         call transpose2(AEA(1,1,2),auxmat(1,1))
7098         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7099         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7100         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7101         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7102         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7103         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7104         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7105         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7106         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7107         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7108         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7109 ! Calculate the Cartesian derivatives of the vectors.
7110         do iii=1,2
7111           do kkk=1,5
7112             do lll=1,3
7113               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7114               call matvec2(auxmat(1,1),b1(1,iti),&
7115                 AEAb1derx(1,lll,kkk,iii,1,1))
7116               call matvec2(auxmat(1,1),Ub2(1,i),&
7117                 AEAb2derx(1,lll,kkk,iii,1,1))
7118               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7119                 AEAb1derx(1,lll,kkk,iii,2,1))
7120               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7121                 AEAb2derx(1,lll,kkk,iii,2,1))
7122               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7123               call matvec2(auxmat(1,1),b1(1,itl),&
7124                 AEAb1derx(1,lll,kkk,iii,1,2))
7125               call matvec2(auxmat(1,1),Ub2(1,l),&
7126                 AEAb2derx(1,lll,kkk,iii,1,2))
7127               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7128                 AEAb1derx(1,lll,kkk,iii,2,2))
7129               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7130                 AEAb2derx(1,lll,kkk,iii,2,2))
7131             enddo
7132           enddo
7133         enddo
7134         ENDIF
7135 ! End vectors
7136       endif
7137       return
7138       end subroutine calc_eello
7139 !-----------------------------------------------------------------------------
7140       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7141       use comm_kut
7142       implicit none
7143       integer :: nderg
7144       logical :: transp
7145       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7146       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7147       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7148       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7149       integer :: iii,kkk,lll
7150       integer :: jjj,mmm
7151 !el      logical :: lprn
7152 !el      common /kutas/ lprn
7153       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7154       do iii=1,nderg
7155         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7156           AKAderg(1,1,iii))
7157       enddo
7158 !d      if (lprn) write (2,*) 'In kernel'
7159       do kkk=1,5
7160 !d        if (lprn) write (2,*) 'kkk=',kkk
7161         do lll=1,3
7162           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7163             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7164 !d          if (lprn) then
7165 !d            write (2,*) 'lll=',lll
7166 !d            write (2,*) 'iii=1'
7167 !d            do jjj=1,2
7168 !d              write (2,'(3(2f10.5),5x)')
7169 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7170 !d            enddo
7171 !d          endif
7172           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7173             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7174 !d          if (lprn) then
7175 !d            write (2,*) 'lll=',lll
7176 !d            write (2,*) 'iii=2'
7177 !d            do jjj=1,2
7178 !d              write (2,'(3(2f10.5),5x)')
7179 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7180 !d            enddo
7181 !d          endif
7182         enddo
7183       enddo
7184       return
7185       end subroutine kernel
7186 !-----------------------------------------------------------------------------
7187       real(kind=8) function eello4(i,j,k,l,jj,kk)
7188 !      implicit real*8 (a-h,o-z)
7189 !      include 'DIMENSIONS'
7190 !      include 'COMMON.IOUNITS'
7191 !      include 'COMMON.CHAIN'
7192 !      include 'COMMON.DERIV'
7193 !      include 'COMMON.INTERACT'
7194 !      include 'COMMON.CONTACTS'
7195 !      include 'COMMON.TORSION'
7196 !      include 'COMMON.VAR'
7197 !      include 'COMMON.GEO'
7198       real(kind=8),dimension(2,2) :: pizda
7199       real(kind=8),dimension(3) :: ggg1,ggg2
7200       real(kind=8) ::  eel4,glongij,glongkl
7201       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7202 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7203 !d        eello4=0.0d0
7204 !d        return
7205 !d      endif
7206 !d      print *,'eello4:',i,j,k,l,jj,kk
7207 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7208 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7209 !old      eij=facont_hb(jj,i)
7210 !old      ekl=facont_hb(kk,k)
7211 !old      ekont=eij*ekl
7212       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7213 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7214       gcorr_loc(k-1)=gcorr_loc(k-1) &
7215          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7216       if (l.eq.j+1) then
7217         gcorr_loc(l-1)=gcorr_loc(l-1) &
7218            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7219       else
7220         gcorr_loc(j-1)=gcorr_loc(j-1) &
7221            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7222       endif
7223       do iii=1,2
7224         do kkk=1,5
7225           do lll=1,3
7226             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7227                               -EAEAderx(2,2,lll,kkk,iii,1)
7228 !d            derx(lll,kkk,iii)=0.0d0
7229           enddo
7230         enddo
7231       enddo
7232 !d      gcorr_loc(l-1)=0.0d0
7233 !d      gcorr_loc(j-1)=0.0d0
7234 !d      gcorr_loc(k-1)=0.0d0
7235 !d      eel4=1.0d0
7236 !d      write (iout,*)'Contacts have occurred for peptide groups',
7237 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7238 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7239       if (j.lt.nres-1) then
7240         j1=j+1
7241         j2=j-1
7242       else
7243         j1=j-1
7244         j2=j-2
7245       endif
7246       if (l.lt.nres-1) then
7247         l1=l+1
7248         l2=l-1
7249       else
7250         l1=l-1
7251         l2=l-2
7252       endif
7253       do ll=1,3
7254 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7255 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7256         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7257         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7258 !grad        ghalf=0.5d0*ggg1(ll)
7259         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7260         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7261         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7262         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7263         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7264         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7265 !grad        ghalf=0.5d0*ggg2(ll)
7266         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7267         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7268         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7269         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7270         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7271         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7272       enddo
7273 !grad      do m=i+1,j-1
7274 !grad        do ll=1,3
7275 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7276 !grad        enddo
7277 !grad      enddo
7278 !grad      do m=k+1,l-1
7279 !grad        do ll=1,3
7280 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7281 !grad        enddo
7282 !grad      enddo
7283 !grad      do m=i+2,j2
7284 !grad        do ll=1,3
7285 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7286 !grad        enddo
7287 !grad      enddo
7288 !grad      do m=k+2,l2
7289 !grad        do ll=1,3
7290 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7291 !grad        enddo
7292 !grad      enddo
7293 !d      do iii=1,nres-3
7294 !d        write (2,*) iii,gcorr_loc(iii)
7295 !d      enddo
7296       eello4=ekont*eel4
7297 !d      write (2,*) 'ekont',ekont
7298 !d      write (iout,*) 'eello4',ekont*eel4
7299       return
7300       end function eello4
7301 !-----------------------------------------------------------------------------
7302       real(kind=8) function eello5(i,j,k,l,jj,kk)
7303 !      implicit real*8 (a-h,o-z)
7304 !      include 'DIMENSIONS'
7305 !      include 'COMMON.IOUNITS'
7306 !      include 'COMMON.CHAIN'
7307 !      include 'COMMON.DERIV'
7308 !      include 'COMMON.INTERACT'
7309 !      include 'COMMON.CONTACTS'
7310 !      include 'COMMON.TORSION'
7311 !      include 'COMMON.VAR'
7312 !      include 'COMMON.GEO'
7313       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7314       real(kind=8),dimension(2) :: vv
7315       real(kind=8),dimension(3) :: ggg1,ggg2
7316       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7317       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7318       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7319 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7320 !                                                                              C
7321 !                            Parallel chains                                   C
7322 !                                                                              C
7323 !          o             o                   o             o                   C
7324 !         /l\           / \             \   / \           / \   /              C
7325 !        /   \         /   \             \ /   \         /   \ /               C
7326 !       j| o |l1       | o |              o| o |         | o |o                C
7327 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7328 !      \i/   \         /   \ /             /   \         /   \                 C
7329 !       o    k1             o                                                  C
7330 !         (I)          (II)                (III)          (IV)                 C
7331 !                                                                              C
7332 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7333 !                                                                              C
7334 !                            Antiparallel chains                               C
7335 !                                                                              C
7336 !          o             o                   o             o                   C
7337 !         /j\           / \             \   / \           / \   /              C
7338 !        /   \         /   \             \ /   \         /   \ /               C
7339 !      j1| o |l        | o |              o| o |         | o |o                C
7340 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7341 !      \i/   \         /   \ /             /   \         /   \                 C
7342 !       o     k1            o                                                  C
7343 !         (I)          (II)                (III)          (IV)                 C
7344 !                                                                              C
7345 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7346 !                                                                              C
7347 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7348 !                                                                              C
7349 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7350 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7351 !d        eello5=0.0d0
7352 !d        return
7353 !d      endif
7354 !d      write (iout,*)
7355 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7356 !d     &   ' and',k,l
7357       itk=itortyp(itype(k))
7358       itl=itortyp(itype(l))
7359       itj=itortyp(itype(j))
7360       eello5_1=0.0d0
7361       eello5_2=0.0d0
7362       eello5_3=0.0d0
7363       eello5_4=0.0d0
7364 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7365 !d     &   eel5_3_num,eel5_4_num)
7366       do iii=1,2
7367         do kkk=1,5
7368           do lll=1,3
7369             derx(lll,kkk,iii)=0.0d0
7370           enddo
7371         enddo
7372       enddo
7373 !d      eij=facont_hb(jj,i)
7374 !d      ekl=facont_hb(kk,k)
7375 !d      ekont=eij*ekl
7376 !d      write (iout,*)'Contacts have occurred for peptide groups',
7377 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7378 !d      goto 1111
7379 ! Contribution from the graph I.
7380 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7381 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7382       call transpose2(EUg(1,1,k),auxmat(1,1))
7383       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7384       vv(1)=pizda(1,1)-pizda(2,2)
7385       vv(2)=pizda(1,2)+pizda(2,1)
7386       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7387        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7388 ! Explicit gradient in virtual-dihedral angles.
7389       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7390        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7391        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7392       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7393       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7394       vv(1)=pizda(1,1)-pizda(2,2)
7395       vv(2)=pizda(1,2)+pizda(2,1)
7396       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7397        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7398        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7399       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7400       vv(1)=pizda(1,1)-pizda(2,2)
7401       vv(2)=pizda(1,2)+pizda(2,1)
7402       if (l.eq.j+1) then
7403         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7404          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7405          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7406       else
7407         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7408          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7409          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7410       endif
7411 ! Cartesian gradient
7412       do iii=1,2
7413         do kkk=1,5
7414           do lll=1,3
7415             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7416               pizda(1,1))
7417             vv(1)=pizda(1,1)-pizda(2,2)
7418             vv(2)=pizda(1,2)+pizda(2,1)
7419             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7420              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7421              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7422           enddo
7423         enddo
7424       enddo
7425 !      goto 1112
7426 !1111  continue
7427 ! Contribution from graph II
7428       call transpose2(EE(1,1,itk),auxmat(1,1))
7429       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7430       vv(1)=pizda(1,1)+pizda(2,2)
7431       vv(2)=pizda(2,1)-pizda(1,2)
7432       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7433        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7434 ! Explicit gradient in virtual-dihedral angles.
7435       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7436        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7437       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7438       vv(1)=pizda(1,1)+pizda(2,2)
7439       vv(2)=pizda(2,1)-pizda(1,2)
7440       if (l.eq.j+1) then
7441         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7442          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7443          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7444       else
7445         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7446          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7447          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7448       endif
7449 ! Cartesian gradient
7450       do iii=1,2
7451         do kkk=1,5
7452           do lll=1,3
7453             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7454               pizda(1,1))
7455             vv(1)=pizda(1,1)+pizda(2,2)
7456             vv(2)=pizda(2,1)-pizda(1,2)
7457             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7458              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7459              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7460           enddo
7461         enddo
7462       enddo
7463 !d      goto 1112
7464 !d1111  continue
7465       if (l.eq.j+1) then
7466 !d        goto 1110
7467 ! Parallel orientation
7468 ! Contribution from graph III
7469         call transpose2(EUg(1,1,l),auxmat(1,1))
7470         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7471         vv(1)=pizda(1,1)-pizda(2,2)
7472         vv(2)=pizda(1,2)+pizda(2,1)
7473         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7474          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7475 ! Explicit gradient in virtual-dihedral angles.
7476         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7477          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7478          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7479         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7480         vv(1)=pizda(1,1)-pizda(2,2)
7481         vv(2)=pizda(1,2)+pizda(2,1)
7482         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7483          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7484          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7485         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7486         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7487         vv(1)=pizda(1,1)-pizda(2,2)
7488         vv(2)=pizda(1,2)+pizda(2,1)
7489         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7490          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7491          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7492 ! Cartesian gradient
7493         do iii=1,2
7494           do kkk=1,5
7495             do lll=1,3
7496               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7497                 pizda(1,1))
7498               vv(1)=pizda(1,1)-pizda(2,2)
7499               vv(2)=pizda(1,2)+pizda(2,1)
7500               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7501                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7502                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7503             enddo
7504           enddo
7505         enddo
7506 !d        goto 1112
7507 ! Contribution from graph IV
7508 !d1110    continue
7509         call transpose2(EE(1,1,itl),auxmat(1,1))
7510         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7511         vv(1)=pizda(1,1)+pizda(2,2)
7512         vv(2)=pizda(2,1)-pizda(1,2)
7513         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7514          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7515 ! Explicit gradient in virtual-dihedral angles.
7516         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7517          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7518         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7519         vv(1)=pizda(1,1)+pizda(2,2)
7520         vv(2)=pizda(2,1)-pizda(1,2)
7521         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7522          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7523          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
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,2),&
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,2),b1(1,itl)) &
7534                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7535             enddo
7536           enddo
7537         enddo
7538       else
7539 ! Antiparallel orientation
7540 ! Contribution from graph III
7541 !        goto 1110
7542         call transpose2(EUg(1,1,j),auxmat(1,1))
7543         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7544         vv(1)=pizda(1,1)-pizda(2,2)
7545         vv(2)=pizda(1,2)+pizda(2,1)
7546         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7547          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7548 ! Explicit gradient in virtual-dihedral angles.
7549         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7550          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7551          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7552         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7553         vv(1)=pizda(1,1)-pizda(2,2)
7554         vv(2)=pizda(1,2)+pizda(2,1)
7555         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7556          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7557          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7558         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7559         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7560         vv(1)=pizda(1,1)-pizda(2,2)
7561         vv(2)=pizda(1,2)+pizda(2,1)
7562         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7563          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7564          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7565 ! Cartesian gradient
7566         do iii=1,2
7567           do kkk=1,5
7568             do lll=1,3
7569               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7570                 pizda(1,1))
7571               vv(1)=pizda(1,1)-pizda(2,2)
7572               vv(2)=pizda(1,2)+pizda(2,1)
7573               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7574                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7575                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7576             enddo
7577           enddo
7578         enddo
7579 !d        goto 1112
7580 ! Contribution from graph IV
7581 1110    continue
7582         call transpose2(EE(1,1,itj),auxmat(1,1))
7583         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7584         vv(1)=pizda(1,1)+pizda(2,2)
7585         vv(2)=pizda(2,1)-pizda(1,2)
7586         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7587          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7588 ! Explicit gradient in virtual-dihedral angles.
7589         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7590          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7591         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7592         vv(1)=pizda(1,1)+pizda(2,2)
7593         vv(2)=pizda(2,1)-pizda(1,2)
7594         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7595          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7596          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7597 ! Cartesian gradient
7598         do iii=1,2
7599           do kkk=1,5
7600             do lll=1,3
7601               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7602                 pizda(1,1))
7603               vv(1)=pizda(1,1)+pizda(2,2)
7604               vv(2)=pizda(2,1)-pizda(1,2)
7605               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7606                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7607                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7608             enddo
7609           enddo
7610         enddo
7611       endif
7612 1112  continue
7613       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7614 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7615 !d        write (2,*) 'ijkl',i,j,k,l
7616 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7617 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7618 !d      endif
7619 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7620 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7621 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7622 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7623       if (j.lt.nres-1) then
7624         j1=j+1
7625         j2=j-1
7626       else
7627         j1=j-1
7628         j2=j-2
7629       endif
7630       if (l.lt.nres-1) then
7631         l1=l+1
7632         l2=l-1
7633       else
7634         l1=l-1
7635         l2=l-2
7636       endif
7637 !d      eij=1.0d0
7638 !d      ekl=1.0d0
7639 !d      ekont=1.0d0
7640 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7641 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7642 !        summed up outside the subrouine as for the other subroutines
7643 !        handling long-range interactions. The old code is commented out
7644 !        with "cgrad" to keep track of changes.
7645       do ll=1,3
7646 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7647 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7648         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7649         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7650 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7651 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7652 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7653 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7654 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7655 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7656 !     &   gradcorr5ij,
7657 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7658 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7659 !grad        ghalf=0.5d0*ggg1(ll)
7660 !d        ghalf=0.0d0
7661         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7662         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7663         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7664         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7665         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7666         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7667 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7668 !grad        ghalf=0.5d0*ggg2(ll)
7669         ghalf=0.0d0
7670         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7671         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7672         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7673         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7674         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7675         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7676       enddo
7677 !d      goto 1112
7678 !grad      do m=i+1,j-1
7679 !grad        do ll=1,3
7680 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7681 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7682 !grad        enddo
7683 !grad      enddo
7684 !grad      do m=k+1,l-1
7685 !grad        do ll=1,3
7686 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7687 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7688 !grad        enddo
7689 !grad      enddo
7690 !1112  continue
7691 !grad      do m=i+2,j2
7692 !grad        do ll=1,3
7693 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7694 !grad        enddo
7695 !grad      enddo
7696 !grad      do m=k+2,l2
7697 !grad        do ll=1,3
7698 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7699 !grad        enddo
7700 !grad      enddo
7701 !d      do iii=1,nres-3
7702 !d        write (2,*) iii,g_corr5_loc(iii)
7703 !d      enddo
7704       eello5=ekont*eel5
7705 !d      write (2,*) 'ekont',ekont
7706 !d      write (iout,*) 'eello5',ekont*eel5
7707       return
7708       end function eello5
7709 !-----------------------------------------------------------------------------
7710       real(kind=8) function eello6(i,j,k,l,jj,kk)
7711 !      implicit real*8 (a-h,o-z)
7712 !      include 'DIMENSIONS'
7713 !      include 'COMMON.IOUNITS'
7714 !      include 'COMMON.CHAIN'
7715 !      include 'COMMON.DERIV'
7716 !      include 'COMMON.INTERACT'
7717 !      include 'COMMON.CONTACTS'
7718 !      include 'COMMON.TORSION'
7719 !      include 'COMMON.VAR'
7720 !      include 'COMMON.GEO'
7721 !      include 'COMMON.FFIELD'
7722       real(kind=8),dimension(3) :: ggg1,ggg2
7723       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7724                    eello6_6,eel6
7725       real(kind=8) :: gradcorr6ij,gradcorr6kl
7726       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7727 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7728 !d        eello6=0.0d0
7729 !d        return
7730 !d      endif
7731 !d      write (iout,*)
7732 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7733 !d     &   ' and',k,l
7734       eello6_1=0.0d0
7735       eello6_2=0.0d0
7736       eello6_3=0.0d0
7737       eello6_4=0.0d0
7738       eello6_5=0.0d0
7739       eello6_6=0.0d0
7740 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7741 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7742       do iii=1,2
7743         do kkk=1,5
7744           do lll=1,3
7745             derx(lll,kkk,iii)=0.0d0
7746           enddo
7747         enddo
7748       enddo
7749 !d      eij=facont_hb(jj,i)
7750 !d      ekl=facont_hb(kk,k)
7751 !d      ekont=eij*ekl
7752 !d      eij=1.0d0
7753 !d      ekl=1.0d0
7754 !d      ekont=1.0d0
7755       if (l.eq.j+1) then
7756         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7757         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7758         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7759         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7760         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7761         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7762       else
7763         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7764         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7765         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7766         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7767         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7768           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7769         else
7770           eello6_5=0.0d0
7771         endif
7772         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7773       endif
7774 ! If turn contributions are considered, they will be handled separately.
7775       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7776 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7777 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7778 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7779 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7780 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7781 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7782 !d      goto 1112
7783       if (j.lt.nres-1) then
7784         j1=j+1
7785         j2=j-1
7786       else
7787         j1=j-1
7788         j2=j-2
7789       endif
7790       if (l.lt.nres-1) then
7791         l1=l+1
7792         l2=l-1
7793       else
7794         l1=l-1
7795         l2=l-2
7796       endif
7797       do ll=1,3
7798 !grad        ggg1(ll)=eel6*g_contij(ll,1)
7799 !grad        ggg2(ll)=eel6*g_contij(ll,2)
7800 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7801 !grad        ghalf=0.5d0*ggg1(ll)
7802 !d        ghalf=0.0d0
7803         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7804         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7805         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7806         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7807         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7808         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7809         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7810         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7811 !grad        ghalf=0.5d0*ggg2(ll)
7812 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7813 !d        ghalf=0.0d0
7814         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7815         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7816         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7817         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7818         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7819         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7820       enddo
7821 !d      goto 1112
7822 !grad      do m=i+1,j-1
7823 !grad        do ll=1,3
7824 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7825 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7826 !grad        enddo
7827 !grad      enddo
7828 !grad      do m=k+1,l-1
7829 !grad        do ll=1,3
7830 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7831 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7832 !grad        enddo
7833 !grad      enddo
7834 !grad1112  continue
7835 !grad      do m=i+2,j2
7836 !grad        do ll=1,3
7837 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7838 !grad        enddo
7839 !grad      enddo
7840 !grad      do m=k+2,l2
7841 !grad        do ll=1,3
7842 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7843 !grad        enddo
7844 !grad      enddo
7845 !d      do iii=1,nres-3
7846 !d        write (2,*) iii,g_corr6_loc(iii)
7847 !d      enddo
7848       eello6=ekont*eel6
7849 !d      write (2,*) 'ekont',ekont
7850 !d      write (iout,*) 'eello6',ekont*eel6
7851       return
7852       end function eello6
7853 !-----------------------------------------------------------------------------
7854       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
7855       use comm_kut
7856 !      implicit real*8 (a-h,o-z)
7857 !      include 'DIMENSIONS'
7858 !      include 'COMMON.IOUNITS'
7859 !      include 'COMMON.CHAIN'
7860 !      include 'COMMON.DERIV'
7861 !      include 'COMMON.INTERACT'
7862 !      include 'COMMON.CONTACTS'
7863 !      include 'COMMON.TORSION'
7864 !      include 'COMMON.VAR'
7865 !      include 'COMMON.GEO'
7866       real(kind=8),dimension(2) :: vv,vv1
7867       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
7868       logical :: swap
7869 !el      logical :: lprn
7870 !el      common /kutas/ lprn
7871       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
7872       real(kind=8) :: s1,s2,s3,s4,s5
7873 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7874 !                                                                              C
7875 !      Parallel       Antiparallel                                             C
7876 !                                                                              C
7877 !          o             o                                                     C
7878 !         /l\           /j\                                                    C
7879 !        /   \         /   \                                                   C
7880 !       /| o |         | o |\                                                  C
7881 !     \ j|/k\|  /   \  |/k\|l /                                                C
7882 !      \ /   \ /     \ /   \ /                                                 C
7883 !       o     o       o     o                                                  C
7884 !       i             i                                                        C
7885 !                                                                              C
7886 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7887       itk=itortyp(itype(k))
7888       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7889       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7890       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7891       call transpose2(EUgC(1,1,k),auxmat(1,1))
7892       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7893       vv1(1)=pizda1(1,1)-pizda1(2,2)
7894       vv1(2)=pizda1(1,2)+pizda1(2,1)
7895       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7896       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7897       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7898       s5=scalar2(vv(1),Dtobr2(1,i))
7899 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7900       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7901       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
7902        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
7903        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
7904        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
7905        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
7906        +scalar2(vv(1),Dtobr2der(1,i)))
7907       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7908       vv1(1)=pizda1(1,1)-pizda1(2,2)
7909       vv1(2)=pizda1(1,2)+pizda1(2,1)
7910       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7911       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7912       if (l.eq.j+1) then
7913         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
7914        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7915        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7916        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7917        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7918       else
7919         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
7920        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
7921        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
7922        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
7923        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7924       endif
7925       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7926       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7927       vv1(1)=pizda1(1,1)-pizda1(2,2)
7928       vv1(2)=pizda1(1,2)+pizda1(2,1)
7929       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
7930        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
7931        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
7932        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7933       do iii=1,2
7934         if (swap) then
7935           ind=3-iii
7936         else
7937           ind=iii
7938         endif
7939         do kkk=1,5
7940           do lll=1,3
7941             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7942             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7943             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7944             call transpose2(EUgC(1,1,k),auxmat(1,1))
7945             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
7946               pizda1(1,1))
7947             vv1(1)=pizda1(1,1)-pizda1(2,2)
7948             vv1(2)=pizda1(1,2)+pizda1(2,1)
7949             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7950             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
7951              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7952             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
7953              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7954             s5=scalar2(vv(1),Dtobr2(1,i))
7955             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7956           enddo
7957         enddo
7958       enddo
7959       return
7960       end function eello6_graph1
7961 !-----------------------------------------------------------------------------
7962       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
7963       use comm_kut
7964 !      implicit real*8 (a-h,o-z)
7965 !      include 'DIMENSIONS'
7966 !      include 'COMMON.IOUNITS'
7967 !      include 'COMMON.CHAIN'
7968 !      include 'COMMON.DERIV'
7969 !      include 'COMMON.INTERACT'
7970 !      include 'COMMON.CONTACTS'
7971 !      include 'COMMON.TORSION'
7972 !      include 'COMMON.VAR'
7973 !      include 'COMMON.GEO'
7974       logical :: swap
7975       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
7976       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7977 !el      logical :: lprn
7978 !el      common /kutas/ lprn
7979       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
7980       real(kind=8) :: s2,s3,s4
7981 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7982 !                                                                              C
7983 !      Parallel       Antiparallel                                             C
7984 !                                                                              C
7985 !          o             o                                                     C
7986 !     \   /l\           /j\   /                                                C
7987 !      \ /   \         /   \ /                                                 C
7988 !       o| o |         | o |o                                                  C
7989 !     \ j|/k\|      \  |/k\|l                                                  C
7990 !      \ /   \       \ /   \                                                   C
7991 !       o             o                                                        C
7992 !       i             i                                                        C
7993 !                                                                              C
7994 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7995 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7996 ! AL 7/4/01 s1 would occur in the sixth-order moment,
7997 !           but not in a cluster cumulant
7998 #ifdef MOMENT
7999       s1=dip(1,jj,i)*dip(1,kk,k)
8000 #endif
8001       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8002       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8003       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8004       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8005       call transpose2(EUg(1,1,k),auxmat(1,1))
8006       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8007       vv(1)=pizda(1,1)-pizda(2,2)
8008       vv(2)=pizda(1,2)+pizda(2,1)
8009       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8010 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8011 #ifdef MOMENT
8012       eello6_graph2=-(s1+s2+s3+s4)
8013 #else
8014       eello6_graph2=-(s2+s3+s4)
8015 #endif
8016 !      eello6_graph2=-s3
8017 ! Derivatives in gamma(i-1)
8018       if (i.gt.1) then
8019 #ifdef MOMENT
8020         s1=dipderg(1,jj,i)*dip(1,kk,k)
8021 #endif
8022         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8023         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8024         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8025         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8026 #ifdef MOMENT
8027         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8028 #else
8029         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8030 #endif
8031 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8032       endif
8033 ! Derivatives in gamma(k-1)
8034 #ifdef MOMENT
8035       s1=dip(1,jj,i)*dipderg(1,kk,k)
8036 #endif
8037       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8038       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8039       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8040       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8041       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8042       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8043       vv(1)=pizda(1,1)-pizda(2,2)
8044       vv(2)=pizda(1,2)+pizda(2,1)
8045       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8046 #ifdef MOMENT
8047       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8048 #else
8049       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8050 #endif
8051 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8052 ! Derivatives in gamma(j-1) or gamma(l-1)
8053       if (j.gt.1) then
8054 #ifdef MOMENT
8055         s1=dipderg(3,jj,i)*dip(1,kk,k)
8056 #endif
8057         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8058         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8059         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8060         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8061         vv(1)=pizda(1,1)-pizda(2,2)
8062         vv(2)=pizda(1,2)+pizda(2,1)
8063         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8064 #ifdef MOMENT
8065         if (swap) then
8066           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8067         else
8068           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8069         endif
8070 #endif
8071         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8072 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8073       endif
8074 ! Derivatives in gamma(l-1) or gamma(j-1)
8075       if (l.gt.1) then
8076 #ifdef MOMENT
8077         s1=dip(1,jj,i)*dipderg(3,kk,k)
8078 #endif
8079         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8080         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8081         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8082         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8083         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8084         vv(1)=pizda(1,1)-pizda(2,2)
8085         vv(2)=pizda(1,2)+pizda(2,1)
8086         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8087 #ifdef MOMENT
8088         if (swap) then
8089           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8090         else
8091           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8092         endif
8093 #endif
8094         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8095 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8096       endif
8097 ! Cartesian derivatives.
8098       if (lprn) then
8099         write (2,*) 'In eello6_graph2'
8100         do iii=1,2
8101           write (2,*) 'iii=',iii
8102           do kkk=1,5
8103             write (2,*) 'kkk=',kkk
8104             do jjj=1,2
8105               write (2,'(3(2f10.5),5x)') &
8106               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8107             enddo
8108           enddo
8109         enddo
8110       endif
8111       do iii=1,2
8112         do kkk=1,5
8113           do lll=1,3
8114 #ifdef MOMENT
8115             if (iii.eq.1) then
8116               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8117             else
8118               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8119             endif
8120 #endif
8121             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8122               auxvec(1))
8123             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8124             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8125               auxvec(1))
8126             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8127             call transpose2(EUg(1,1,k),auxmat(1,1))
8128             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8129               pizda(1,1))
8130             vv(1)=pizda(1,1)-pizda(2,2)
8131             vv(2)=pizda(1,2)+pizda(2,1)
8132             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8133 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8134 #ifdef MOMENT
8135             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8136 #else
8137             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8138 #endif
8139             if (swap) then
8140               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8141             else
8142               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8143             endif
8144           enddo
8145         enddo
8146       enddo
8147       return
8148       end function eello6_graph2
8149 !-----------------------------------------------------------------------------
8150       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8151 !      implicit real*8 (a-h,o-z)
8152 !      include 'DIMENSIONS'
8153 !      include 'COMMON.IOUNITS'
8154 !      include 'COMMON.CHAIN'
8155 !      include 'COMMON.DERIV'
8156 !      include 'COMMON.INTERACT'
8157 !      include 'COMMON.CONTACTS'
8158 !      include 'COMMON.TORSION'
8159 !      include 'COMMON.VAR'
8160 !      include 'COMMON.GEO'
8161       real(kind=8),dimension(2) :: vv,auxvec
8162       real(kind=8),dimension(2,2) :: pizda,auxmat
8163       logical :: swap
8164       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8165       real(kind=8) :: s1,s2,s3,s4
8166 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8167 !                                                                              C
8168 !      Parallel       Antiparallel                                             C
8169 !                                                                              C
8170 !          o             o                                                     C
8171 !         /l\   /   \   /j\                                                    C
8172 !        /   \ /     \ /   \                                                   C
8173 !       /| o |o       o| o |\                                                  C
8174 !       j|/k\|  /      |/k\|l /                                                C
8175 !        /   \ /       /   \ /                                                 C
8176 !       /     o       /     o                                                  C
8177 !       i             i                                                        C
8178 !                                                                              C
8179 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8180 !
8181 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8182 !           energy moment and not to the cluster cumulant.
8183       iti=itortyp(itype(i))
8184       if (j.lt.nres-1) then
8185         itj1=itortyp(itype(j+1))
8186       else
8187         itj1=ntortyp+1
8188       endif
8189       itk=itortyp(itype(k))
8190       itk1=itortyp(itype(k+1))
8191       if (l.lt.nres-1) then
8192         itl1=itortyp(itype(l+1))
8193       else
8194         itl1=ntortyp+1
8195       endif
8196 #ifdef MOMENT
8197       s1=dip(4,jj,i)*dip(4,kk,k)
8198 #endif
8199       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8200       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8201       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8202       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8203       call transpose2(EE(1,1,itk),auxmat(1,1))
8204       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8205       vv(1)=pizda(1,1)+pizda(2,2)
8206       vv(2)=pizda(2,1)-pizda(1,2)
8207       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8208 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8209 !d     & "sum",-(s2+s3+s4)
8210 #ifdef MOMENT
8211       eello6_graph3=-(s1+s2+s3+s4)
8212 #else
8213       eello6_graph3=-(s2+s3+s4)
8214 #endif
8215 !      eello6_graph3=-s4
8216 ! Derivatives in gamma(k-1)
8217       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8218       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8219       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8220       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8221 ! Derivatives in gamma(l-1)
8222       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8223       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8224       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8225       vv(1)=pizda(1,1)+pizda(2,2)
8226       vv(2)=pizda(2,1)-pizda(1,2)
8227       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8228       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8229 ! Cartesian derivatives.
8230       do iii=1,2
8231         do kkk=1,5
8232           do lll=1,3
8233 #ifdef MOMENT
8234             if (iii.eq.1) then
8235               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8236             else
8237               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8238             endif
8239 #endif
8240             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8241               auxvec(1))
8242             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8243             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8244               auxvec(1))
8245             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8246             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8247               pizda(1,1))
8248             vv(1)=pizda(1,1)+pizda(2,2)
8249             vv(2)=pizda(2,1)-pizda(1,2)
8250             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8251 #ifdef MOMENT
8252             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8253 #else
8254             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8255 #endif
8256             if (swap) then
8257               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8258             else
8259               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8260             endif
8261 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8262           enddo
8263         enddo
8264       enddo
8265       return
8266       end function eello6_graph3
8267 !-----------------------------------------------------------------------------
8268       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8269 !      implicit real*8 (a-h,o-z)
8270 !      include 'DIMENSIONS'
8271 !      include 'COMMON.IOUNITS'
8272 !      include 'COMMON.CHAIN'
8273 !      include 'COMMON.DERIV'
8274 !      include 'COMMON.INTERACT'
8275 !      include 'COMMON.CONTACTS'
8276 !      include 'COMMON.TORSION'
8277 !      include 'COMMON.VAR'
8278 !      include 'COMMON.GEO'
8279 !      include 'COMMON.FFIELD'
8280       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8281       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8282       logical :: swap
8283       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8284               iii,kkk,lll
8285       real(kind=8) :: s1,s2,s3,s4
8286 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8287 !                                                                              C
8288 !      Parallel       Antiparallel                                             C
8289 !                                                                              C
8290 !          o             o                                                     C
8291 !         /l\   /   \   /j\                                                    C
8292 !        /   \ /     \ /   \                                                   C
8293 !       /| o |o       o| o |\                                                  C
8294 !     \ j|/k\|      \  |/k\|l                                                  C
8295 !      \ /   \       \ /   \                                                   C
8296 !       o     \       o     \                                                  C
8297 !       i             i                                                        C
8298 !                                                                              C
8299 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8300 !
8301 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8302 !           energy moment and not to the cluster cumulant.
8303 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8304       iti=itortyp(itype(i))
8305       itj=itortyp(itype(j))
8306       if (j.lt.nres-1) then
8307         itj1=itortyp(itype(j+1))
8308       else
8309         itj1=ntortyp+1
8310       endif
8311       itk=itortyp(itype(k))
8312       if (k.lt.nres-1) then
8313         itk1=itortyp(itype(k+1))
8314       else
8315         itk1=ntortyp+1
8316       endif
8317       itl=itortyp(itype(l))
8318       if (l.lt.nres-1) then
8319         itl1=itortyp(itype(l+1))
8320       else
8321         itl1=ntortyp+1
8322       endif
8323 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8324 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8325 !d     & ' itl',itl,' itl1',itl1
8326 #ifdef MOMENT
8327       if (imat.eq.1) then
8328         s1=dip(3,jj,i)*dip(3,kk,k)
8329       else
8330         s1=dip(2,jj,j)*dip(2,kk,l)
8331       endif
8332 #endif
8333       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8334       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8335       if (j.eq.l+1) then
8336         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8337         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8338       else
8339         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8340         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8341       endif
8342       call transpose2(EUg(1,1,k),auxmat(1,1))
8343       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8344       vv(1)=pizda(1,1)-pizda(2,2)
8345       vv(2)=pizda(2,1)+pizda(1,2)
8346       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8347 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8348 #ifdef MOMENT
8349       eello6_graph4=-(s1+s2+s3+s4)
8350 #else
8351       eello6_graph4=-(s2+s3+s4)
8352 #endif
8353 ! Derivatives in gamma(i-1)
8354       if (i.gt.1) then
8355 #ifdef MOMENT
8356         if (imat.eq.1) then
8357           s1=dipderg(2,jj,i)*dip(3,kk,k)
8358         else
8359           s1=dipderg(4,jj,j)*dip(2,kk,l)
8360         endif
8361 #endif
8362         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8363         if (j.eq.l+1) then
8364           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8365           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8366         else
8367           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8368           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8369         endif
8370         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8371         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8372 !d          write (2,*) 'turn6 derivatives'
8373 #ifdef MOMENT
8374           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8375 #else
8376           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8377 #endif
8378         else
8379 #ifdef MOMENT
8380           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8381 #else
8382           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8383 #endif
8384         endif
8385       endif
8386 ! Derivatives in gamma(k-1)
8387 #ifdef MOMENT
8388       if (imat.eq.1) then
8389         s1=dip(3,jj,i)*dipderg(2,kk,k)
8390       else
8391         s1=dip(2,jj,j)*dipderg(4,kk,l)
8392       endif
8393 #endif
8394       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8395       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8396       if (j.eq.l+1) then
8397         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8398         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8399       else
8400         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8401         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8402       endif
8403       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8404       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8405       vv(1)=pizda(1,1)-pizda(2,2)
8406       vv(2)=pizda(2,1)+pizda(1,2)
8407       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8408       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8409 #ifdef MOMENT
8410         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8411 #else
8412         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8413 #endif
8414       else
8415 #ifdef MOMENT
8416         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8417 #else
8418         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8419 #endif
8420       endif
8421 ! Derivatives in gamma(j-1) or gamma(l-1)
8422       if (l.eq.j+1 .and. l.gt.1) then
8423         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8424         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8425         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8426         vv(1)=pizda(1,1)-pizda(2,2)
8427         vv(2)=pizda(2,1)+pizda(1,2)
8428         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8429         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8430       else if (j.gt.1) then
8431         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8432         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8433         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8434         vv(1)=pizda(1,1)-pizda(2,2)
8435         vv(2)=pizda(2,1)+pizda(1,2)
8436         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8437         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8438           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8439         else
8440           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8441         endif
8442       endif
8443 ! Cartesian derivatives.
8444       do iii=1,2
8445         do kkk=1,5
8446           do lll=1,3
8447 #ifdef MOMENT
8448             if (iii.eq.1) then
8449               if (imat.eq.1) then
8450                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8451               else
8452                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8453               endif
8454             else
8455               if (imat.eq.1) then
8456                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8457               else
8458                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8459               endif
8460             endif
8461 #endif
8462             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8463               auxvec(1))
8464             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8465             if (j.eq.l+1) then
8466               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8467                 b1(1,itj1),auxvec(1))
8468               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8469             else
8470               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8471                 b1(1,itl1),auxvec(1))
8472               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8473             endif
8474             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8475               pizda(1,1))
8476             vv(1)=pizda(1,1)-pizda(2,2)
8477             vv(2)=pizda(2,1)+pizda(1,2)
8478             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8479             if (swap) then
8480               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8481 #ifdef MOMENT
8482                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8483                    -(s1+s2+s4)
8484 #else
8485                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8486                    -(s2+s4)
8487 #endif
8488                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8489               else
8490 #ifdef MOMENT
8491                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8492 #else
8493                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8494 #endif
8495                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8496               endif
8497             else
8498 #ifdef MOMENT
8499               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8500 #else
8501               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8502 #endif
8503               if (l.eq.j+1) then
8504                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8505               else
8506                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8507               endif
8508             endif
8509           enddo
8510         enddo
8511       enddo
8512       return
8513       end function eello6_graph4
8514 !-----------------------------------------------------------------------------
8515       real(kind=8) function eello_turn6(i,jj,kk)
8516 !      implicit real*8 (a-h,o-z)
8517 !      include 'DIMENSIONS'
8518 !      include 'COMMON.IOUNITS'
8519 !      include 'COMMON.CHAIN'
8520 !      include 'COMMON.DERIV'
8521 !      include 'COMMON.INTERACT'
8522 !      include 'COMMON.CONTACTS'
8523 !      include 'COMMON.TORSION'
8524 !      include 'COMMON.VAR'
8525 !      include 'COMMON.GEO'
8526       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8527       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8528       real(kind=8),dimension(3) :: ggg1,ggg2
8529       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8530       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8531 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8532 !           the respective energy moment and not to the cluster cumulant.
8533 !el local variables
8534       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8535       integer :: j1,j2,l1,l2,ll
8536       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8537       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8538       s1=0.0d0
8539       s8=0.0d0
8540       s13=0.0d0
8541 !
8542       eello_turn6=0.0d0
8543       j=i+4
8544       k=i+1
8545       l=i+3
8546       iti=itortyp(itype(i))
8547       itk=itortyp(itype(k))
8548       itk1=itortyp(itype(k+1))
8549       itl=itortyp(itype(l))
8550       itj=itortyp(itype(j))
8551 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8552 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8553 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8554 !d        eello6=0.0d0
8555 !d        return
8556 !d      endif
8557 !d      write (iout,*)
8558 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8559 !d     &   ' and',k,l
8560 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8561       do iii=1,2
8562         do kkk=1,5
8563           do lll=1,3
8564             derx_turn(lll,kkk,iii)=0.0d0
8565           enddo
8566         enddo
8567       enddo
8568 !d      eij=1.0d0
8569 !d      ekl=1.0d0
8570 !d      ekont=1.0d0
8571       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8572 !d      eello6_5=0.0d0
8573 !d      write (2,*) 'eello6_5',eello6_5
8574 #ifdef MOMENT
8575       call transpose2(AEA(1,1,1),auxmat(1,1))
8576       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8577       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8578       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8579 #endif
8580       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8581       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8582       s2 = scalar2(b1(1,itk),vtemp1(1))
8583 #ifdef MOMENT
8584       call transpose2(AEA(1,1,2),atemp(1,1))
8585       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8586       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8587       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8588 #endif
8589       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8590       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8591       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8592 #ifdef MOMENT
8593       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8594       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8595       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8596       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8597       ss13 = scalar2(b1(1,itk),vtemp4(1))
8598       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8599 #endif
8600 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8601 !      s1=0.0d0
8602 !      s2=0.0d0
8603 !      s8=0.0d0
8604 !      s12=0.0d0
8605 !      s13=0.0d0
8606       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8607 ! Derivatives in gamma(i+2)
8608       s1d =0.0d0
8609       s8d =0.0d0
8610 #ifdef MOMENT
8611       call transpose2(AEA(1,1,1),auxmatd(1,1))
8612       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8613       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8614       call transpose2(AEAderg(1,1,2),atempd(1,1))
8615       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8616       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8617 #endif
8618       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8619       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8620       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8621 !      s1d=0.0d0
8622 !      s2d=0.0d0
8623 !      s8d=0.0d0
8624 !      s12d=0.0d0
8625 !      s13d=0.0d0
8626       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8627 ! Derivatives in gamma(i+3)
8628 #ifdef MOMENT
8629       call transpose2(AEA(1,1,1),auxmatd(1,1))
8630       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8631       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8632       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8633 #endif
8634       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8635       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8636       s2d = scalar2(b1(1,itk),vtemp1d(1))
8637 #ifdef MOMENT
8638       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8639       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8640 #endif
8641       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8642 #ifdef MOMENT
8643       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8644       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8645       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8646 #endif
8647 !      s1d=0.0d0
8648 !      s2d=0.0d0
8649 !      s8d=0.0d0
8650 !      s12d=0.0d0
8651 !      s13d=0.0d0
8652 #ifdef MOMENT
8653       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8654                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8655 #else
8656       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8657                     -0.5d0*ekont*(s2d+s12d)
8658 #endif
8659 ! Derivatives in gamma(i+4)
8660       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8661       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8662       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8663 #ifdef MOMENT
8664       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8665       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8666       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8667 #endif
8668 !      s1d=0.0d0
8669 !      s2d=0.0d0
8670 !      s8d=0.0d0
8671 !      s12d=0.0d0
8672 !      s13d=0.0d0
8673 #ifdef MOMENT
8674       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8675 #else
8676       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8677 #endif
8678 ! Derivatives in gamma(i+5)
8679 #ifdef MOMENT
8680       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8681       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8682       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8683 #endif
8684       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8685       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8686       s2d = scalar2(b1(1,itk),vtemp1d(1))
8687 #ifdef MOMENT
8688       call transpose2(AEA(1,1,2),atempd(1,1))
8689       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8690       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8691 #endif
8692       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8693       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8694 #ifdef MOMENT
8695       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8696       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8697       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8698 #endif
8699 !      s1d=0.0d0
8700 !      s2d=0.0d0
8701 !      s8d=0.0d0
8702 !      s12d=0.0d0
8703 !      s13d=0.0d0
8704 #ifdef MOMENT
8705       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8706                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8707 #else
8708       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8709                     -0.5d0*ekont*(s2d+s12d)
8710 #endif
8711 ! Cartesian derivatives
8712       do iii=1,2
8713         do kkk=1,5
8714           do lll=1,3
8715 #ifdef MOMENT
8716             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8717             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8718             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8719 #endif
8720             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8721             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8722                 vtemp1d(1))
8723             s2d = scalar2(b1(1,itk),vtemp1d(1))
8724 #ifdef MOMENT
8725             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8726             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8727             s8d = -(atempd(1,1)+atempd(2,2))* &
8728                  scalar2(cc(1,1,itl),vtemp2(1))
8729 #endif
8730             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8731                  auxmatd(1,1))
8732             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8733             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8734 !      s1d=0.0d0
8735 !      s2d=0.0d0
8736 !      s8d=0.0d0
8737 !      s12d=0.0d0
8738 !      s13d=0.0d0
8739 #ifdef MOMENT
8740             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8741               - 0.5d0*(s1d+s2d)
8742 #else
8743             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8744               - 0.5d0*s2d
8745 #endif
8746 #ifdef MOMENT
8747             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8748               - 0.5d0*(s8d+s12d)
8749 #else
8750             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8751               - 0.5d0*s12d
8752 #endif
8753           enddo
8754         enddo
8755       enddo
8756 #ifdef MOMENT
8757       do kkk=1,5
8758         do lll=1,3
8759           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
8760             achuj_tempd(1,1))
8761           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8762           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8763           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8764           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8765           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
8766             vtemp4d(1))
8767           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8768           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8769           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8770         enddo
8771       enddo
8772 #endif
8773 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8774 !d     &  16*eel_turn6_num
8775 !d      goto 1112
8776       if (j.lt.nres-1) then
8777         j1=j+1
8778         j2=j-1
8779       else
8780         j1=j-1
8781         j2=j-2
8782       endif
8783       if (l.lt.nres-1) then
8784         l1=l+1
8785         l2=l-1
8786       else
8787         l1=l-1
8788         l2=l-2
8789       endif
8790       do ll=1,3
8791 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8792 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8793 !grad        ghalf=0.5d0*ggg1(ll)
8794 !d        ghalf=0.0d0
8795         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8796         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8797         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
8798           +ekont*derx_turn(ll,2,1)
8799         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8800         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
8801           +ekont*derx_turn(ll,4,1)
8802         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8803         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8804         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8805 !grad        ghalf=0.5d0*ggg2(ll)
8806 !d        ghalf=0.0d0
8807         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
8808           +ekont*derx_turn(ll,2,2)
8809         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8810         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
8811           +ekont*derx_turn(ll,4,2)
8812         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8813         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8814         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8815       enddo
8816 !d      goto 1112
8817 !grad      do m=i+1,j-1
8818 !grad        do ll=1,3
8819 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8820 !grad        enddo
8821 !grad      enddo
8822 !grad      do m=k+1,l-1
8823 !grad        do ll=1,3
8824 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8825 !grad        enddo
8826 !grad      enddo
8827 !grad1112  continue
8828 !grad      do m=i+2,j2
8829 !grad        do ll=1,3
8830 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8831 !grad        enddo
8832 !grad      enddo
8833 !grad      do m=k+2,l2
8834 !grad        do ll=1,3
8835 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8836 !grad        enddo
8837 !grad      enddo
8838 !d      do iii=1,nres-3
8839 !d        write (2,*) iii,g_corr6_loc(iii)
8840 !d      enddo
8841       eello_turn6=ekont*eel_turn6
8842 !d      write (2,*) 'ekont',ekont
8843 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
8844       return
8845       end function eello_turn6
8846 !-----------------------------------------------------------------------------
8847       subroutine MATVEC2(A1,V1,V2)
8848 !DIR$ INLINEALWAYS MATVEC2
8849 #ifndef OSF
8850 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8851 #endif
8852 !      implicit real*8 (a-h,o-z)
8853 !      include 'DIMENSIONS'
8854       real(kind=8),dimension(2) :: V1,V2
8855       real(kind=8),dimension(2,2) :: A1
8856       real(kind=8) :: vaux1,vaux2
8857 !      DO 1 I=1,2
8858 !        VI=0.0
8859 !        DO 3 K=1,2
8860 !    3     VI=VI+A1(I,K)*V1(K)
8861 !        Vaux(I)=VI
8862 !    1 CONTINUE
8863
8864       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8865       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8866
8867       v2(1)=vaux1
8868       v2(2)=vaux2
8869       end subroutine MATVEC2
8870 !-----------------------------------------------------------------------------
8871       subroutine MATMAT2(A1,A2,A3)
8872 #ifndef OSF
8873 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8874 #endif
8875 !      implicit real*8 (a-h,o-z)
8876 !      include 'DIMENSIONS'
8877       real(kind=8),dimension(2,2) :: A1,A2,A3
8878       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
8879 !      DIMENSION AI3(2,2)
8880 !        DO  J=1,2
8881 !          A3IJ=0.0
8882 !          DO K=1,2
8883 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8884 !          enddo
8885 !          A3(I,J)=A3IJ
8886 !       enddo
8887 !      enddo
8888
8889       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8890       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8891       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8892       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8893
8894       A3(1,1)=AI3_11
8895       A3(2,1)=AI3_21
8896       A3(1,2)=AI3_12
8897       A3(2,2)=AI3_22
8898       end subroutine MATMAT2
8899 !-----------------------------------------------------------------------------
8900       real(kind=8) function scalar2(u,v)
8901 !DIR$ INLINEALWAYS scalar2
8902       implicit none
8903       real(kind=8),dimension(2) :: u,v
8904       real(kind=8) :: sc
8905       integer :: i
8906       scalar2=u(1)*v(1)+u(2)*v(2)
8907       return
8908       end function scalar2
8909 !-----------------------------------------------------------------------------
8910       subroutine transpose2(a,at)
8911 !DIR$ INLINEALWAYS transpose2
8912 #ifndef OSF
8913 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
8914 #endif
8915       implicit none
8916       real(kind=8),dimension(2,2) :: a,at
8917       at(1,1)=a(1,1)
8918       at(1,2)=a(2,1)
8919       at(2,1)=a(1,2)
8920       at(2,2)=a(2,2)
8921       return
8922       end subroutine transpose2
8923 !-----------------------------------------------------------------------------
8924       subroutine transpose(n,a,at)
8925       implicit none
8926       integer :: n,i,j
8927       real(kind=8),dimension(n,n) :: a,at
8928       do i=1,n
8929         do j=1,n
8930           at(j,i)=a(i,j)
8931         enddo
8932       enddo
8933       return
8934       end subroutine transpose
8935 !-----------------------------------------------------------------------------
8936       subroutine prodmat3(a1,a2,kk,transp,prod)
8937 !DIR$ INLINEALWAYS prodmat3
8938 #ifndef OSF
8939 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
8940 #endif
8941       implicit none
8942       integer :: i,j
8943       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
8944       logical :: transp
8945 !rc      double precision auxmat(2,2),prod_(2,2)
8946
8947       if (transp) then
8948 !rc        call transpose2(kk(1,1),auxmat(1,1))
8949 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8950 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8951
8952            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
8953        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8954            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
8955        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8956            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
8957        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8958            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
8959        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8960
8961       else
8962 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8963 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8964
8965            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
8966         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8967            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
8968         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8969            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
8970         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8971            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
8972         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8973
8974       endif
8975 !      call transpose2(a2(1,1),a2t(1,1))
8976
8977 !rc      print *,transp
8978 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
8979 !rc      print *,((prod(i,j),i=1,2),j=1,2)
8980
8981       return
8982       end subroutine prodmat3
8983 !-----------------------------------------------------------------------------
8984 ! energy_p_new_barrier.F
8985 !-----------------------------------------------------------------------------
8986       subroutine sum_gradient
8987 !      implicit real*8 (a-h,o-z)
8988       use io_base, only: pdbout
8989 !      include 'DIMENSIONS'
8990 #ifndef ISNAN
8991       external proc_proc
8992 #ifdef WINPGI
8993 !MS$ATTRIBUTES C ::  proc_proc
8994 #endif
8995 #endif
8996 #ifdef MPI
8997       include 'mpif.h'
8998 !el#endif
8999       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9000                    gloc_scbuf !(3,maxres)
9001
9002       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9003 #endif
9004 !el local variables
9005       integer :: i,j,k,ierror,ierr
9006       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9007                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9008                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9009                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9010                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9011                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9012                    gsccorr_max,gsccorrx_max,time00
9013
9014 !      include 'COMMON.SETUP'
9015 !      include 'COMMON.IOUNITS'
9016 !      include 'COMMON.FFIELD'
9017 !      include 'COMMON.DERIV'
9018 !      include 'COMMON.INTERACT'
9019 !      include 'COMMON.SBRIDGE'
9020 !      include 'COMMON.CHAIN'
9021 !      include 'COMMON.VAR'
9022 !      include 'COMMON.CONTROL'
9023 !      include 'COMMON.TIME1'
9024 !      include 'COMMON.MAXGRAD'
9025 !      include 'COMMON.SCCOR'
9026 #ifdef TIMING
9027       time01=MPI_Wtime()
9028 #endif
9029 #ifdef DEBUG
9030       write (iout,*) "sum_gradient gvdwc, gvdwx"
9031       do i=1,nres
9032         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9033          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9034       enddo
9035       call flush(iout)
9036 #endif
9037 #ifdef MPI
9038         gradbufc=0.0d0
9039         gradbufx=0.0d0
9040         gradbufc_sum=0.0d0
9041         gloc_scbuf=0.0d0
9042         glocbuf=0.0d0
9043 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9044         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9045           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9046 #endif
9047 !
9048 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9049 !            in virtual-bond-vector coordinates
9050 !
9051 #ifdef DEBUG
9052 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9053 !      do i=1,nres-1
9054 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9055 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9056 !      enddo
9057 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9058 !      do i=1,nres-1
9059 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9060 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9061 !      enddo
9062       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9063       do i=1,nres
9064         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9065          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9066          (gvdwc_scpp(j,i),j=1,3)
9067       enddo
9068       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9069       do i=1,nres
9070         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9071          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9072          (gelc_loc_long(j,i),j=1,3)
9073       enddo
9074       call flush(iout)
9075 #endif
9076 #ifdef SPLITELE
9077       do i=1,nct
9078         do j=1,3
9079           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9080                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9081                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9082                       wel_loc*gel_loc_long(j,i)+ &
9083                       wcorr*gradcorr_long(j,i)+ &
9084                       wcorr5*gradcorr5_long(j,i)+ &
9085                       wcorr6*gradcorr6_long(j,i)+ &
9086                       wturn6*gcorr6_turn_long(j,i)+ &
9087                       wstrain*ghpbc(j,i)
9088         enddo
9089       enddo
9090 #else
9091       do i=1,nct
9092         do j=1,3
9093           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9094                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9095                       welec*gelc_long(j,i)+ &
9096                       wbond*gradb(j,i)+ &
9097                       wel_loc*gel_loc_long(j,i)+ &
9098                       wcorr*gradcorr_long(j,i)+ &
9099                       wcorr5*gradcorr5_long(j,i)+ &
9100                       wcorr6*gradcorr6_long(j,i)+ &
9101                       wturn6*gcorr6_turn_long(j,i)+ &
9102                       wstrain*ghpbc(j,i)
9103         enddo
9104       enddo
9105 #endif
9106 #ifdef MPI
9107       if (nfgtasks.gt.1) then
9108       time00=MPI_Wtime()
9109 #ifdef DEBUG
9110       write (iout,*) "gradbufc before allreduce"
9111       do i=1,nres
9112         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9113       enddo
9114       call flush(iout)
9115 #endif
9116       do i=1,nres
9117         do j=1,3
9118           gradbufc_sum(j,i)=gradbufc(j,i)
9119         enddo
9120       enddo
9121 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9122 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9123 !      time_reduce=time_reduce+MPI_Wtime()-time00
9124 #ifdef DEBUG
9125 !      write (iout,*) "gradbufc_sum after allreduce"
9126 !      do i=1,nres
9127 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9128 !      enddo
9129 !      call flush(iout)
9130 #endif
9131 #ifdef TIMING
9132 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9133 #endif
9134       do i=nnt,nres
9135         do k=1,3
9136           gradbufc(k,i)=0.0d0
9137         enddo
9138       enddo
9139 #ifdef DEBUG
9140       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9141       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9142                         " jgrad_end  ",jgrad_end(i),&
9143                         i=igrad_start,igrad_end)
9144 #endif
9145 !
9146 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9147 ! do not parallelize this part.
9148 !
9149 !      do i=igrad_start,igrad_end
9150 !        do j=jgrad_start(i),jgrad_end(i)
9151 !          do k=1,3
9152 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9153 !          enddo
9154 !        enddo
9155 !      enddo
9156       do j=1,3
9157         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9158       enddo
9159       do i=nres-2,nnt,-1
9160         do j=1,3
9161           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9162         enddo
9163       enddo
9164 #ifdef DEBUG
9165       write (iout,*) "gradbufc after summing"
9166       do i=1,nres
9167         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9168       enddo
9169       call flush(iout)
9170 #endif
9171       else
9172 #endif
9173 !el#define DEBUG
9174 #ifdef DEBUG
9175       write (iout,*) "gradbufc"
9176       do i=1,nres
9177         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9178       enddo
9179       call flush(iout)
9180 #endif
9181 !el#undef DEBUG
9182       do i=1,nres
9183         do j=1,3
9184           gradbufc_sum(j,i)=gradbufc(j,i)
9185           gradbufc(j,i)=0.0d0
9186         enddo
9187       enddo
9188       do j=1,3
9189         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9190       enddo
9191       do i=nres-2,nnt,-1
9192         do j=1,3
9193           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9194         enddo
9195       enddo
9196 !      do i=nnt,nres-1
9197 !        do k=1,3
9198 !          gradbufc(k,i)=0.0d0
9199 !        enddo
9200 !        do j=i+1,nres
9201 !          do k=1,3
9202 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9203 !          enddo
9204 !        enddo
9205 !      enddo
9206 !el#define DEBUG
9207 #ifdef DEBUG
9208       write (iout,*) "gradbufc after summing"
9209       do i=1,nres
9210         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9211       enddo
9212       call flush(iout)
9213 #endif
9214 !el#undef DEBUG
9215 #ifdef MPI
9216       endif
9217 #endif
9218       do k=1,3
9219         gradbufc(k,nres)=0.0d0
9220       enddo
9221 !el----------------
9222 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9223 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9224 !el-----------------
9225       do i=1,nct
9226         do j=1,3
9227 #ifdef SPLITELE
9228           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9229                       wel_loc*gel_loc(j,i)+ &
9230                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9231                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9232                       wel_loc*gel_loc_long(j,i)+ &
9233                       wcorr*gradcorr_long(j,i)+ &
9234                       wcorr5*gradcorr5_long(j,i)+ &
9235                       wcorr6*gradcorr6_long(j,i)+ &
9236                       wturn6*gcorr6_turn_long(j,i))+ &
9237                       wbond*gradb(j,i)+ &
9238                       wcorr*gradcorr(j,i)+ &
9239                       wturn3*gcorr3_turn(j,i)+ &
9240                       wturn4*gcorr4_turn(j,i)+ &
9241                       wcorr5*gradcorr5(j,i)+ &
9242                       wcorr6*gradcorr6(j,i)+ &
9243                       wturn6*gcorr6_turn(j,i)+ &
9244                       wsccor*gsccorc(j,i) &
9245                      +wscloc*gscloc(j,i)
9246 #else
9247           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9248                       wel_loc*gel_loc(j,i)+ &
9249                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9250                       welec*gelc_long(j,i)+ &
9251                       wel_loc*gel_loc_long(j,i)+ &
9252 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9253                       wcorr5*gradcorr5_long(j,i)+ &
9254                       wcorr6*gradcorr6_long(j,i)+ &
9255                       wturn6*gcorr6_turn_long(j,i))+ &
9256                       wbond*gradb(j,i)+ &
9257                       wcorr*gradcorr(j,i)+ &
9258                       wturn3*gcorr3_turn(j,i)+ &
9259                       wturn4*gcorr4_turn(j,i)+ &
9260                       wcorr5*gradcorr5(j,i)+ &
9261                       wcorr6*gradcorr6(j,i)+ &
9262                       wturn6*gcorr6_turn(j,i)+ &
9263                       wsccor*gsccorc(j,i) &
9264                      +wscloc*gscloc(j,i)
9265 #endif
9266           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9267                         wbond*gradbx(j,i)+ &
9268                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9269                         wsccor*gsccorx(j,i) &
9270                        +wscloc*gsclocx(j,i)
9271         enddo
9272       enddo
9273 #ifdef DEBUG
9274       write (iout,*) "gloc before adding corr"
9275       do i=1,4*nres
9276         write (iout,*) i,gloc(i,icg)
9277       enddo
9278 #endif
9279       do i=1,nres-3
9280         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9281          +wcorr5*g_corr5_loc(i) &
9282          +wcorr6*g_corr6_loc(i) &
9283          +wturn4*gel_loc_turn4(i) &
9284          +wturn3*gel_loc_turn3(i) &
9285          +wturn6*gel_loc_turn6(i) &
9286          +wel_loc*gel_loc_loc(i)
9287       enddo
9288 #ifdef DEBUG
9289       write (iout,*) "gloc after adding corr"
9290       do i=1,4*nres
9291         write (iout,*) i,gloc(i,icg)
9292       enddo
9293 #endif
9294 #ifdef MPI
9295       if (nfgtasks.gt.1) then
9296         do j=1,3
9297           do i=1,nres
9298             gradbufc(j,i)=gradc(j,i,icg)
9299             gradbufx(j,i)=gradx(j,i,icg)
9300           enddo
9301         enddo
9302         do i=1,4*nres
9303           glocbuf(i)=gloc(i,icg)
9304         enddo
9305 !#define DEBUG
9306 #ifdef DEBUG
9307       write (iout,*) "gloc_sc before reduce"
9308       do i=1,nres
9309        do j=1,1
9310         write (iout,*) i,j,gloc_sc(j,i,icg)
9311        enddo
9312       enddo
9313 #endif
9314 !#undef DEBUG
9315         do i=1,nres
9316          do j=1,3
9317           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9318          enddo
9319         enddo
9320         time00=MPI_Wtime()
9321         call MPI_Barrier(FG_COMM,IERR)
9322         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9323         time00=MPI_Wtime()
9324         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9325           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9326         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9327           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9328         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9329           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9330         time_reduce=time_reduce+MPI_Wtime()-time00
9331         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9332           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9333         time_reduce=time_reduce+MPI_Wtime()-time00
9334 !#define DEBUG
9335 #ifdef DEBUG
9336       write (iout,*) "gloc_sc after reduce"
9337       do i=1,nres
9338        do j=1,1
9339         write (iout,*) i,j,gloc_sc(j,i,icg)
9340        enddo
9341       enddo
9342 #endif
9343 !#undef DEBUG
9344 #ifdef DEBUG
9345       write (iout,*) "gloc after reduce"
9346       do i=1,4*nres
9347         write (iout,*) i,gloc(i,icg)
9348       enddo
9349 #endif
9350       endif
9351 #endif
9352       if (gnorm_check) then
9353 !
9354 ! Compute the maximum elements of the gradient
9355 !
9356       gvdwc_max=0.0d0
9357       gvdwc_scp_max=0.0d0
9358       gelc_max=0.0d0
9359       gvdwpp_max=0.0d0
9360       gradb_max=0.0d0
9361       ghpbc_max=0.0d0
9362       gradcorr_max=0.0d0
9363       gel_loc_max=0.0d0
9364       gcorr3_turn_max=0.0d0
9365       gcorr4_turn_max=0.0d0
9366       gradcorr5_max=0.0d0
9367       gradcorr6_max=0.0d0
9368       gcorr6_turn_max=0.0d0
9369       gsccorc_max=0.0d0
9370       gscloc_max=0.0d0
9371       gvdwx_max=0.0d0
9372       gradx_scp_max=0.0d0
9373       ghpbx_max=0.0d0
9374       gradxorr_max=0.0d0
9375       gsccorx_max=0.0d0
9376       gsclocx_max=0.0d0
9377       do i=1,nct
9378         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9379         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9380         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9381         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9382          gvdwc_scp_max=gvdwc_scp_norm
9383         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9384         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9385         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9386         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9387         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9388         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9389         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9390         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9391         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9392         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9393         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9394         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9395         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9396           gcorr3_turn(1,i)))
9397         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9398           gcorr3_turn_max=gcorr3_turn_norm
9399         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9400           gcorr4_turn(1,i)))
9401         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9402           gcorr4_turn_max=gcorr4_turn_norm
9403         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9404         if (gradcorr5_norm.gt.gradcorr5_max) &
9405           gradcorr5_max=gradcorr5_norm
9406         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9407         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9408         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9409           gcorr6_turn(1,i)))
9410         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9411           gcorr6_turn_max=gcorr6_turn_norm
9412         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9413         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9414         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9415         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9416         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9417         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9418         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9419         if (gradx_scp_norm.gt.gradx_scp_max) &
9420           gradx_scp_max=gradx_scp_norm
9421         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9422         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9423         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9424         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9425         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9426         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9427         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9428         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9429       enddo
9430       if (gradout) then
9431 #ifdef AIX
9432         open(istat,file=statname,position="append")
9433 #else
9434         open(istat,file=statname,access="append")
9435 #endif
9436         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9437            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9438            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9439            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9440            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9441            gsccorx_max,gsclocx_max
9442         close(istat)
9443         if (gvdwc_max.gt.1.0d4) then
9444           write (iout,*) "gvdwc gvdwx gradb gradbx"
9445           do i=nnt,nct
9446             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9447               gradb(j,i),gradbx(j,i),j=1,3)
9448           enddo
9449           call pdbout(0.0d0,'cipiszcze',iout)
9450           call flush(iout)
9451         endif
9452       endif
9453       endif
9454 !el#define DEBUG
9455 #ifdef DEBUG
9456       write (iout,*) "gradc gradx gloc"
9457       do i=1,nres
9458         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9459          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9460       enddo
9461 #endif
9462 !el#undef DEBUG
9463 #ifdef TIMING
9464       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9465 #endif
9466       return
9467       end subroutine sum_gradient
9468 !-----------------------------------------------------------------------------
9469       subroutine sc_grad
9470 !      implicit real*8 (a-h,o-z)
9471       use calc_data
9472 !      include 'DIMENSIONS'
9473 !      include 'COMMON.CHAIN'
9474 !      include 'COMMON.DERIV'
9475 !      include 'COMMON.CALC'
9476 !      include 'COMMON.IOUNITS'
9477       real(kind=8), dimension(3) :: dcosom1,dcosom2
9478
9479       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9480       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9481       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9482            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9483 ! diagnostics only
9484 !      eom1=0.0d0
9485 !      eom2=0.0d0
9486 !      eom12=evdwij*eps1_om12
9487 ! end diagnostics
9488 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9489 !       " sigder",sigder
9490 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9491 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9492       do k=1,3
9493         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9494         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9495       enddo
9496       do k=1,3
9497         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
9498       enddo
9499 !      write (iout,*) "gg",(gg(k),k=1,3)
9500       do k=1,3
9501         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9502                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9503                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9504         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9505                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9506                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9507 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9508 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9509 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9510 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9511       enddo
9512 !
9513 ! Calculate the components of the gradient in DC and X
9514 !
9515 !grad      do k=i,j-1
9516 !grad        do l=1,3
9517 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9518 !grad        enddo
9519 !grad      enddo
9520       do l=1,3
9521         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9522         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9523       enddo
9524       return
9525       end subroutine sc_grad
9526 #ifdef CRYST_THETA
9527 !-----------------------------------------------------------------------------
9528       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9529
9530       use comm_calcthet
9531 !      implicit real*8 (a-h,o-z)
9532 !      include 'DIMENSIONS'
9533 !      include 'COMMON.LOCAL'
9534 !      include 'COMMON.IOUNITS'
9535 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9536 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9537 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9538       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9539       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9540 !el      integer :: it
9541 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9542 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9543 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9544 !el local variables
9545
9546       delthec=thetai-thet_pred_mean
9547       delthe0=thetai-theta0i
9548 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9549       t3 = thetai-thet_pred_mean
9550       t6 = t3**2
9551       t9 = term1
9552       t12 = t3*sigcsq
9553       t14 = t12+t6*sigsqtc
9554       t16 = 1.0d0
9555       t21 = thetai-theta0i
9556       t23 = t21**2
9557       t26 = term2
9558       t27 = t21*t26
9559       t32 = termexp
9560       t40 = t32**2
9561       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9562        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9563        *(-t12*t9-ak*sig0inv*t27)
9564       return
9565       end subroutine mixder
9566 #endif
9567 !-----------------------------------------------------------------------------
9568 ! cartder.F
9569 !-----------------------------------------------------------------------------
9570       subroutine cartder
9571 !-----------------------------------------------------------------------------
9572 ! This subroutine calculates the derivatives of the consecutive virtual
9573 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9574 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9575 ! in the angles alpha and omega, describing the location of a side chain
9576 ! in its local coordinate system.
9577 !
9578 ! The derivatives are stored in the following arrays:
9579 !
9580 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9581 ! The structure is as follows:
9582 !
9583 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9584 ! 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)
9585 !         . . . . . . . . . . . .  . . . . . .
9586 ! 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)
9587 !                          .
9588 !                          .
9589 !                          .
9590 ! 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)
9591 !
9592 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9593 ! The structure is same as above.
9594 !
9595 ! DCDS - the derivatives of the side chain vectors in the local spherical
9596 ! andgles alph and omega:
9597 !
9598 ! 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)
9599 ! 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)
9600 !                          .
9601 !                          .
9602 !                          .
9603 ! 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)
9604 !
9605 ! Version of March '95, based on an early version of November '91.
9606 !
9607 !**********************************************************************
9608 !      implicit real*8 (a-h,o-z)
9609 !      include 'DIMENSIONS'
9610 !      include 'COMMON.VAR'
9611 !      include 'COMMON.CHAIN'
9612 !      include 'COMMON.DERIV'
9613 !      include 'COMMON.GEO'
9614 !      include 'COMMON.LOCAL'
9615 !      include 'COMMON.INTERACT'
9616       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9617       real(kind=8),dimension(3,3) :: dp,temp
9618 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9619       real(kind=8),dimension(3) :: xx,xx1
9620 !el local variables
9621       integer :: i,k,l,j,m,ind,ind1,jjj
9622       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9623                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9624                  sint2,xp,yp,xxp,yyp,zzp,dj
9625
9626 !      common /przechowalnia/ fromto
9627       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9628 ! get the position of the jth ijth fragment of the chain coordinate system
9629 ! in the fromto array.
9630 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9631 !
9632 !      maxdim=(nres-1)*(nres-2)/2
9633 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9634 ! calculate the derivatives of transformation matrix elements in theta
9635 !
9636
9637 !el      call flush(iout) !el
9638       do i=1,nres-2
9639         rdt(1,1,i)=-rt(1,2,i)
9640         rdt(1,2,i)= rt(1,1,i)
9641         rdt(1,3,i)= 0.0d0
9642         rdt(2,1,i)=-rt(2,2,i)
9643         rdt(2,2,i)= rt(2,1,i)
9644         rdt(2,3,i)= 0.0d0
9645         rdt(3,1,i)=-rt(3,2,i)
9646         rdt(3,2,i)= rt(3,1,i)
9647         rdt(3,3,i)= 0.0d0
9648       enddo
9649 !
9650 ! derivatives in phi
9651 !
9652       do i=2,nres-2
9653         drt(1,1,i)= 0.0d0
9654         drt(1,2,i)= 0.0d0
9655         drt(1,3,i)= 0.0d0
9656         drt(2,1,i)= rt(3,1,i)
9657         drt(2,2,i)= rt(3,2,i)
9658         drt(2,3,i)= rt(3,3,i)
9659         drt(3,1,i)=-rt(2,1,i)
9660         drt(3,2,i)=-rt(2,2,i)
9661         drt(3,3,i)=-rt(2,3,i)
9662       enddo
9663 !
9664 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9665 !
9666       do i=2,nres-2
9667         ind=indmat(i,i+1)
9668         do k=1,3
9669           do l=1,3
9670             temp(k,l)=rt(k,l,i)
9671           enddo
9672         enddo
9673         do k=1,3
9674           do l=1,3
9675             fromto(k,l,ind)=temp(k,l)
9676           enddo
9677         enddo
9678         do j=i+1,nres-2
9679           ind=indmat(i,j+1)
9680           do k=1,3
9681             do l=1,3
9682               dpkl=0.0d0
9683               do m=1,3
9684                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9685               enddo
9686               dp(k,l)=dpkl
9687               fromto(k,l,ind)=dpkl
9688             enddo
9689           enddo
9690           do k=1,3
9691             do l=1,3
9692               temp(k,l)=dp(k,l)
9693             enddo
9694           enddo
9695         enddo
9696       enddo
9697 !
9698 ! Calculate derivatives.
9699 !
9700       ind1=0
9701       do i=1,nres-2
9702         ind1=ind1+1
9703 !
9704 ! Derivatives of DC(i+1) in theta(i+2)
9705 !
9706         do j=1,3
9707           do k=1,2
9708             dpjk=0.0D0
9709             do l=1,3
9710               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9711             enddo
9712             dp(j,k)=dpjk
9713             prordt(j,k,i)=dp(j,k)
9714           enddo
9715           dp(j,3)=0.0D0
9716           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9717         enddo
9718 !
9719 ! Derivatives of SC(i+1) in theta(i+2)
9720 !
9721         xx1(1)=-0.5D0*xloc(2,i+1)
9722         xx1(2)= 0.5D0*xloc(1,i+1)
9723         do j=1,3
9724           xj=0.0D0
9725           do k=1,2
9726             xj=xj+r(j,k,i)*xx1(k)
9727           enddo
9728           xx(j)=xj
9729         enddo
9730         do j=1,3
9731           rj=0.0D0
9732           do k=1,3
9733             rj=rj+prod(j,k,i)*xx(k)
9734           enddo
9735           dxdv(j,ind1)=rj
9736         enddo
9737 !
9738 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
9739 ! than the other off-diagonal derivatives.
9740 !
9741         do j=1,3
9742           dxoiij=0.0D0
9743           do k=1,3
9744             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9745           enddo
9746           dxdv(j,ind1+1)=dxoiij
9747         enddo
9748 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
9749 !
9750 ! Derivatives of DC(i+1) in phi(i+2)
9751 !
9752         do j=1,3
9753           do k=1,3
9754             dpjk=0.0
9755             do l=2,3
9756               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
9757             enddo
9758             dp(j,k)=dpjk
9759             prodrt(j,k,i)=dp(j,k)
9760           enddo
9761           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
9762         enddo
9763 !
9764 ! Derivatives of SC(i+1) in phi(i+2)
9765 !
9766         xx(1)= 0.0D0
9767         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
9768         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
9769         do j=1,3
9770           rj=0.0D0
9771           do k=2,3
9772             rj=rj+prod(j,k,i)*xx(k)
9773           enddo
9774           dxdv(j+3,ind1)=-rj
9775         enddo
9776 !
9777 ! Derivatives of SC(i+1) in phi(i+3).
9778 !
9779         do j=1,3
9780           dxoiij=0.0D0
9781           do k=1,3
9782             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9783           enddo
9784           dxdv(j+3,ind1+1)=dxoiij
9785         enddo
9786 !
9787 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
9788 ! theta(nres) and phi(i+3) thru phi(nres).
9789 !
9790         do j=i+1,nres-2
9791           ind1=ind1+1
9792           ind=indmat(i+1,j+1)
9793 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
9794           do k=1,3
9795             do l=1,3
9796               tempkl=0.0D0
9797               do m=1,2
9798                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
9799               enddo
9800               temp(k,l)=tempkl
9801             enddo
9802           enddo
9803 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
9804 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
9805 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
9806 ! Derivatives of virtual-bond vectors in theta
9807           do k=1,3
9808             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
9809           enddo
9810 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
9811 ! Derivatives of SC vectors in theta
9812           do k=1,3
9813             dxoijk=0.0D0
9814             do l=1,3
9815               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9816             enddo
9817             dxdv(k,ind1+1)=dxoijk
9818           enddo
9819 !
9820 !--- Calculate the derivatives in phi
9821 !
9822           do k=1,3
9823             do l=1,3
9824               tempkl=0.0D0
9825               do m=1,3
9826                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
9827               enddo
9828               temp(k,l)=tempkl
9829             enddo
9830           enddo
9831           do k=1,3
9832             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
9833           enddo
9834           do k=1,3
9835             dxoijk=0.0D0
9836             do l=1,3
9837               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9838             enddo
9839             dxdv(k+3,ind1+1)=dxoijk
9840           enddo
9841         enddo
9842       enddo
9843 !
9844 ! Derivatives in alpha and omega:
9845 !
9846       do i=2,nres-1
9847 !       dsci=dsc(itype(i))
9848         dsci=vbld(i+nres)
9849 #ifdef OSF
9850         alphi=alph(i)
9851         omegi=omeg(i)
9852         if(alphi.ne.alphi) alphi=100.0
9853         if(omegi.ne.omegi) omegi=-100.0
9854 #else
9855         alphi=alph(i)
9856         omegi=omeg(i)
9857 #endif
9858 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
9859         cosalphi=dcos(alphi)
9860         sinalphi=dsin(alphi)
9861         cosomegi=dcos(omegi)
9862         sinomegi=dsin(omegi)
9863         temp(1,1)=-dsci*sinalphi
9864         temp(2,1)= dsci*cosalphi*cosomegi
9865         temp(3,1)=-dsci*cosalphi*sinomegi
9866         temp(1,2)=0.0D0
9867         temp(2,2)=-dsci*sinalphi*sinomegi
9868         temp(3,2)=-dsci*sinalphi*cosomegi
9869         theta2=pi-0.5D0*theta(i+1)
9870         cost2=dcos(theta2)
9871         sint2=dsin(theta2)
9872         jjj=0
9873 !d      print *,((temp(l,k),l=1,3),k=1,2)
9874         do j=1,2
9875           xp=temp(1,j)
9876           yp=temp(2,j)
9877           xxp= xp*cost2+yp*sint2
9878           yyp=-xp*sint2+yp*cost2
9879           zzp=temp(3,j)
9880           xx(1)=xxp
9881           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
9882           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
9883           do k=1,3
9884             dj=0.0D0
9885             do l=1,3
9886               dj=dj+prod(k,l,i-1)*xx(l)
9887             enddo
9888             dxds(jjj+k,i)=dj
9889           enddo
9890           jjj=jjj+3
9891         enddo
9892       enddo
9893       return
9894       end subroutine cartder
9895 !-----------------------------------------------------------------------------
9896 ! checkder_p.F
9897 !-----------------------------------------------------------------------------
9898       subroutine check_cartgrad
9899 ! Check the gradient of Cartesian coordinates in internal coordinates.
9900 !      implicit real*8 (a-h,o-z)
9901 !      include 'DIMENSIONS'
9902 !      include 'COMMON.IOUNITS'
9903 !      include 'COMMON.VAR'
9904 !      include 'COMMON.CHAIN'
9905 !      include 'COMMON.GEO'
9906 !      include 'COMMON.LOCAL'
9907 !      include 'COMMON.DERIV'
9908       real(kind=8),dimension(6,nres) :: temp
9909       real(kind=8),dimension(3) :: xx,gg
9910       integer :: i,k,j,ii
9911       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
9912 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9913 !
9914 ! Check the gradient of the virtual-bond and SC vectors in the internal
9915 ! coordinates.
9916 !
9917       aincr=1.0d-7
9918       aincr2=5.0d-8
9919       call cartder
9920       write (iout,'(a)') '**************** dx/dalpha'
9921       write (iout,'(a)')
9922       do i=2,nres-1
9923         alphi=alph(i)
9924         alph(i)=alph(i)+aincr
9925         do k=1,3
9926           temp(k,i)=dc(k,nres+i)
9927         enddo
9928         call chainbuild
9929         do k=1,3
9930           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
9931           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
9932         enddo
9933         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
9934         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
9935         write (iout,'(a)')
9936         alph(i)=alphi
9937         call chainbuild
9938       enddo
9939       write (iout,'(a)')
9940       write (iout,'(a)') '**************** dx/domega'
9941       write (iout,'(a)')
9942       do i=2,nres-1
9943         omegi=omeg(i)
9944         omeg(i)=omeg(i)+aincr
9945         do k=1,3
9946           temp(k,i)=dc(k,nres+i)
9947         enddo
9948         call chainbuild
9949         do k=1,3
9950           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
9951           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
9952                 (aincr*dabs(dxds(k+3,i))+aincr))
9953         enddo
9954         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
9955             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
9956         write (iout,'(a)')
9957         omeg(i)=omegi
9958         call chainbuild
9959       enddo
9960       write (iout,'(a)')
9961       write (iout,'(a)') '**************** dx/dtheta'
9962       write (iout,'(a)')
9963       do i=3,nres
9964         theti=theta(i)
9965         theta(i)=theta(i)+aincr
9966         do j=i-1,nres-1
9967           do k=1,3
9968             temp(k,j)=dc(k,nres+j)
9969           enddo
9970         enddo
9971         call chainbuild
9972         do j=i-1,nres-1
9973           ii = indmat(i-2,j)
9974 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
9975           do k=1,3
9976             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
9977             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
9978                   (aincr*dabs(dxdv(k,ii))+aincr))
9979           enddo
9980           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
9981               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
9982           write(iout,'(a)')
9983         enddo
9984         write (iout,'(a)')
9985         theta(i)=theti
9986         call chainbuild
9987       enddo
9988       write (iout,'(a)') '***************** dx/dphi'
9989       write (iout,'(a)')
9990       do i=4,nres
9991         phi(i)=phi(i)+aincr
9992         do j=i-1,nres-1
9993           do k=1,3
9994             temp(k,j)=dc(k,nres+j)
9995           enddo
9996         enddo
9997         call chainbuild
9998         do j=i-1,nres-1
9999           ii = indmat(i-2,j)
10000 !         print *,'ii=',ii
10001           do k=1,3
10002             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10003             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10004                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10005           enddo
10006           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10007               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10008           write(iout,'(a)')
10009         enddo
10010         phi(i)=phi(i)-aincr
10011         call chainbuild
10012       enddo
10013       write (iout,'(a)') '****************** ddc/dtheta'
10014       do i=1,nres-2
10015         thet=theta(i+2)
10016         theta(i+2)=thet+aincr
10017         do j=i,nres
10018           do k=1,3
10019             temp(k,j)=dc(k,j)
10020           enddo
10021         enddo
10022         call chainbuild
10023         do j=i+1,nres-1
10024           ii = indmat(i,j)
10025 !         print *,'ii=',ii
10026           do k=1,3
10027             gg(k)=(dc(k,j)-temp(k,j))/aincr
10028             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10029                  (aincr*dabs(dcdv(k,ii))+aincr))
10030           enddo
10031           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10032                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10033           write (iout,'(a)')
10034         enddo
10035         do j=1,nres
10036           do k=1,3
10037             dc(k,j)=temp(k,j)
10038           enddo
10039         enddo
10040         theta(i+2)=thet
10041       enddo
10042       write (iout,'(a)') '******************* ddc/dphi'
10043       do i=1,nres-3
10044         phii=phi(i+3)
10045         phi(i+3)=phii+aincr
10046         do j=1,nres
10047           do k=1,3
10048             temp(k,j)=dc(k,j)
10049           enddo
10050         enddo
10051         call chainbuild
10052         do j=i+2,nres-1
10053           ii = indmat(i+1,j)
10054 !         print *,'ii=',ii
10055           do k=1,3
10056             gg(k)=(dc(k,j)-temp(k,j))/aincr
10057             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10058                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10059           enddo
10060           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10061                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10062           write (iout,'(a)')
10063         enddo
10064         do j=1,nres
10065           do k=1,3
10066             dc(k,j)=temp(k,j)
10067           enddo
10068         enddo
10069         phi(i+3)=phii
10070       enddo
10071       return
10072       end subroutine check_cartgrad
10073 !-----------------------------------------------------------------------------
10074       subroutine check_ecart
10075 ! Check the gradient of the energy in Cartesian coordinates.
10076 !     implicit real*8 (a-h,o-z)
10077 !     include 'DIMENSIONS'
10078 !     include 'COMMON.CHAIN'
10079 !     include 'COMMON.DERIV'
10080 !     include 'COMMON.IOUNITS'
10081 !     include 'COMMON.VAR'
10082 !     include 'COMMON.CONTACTS'
10083       use comm_srutu
10084 !el      integer :: icall
10085 !el      common /srutu/ icall
10086       real(kind=8),dimension(6) :: ggg
10087       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10088       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10089       real(kind=8),dimension(6,nres) :: grad_s
10090       real(kind=8),dimension(0:n_ene) :: energia,energia1
10091       integer :: uiparm(1)
10092       real(kind=8) :: urparm(1)
10093 !EL      external fdum
10094       integer :: nf,i,j,k
10095       real(kind=8) :: aincr,etot,etot1
10096       icg=1
10097       nf=0
10098       nfl=0
10099       call zerograd
10100       aincr=1.0D-7
10101       print '(a)','CG processor',me,' calling CHECK_CART.'
10102       nf=0
10103       icall=0
10104       call geom_to_var(nvar,x)
10105       call etotal(energia)
10106       etot=energia(0)
10107 !el      call enerprint(energia)
10108       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10109       icall =1
10110       do i=1,nres
10111         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10112       enddo
10113       do i=1,nres
10114         do j=1,3
10115           grad_s(j,i)=gradc(j,i,icg)
10116           grad_s(j+3,i)=gradx(j,i,icg)
10117         enddo
10118       enddo
10119       call flush(iout)
10120       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10121       do i=1,nres
10122         do j=1,3
10123           xx(j)=c(j,i+nres)
10124           ddc(j)=dc(j,i)
10125           ddx(j)=dc(j,i+nres)
10126         enddo
10127         do j=1,3
10128           dc(j,i)=dc(j,i)+aincr
10129           do k=i+1,nres
10130             c(j,k)=c(j,k)+aincr
10131             c(j,k+nres)=c(j,k+nres)+aincr
10132           enddo
10133           call etotal(energia1)
10134           etot1=energia1(0)
10135           ggg(j)=(etot1-etot)/aincr
10136           dc(j,i)=ddc(j)
10137           do k=i+1,nres
10138             c(j,k)=c(j,k)-aincr
10139             c(j,k+nres)=c(j,k+nres)-aincr
10140           enddo
10141         enddo
10142         do j=1,3
10143           c(j,i+nres)=c(j,i+nres)+aincr
10144           dc(j,i+nres)=dc(j,i+nres)+aincr
10145           call etotal(energia1)
10146           etot1=energia1(0)
10147           ggg(j+3)=(etot1-etot)/aincr
10148           c(j,i+nres)=xx(j)
10149           dc(j,i+nres)=ddx(j)
10150         enddo
10151         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10152          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10153       enddo
10154       return
10155       end subroutine check_ecart
10156 !-----------------------------------------------------------------------------
10157       subroutine check_ecartint
10158 ! Check the gradient of the energy in Cartesian coordinates.
10159       use io_base, only: intout
10160 !      implicit real*8 (a-h,o-z)
10161 !      include 'DIMENSIONS'
10162 !      include 'COMMON.CONTROL'
10163 !      include 'COMMON.CHAIN'
10164 !      include 'COMMON.DERIV'
10165 !      include 'COMMON.IOUNITS'
10166 !      include 'COMMON.VAR'
10167 !      include 'COMMON.CONTACTS'
10168 !      include 'COMMON.MD'
10169 !      include 'COMMON.LOCAL'
10170 !      include 'COMMON.SPLITELE'
10171       use comm_srutu
10172 !el      integer :: icall
10173 !el      common /srutu/ icall
10174       real(kind=8),dimension(6) :: ggg,ggg1
10175       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10176       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10177       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10178       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10179       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10180       real(kind=8),dimension(0:n_ene) :: energia,energia1
10181       integer :: uiparm(1)
10182       real(kind=8) :: urparm(1)
10183 !EL      external fdum
10184       integer :: i,j,k,nf
10185       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10186                    etot21,etot22
10187       r_cut=2.0d0
10188       rlambd=0.3d0
10189       icg=1
10190       nf=0
10191       nfl=0
10192       call intout
10193 !      call intcartderiv
10194 !      call checkintcartgrad
10195       call zerograd
10196       aincr=1.0D-5
10197       write(iout,*) 'Calling CHECK_ECARTINT.'
10198       nf=0
10199       icall=0
10200       call geom_to_var(nvar,x)
10201       if (.not.split_ene) then
10202 write(iout,*) 'Calling CHECK_ECARTINT if'
10203         call etotal(energia)
10204 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10205         etot=energia(0)
10206 !el        call enerprint(energia)
10207 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10208         call flush(iout)
10209         write (iout,*) "enter cartgrad"
10210         call flush(iout)
10211         call cartgrad
10212 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10213         write (iout,*) "exit cartgrad"
10214         call flush(iout)
10215         icall =1
10216         do i=1,nres
10217           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10218         enddo
10219         do j=1,3
10220           grad_s(j,0)=gcart(j,0)
10221         enddo
10222 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10223         do i=1,nres
10224           do j=1,3
10225             grad_s(j,i)=gcart(j,i)
10226             grad_s(j+3,i)=gxcart(j,i)
10227           enddo
10228         enddo
10229       else
10230 write(iout,*) 'Calling CHECK_ECARTIN else.'
10231 !- split gradient check
10232         call zerograd
10233         call etotal_long(energia)
10234 !el        call enerprint(energia)
10235         call flush(iout)
10236         write (iout,*) "enter cartgrad"
10237         call flush(iout)
10238         call cartgrad
10239         write (iout,*) "exit cartgrad"
10240         call flush(iout)
10241         icall =1
10242         write (iout,*) "longrange grad"
10243         do i=1,nres
10244           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10245           (gxcart(j,i),j=1,3)
10246         enddo
10247         do j=1,3
10248           grad_s(j,0)=gcart(j,0)
10249         enddo
10250         do i=1,nres
10251           do j=1,3
10252             grad_s(j,i)=gcart(j,i)
10253             grad_s(j+3,i)=gxcart(j,i)
10254           enddo
10255         enddo
10256         call zerograd
10257         call etotal_short(energia)
10258 !el        call enerprint(energia)
10259         call flush(iout)
10260         write (iout,*) "enter cartgrad"
10261         call flush(iout)
10262         call cartgrad
10263         write (iout,*) "exit cartgrad"
10264         call flush(iout)
10265         icall =1
10266         write (iout,*) "shortrange grad"
10267         do i=1,nres
10268           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10269           (gxcart(j,i),j=1,3)
10270         enddo
10271         do j=1,3
10272           grad_s1(j,0)=gcart(j,0)
10273         enddo
10274         do i=1,nres
10275           do j=1,3
10276             grad_s1(j,i)=gcart(j,i)
10277             grad_s1(j+3,i)=gxcart(j,i)
10278           enddo
10279         enddo
10280       endif
10281       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10282       do i=0,nres
10283         do j=1,3
10284           xx(j)=c(j,i+nres)
10285           ddc(j)=dc(j,i)
10286           ddx(j)=dc(j,i+nres)
10287           do k=1,3
10288             dcnorm_safe(k)=dc_norm(k,i)
10289             dxnorm_safe(k)=dc_norm(k,i+nres)
10290           enddo
10291         enddo
10292         do j=1,3
10293           dc(j,i)=ddc(j)+aincr
10294           call chainbuild_cart
10295 #ifdef MPI
10296 ! Broadcast the order to compute internal coordinates to the slaves.
10297 !          if (nfgtasks.gt.1)
10298 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10299 #endif
10300 !          call int_from_cart1(.false.)
10301           if (.not.split_ene) then
10302             call etotal(energia1)
10303             etot1=energia1(0)
10304           else
10305 !- split gradient
10306             call etotal_long(energia1)
10307             etot11=energia1(0)
10308             call etotal_short(energia1)
10309             etot12=energia1(0)
10310 !            write (iout,*) "etot11",etot11," etot12",etot12
10311           endif
10312 !- end split gradient
10313 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10314           dc(j,i)=ddc(j)-aincr
10315           call chainbuild_cart
10316 !          call int_from_cart1(.false.)
10317           if (.not.split_ene) then
10318             call etotal(energia1)
10319             etot2=energia1(0)
10320             ggg(j)=(etot1-etot2)/(2*aincr)
10321           else
10322 !- split gradient
10323             call etotal_long(energia1)
10324             etot21=energia1(0)
10325             ggg(j)=(etot11-etot21)/(2*aincr)
10326             call etotal_short(energia1)
10327             etot22=energia1(0)
10328             ggg1(j)=(etot12-etot22)/(2*aincr)
10329 !- end split gradient
10330 !            write (iout,*) "etot21",etot21," etot22",etot22
10331           endif
10332 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10333           dc(j,i)=ddc(j)
10334           call chainbuild_cart
10335         enddo
10336         do j=1,3
10337           dc(j,i+nres)=ddx(j)+aincr
10338           call chainbuild_cart
10339 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10340 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10341 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10342 !          write (iout,*) "dxnormnorm",dsqrt(
10343 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10344 !          write (iout,*) "dxnormnormsafe",dsqrt(
10345 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10346 !          write (iout,*)
10347           if (.not.split_ene) then
10348             call etotal(energia1)
10349             etot1=energia1(0)
10350           else
10351 !- split gradient
10352             call etotal_long(energia1)
10353             etot11=energia1(0)
10354             call etotal_short(energia1)
10355             etot12=energia1(0)
10356           endif
10357 !- end split gradient
10358 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10359           dc(j,i+nres)=ddx(j)-aincr
10360           call chainbuild_cart
10361 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10362 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10363 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10364 !          write (iout,*)
10365 !          write (iout,*) "dxnormnorm",dsqrt(
10366 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10367 !          write (iout,*) "dxnormnormsafe",dsqrt(
10368 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10369           if (.not.split_ene) then
10370             call etotal(energia1)
10371             etot2=energia1(0)
10372             ggg(j+3)=(etot1-etot2)/(2*aincr)
10373           else
10374 !- split gradient
10375             call etotal_long(energia1)
10376             etot21=energia1(0)
10377             ggg(j+3)=(etot11-etot21)/(2*aincr)
10378             call etotal_short(energia1)
10379             etot22=energia1(0)
10380             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10381 !- end split gradient
10382           endif
10383 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10384           dc(j,i+nres)=ddx(j)
10385           call chainbuild_cart
10386         enddo
10387         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10388          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10389         if (split_ene) then
10390           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10391          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10392          k=1,6)
10393          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10394          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10395          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10396         endif
10397       enddo
10398       return
10399       end subroutine check_ecartint
10400 !-----------------------------------------------------------------------------
10401       subroutine check_eint
10402 ! Check the gradient of energy in internal coordinates.
10403 !      implicit real*8 (a-h,o-z)
10404 !      include 'DIMENSIONS'
10405 !      include 'COMMON.CHAIN'
10406 !      include 'COMMON.DERIV'
10407 !      include 'COMMON.IOUNITS'
10408 !      include 'COMMON.VAR'
10409 !      include 'COMMON.GEO'
10410       use comm_srutu
10411 !el      integer :: icall
10412 !el      common /srutu/ icall
10413       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10414       integer :: uiparm(1)
10415       real(kind=8) :: urparm(1)
10416       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10417       character(len=6) :: key
10418 !EL      external fdum
10419       integer :: i,ii,nf
10420       real(kind=8) :: xi,aincr,etot,etot1,etot2
10421       call zerograd
10422       aincr=1.0D-7
10423       print '(a)','Calling CHECK_INT.'
10424 write(iout,*) 'Calling CHECK_INT.'
10425       nf=0
10426       nfl=0
10427       icg=1
10428       call geom_to_var(nvar,x)
10429       call var_to_geom(nvar,x)
10430       call chainbuild
10431 write(iout,*) 'Calling CHECK_INT.'
10432       icall=1
10433       print *,'ICG=',ICG
10434       call etotal(energia)
10435       etot = energia(0)
10436 !el      call enerprint(energia)
10437       print *,'ICG=',ICG
10438 #ifdef MPL
10439       if (MyID.ne.BossID) then
10440         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10441         nf=x(nvar+1)
10442         nfl=x(nvar+2)
10443         icg=x(nvar+3)
10444       endif
10445 #endif
10446       nf=1
10447       nfl=3
10448 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10449       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10450     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10451       icall=1
10452       do i=1,nvar
10453         xi=x(i)
10454         x(i)=xi-0.5D0*aincr
10455         call var_to_geom(nvar,x)
10456         call chainbuild
10457         call etotal(energia1)
10458         etot1=energia1(0)
10459         x(i)=xi+0.5D0*aincr
10460         call var_to_geom(nvar,x)
10461         call chainbuild
10462         call etotal(energia2)
10463         etot2=energia2(0)
10464         gg(i)=(etot2-etot1)/aincr
10465         write (iout,*) i,etot1,etot2
10466         x(i)=xi
10467       enddo
10468       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10469           '     RelDiff*100% '
10470       do i=1,nvar
10471         if (i.le.nphi) then
10472           ii=i
10473           key = ' phi'
10474         else if (i.le.nphi+ntheta) then
10475           ii=i-nphi
10476           key=' theta'
10477         else if (i.le.nphi+ntheta+nside) then
10478            ii=i-(nphi+ntheta)
10479            key=' alpha'
10480         else
10481            ii=i-(nphi+ntheta+nside)
10482            key=' omega'
10483         endif
10484         write (iout,'(i3,a,i3,3(1pd16.6))') &
10485        i,key,ii,gg(i),gana(i),&
10486        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10487       enddo
10488 write(iout,*) "jestesmy sobie w check eint!!"
10489       return
10490       end subroutine check_eint
10491 !-----------------------------------------------------------------------------
10492 ! econstr_local.F
10493 !-----------------------------------------------------------------------------
10494       subroutine Econstr_back
10495 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
10496 !      implicit real*8 (a-h,o-z)
10497 !      include 'DIMENSIONS'
10498 !      include 'COMMON.CONTROL'
10499 !      include 'COMMON.VAR'
10500 !      include 'COMMON.MD'
10501       use MD_data
10502 !#ifndef LANG0
10503 !      include 'COMMON.LANGEVIN'
10504 !#else
10505 !      include 'COMMON.LANGEVIN.lang0'
10506 !#endif
10507 !      include 'COMMON.CHAIN'
10508 !      include 'COMMON.DERIV'
10509 !      include 'COMMON.GEO'
10510 !      include 'COMMON.LOCAL'
10511 !      include 'COMMON.INTERACT'
10512 !      include 'COMMON.IOUNITS'
10513 !      include 'COMMON.NAMES'
10514 !      include 'COMMON.TIME1'
10515       integer :: i,j,ii,k
10516       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
10517
10518       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
10519       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
10520       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
10521
10522       Uconst_back=0.0d0
10523       do i=1,nres
10524         dutheta(i)=0.0d0
10525         dugamma(i)=0.0d0
10526         do j=1,3
10527           duscdiff(j,i)=0.0d0
10528           duscdiffx(j,i)=0.0d0
10529         enddo
10530       enddo
10531       do i=1,nfrag_back
10532         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10533 !
10534 ! Deviations from theta angles
10535 !
10536         utheta_i=0.0d0
10537         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
10538           dtheta_i=theta(j)-thetaref(j)
10539           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
10540           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10541         enddo
10542         utheta(i)=utheta_i/(ii-1)
10543 !
10544 ! Deviations from gamma angles
10545 !
10546         ugamma_i=0.0d0
10547         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
10548           dgamma_i=pinorm(phi(j)-phiref(j))
10549 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
10550           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
10551           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
10552 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
10553         enddo
10554         ugamma(i)=ugamma_i/(ii-2)
10555 !
10556 ! Deviations from local SC geometry
10557 !
10558         uscdiff(i)=0.0d0
10559         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
10560           dxx=xxtab(j)-xxref(j)
10561           dyy=yytab(j)-yyref(j)
10562           dzz=zztab(j)-zzref(j)
10563           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
10564           do k=1,3
10565             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
10566              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
10567              (ii-1)
10568             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
10569              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
10570              (ii-1)
10571             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
10572            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
10573             /(ii-1)
10574           enddo
10575 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10576 !     &      xxref(j),yyref(j),zzref(j)
10577         enddo
10578         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
10579 !        write (iout,*) i," uscdiff",uscdiff(i)
10580 !
10581 ! Put together deviations from local geometry
10582 !
10583         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
10584           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
10585 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
10586 !     &   " uconst_back",uconst_back
10587         utheta(i)=dsqrt(utheta(i))
10588         ugamma(i)=dsqrt(ugamma(i))
10589         uscdiff(i)=dsqrt(uscdiff(i))
10590       enddo
10591       return
10592       end subroutine Econstr_back
10593 !-----------------------------------------------------------------------------
10594 ! energy_p_new-sep_barrier.F
10595 !-----------------------------------------------------------------------------
10596       real(kind=8) function sscale(r)
10597 !      include "COMMON.SPLITELE"
10598       real(kind=8) :: r,gamm
10599       if(r.lt.r_cut-rlamb) then
10600         sscale=1.0d0
10601       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10602         gamm=(r-(r_cut-rlamb))/rlamb
10603         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10604       else
10605         sscale=0d0
10606       endif
10607       return
10608       end function sscale
10609 !-----------------------------------------------------------------------------
10610       subroutine elj_long(evdw)
10611 !
10612 ! This subroutine calculates the interaction energy of nonbonded side chains
10613 ! assuming the LJ potential of interaction.
10614 !
10615 !      implicit real*8 (a-h,o-z)
10616 !      include 'DIMENSIONS'
10617 !      include 'COMMON.GEO'
10618 !      include 'COMMON.VAR'
10619 !      include 'COMMON.LOCAL'
10620 !      include 'COMMON.CHAIN'
10621 !      include 'COMMON.DERIV'
10622 !      include 'COMMON.INTERACT'
10623 !      include 'COMMON.TORSION'
10624 !      include 'COMMON.SBRIDGE'
10625 !      include 'COMMON.NAMES'
10626 !      include 'COMMON.IOUNITS'
10627 !      include 'COMMON.CONTACTS'
10628       real(kind=8),parameter :: accur=1.0d-10
10629       real(kind=8),dimension(3) :: gg
10630 !el local variables
10631       integer :: i,iint,j,k,itypi,itypi1,itypj
10632       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
10633       real(kind=8) :: e1,e2,evdwij,evdw
10634 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
10635       evdw=0.0D0
10636       do i=iatsc_s,iatsc_e
10637         itypi=itype(i)
10638         if (itypi.eq.ntyp1) cycle
10639         itypi1=itype(i+1)
10640         xi=c(1,nres+i)
10641         yi=c(2,nres+i)
10642         zi=c(3,nres+i)
10643 !
10644 ! Calculate SC interaction energy.
10645 !
10646         do iint=1,nint_gr(i)
10647 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
10648 !d   &                  'iend=',iend(i,iint)
10649           do j=istart(i,iint),iend(i,iint)
10650             itypj=itype(j)
10651             if (itypj.eq.ntyp1) cycle
10652             xj=c(1,nres+j)-xi
10653             yj=c(2,nres+j)-yi
10654             zj=c(3,nres+j)-zi
10655             rij=xj*xj+yj*yj+zj*zj
10656             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
10657             if (sss.lt.1.0d0) then
10658               rrij=1.0D0/rij
10659               eps0ij=eps(itypi,itypj)
10660               fac=rrij**expon2
10661               e1=fac*fac*aa(itypi,itypj)
10662               e2=fac*bb(itypi,itypj)
10663               evdwij=e1+e2
10664               evdw=evdw+(1.0d0-sss)*evdwij
10665 !
10666 ! Calculate the components of the gradient in DC and X
10667 !
10668               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
10669               gg(1)=xj*fac
10670               gg(2)=yj*fac
10671               gg(3)=zj*fac
10672               do k=1,3
10673                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10674                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10675                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10676                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10677               enddo
10678             endif
10679           enddo      ! j
10680         enddo        ! iint
10681       enddo          ! i
10682       do i=1,nct
10683         do j=1,3
10684           gvdwc(j,i)=expon*gvdwc(j,i)
10685           gvdwx(j,i)=expon*gvdwx(j,i)
10686         enddo
10687       enddo
10688 !******************************************************************************
10689 !
10690 !                              N O T E !!!
10691 !
10692 ! To save time, the factor of EXPON has been extracted from ALL components
10693 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
10694 ! use!
10695 !
10696 !******************************************************************************
10697       return
10698       end subroutine elj_long
10699 !-----------------------------------------------------------------------------
10700       subroutine elj_short(evdw)
10701 !
10702 ! This subroutine calculates the interaction energy of nonbonded side chains
10703 ! assuming the LJ potential of interaction.
10704 !
10705 !      implicit real*8 (a-h,o-z)
10706 !      include 'DIMENSIONS'
10707 !      include 'COMMON.GEO'
10708 !      include 'COMMON.VAR'
10709 !      include 'COMMON.LOCAL'
10710 !      include 'COMMON.CHAIN'
10711 !      include 'COMMON.DERIV'
10712 !      include 'COMMON.INTERACT'
10713 !      include 'COMMON.TORSION'
10714 !      include 'COMMON.SBRIDGE'
10715 !      include 'COMMON.NAMES'
10716 !      include 'COMMON.IOUNITS'
10717 !      include 'COMMON.CONTACTS'
10718       real(kind=8),parameter :: accur=1.0d-10
10719       real(kind=8),dimension(3) :: gg
10720 !el local variables
10721       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
10722       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
10723       real(kind=8) :: e1,e2,evdwij,evdw
10724 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
10725       evdw=0.0D0
10726       do i=iatsc_s,iatsc_e
10727         itypi=itype(i)
10728         if (itypi.eq.ntyp1) cycle
10729         itypi1=itype(i+1)
10730         xi=c(1,nres+i)
10731         yi=c(2,nres+i)
10732         zi=c(3,nres+i)
10733 ! Change 12/1/95
10734         num_conti=0
10735 !
10736 ! Calculate SC interaction energy.
10737 !
10738         do iint=1,nint_gr(i)
10739 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
10740 !d   &                  'iend=',iend(i,iint)
10741           do j=istart(i,iint),iend(i,iint)
10742             itypj=itype(j)
10743             if (itypj.eq.ntyp1) cycle
10744             xj=c(1,nres+j)-xi
10745             yj=c(2,nres+j)-yi
10746             zj=c(3,nres+j)-zi
10747 ! Change 12/1/95 to calculate four-body interactions
10748             rij=xj*xj+yj*yj+zj*zj
10749             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
10750             if (sss.gt.0.0d0) then
10751               rrij=1.0D0/rij
10752               eps0ij=eps(itypi,itypj)
10753               fac=rrij**expon2
10754               e1=fac*fac*aa(itypi,itypj)
10755               e2=fac*bb(itypi,itypj)
10756               evdwij=e1+e2
10757               evdw=evdw+sss*evdwij
10758 !
10759 ! Calculate the components of the gradient in DC and X
10760 !
10761               fac=-rrij*(e1+evdwij)*sss
10762               gg(1)=xj*fac
10763               gg(2)=yj*fac
10764               gg(3)=zj*fac
10765               do k=1,3
10766                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10767                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10768                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10769                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10770               enddo
10771             endif
10772           enddo      ! j
10773         enddo        ! iint
10774       enddo          ! i
10775       do i=1,nct
10776         do j=1,3
10777           gvdwc(j,i)=expon*gvdwc(j,i)
10778           gvdwx(j,i)=expon*gvdwx(j,i)
10779         enddo
10780       enddo
10781 !******************************************************************************
10782 !
10783 !                              N O T E !!!
10784 !
10785 ! To save time, the factor of EXPON has been extracted from ALL components
10786 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
10787 ! use!
10788 !
10789 !******************************************************************************
10790       return
10791       end subroutine elj_short
10792 !-----------------------------------------------------------------------------
10793       subroutine eljk_long(evdw)
10794 !
10795 ! This subroutine calculates the interaction energy of nonbonded side chains
10796 ! assuming the LJK potential of interaction.
10797 !
10798 !      implicit real*8 (a-h,o-z)
10799 !      include 'DIMENSIONS'
10800 !      include 'COMMON.GEO'
10801 !      include 'COMMON.VAR'
10802 !      include 'COMMON.LOCAL'
10803 !      include 'COMMON.CHAIN'
10804 !      include 'COMMON.DERIV'
10805 !      include 'COMMON.INTERACT'
10806 !      include 'COMMON.IOUNITS'
10807 !      include 'COMMON.NAMES'
10808       real(kind=8),dimension(3) :: gg
10809       logical :: scheck
10810 !el local variables
10811       integer :: i,iint,j,k,itypi,itypi1,itypj
10812       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
10813                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
10814 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
10815       evdw=0.0D0
10816       do i=iatsc_s,iatsc_e
10817         itypi=itype(i)
10818         if (itypi.eq.ntyp1) cycle
10819         itypi1=itype(i+1)
10820         xi=c(1,nres+i)
10821         yi=c(2,nres+i)
10822         zi=c(3,nres+i)
10823 !
10824 ! Calculate SC interaction energy.
10825 !
10826         do iint=1,nint_gr(i)
10827           do j=istart(i,iint),iend(i,iint)
10828             itypj=itype(j)
10829             if (itypj.eq.ntyp1) cycle
10830             xj=c(1,nres+j)-xi
10831             yj=c(2,nres+j)-yi
10832             zj=c(3,nres+j)-zi
10833             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
10834             fac_augm=rrij**expon
10835             e_augm=augm(itypi,itypj)*fac_augm
10836             r_inv_ij=dsqrt(rrij)
10837             rij=1.0D0/r_inv_ij
10838             sss=sscale(rij/sigma(itypi,itypj))
10839             if (sss.lt.1.0d0) then
10840               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
10841               fac=r_shift_inv**expon
10842               e1=fac*fac*aa(itypi,itypj)
10843               e2=fac*bb(itypi,itypj)
10844               evdwij=e_augm+e1+e2
10845 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
10846 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
10847 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
10848 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
10849 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
10850 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
10851 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
10852               evdw=evdw+(1.0d0-sss)*evdwij
10853 !
10854 ! Calculate the components of the gradient in DC and X
10855 !
10856               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
10857               fac=fac*(1.0d0-sss)
10858               gg(1)=xj*fac
10859               gg(2)=yj*fac
10860               gg(3)=zj*fac
10861               do k=1,3
10862                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10863                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10864                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10865                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10866               enddo
10867             endif
10868           enddo      ! j
10869         enddo        ! iint
10870       enddo          ! i
10871       do i=1,nct
10872         do j=1,3
10873           gvdwc(j,i)=expon*gvdwc(j,i)
10874           gvdwx(j,i)=expon*gvdwx(j,i)
10875         enddo
10876       enddo
10877       return
10878       end subroutine eljk_long
10879 !-----------------------------------------------------------------------------
10880       subroutine eljk_short(evdw)
10881 !
10882 ! This subroutine calculates the interaction energy of nonbonded side chains
10883 ! assuming the LJK potential of interaction.
10884 !
10885 !      implicit real*8 (a-h,o-z)
10886 !      include 'DIMENSIONS'
10887 !      include 'COMMON.GEO'
10888 !      include 'COMMON.VAR'
10889 !      include 'COMMON.LOCAL'
10890 !      include 'COMMON.CHAIN'
10891 !      include 'COMMON.DERIV'
10892 !      include 'COMMON.INTERACT'
10893 !      include 'COMMON.IOUNITS'
10894 !      include 'COMMON.NAMES'
10895       real(kind=8),dimension(3) :: gg
10896       logical :: scheck
10897 !el local variables
10898       integer :: i,iint,j,k,itypi,itypi1,itypj
10899       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
10900                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
10901 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
10902       evdw=0.0D0
10903       do i=iatsc_s,iatsc_e
10904         itypi=itype(i)
10905         if (itypi.eq.ntyp1) cycle
10906         itypi1=itype(i+1)
10907         xi=c(1,nres+i)
10908         yi=c(2,nres+i)
10909         zi=c(3,nres+i)
10910 !
10911 ! Calculate SC interaction energy.
10912 !
10913         do iint=1,nint_gr(i)
10914           do j=istart(i,iint),iend(i,iint)
10915             itypj=itype(j)
10916             if (itypj.eq.ntyp1) cycle
10917             xj=c(1,nres+j)-xi
10918             yj=c(2,nres+j)-yi
10919             zj=c(3,nres+j)-zi
10920             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
10921             fac_augm=rrij**expon
10922             e_augm=augm(itypi,itypj)*fac_augm
10923             r_inv_ij=dsqrt(rrij)
10924             rij=1.0D0/r_inv_ij
10925             sss=sscale(rij/sigma(itypi,itypj))
10926             if (sss.gt.0.0d0) then
10927               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
10928               fac=r_shift_inv**expon
10929               e1=fac*fac*aa(itypi,itypj)
10930               e2=fac*bb(itypi,itypj)
10931               evdwij=e_augm+e1+e2
10932 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
10933 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
10934 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
10935 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
10936 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
10937 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
10938 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
10939               evdw=evdw+sss*evdwij
10940 !
10941 ! Calculate the components of the gradient in DC and X
10942 !
10943               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
10944               fac=fac*sss
10945               gg(1)=xj*fac
10946               gg(2)=yj*fac
10947               gg(3)=zj*fac
10948               do k=1,3
10949                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
10950                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
10951                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
10952                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
10953               enddo
10954             endif
10955           enddo      ! j
10956         enddo        ! iint
10957       enddo          ! i
10958       do i=1,nct
10959         do j=1,3
10960           gvdwc(j,i)=expon*gvdwc(j,i)
10961           gvdwx(j,i)=expon*gvdwx(j,i)
10962         enddo
10963       enddo
10964       return
10965       end subroutine eljk_short
10966 !-----------------------------------------------------------------------------
10967       subroutine ebp_long(evdw)
10968 !
10969 ! This subroutine calculates the interaction energy of nonbonded side chains
10970 ! assuming the Berne-Pechukas potential of interaction.
10971 !
10972       use calc_data
10973 !      implicit real*8 (a-h,o-z)
10974 !      include 'DIMENSIONS'
10975 !      include 'COMMON.GEO'
10976 !      include 'COMMON.VAR'
10977 !      include 'COMMON.LOCAL'
10978 !      include 'COMMON.CHAIN'
10979 !      include 'COMMON.DERIV'
10980 !      include 'COMMON.NAMES'
10981 !      include 'COMMON.INTERACT'
10982 !      include 'COMMON.IOUNITS'
10983 !      include 'COMMON.CALC'
10984       use comm_srutu
10985 !el      integer :: icall
10986 !el      common /srutu/ icall
10987 !     double precision rrsave(maxdim)
10988       logical :: lprn
10989 !el local variables
10990       integer :: iint,itypi,itypi1,itypj
10991       real(kind=8) :: rrij,xi,yi,zi,fac
10992       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
10993       evdw=0.0D0
10994 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
10995       evdw=0.0D0
10996 !     if (icall.eq.0) then
10997 !       lprn=.true.
10998 !     else
10999         lprn=.false.
11000 !     endif
11001 !el      ind=0
11002       do i=iatsc_s,iatsc_e
11003         itypi=itype(i)
11004         if (itypi.eq.ntyp1) cycle
11005         itypi1=itype(i+1)
11006         xi=c(1,nres+i)
11007         yi=c(2,nres+i)
11008         zi=c(3,nres+i)
11009         dxi=dc_norm(1,nres+i)
11010         dyi=dc_norm(2,nres+i)
11011         dzi=dc_norm(3,nres+i)
11012 !        dsci_inv=dsc_inv(itypi)
11013         dsci_inv=vbld_inv(i+nres)
11014 !
11015 ! Calculate SC interaction energy.
11016 !
11017         do iint=1,nint_gr(i)
11018           do j=istart(i,iint),iend(i,iint)
11019 !el            ind=ind+1
11020             itypj=itype(j)
11021             if (itypj.eq.ntyp1) cycle
11022 !            dscj_inv=dsc_inv(itypj)
11023             dscj_inv=vbld_inv(j+nres)
11024             chi1=chi(itypi,itypj)
11025             chi2=chi(itypj,itypi)
11026             chi12=chi1*chi2
11027             chip1=chip(itypi)
11028             chip2=chip(itypj)
11029             chip12=chip1*chip2
11030             alf1=alp(itypi)
11031             alf2=alp(itypj)
11032             alf12=0.5D0*(alf1+alf2)
11033             xj=c(1,nres+j)-xi
11034             yj=c(2,nres+j)-yi
11035             zj=c(3,nres+j)-zi
11036             dxj=dc_norm(1,nres+j)
11037             dyj=dc_norm(2,nres+j)
11038             dzj=dc_norm(3,nres+j)
11039             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11040             rij=dsqrt(rrij)
11041             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11042
11043             if (sss.lt.1.0d0) then
11044
11045 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11046               call sc_angular
11047 ! Calculate whole angle-dependent part of epsilon and contributions
11048 ! to its derivatives
11049               fac=(rrij*sigsq)**expon2
11050               e1=fac*fac*aa(itypi,itypj)
11051               e2=fac*bb(itypi,itypj)
11052               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11053               eps2der=evdwij*eps3rt
11054               eps3der=evdwij*eps2rt
11055               evdwij=evdwij*eps2rt*eps3rt
11056               evdw=evdw+evdwij*(1.0d0-sss)
11057               if (lprn) then
11058               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11059               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11060 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11061 !d     &          restyp(itypi),i,restyp(itypj),j,
11062 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11063 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11064 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11065 !d     &          evdwij
11066               endif
11067 ! Calculate gradient components.
11068               e1=e1*eps1*eps2rt**2*eps3rt**2
11069               fac=-expon*(e1+evdwij)
11070               sigder=fac/sigsq
11071               fac=rrij*fac
11072 ! Calculate radial part of the gradient
11073               gg(1)=xj*fac
11074               gg(2)=yj*fac
11075               gg(3)=zj*fac
11076 ! Calculate the angular part of the gradient and sum add the contributions
11077 ! to the appropriate components of the Cartesian gradient.
11078               call sc_grad_scale(1.0d0-sss)
11079             endif
11080           enddo      ! j
11081         enddo        ! iint
11082       enddo          ! i
11083 !     stop
11084       return
11085       end subroutine ebp_long
11086 !-----------------------------------------------------------------------------
11087       subroutine ebp_short(evdw)
11088 !
11089 ! This subroutine calculates the interaction energy of nonbonded side chains
11090 ! assuming the Berne-Pechukas potential of interaction.
11091 !
11092       use calc_data
11093 !      implicit real*8 (a-h,o-z)
11094 !      include 'DIMENSIONS'
11095 !      include 'COMMON.GEO'
11096 !      include 'COMMON.VAR'
11097 !      include 'COMMON.LOCAL'
11098 !      include 'COMMON.CHAIN'
11099 !      include 'COMMON.DERIV'
11100 !      include 'COMMON.NAMES'
11101 !      include 'COMMON.INTERACT'
11102 !      include 'COMMON.IOUNITS'
11103 !      include 'COMMON.CALC'
11104       use comm_srutu
11105 !el      integer :: icall
11106 !el      common /srutu/ icall
11107 !     double precision rrsave(maxdim)
11108       logical :: lprn
11109 !el local variables
11110       integer :: iint,itypi,itypi1,itypj
11111       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11112       real(kind=8) :: sss,e1,e2,evdw
11113       evdw=0.0D0
11114 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11115       evdw=0.0D0
11116 !     if (icall.eq.0) then
11117 !       lprn=.true.
11118 !     else
11119         lprn=.false.
11120 !     endif
11121 !el      ind=0
11122       do i=iatsc_s,iatsc_e
11123         itypi=itype(i)
11124         if (itypi.eq.ntyp1) cycle
11125         itypi1=itype(i+1)
11126         xi=c(1,nres+i)
11127         yi=c(2,nres+i)
11128         zi=c(3,nres+i)
11129         dxi=dc_norm(1,nres+i)
11130         dyi=dc_norm(2,nres+i)
11131         dzi=dc_norm(3,nres+i)
11132 !        dsci_inv=dsc_inv(itypi)
11133         dsci_inv=vbld_inv(i+nres)
11134 !
11135 ! Calculate SC interaction energy.
11136 !
11137         do iint=1,nint_gr(i)
11138           do j=istart(i,iint),iend(i,iint)
11139 !el            ind=ind+1
11140             itypj=itype(j)
11141             if (itypj.eq.ntyp1) cycle
11142 !            dscj_inv=dsc_inv(itypj)
11143             dscj_inv=vbld_inv(j+nres)
11144             chi1=chi(itypi,itypj)
11145             chi2=chi(itypj,itypi)
11146             chi12=chi1*chi2
11147             chip1=chip(itypi)
11148             chip2=chip(itypj)
11149             chip12=chip1*chip2
11150             alf1=alp(itypi)
11151             alf2=alp(itypj)
11152             alf12=0.5D0*(alf1+alf2)
11153             xj=c(1,nres+j)-xi
11154             yj=c(2,nres+j)-yi
11155             zj=c(3,nres+j)-zi
11156             dxj=dc_norm(1,nres+j)
11157             dyj=dc_norm(2,nres+j)
11158             dzj=dc_norm(3,nres+j)
11159             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11160             rij=dsqrt(rrij)
11161             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11162
11163             if (sss.gt.0.0d0) then
11164
11165 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11166               call sc_angular
11167 ! Calculate whole angle-dependent part of epsilon and contributions
11168 ! to its derivatives
11169               fac=(rrij*sigsq)**expon2
11170               e1=fac*fac*aa(itypi,itypj)
11171               e2=fac*bb(itypi,itypj)
11172               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11173               eps2der=evdwij*eps3rt
11174               eps3der=evdwij*eps2rt
11175               evdwij=evdwij*eps2rt*eps3rt
11176               evdw=evdw+evdwij*sss
11177               if (lprn) then
11178               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11179               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11180 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11181 !d     &          restyp(itypi),i,restyp(itypj),j,
11182 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11183 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11184 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11185 !d     &          evdwij
11186               endif
11187 ! Calculate gradient components.
11188               e1=e1*eps1*eps2rt**2*eps3rt**2
11189               fac=-expon*(e1+evdwij)
11190               sigder=fac/sigsq
11191               fac=rrij*fac
11192 ! Calculate radial part of the gradient
11193               gg(1)=xj*fac
11194               gg(2)=yj*fac
11195               gg(3)=zj*fac
11196 ! Calculate the angular part of the gradient and sum add the contributions
11197 ! to the appropriate components of the Cartesian gradient.
11198               call sc_grad_scale(sss)
11199             endif
11200           enddo      ! j
11201         enddo        ! iint
11202       enddo          ! i
11203 !     stop
11204       return
11205       end subroutine ebp_short
11206 !-----------------------------------------------------------------------------
11207       subroutine egb_long(evdw)
11208 !
11209 ! This subroutine calculates the interaction energy of nonbonded side chains
11210 ! assuming the Gay-Berne potential of interaction.
11211 !
11212       use calc_data
11213 !      implicit real*8 (a-h,o-z)
11214 !      include 'DIMENSIONS'
11215 !      include 'COMMON.GEO'
11216 !      include 'COMMON.VAR'
11217 !      include 'COMMON.LOCAL'
11218 !      include 'COMMON.CHAIN'
11219 !      include 'COMMON.DERIV'
11220 !      include 'COMMON.NAMES'
11221 !      include 'COMMON.INTERACT'
11222 !      include 'COMMON.IOUNITS'
11223 !      include 'COMMON.CALC'
11224 !      include 'COMMON.CONTROL'
11225       logical :: lprn
11226 !el local variables
11227       integer :: iint,itypi,itypi1,itypj
11228       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11229       real(kind=8) :: sss,e1,e2,evdw
11230       evdw=0.0D0
11231 !cccc      energy_dec=.false.
11232 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11233       evdw=0.0D0
11234       lprn=.false.
11235 !     if (icall.eq.0) lprn=.false.
11236 !el      ind=0
11237       do i=iatsc_s,iatsc_e
11238         itypi=itype(i)
11239         if (itypi.eq.ntyp1) cycle
11240         itypi1=itype(i+1)
11241         xi=c(1,nres+i)
11242         yi=c(2,nres+i)
11243         zi=c(3,nres+i)
11244         dxi=dc_norm(1,nres+i)
11245         dyi=dc_norm(2,nres+i)
11246         dzi=dc_norm(3,nres+i)
11247 !        dsci_inv=dsc_inv(itypi)
11248         dsci_inv=vbld_inv(i+nres)
11249 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11250 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11251 !
11252 ! Calculate SC interaction energy.
11253 !
11254         do iint=1,nint_gr(i)
11255           do j=istart(i,iint),iend(i,iint)
11256 !el            ind=ind+1
11257             itypj=itype(j)
11258             if (itypj.eq.ntyp1) cycle
11259 !            dscj_inv=dsc_inv(itypj)
11260             dscj_inv=vbld_inv(j+nres)
11261 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11262 !     &       1.0d0/vbld(j+nres)
11263 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11264             sig0ij=sigma(itypi,itypj)
11265             chi1=chi(itypi,itypj)
11266             chi2=chi(itypj,itypi)
11267             chi12=chi1*chi2
11268             chip1=chip(itypi)
11269             chip2=chip(itypj)
11270             chip12=chip1*chip2
11271             alf1=alp(itypi)
11272             alf2=alp(itypj)
11273             alf12=0.5D0*(alf1+alf2)
11274             xj=c(1,nres+j)-xi
11275             yj=c(2,nres+j)-yi
11276             zj=c(3,nres+j)-zi
11277             dxj=dc_norm(1,nres+j)
11278             dyj=dc_norm(2,nres+j)
11279             dzj=dc_norm(3,nres+j)
11280             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11281             rij=dsqrt(rrij)
11282             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11283
11284             if (sss.lt.1.0d0) then
11285
11286 ! Calculate angle-dependent terms of energy and contributions to their
11287 ! derivatives.
11288               call sc_angular
11289               sigsq=1.0D0/sigsq
11290               sig=sig0ij*dsqrt(sigsq)
11291               rij_shift=1.0D0/rij-sig+sig0ij
11292 ! for diagnostics; uncomment
11293 !              rij_shift=1.2*sig0ij
11294 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11295               if (rij_shift.le.0.0D0) then
11296                 evdw=1.0D20
11297 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11298 !d     &          restyp(itypi),i,restyp(itypj),j,
11299 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11300                 return
11301               endif
11302               sigder=-sig*sigsq
11303 !---------------------------------------------------------------
11304               rij_shift=1.0D0/rij_shift
11305               fac=rij_shift**expon
11306               e1=fac*fac*aa(itypi,itypj)
11307               e2=fac*bb(itypi,itypj)
11308               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11309               eps2der=evdwij*eps3rt
11310               eps3der=evdwij*eps2rt
11311 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11312 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11313               evdwij=evdwij*eps2rt*eps3rt
11314               evdw=evdw+evdwij*(1.0d0-sss)
11315               if (lprn) then
11316               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11317               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11318               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11319                 restyp(itypi),i,restyp(itypj),j,&
11320                 epsi,sigm,chi1,chi2,chip1,chip2,&
11321                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11322                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11323                 evdwij
11324               endif
11325
11326               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11327                               'evdw',i,j,evdwij
11328
11329 ! Calculate gradient components.
11330               e1=e1*eps1*eps2rt**2*eps3rt**2
11331               fac=-expon*(e1+evdwij)*rij_shift
11332               sigder=fac*sigder
11333               fac=rij*fac
11334 !              fac=0.0d0
11335 ! Calculate the radial part of the gradient
11336               gg(1)=xj*fac
11337               gg(2)=yj*fac
11338               gg(3)=zj*fac
11339 ! Calculate angular part of the gradient.
11340               call sc_grad_scale(1.0d0-sss)
11341             endif
11342           enddo      ! j
11343         enddo        ! iint
11344       enddo          ! i
11345 !      write (iout,*) "Number of loop steps in EGB:",ind
11346 !ccc      energy_dec=.false.
11347       return
11348       end subroutine egb_long
11349 !-----------------------------------------------------------------------------
11350       subroutine egb_short(evdw)
11351 !
11352 ! This subroutine calculates the interaction energy of nonbonded side chains
11353 ! assuming the Gay-Berne potential of interaction.
11354 !
11355       use calc_data
11356 !      implicit real*8 (a-h,o-z)
11357 !      include 'DIMENSIONS'
11358 !      include 'COMMON.GEO'
11359 !      include 'COMMON.VAR'
11360 !      include 'COMMON.LOCAL'
11361 !      include 'COMMON.CHAIN'
11362 !      include 'COMMON.DERIV'
11363 !      include 'COMMON.NAMES'
11364 !      include 'COMMON.INTERACT'
11365 !      include 'COMMON.IOUNITS'
11366 !      include 'COMMON.CALC'
11367 !      include 'COMMON.CONTROL'
11368       logical :: lprn
11369 !el local variables
11370       integer :: iint,itypi,itypi1,itypj
11371       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11372       real(kind=8) :: sss,e1,e2,evdw,rij_shift
11373       evdw=0.0D0
11374 !cccc      energy_dec=.false.
11375 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11376       evdw=0.0D0
11377       lprn=.false.
11378 !     if (icall.eq.0) lprn=.false.
11379 !el      ind=0
11380       do i=iatsc_s,iatsc_e
11381         itypi=itype(i)
11382         if (itypi.eq.ntyp1) cycle
11383         itypi1=itype(i+1)
11384         xi=c(1,nres+i)
11385         yi=c(2,nres+i)
11386         zi=c(3,nres+i)
11387         dxi=dc_norm(1,nres+i)
11388         dyi=dc_norm(2,nres+i)
11389         dzi=dc_norm(3,nres+i)
11390 !        dsci_inv=dsc_inv(itypi)
11391         dsci_inv=vbld_inv(i+nres)
11392 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11393 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11394 !
11395 ! Calculate SC interaction energy.
11396 !
11397         do iint=1,nint_gr(i)
11398           do j=istart(i,iint),iend(i,iint)
11399 !el            ind=ind+1
11400             itypj=itype(j)
11401             if (itypj.eq.ntyp1) cycle
11402 !            dscj_inv=dsc_inv(itypj)
11403             dscj_inv=vbld_inv(j+nres)
11404 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11405 !     &       1.0d0/vbld(j+nres)
11406 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11407             sig0ij=sigma(itypi,itypj)
11408             chi1=chi(itypi,itypj)
11409             chi2=chi(itypj,itypi)
11410             chi12=chi1*chi2
11411             chip1=chip(itypi)
11412             chip2=chip(itypj)
11413             chip12=chip1*chip2
11414             alf1=alp(itypi)
11415             alf2=alp(itypj)
11416             alf12=0.5D0*(alf1+alf2)
11417             xj=c(1,nres+j)-xi
11418             yj=c(2,nres+j)-yi
11419             zj=c(3,nres+j)-zi
11420             dxj=dc_norm(1,nres+j)
11421             dyj=dc_norm(2,nres+j)
11422             dzj=dc_norm(3,nres+j)
11423             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11424             rij=dsqrt(rrij)
11425             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11426
11427             if (sss.gt.0.0d0) then
11428
11429 ! Calculate angle-dependent terms of energy and contributions to their
11430 ! derivatives.
11431               call sc_angular
11432               sigsq=1.0D0/sigsq
11433               sig=sig0ij*dsqrt(sigsq)
11434               rij_shift=1.0D0/rij-sig+sig0ij
11435 ! for diagnostics; uncomment
11436 !              rij_shift=1.2*sig0ij
11437 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11438               if (rij_shift.le.0.0D0) then
11439                 evdw=1.0D20
11440 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11441 !d     &          restyp(itypi),i,restyp(itypj),j,
11442 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11443                 return
11444               endif
11445               sigder=-sig*sigsq
11446 !---------------------------------------------------------------
11447               rij_shift=1.0D0/rij_shift
11448               fac=rij_shift**expon
11449               e1=fac*fac*aa(itypi,itypj)
11450               e2=fac*bb(itypi,itypj)
11451               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11452               eps2der=evdwij*eps3rt
11453               eps3der=evdwij*eps2rt
11454 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11455 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11456               evdwij=evdwij*eps2rt*eps3rt
11457               evdw=evdw+evdwij*sss
11458               if (lprn) then
11459               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11460               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11461               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11462                 restyp(itypi),i,restyp(itypj),j,&
11463                 epsi,sigm,chi1,chi2,chip1,chip2,&
11464                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11465                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11466                 evdwij
11467               endif
11468
11469               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11470                               'evdw',i,j,evdwij
11471
11472 ! Calculate gradient components.
11473               e1=e1*eps1*eps2rt**2*eps3rt**2
11474               fac=-expon*(e1+evdwij)*rij_shift
11475               sigder=fac*sigder
11476               fac=rij*fac
11477 !              fac=0.0d0
11478 ! Calculate the radial part of the gradient
11479               gg(1)=xj*fac
11480               gg(2)=yj*fac
11481               gg(3)=zj*fac
11482 ! Calculate angular part of the gradient.
11483               call sc_grad_scale(sss)
11484             endif
11485           enddo      ! j
11486         enddo        ! iint
11487       enddo          ! i
11488 !      write (iout,*) "Number of loop steps in EGB:",ind
11489 !ccc      energy_dec=.false.
11490       return
11491       end subroutine egb_short
11492 !-----------------------------------------------------------------------------
11493       subroutine egbv_long(evdw)
11494 !
11495 ! This subroutine calculates the interaction energy of nonbonded side chains
11496 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11497 !
11498       use calc_data
11499 !      implicit real*8 (a-h,o-z)
11500 !      include 'DIMENSIONS'
11501 !      include 'COMMON.GEO'
11502 !      include 'COMMON.VAR'
11503 !      include 'COMMON.LOCAL'
11504 !      include 'COMMON.CHAIN'
11505 !      include 'COMMON.DERIV'
11506 !      include 'COMMON.NAMES'
11507 !      include 'COMMON.INTERACT'
11508 !      include 'COMMON.IOUNITS'
11509 !      include 'COMMON.CALC'
11510       use comm_srutu
11511 !el      integer :: icall
11512 !el      common /srutu/ icall
11513       logical :: lprn
11514 !el local variables
11515       integer :: iint,itypi,itypi1,itypj
11516       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
11517       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
11518       evdw=0.0D0
11519 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11520       evdw=0.0D0
11521       lprn=.false.
11522 !     if (icall.eq.0) lprn=.true.
11523 !el      ind=0
11524       do i=iatsc_s,iatsc_e
11525         itypi=itype(i)
11526         if (itypi.eq.ntyp1) cycle
11527         itypi1=itype(i+1)
11528         xi=c(1,nres+i)
11529         yi=c(2,nres+i)
11530         zi=c(3,nres+i)
11531         dxi=dc_norm(1,nres+i)
11532         dyi=dc_norm(2,nres+i)
11533         dzi=dc_norm(3,nres+i)
11534 !        dsci_inv=dsc_inv(itypi)
11535         dsci_inv=vbld_inv(i+nres)
11536 !
11537 ! Calculate SC interaction energy.
11538 !
11539         do iint=1,nint_gr(i)
11540           do j=istart(i,iint),iend(i,iint)
11541 !el            ind=ind+1
11542             itypj=itype(j)
11543             if (itypj.eq.ntyp1) cycle
11544 !            dscj_inv=dsc_inv(itypj)
11545             dscj_inv=vbld_inv(j+nres)
11546             sig0ij=sigma(itypi,itypj)
11547             r0ij=r0(itypi,itypj)
11548             chi1=chi(itypi,itypj)
11549             chi2=chi(itypj,itypi)
11550             chi12=chi1*chi2
11551             chip1=chip(itypi)
11552             chip2=chip(itypj)
11553             chip12=chip1*chip2
11554             alf1=alp(itypi)
11555             alf2=alp(itypj)
11556             alf12=0.5D0*(alf1+alf2)
11557             xj=c(1,nres+j)-xi
11558             yj=c(2,nres+j)-yi
11559             zj=c(3,nres+j)-zi
11560             dxj=dc_norm(1,nres+j)
11561             dyj=dc_norm(2,nres+j)
11562             dzj=dc_norm(3,nres+j)
11563             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11564             rij=dsqrt(rrij)
11565
11566             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11567
11568             if (sss.lt.1.0d0) then
11569
11570 ! Calculate angle-dependent terms of energy and contributions to their
11571 ! derivatives.
11572               call sc_angular
11573               sigsq=1.0D0/sigsq
11574               sig=sig0ij*dsqrt(sigsq)
11575               rij_shift=1.0D0/rij-sig+r0ij
11576 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11577               if (rij_shift.le.0.0D0) then
11578                 evdw=1.0D20
11579                 return
11580               endif
11581               sigder=-sig*sigsq
11582 !---------------------------------------------------------------
11583               rij_shift=1.0D0/rij_shift
11584               fac=rij_shift**expon
11585               e1=fac*fac*aa(itypi,itypj)
11586               e2=fac*bb(itypi,itypj)
11587               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11588               eps2der=evdwij*eps3rt
11589               eps3der=evdwij*eps2rt
11590               fac_augm=rrij**expon
11591               e_augm=augm(itypi,itypj)*fac_augm
11592               evdwij=evdwij*eps2rt*eps3rt
11593               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
11594               if (lprn) then
11595               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11596               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11597               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11598                 restyp(itypi),i,restyp(itypj),j,&
11599                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
11600                 chi1,chi2,chip1,chip2,&
11601                 eps1,eps2rt**2,eps3rt**2,&
11602                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11603                 evdwij+e_augm
11604               endif
11605 ! Calculate gradient components.
11606               e1=e1*eps1*eps2rt**2*eps3rt**2
11607               fac=-expon*(e1+evdwij)*rij_shift
11608               sigder=fac*sigder
11609               fac=rij*fac-2*expon*rrij*e_augm
11610 ! Calculate the radial part of the gradient
11611               gg(1)=xj*fac
11612               gg(2)=yj*fac
11613               gg(3)=zj*fac
11614 ! Calculate angular part of the gradient.
11615               call sc_grad_scale(1.0d0-sss)
11616             endif
11617           enddo      ! j
11618         enddo        ! iint
11619       enddo          ! i
11620       end subroutine egbv_long
11621 !-----------------------------------------------------------------------------
11622       subroutine egbv_short(evdw)
11623 !
11624 ! This subroutine calculates the interaction energy of nonbonded side chains
11625 ! assuming the Gay-Berne-Vorobjev potential of interaction.
11626 !
11627       use calc_data
11628 !      implicit real*8 (a-h,o-z)
11629 !      include 'DIMENSIONS'
11630 !      include 'COMMON.GEO'
11631 !      include 'COMMON.VAR'
11632 !      include 'COMMON.LOCAL'
11633 !      include 'COMMON.CHAIN'
11634 !      include 'COMMON.DERIV'
11635 !      include 'COMMON.NAMES'
11636 !      include 'COMMON.INTERACT'
11637 !      include 'COMMON.IOUNITS'
11638 !      include 'COMMON.CALC'
11639       use comm_srutu
11640 !el      integer :: icall
11641 !el      common /srutu/ icall
11642       logical :: lprn
11643 !el local variables
11644       integer :: iint,itypi,itypi1,itypj
11645       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
11646       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
11647       evdw=0.0D0
11648 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11649       evdw=0.0D0
11650       lprn=.false.
11651 !     if (icall.eq.0) lprn=.true.
11652 !el      ind=0
11653       do i=iatsc_s,iatsc_e
11654         itypi=itype(i)
11655         if (itypi.eq.ntyp1) cycle
11656         itypi1=itype(i+1)
11657         xi=c(1,nres+i)
11658         yi=c(2,nres+i)
11659         zi=c(3,nres+i)
11660         dxi=dc_norm(1,nres+i)
11661         dyi=dc_norm(2,nres+i)
11662         dzi=dc_norm(3,nres+i)
11663 !        dsci_inv=dsc_inv(itypi)
11664         dsci_inv=vbld_inv(i+nres)
11665 !
11666 ! Calculate SC interaction energy.
11667 !
11668         do iint=1,nint_gr(i)
11669           do j=istart(i,iint),iend(i,iint)
11670 !el            ind=ind+1
11671             itypj=itype(j)
11672             if (itypj.eq.ntyp1) cycle
11673 !            dscj_inv=dsc_inv(itypj)
11674             dscj_inv=vbld_inv(j+nres)
11675             sig0ij=sigma(itypi,itypj)
11676             r0ij=r0(itypi,itypj)
11677             chi1=chi(itypi,itypj)
11678             chi2=chi(itypj,itypi)
11679             chi12=chi1*chi2
11680             chip1=chip(itypi)
11681             chip2=chip(itypj)
11682             chip12=chip1*chip2
11683             alf1=alp(itypi)
11684             alf2=alp(itypj)
11685             alf12=0.5D0*(alf1+alf2)
11686             xj=c(1,nres+j)-xi
11687             yj=c(2,nres+j)-yi
11688             zj=c(3,nres+j)-zi
11689             dxj=dc_norm(1,nres+j)
11690             dyj=dc_norm(2,nres+j)
11691             dzj=dc_norm(3,nres+j)
11692             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11693             rij=dsqrt(rrij)
11694
11695             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11696
11697             if (sss.gt.0.0d0) then
11698
11699 ! Calculate angle-dependent terms of energy and contributions to their
11700 ! derivatives.
11701               call sc_angular
11702               sigsq=1.0D0/sigsq
11703               sig=sig0ij*dsqrt(sigsq)
11704               rij_shift=1.0D0/rij-sig+r0ij
11705 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11706               if (rij_shift.le.0.0D0) then
11707                 evdw=1.0D20
11708                 return
11709               endif
11710               sigder=-sig*sigsq
11711 !---------------------------------------------------------------
11712               rij_shift=1.0D0/rij_shift
11713               fac=rij_shift**expon
11714               e1=fac*fac*aa(itypi,itypj)
11715               e2=fac*bb(itypi,itypj)
11716               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11717               eps2der=evdwij*eps3rt
11718               eps3der=evdwij*eps2rt
11719               fac_augm=rrij**expon
11720               e_augm=augm(itypi,itypj)*fac_augm
11721               evdwij=evdwij*eps2rt*eps3rt
11722               evdw=evdw+(evdwij+e_augm)*sss
11723               if (lprn) then
11724               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11725               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11726               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11727                 restyp(itypi),i,restyp(itypj),j,&
11728                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
11729                 chi1,chi2,chip1,chip2,&
11730                 eps1,eps2rt**2,eps3rt**2,&
11731                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11732                 evdwij+e_augm
11733               endif
11734 ! Calculate gradient components.
11735               e1=e1*eps1*eps2rt**2*eps3rt**2
11736               fac=-expon*(e1+evdwij)*rij_shift
11737               sigder=fac*sigder
11738               fac=rij*fac-2*expon*rrij*e_augm
11739 ! Calculate the radial part of the gradient
11740               gg(1)=xj*fac
11741               gg(2)=yj*fac
11742               gg(3)=zj*fac
11743 ! Calculate angular part of the gradient.
11744               call sc_grad_scale(sss)
11745             endif
11746           enddo      ! j
11747         enddo        ! iint
11748       enddo          ! i
11749       end subroutine egbv_short
11750 !-----------------------------------------------------------------------------
11751       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
11752 !
11753 ! This subroutine calculates the average interaction energy and its gradient
11754 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
11755 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
11756 ! The potential depends both on the distance of peptide-group centers and on
11757 ! the orientation of the CA-CA virtual bonds.
11758 !
11759 !      implicit real*8 (a-h,o-z)
11760
11761       use comm_locel
11762 #ifdef MPI
11763       include 'mpif.h'
11764 #endif
11765 !      include 'DIMENSIONS'
11766 !      include 'COMMON.CONTROL'
11767 !      include 'COMMON.SETUP'
11768 !      include 'COMMON.IOUNITS'
11769 !      include 'COMMON.GEO'
11770 !      include 'COMMON.VAR'
11771 !      include 'COMMON.LOCAL'
11772 !      include 'COMMON.CHAIN'
11773 !      include 'COMMON.DERIV'
11774 !      include 'COMMON.INTERACT'
11775 !      include 'COMMON.CONTACTS'
11776 !      include 'COMMON.TORSION'
11777 !      include 'COMMON.VECTORS'
11778 !      include 'COMMON.FFIELD'
11779 !      include 'COMMON.TIME1'
11780       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
11781       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
11782       real(kind=8),dimension(2,2) :: acipa !el,a_temp
11783 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
11784       real(kind=8),dimension(4) :: muij
11785 !el      integer :: num_conti,j1,j2
11786 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
11787 !el                   dz_normi,xmedi,ymedi,zmedi
11788 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
11789 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
11790 !el          num_conti,j1,j2
11791 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
11792 #ifdef MOMENT
11793       real(kind=8) :: scal_el=1.0d0
11794 #else
11795       real(kind=8) :: scal_el=0.5d0
11796 #endif
11797 ! 12/13/98
11798 ! 13-go grudnia roku pamietnego...
11799       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
11800                                              0.0d0,1.0d0,0.0d0,&
11801                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
11802 !el local variables
11803       integer :: i,j,k
11804       real(kind=8) :: fac
11805       real(kind=8) :: dxj,dyj,dzj
11806       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
11807
11808 !      allocate(num_cont_hb(nres)) !(maxres)
11809 !d      write(iout,*) 'In EELEC'
11810 !d      do i=1,nloctyp
11811 !d        write(iout,*) 'Type',i
11812 !d        write(iout,*) 'B1',B1(:,i)
11813 !d        write(iout,*) 'B2',B2(:,i)
11814 !d        write(iout,*) 'CC',CC(:,:,i)
11815 !d        write(iout,*) 'DD',DD(:,:,i)
11816 !d        write(iout,*) 'EE',EE(:,:,i)
11817 !d      enddo
11818 !d      call check_vecgrad
11819 !d      stop
11820       if (icheckgrad.eq.1) then
11821         do i=1,nres-1
11822           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
11823           do k=1,3
11824             dc_norm(k,i)=dc(k,i)*fac
11825           enddo
11826 !          write (iout,*) 'i',i,' fac',fac
11827         enddo
11828       endif
11829       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
11830           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
11831           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
11832 !        call vec_and_deriv
11833 #ifdef TIMING
11834         time01=MPI_Wtime()
11835 #endif
11836         call set_matrices
11837 #ifdef TIMING
11838         time_mat=time_mat+MPI_Wtime()-time01
11839 #endif
11840       endif
11841 !d      do i=1,nres-1
11842 !d        write (iout,*) 'i=',i
11843 !d        do k=1,3
11844 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
11845 !d        enddo
11846 !d        do k=1,3
11847 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
11848 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
11849 !d        enddo
11850 !d      enddo
11851       t_eelecij=0.0d0
11852       ees=0.0D0
11853       evdw1=0.0D0
11854       eel_loc=0.0d0
11855       eello_turn3=0.0d0
11856       eello_turn4=0.0d0
11857 !el      ind=0
11858       do i=1,nres
11859         num_cont_hb(i)=0
11860       enddo
11861 !d      print '(a)','Enter EELEC'
11862 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
11863 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
11864 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
11865       do i=1,nres
11866         gel_loc_loc(i)=0.0d0
11867         gcorr_loc(i)=0.0d0
11868       enddo
11869 !
11870 !
11871 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
11872 !
11873 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
11874 !
11875       do i=iturn3_start,iturn3_end
11876         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
11877         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
11878         dxi=dc(1,i)
11879         dyi=dc(2,i)
11880         dzi=dc(3,i)
11881         dx_normi=dc_norm(1,i)
11882         dy_normi=dc_norm(2,i)
11883         dz_normi=dc_norm(3,i)
11884         xmedi=c(1,i)+0.5d0*dxi
11885         ymedi=c(2,i)+0.5d0*dyi
11886         zmedi=c(3,i)+0.5d0*dzi
11887         num_conti=0
11888         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
11889         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
11890         num_cont_hb(i)=num_conti
11891       enddo
11892       do i=iturn4_start,iturn4_end
11893         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
11894           .or. itype(i+3).eq.ntyp1 &
11895           .or. itype(i+4).eq.ntyp1) cycle
11896         dxi=dc(1,i)
11897         dyi=dc(2,i)
11898         dzi=dc(3,i)
11899         dx_normi=dc_norm(1,i)
11900         dy_normi=dc_norm(2,i)
11901         dz_normi=dc_norm(3,i)
11902         xmedi=c(1,i)+0.5d0*dxi
11903         ymedi=c(2,i)+0.5d0*dyi
11904         zmedi=c(3,i)+0.5d0*dzi
11905         num_conti=num_cont_hb(i)
11906         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
11907         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
11908           call eturn4(i,eello_turn4)
11909         num_cont_hb(i)=num_conti
11910       enddo   ! i
11911 !
11912 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
11913 !
11914       do i=iatel_s,iatel_e
11915         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
11916         dxi=dc(1,i)
11917         dyi=dc(2,i)
11918         dzi=dc(3,i)
11919         dx_normi=dc_norm(1,i)
11920         dy_normi=dc_norm(2,i)
11921         dz_normi=dc_norm(3,i)
11922         xmedi=c(1,i)+0.5d0*dxi
11923         ymedi=c(2,i)+0.5d0*dyi
11924         zmedi=c(3,i)+0.5d0*dzi
11925 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
11926         num_conti=num_cont_hb(i)
11927         do j=ielstart(i),ielend(i)
11928           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
11929           call eelecij_scale(i,j,ees,evdw1,eel_loc)
11930         enddo ! j
11931         num_cont_hb(i)=num_conti
11932       enddo   ! i
11933 !      write (iout,*) "Number of loop steps in EELEC:",ind
11934 !d      do i=1,nres
11935 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
11936 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
11937 !d      enddo
11938 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
11939 !cc      eel_loc=eel_loc+eello_turn3
11940 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
11941       return
11942       end subroutine eelec_scale
11943 !-----------------------------------------------------------------------------
11944       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
11945 !      implicit real*8 (a-h,o-z)
11946
11947       use comm_locel
11948 !      include 'DIMENSIONS'
11949 #ifdef MPI
11950       include "mpif.h"
11951 #endif
11952 !      include 'COMMON.CONTROL'
11953 !      include 'COMMON.IOUNITS'
11954 !      include 'COMMON.GEO'
11955 !      include 'COMMON.VAR'
11956 !      include 'COMMON.LOCAL'
11957 !      include 'COMMON.CHAIN'
11958 !      include 'COMMON.DERIV'
11959 !      include 'COMMON.INTERACT'
11960 !      include 'COMMON.CONTACTS'
11961 !      include 'COMMON.TORSION'
11962 !      include 'COMMON.VECTORS'
11963 !      include 'COMMON.FFIELD'
11964 !      include 'COMMON.TIME1'
11965       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
11966       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
11967       real(kind=8),dimension(2,2) :: acipa !el,a_temp
11968 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
11969       real(kind=8),dimension(4) :: muij
11970 !el      integer :: num_conti,j1,j2
11971 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
11972 !el                   dz_normi,xmedi,ymedi,zmedi
11973 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
11974 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
11975 !el          num_conti,j1,j2
11976 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
11977 #ifdef MOMENT
11978       real(kind=8) :: scal_el=1.0d0
11979 #else
11980       real(kind=8) :: scal_el=0.5d0
11981 #endif
11982 ! 12/13/98
11983 ! 13-go grudnia roku pamietnego...
11984       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
11985                                              0.0d0,1.0d0,0.0d0,&
11986                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
11987 !el local variables
11988       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
11989       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
11990       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
11991       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
11992       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
11993       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
11994       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
11995                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
11996                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
11997                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
11998                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
11999                   ecosam,ecosbm,ecosgm,ghalf,time00
12000 !      integer :: maxconts
12001 !      maxconts = nres/4
12002 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12003 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12004 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12005 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12006 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12007 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12008 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12009 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12010 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12011 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12012 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12013 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12014 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12015
12016 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12017 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12018
12019 #ifdef MPI
12020           time00=MPI_Wtime()
12021 #endif
12022 !d      write (iout,*) "eelecij",i,j
12023 !el          ind=ind+1
12024           iteli=itel(i)
12025           itelj=itel(j)
12026           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12027           aaa=app(iteli,itelj)
12028           bbb=bpp(iteli,itelj)
12029           ael6i=ael6(iteli,itelj)
12030           ael3i=ael3(iteli,itelj)
12031           dxj=dc(1,j)
12032           dyj=dc(2,j)
12033           dzj=dc(3,j)
12034           dx_normj=dc_norm(1,j)
12035           dy_normj=dc_norm(2,j)
12036           dz_normj=dc_norm(3,j)
12037           xj=c(1,j)+0.5D0*dxj-xmedi
12038           yj=c(2,j)+0.5D0*dyj-ymedi
12039           zj=c(3,j)+0.5D0*dzj-zmedi
12040           rij=xj*xj+yj*yj+zj*zj
12041           rrmij=1.0D0/rij
12042           rij=dsqrt(rij)
12043           rmij=1.0D0/rij
12044 ! For extracting the short-range part of Evdwpp
12045           sss=sscale(rij/rpp(iteli,itelj))
12046
12047           r3ij=rrmij*rmij
12048           r6ij=r3ij*r3ij
12049           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12050           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12051           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12052           fac=cosa-3.0D0*cosb*cosg
12053           ev1=aaa*r6ij*r6ij
12054 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12055           if (j.eq.i+2) ev1=scal_el*ev1
12056           ev2=bbb*r6ij
12057           fac3=ael6i*r6ij
12058           fac4=ael3i*r3ij
12059           evdwij=ev1+ev2
12060           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12061           el2=fac4*fac
12062           eesij=el1+el2
12063 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12064           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12065           ees=ees+eesij
12066           evdw1=evdw1+evdwij*(1.0d0-sss)
12067 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12068 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12069 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12070 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12071
12072           if (energy_dec) then
12073               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12074               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12075           endif
12076
12077 !
12078 ! Calculate contributions to the Cartesian gradient.
12079 !
12080 #ifdef SPLITELE
12081           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12082           facel=-3*rrmij*(el1+eesij)
12083           fac1=fac
12084           erij(1)=xj*rmij
12085           erij(2)=yj*rmij
12086           erij(3)=zj*rmij
12087 !
12088 ! Radial derivatives. First process both termini of the fragment (i,j)
12089 !
12090           ggg(1)=facel*xj
12091           ggg(2)=facel*yj
12092           ggg(3)=facel*zj
12093 !          do k=1,3
12094 !            ghalf=0.5D0*ggg(k)
12095 !            gelc(k,i)=gelc(k,i)+ghalf
12096 !            gelc(k,j)=gelc(k,j)+ghalf
12097 !          enddo
12098 ! 9/28/08 AL Gradient compotents will be summed only at the end
12099           do k=1,3
12100             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12101             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12102           enddo
12103 !
12104 ! Loop over residues i+1 thru j-1.
12105 !
12106 !grad          do k=i+1,j-1
12107 !grad            do l=1,3
12108 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12109 !grad            enddo
12110 !grad          enddo
12111           ggg(1)=facvdw*xj
12112           ggg(2)=facvdw*yj
12113           ggg(3)=facvdw*zj
12114 !          do k=1,3
12115 !            ghalf=0.5D0*ggg(k)
12116 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12117 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12118 !          enddo
12119 ! 9/28/08 AL Gradient compotents will be summed only at the end
12120           do k=1,3
12121             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12122             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12123           enddo
12124 !
12125 ! Loop over residues i+1 thru j-1.
12126 !
12127 !grad          do k=i+1,j-1
12128 !grad            do l=1,3
12129 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12130 !grad            enddo
12131 !grad          enddo
12132 #else
12133           facvdw=ev1+evdwij*(1.0d0-sss)
12134           facel=el1+eesij
12135           fac1=fac
12136           fac=-3*rrmij*(facvdw+facvdw+facel)
12137           erij(1)=xj*rmij
12138           erij(2)=yj*rmij
12139           erij(3)=zj*rmij
12140 !
12141 ! Radial derivatives. First process both termini of the fragment (i,j)
12142 !
12143           ggg(1)=fac*xj
12144           ggg(2)=fac*yj
12145           ggg(3)=fac*zj
12146 !          do k=1,3
12147 !            ghalf=0.5D0*ggg(k)
12148 !            gelc(k,i)=gelc(k,i)+ghalf
12149 !            gelc(k,j)=gelc(k,j)+ghalf
12150 !          enddo
12151 ! 9/28/08 AL Gradient compotents will be summed only at the end
12152           do k=1,3
12153             gelc_long(k,j)=gelc(k,j)+ggg(k)
12154             gelc_long(k,i)=gelc(k,i)-ggg(k)
12155           enddo
12156 !
12157 ! Loop over residues i+1 thru j-1.
12158 !
12159 !grad          do k=i+1,j-1
12160 !grad            do l=1,3
12161 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12162 !grad            enddo
12163 !grad          enddo
12164 ! 9/28/08 AL Gradient compotents will be summed only at the end
12165           ggg(1)=facvdw*xj
12166           ggg(2)=facvdw*yj
12167           ggg(3)=facvdw*zj
12168           do k=1,3
12169             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12170             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12171           enddo
12172 #endif
12173 !
12174 ! Angular part
12175 !
12176           ecosa=2.0D0*fac3*fac1+fac4
12177           fac4=-3.0D0*fac4
12178           fac3=-6.0D0*fac3
12179           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12180           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12181           do k=1,3
12182             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12183             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12184           enddo
12185 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12186 !d   &          (dcosg(k),k=1,3)
12187           do k=1,3
12188             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12189           enddo
12190 !          do k=1,3
12191 !            ghalf=0.5D0*ggg(k)
12192 !            gelc(k,i)=gelc(k,i)+ghalf
12193 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12194 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12195 !            gelc(k,j)=gelc(k,j)+ghalf
12196 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12197 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12198 !          enddo
12199 !grad          do k=i+1,j-1
12200 !grad            do l=1,3
12201 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12202 !grad            enddo
12203 !grad          enddo
12204           do k=1,3
12205             gelc(k,i)=gelc(k,i) &
12206                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12207                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12208             gelc(k,j)=gelc(k,j) &
12209                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12210                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12211             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12212             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12213           enddo
12214           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12215               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12216               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12217 !
12218 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12219 !   energy of a peptide unit is assumed in the form of a second-order
12220 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12221 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12222 !   are computed for EVERY pair of non-contiguous peptide groups.
12223 !
12224           if (j.lt.nres-1) then
12225             j1=j+1
12226             j2=j-1
12227           else
12228             j1=j-1
12229             j2=j-2
12230           endif
12231           kkk=0
12232           do k=1,2
12233             do l=1,2
12234               kkk=kkk+1
12235               muij(kkk)=mu(k,i)*mu(l,j)
12236             enddo
12237           enddo
12238 !d         write (iout,*) 'EELEC: i',i,' j',j
12239 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12240 !d          write(iout,*) 'muij',muij
12241           ury=scalar(uy(1,i),erij)
12242           urz=scalar(uz(1,i),erij)
12243           vry=scalar(uy(1,j),erij)
12244           vrz=scalar(uz(1,j),erij)
12245           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12246           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12247           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12248           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12249           fac=dsqrt(-ael6i)*r3ij
12250           a22=a22*fac
12251           a23=a23*fac
12252           a32=a32*fac
12253           a33=a33*fac
12254 !d          write (iout,'(4i5,4f10.5)')
12255 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12256 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12257 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12258 !d     &      uy(:,j),uz(:,j)
12259 !d          write (iout,'(4f10.5)')
12260 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12261 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12262 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12263 !d           write (iout,'(9f10.5/)')
12264 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12265 ! Derivatives of the elements of A in virtual-bond vectors
12266           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12267           do k=1,3
12268             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12269             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12270             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12271             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12272             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12273             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12274             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12275             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12276             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12277             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12278             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12279             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12280           enddo
12281 ! Compute radial contributions to the gradient
12282           facr=-3.0d0*rrmij
12283           a22der=a22*facr
12284           a23der=a23*facr
12285           a32der=a32*facr
12286           a33der=a33*facr
12287           agg(1,1)=a22der*xj
12288           agg(2,1)=a22der*yj
12289           agg(3,1)=a22der*zj
12290           agg(1,2)=a23der*xj
12291           agg(2,2)=a23der*yj
12292           agg(3,2)=a23der*zj
12293           agg(1,3)=a32der*xj
12294           agg(2,3)=a32der*yj
12295           agg(3,3)=a32der*zj
12296           agg(1,4)=a33der*xj
12297           agg(2,4)=a33der*yj
12298           agg(3,4)=a33der*zj
12299 ! Add the contributions coming from er
12300           fac3=-3.0d0*fac
12301           do k=1,3
12302             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12303             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12304             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12305             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12306           enddo
12307           do k=1,3
12308 ! Derivatives in DC(i)
12309 !grad            ghalf1=0.5d0*agg(k,1)
12310 !grad            ghalf2=0.5d0*agg(k,2)
12311 !grad            ghalf3=0.5d0*agg(k,3)
12312 !grad            ghalf4=0.5d0*agg(k,4)
12313             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12314             -3.0d0*uryg(k,2)*vry)!+ghalf1
12315             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12316             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12317             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12318             -3.0d0*urzg(k,2)*vry)!+ghalf3
12319             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12320             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12321 ! Derivatives in DC(i+1)
12322             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12323             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12324             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12325             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12326             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
12327             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
12328             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
12329             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
12330 ! Derivatives in DC(j)
12331             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
12332             -3.0d0*vryg(k,2)*ury)!+ghalf1
12333             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
12334             -3.0d0*vrzg(k,2)*ury)!+ghalf2
12335             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
12336             -3.0d0*vryg(k,2)*urz)!+ghalf3
12337             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
12338             -3.0d0*vrzg(k,2)*urz)!+ghalf4
12339 ! Derivatives in DC(j+1) or DC(nres-1)
12340             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
12341             -3.0d0*vryg(k,3)*ury)
12342             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
12343             -3.0d0*vrzg(k,3)*ury)
12344             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
12345             -3.0d0*vryg(k,3)*urz)
12346             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
12347             -3.0d0*vrzg(k,3)*urz)
12348 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
12349 !grad              do l=1,4
12350 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
12351 !grad              enddo
12352 !grad            endif
12353           enddo
12354           acipa(1,1)=a22
12355           acipa(1,2)=a23
12356           acipa(2,1)=a32
12357           acipa(2,2)=a33
12358           a22=-a22
12359           a23=-a23
12360           do l=1,2
12361             do k=1,3
12362               agg(k,l)=-agg(k,l)
12363               aggi(k,l)=-aggi(k,l)
12364               aggi1(k,l)=-aggi1(k,l)
12365               aggj(k,l)=-aggj(k,l)
12366               aggj1(k,l)=-aggj1(k,l)
12367             enddo
12368           enddo
12369           if (j.lt.nres-1) then
12370             a22=-a22
12371             a32=-a32
12372             do l=1,3,2
12373               do k=1,3
12374                 agg(k,l)=-agg(k,l)
12375                 aggi(k,l)=-aggi(k,l)
12376                 aggi1(k,l)=-aggi1(k,l)
12377                 aggj(k,l)=-aggj(k,l)
12378                 aggj1(k,l)=-aggj1(k,l)
12379               enddo
12380             enddo
12381           else
12382             a22=-a22
12383             a23=-a23
12384             a32=-a32
12385             a33=-a33
12386             do l=1,4
12387               do k=1,3
12388                 agg(k,l)=-agg(k,l)
12389                 aggi(k,l)=-aggi(k,l)
12390                 aggi1(k,l)=-aggi1(k,l)
12391                 aggj(k,l)=-aggj(k,l)
12392                 aggj1(k,l)=-aggj1(k,l)
12393               enddo
12394             enddo
12395           endif
12396           ENDIF ! WCORR
12397           IF (wel_loc.gt.0.0d0) THEN
12398 ! Contribution to the local-electrostatic energy coming from the i-j pair
12399           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
12400            +a33*muij(4)
12401 !d          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
12402
12403           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12404                   'eelloc',i,j,eel_loc_ij
12405 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
12406
12407           eel_loc=eel_loc+eel_loc_ij
12408 ! Partial derivatives in virtual-bond dihedral angles gamma
12409           if (i.gt.1) &
12410           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
12411                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
12412                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
12413           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
12414                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
12415                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
12416 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
12417           do l=1,3
12418             ggg(l)=agg(l,1)*muij(1)+ &
12419                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
12420             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
12421             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
12422 !grad            ghalf=0.5d0*ggg(l)
12423 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
12424 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
12425           enddo
12426 !grad          do k=i+1,j2
12427 !grad            do l=1,3
12428 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
12429 !grad            enddo
12430 !grad          enddo
12431 ! Remaining derivatives of eello
12432           do l=1,3
12433             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
12434                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
12435             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
12436                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
12437             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
12438                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
12439             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
12440                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
12441           enddo
12442           ENDIF
12443 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
12444 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
12445           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
12446              .and. num_conti.le.maxconts) then
12447 !            write (iout,*) i,j," entered corr"
12448 !
12449 ! Calculate the contact function. The ith column of the array JCONT will
12450 ! contain the numbers of atoms that make contacts with the atom I (of numbers
12451 ! greater than I). The arrays FACONT and GACONT will contain the values of
12452 ! the contact function and its derivative.
12453 !           r0ij=1.02D0*rpp(iteli,itelj)
12454 !           r0ij=1.11D0*rpp(iteli,itelj)
12455             r0ij=2.20D0*rpp(iteli,itelj)
12456 !           r0ij=1.55D0*rpp(iteli,itelj)
12457             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
12458 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12459             if (fcont.gt.0.0D0) then
12460               num_conti=num_conti+1
12461               if (num_conti.gt.maxconts) then
12462 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
12463                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
12464                                ' will skip next contacts for this conf.',num_conti
12465               else
12466                 jcont_hb(num_conti,i)=j
12467 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
12468 !d     &           " jcont_hb",jcont_hb(num_conti,i)
12469                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
12470                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12471 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
12472 !  terms.
12473                 d_cont(num_conti,i)=rij
12474 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
12475 !     --- Electrostatic-interaction matrix ---
12476                 a_chuj(1,1,num_conti,i)=a22
12477                 a_chuj(1,2,num_conti,i)=a23
12478                 a_chuj(2,1,num_conti,i)=a32
12479                 a_chuj(2,2,num_conti,i)=a33
12480 !     --- Gradient of rij
12481                 do kkk=1,3
12482                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
12483                 enddo
12484                 kkll=0
12485                 do k=1,2
12486                   do l=1,2
12487                     kkll=kkll+1
12488                     do m=1,3
12489                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
12490                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
12491                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
12492                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
12493                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
12494                     enddo
12495                   enddo
12496                 enddo
12497                 ENDIF
12498                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
12499 ! Calculate contact energies
12500                 cosa4=4.0D0*cosa
12501                 wij=cosa-3.0D0*cosb*cosg
12502                 cosbg1=cosb+cosg
12503                 cosbg2=cosb-cosg
12504 !               fac3=dsqrt(-ael6i)/r0ij**3
12505                 fac3=dsqrt(-ael6i)*r3ij
12506 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
12507                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
12508                 if (ees0tmp.gt.0) then
12509                   ees0pij=dsqrt(ees0tmp)
12510                 else
12511                   ees0pij=0
12512                 endif
12513 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
12514                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
12515                 if (ees0tmp.gt.0) then
12516                   ees0mij=dsqrt(ees0tmp)
12517                 else
12518                   ees0mij=0
12519                 endif
12520 !               ees0mij=0.0D0
12521                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
12522                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
12523 ! Diagnostics. Comment out or remove after debugging!
12524 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
12525 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
12526 !               ees0m(num_conti,i)=0.0D0
12527 ! End diagnostics.
12528 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
12529 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
12530 ! Angular derivatives of the contact function
12531                 ees0pij1=fac3/ees0pij
12532                 ees0mij1=fac3/ees0mij
12533                 fac3p=-3.0D0*fac3*rrmij
12534                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
12535                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
12536 !               ees0mij1=0.0D0
12537                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
12538                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
12539                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
12540                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
12541                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
12542                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
12543                 ecosap=ecosa1+ecosa2
12544                 ecosbp=ecosb1+ecosb2
12545                 ecosgp=ecosg1+ecosg2
12546                 ecosam=ecosa1-ecosa2
12547                 ecosbm=ecosb1-ecosb2
12548                 ecosgm=ecosg1-ecosg2
12549 ! Diagnostics
12550 !               ecosap=ecosa1
12551 !               ecosbp=ecosb1
12552 !               ecosgp=ecosg1
12553 !               ecosam=0.0D0
12554 !               ecosbm=0.0D0
12555 !               ecosgm=0.0D0
12556 ! End diagnostics
12557                 facont_hb(num_conti,i)=fcont
12558                 fprimcont=fprimcont/rij
12559 !d              facont_hb(num_conti,i)=1.0D0
12560 ! Following line is for diagnostics.
12561 !d              fprimcont=0.0D0
12562                 do k=1,3
12563                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12564                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12565                 enddo
12566                 do k=1,3
12567                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
12568                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
12569                 enddo
12570                 gggp(1)=gggp(1)+ees0pijp*xj
12571                 gggp(2)=gggp(2)+ees0pijp*yj
12572                 gggp(3)=gggp(3)+ees0pijp*zj
12573                 gggm(1)=gggm(1)+ees0mijp*xj
12574                 gggm(2)=gggm(2)+ees0mijp*yj
12575                 gggm(3)=gggm(3)+ees0mijp*zj
12576 ! Derivatives due to the contact function
12577                 gacont_hbr(1,num_conti,i)=fprimcont*xj
12578                 gacont_hbr(2,num_conti,i)=fprimcont*yj
12579                 gacont_hbr(3,num_conti,i)=fprimcont*zj
12580                 do k=1,3
12581 !
12582 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
12583 !          following the change of gradient-summation algorithm.
12584 !
12585 !grad                  ghalfp=0.5D0*gggp(k)
12586 !grad                  ghalfm=0.5D0*gggm(k)
12587                   gacontp_hb1(k,num_conti,i)= & !ghalfp
12588                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12589                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12590                   gacontp_hb2(k,num_conti,i)= & !ghalfp
12591                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12592                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12593                   gacontp_hb3(k,num_conti,i)=gggp(k)
12594                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
12595                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12596                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12597                   gacontm_hb2(k,num_conti,i)= & !ghalfm
12598                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12599                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12600                   gacontm_hb3(k,num_conti,i)=gggm(k)
12601                 enddo
12602               ENDIF ! wcorr
12603               endif  ! num_conti.le.maxconts
12604             endif  ! fcont.gt.0
12605           endif    ! j.gt.i+1
12606           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
12607             do k=1,4
12608               do l=1,3
12609                 ghalf=0.5d0*agg(l,k)
12610                 aggi(l,k)=aggi(l,k)+ghalf
12611                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
12612                 aggj(l,k)=aggj(l,k)+ghalf
12613               enddo
12614             enddo
12615             if (j.eq.nres-1 .and. i.lt.j-2) then
12616               do k=1,4
12617                 do l=1,3
12618                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
12619                 enddo
12620               enddo
12621             endif
12622           endif
12623 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
12624       return
12625       end subroutine eelecij_scale
12626 !-----------------------------------------------------------------------------
12627       subroutine evdwpp_short(evdw1)
12628 !
12629 ! Compute Evdwpp
12630 !
12631 !      implicit real*8 (a-h,o-z)
12632 !      include 'DIMENSIONS'
12633 !      include 'COMMON.CONTROL'
12634 !      include 'COMMON.IOUNITS'
12635 !      include 'COMMON.GEO'
12636 !      include 'COMMON.VAR'
12637 !      include 'COMMON.LOCAL'
12638 !      include 'COMMON.CHAIN'
12639 !      include 'COMMON.DERIV'
12640 !      include 'COMMON.INTERACT'
12641 !      include 'COMMON.CONTACTS'
12642 !      include 'COMMON.TORSION'
12643 !      include 'COMMON.VECTORS'
12644 !      include 'COMMON.FFIELD'
12645       real(kind=8),dimension(3) :: ggg
12646 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12647 #ifdef MOMENT
12648       real(kind=8) :: scal_el=1.0d0
12649 #else
12650       real(kind=8) :: scal_el=0.5d0
12651 #endif
12652 !el local variables
12653       integer :: i,j,k,iteli,itelj,num_conti
12654       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
12655       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
12656                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12657                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
12658
12659       evdw1=0.0D0
12660 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
12661 !     & " iatel_e_vdw",iatel_e_vdw
12662       call flush(iout)
12663       do i=iatel_s_vdw,iatel_e_vdw
12664         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
12665         dxi=dc(1,i)
12666         dyi=dc(2,i)
12667         dzi=dc(3,i)
12668         dx_normi=dc_norm(1,i)
12669         dy_normi=dc_norm(2,i)
12670         dz_normi=dc_norm(3,i)
12671         xmedi=c(1,i)+0.5d0*dxi
12672         ymedi=c(2,i)+0.5d0*dyi
12673         zmedi=c(3,i)+0.5d0*dzi
12674         num_conti=0
12675 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
12676 !     &   ' ielend',ielend_vdw(i)
12677         call flush(iout)
12678         do j=ielstart_vdw(i),ielend_vdw(i)
12679           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12680 !el          ind=ind+1
12681           iteli=itel(i)
12682           itelj=itel(j)
12683           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12684           aaa=app(iteli,itelj)
12685           bbb=bpp(iteli,itelj)
12686           dxj=dc(1,j)
12687           dyj=dc(2,j)
12688           dzj=dc(3,j)
12689           dx_normj=dc_norm(1,j)
12690           dy_normj=dc_norm(2,j)
12691           dz_normj=dc_norm(3,j)
12692           xj=c(1,j)+0.5D0*dxj-xmedi
12693           yj=c(2,j)+0.5D0*dyj-ymedi
12694           zj=c(3,j)+0.5D0*dzj-zmedi
12695           rij=xj*xj+yj*yj+zj*zj
12696           rrmij=1.0D0/rij
12697           rij=dsqrt(rij)
12698           sss=sscale(rij/rpp(iteli,itelj))
12699           if (sss.gt.0.0d0) then
12700             rmij=1.0D0/rij
12701             r3ij=rrmij*rmij
12702             r6ij=r3ij*r3ij
12703             ev1=aaa*r6ij*r6ij
12704 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12705             if (j.eq.i+2) ev1=scal_el*ev1
12706             ev2=bbb*r6ij
12707             evdwij=ev1+ev2
12708             if (energy_dec) then
12709               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12710             endif
12711             evdw1=evdw1+evdwij*sss
12712 !
12713 ! Calculate contributions to the Cartesian gradient.
12714 !
12715             facvdw=-6*rrmij*(ev1+evdwij)*sss
12716             ggg(1)=facvdw*xj
12717             ggg(2)=facvdw*yj
12718             ggg(3)=facvdw*zj
12719             do k=1,3
12720               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12721               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12722             enddo
12723           endif
12724         enddo ! j
12725       enddo   ! i
12726       return
12727       end subroutine evdwpp_short
12728 !-----------------------------------------------------------------------------
12729       subroutine escp_long(evdw2,evdw2_14)
12730 !
12731 ! This subroutine calculates the excluded-volume interaction energy between
12732 ! peptide-group centers and side chains and its gradient in virtual-bond and
12733 ! side-chain vectors.
12734 !
12735 !      implicit real*8 (a-h,o-z)
12736 !      include 'DIMENSIONS'
12737 !      include 'COMMON.GEO'
12738 !      include 'COMMON.VAR'
12739 !      include 'COMMON.LOCAL'
12740 !      include 'COMMON.CHAIN'
12741 !      include 'COMMON.DERIV'
12742 !      include 'COMMON.INTERACT'
12743 !      include 'COMMON.FFIELD'
12744 !      include 'COMMON.IOUNITS'
12745 !      include 'COMMON.CONTROL'
12746       real(kind=8),dimension(3) :: ggg
12747 !el local variables
12748       integer :: i,iint,j,k,iteli,itypj
12749       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
12750       real(kind=8) :: evdw2,evdw2_14,evdwij
12751       evdw2=0.0D0
12752       evdw2_14=0.0d0
12753 !d    print '(a)','Enter ESCP'
12754 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
12755       do i=iatscp_s,iatscp_e
12756         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12757         iteli=itel(i)
12758         xi=0.5D0*(c(1,i)+c(1,i+1))
12759         yi=0.5D0*(c(2,i)+c(2,i+1))
12760         zi=0.5D0*(c(3,i)+c(3,i+1))
12761
12762         do iint=1,nscp_gr(i)
12763
12764         do j=iscpstart(i,iint),iscpend(i,iint)
12765           itypj=itype(j)
12766           if (itypj.eq.ntyp1) cycle
12767 ! Uncomment following three lines for SC-p interactions
12768 !         xj=c(1,nres+j)-xi
12769 !         yj=c(2,nres+j)-yi
12770 !         zj=c(3,nres+j)-zi
12771 ! Uncomment following three lines for Ca-p interactions
12772           xj=c(1,j)-xi
12773           yj=c(2,j)-yi
12774           zj=c(3,j)-zi
12775           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12776
12777           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
12778
12779           if (sss.lt.1.0d0) then
12780
12781             fac=rrij**expon2
12782             e1=fac*fac*aad(itypj,iteli)
12783             e2=fac*bad(itypj,iteli)
12784             if (iabs(j-i) .le. 2) then
12785               e1=scal14*e1
12786               e2=scal14*e2
12787               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
12788             endif
12789             evdwij=e1+e2
12790             evdw2=evdw2+evdwij*(1.0d0-sss)
12791             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
12792                 'evdw2',i,j,sss,evdwij
12793 !
12794 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
12795 !
12796             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
12797             ggg(1)=xj*fac
12798             ggg(2)=yj*fac
12799             ggg(3)=zj*fac
12800 ! Uncomment following three lines for SC-p interactions
12801 !           do k=1,3
12802 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12803 !           enddo
12804 ! Uncomment following line for SC-p interactions
12805 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12806             do k=1,3
12807               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
12808               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
12809             enddo
12810           endif
12811         enddo
12812
12813         enddo ! iint
12814       enddo ! i
12815       do i=1,nct
12816         do j=1,3
12817           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
12818           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
12819           gradx_scp(j,i)=expon*gradx_scp(j,i)
12820         enddo
12821       enddo
12822 !******************************************************************************
12823 !
12824 !                              N O T E !!!
12825 !
12826 ! To save time the factor EXPON has been extracted from ALL components
12827 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12828 ! use!
12829 !
12830 !******************************************************************************
12831       return
12832       end subroutine escp_long
12833 !-----------------------------------------------------------------------------
12834       subroutine escp_short(evdw2,evdw2_14)
12835 !
12836 ! This subroutine calculates the excluded-volume interaction energy between
12837 ! peptide-group centers and side chains and its gradient in virtual-bond and
12838 ! side-chain vectors.
12839 !
12840 !      implicit real*8 (a-h,o-z)
12841 !      include 'DIMENSIONS'
12842 !      include 'COMMON.GEO'
12843 !      include 'COMMON.VAR'
12844 !      include 'COMMON.LOCAL'
12845 !      include 'COMMON.CHAIN'
12846 !      include 'COMMON.DERIV'
12847 !      include 'COMMON.INTERACT'
12848 !      include 'COMMON.FFIELD'
12849 !      include 'COMMON.IOUNITS'
12850 !      include 'COMMON.CONTROL'
12851       real(kind=8),dimension(3) :: ggg
12852 !el local variables
12853       integer :: i,iint,j,k,iteli,itypj
12854       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
12855       real(kind=8) :: evdw2,evdw2_14,evdwij
12856       evdw2=0.0D0
12857       evdw2_14=0.0d0
12858 !d    print '(a)','Enter ESCP'
12859 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
12860       do i=iatscp_s,iatscp_e
12861         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12862         iteli=itel(i)
12863         xi=0.5D0*(c(1,i)+c(1,i+1))
12864         yi=0.5D0*(c(2,i)+c(2,i+1))
12865         zi=0.5D0*(c(3,i)+c(3,i+1))
12866
12867         do iint=1,nscp_gr(i)
12868
12869         do j=iscpstart(i,iint),iscpend(i,iint)
12870           itypj=itype(j)
12871           if (itypj.eq.ntyp1) cycle
12872 ! Uncomment following three lines for SC-p interactions
12873 !         xj=c(1,nres+j)-xi
12874 !         yj=c(2,nres+j)-yi
12875 !         zj=c(3,nres+j)-zi
12876 ! Uncomment following three lines for Ca-p interactions
12877           xj=c(1,j)-xi
12878           yj=c(2,j)-yi
12879           zj=c(3,j)-zi
12880           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12881
12882           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
12883
12884           if (sss.gt.0.0d0) then
12885
12886             fac=rrij**expon2
12887             e1=fac*fac*aad(itypj,iteli)
12888             e2=fac*bad(itypj,iteli)
12889             if (iabs(j-i) .le. 2) then
12890               e1=scal14*e1
12891               e2=scal14*e2
12892               evdw2_14=evdw2_14+(e1+e2)*sss
12893             endif
12894             evdwij=e1+e2
12895             evdw2=evdw2+evdwij*sss
12896             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
12897                 'evdw2',i,j,sss,evdwij
12898 !
12899 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
12900 !
12901             fac=-(evdwij+e1)*rrij*sss
12902             ggg(1)=xj*fac
12903             ggg(2)=yj*fac
12904             ggg(3)=zj*fac
12905 ! Uncomment following three lines for SC-p interactions
12906 !           do k=1,3
12907 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12908 !           enddo
12909 ! Uncomment following line for SC-p interactions
12910 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
12911             do k=1,3
12912               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
12913               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
12914             enddo
12915           endif
12916         enddo
12917
12918         enddo ! iint
12919       enddo ! i
12920       do i=1,nct
12921         do j=1,3
12922           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
12923           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
12924           gradx_scp(j,i)=expon*gradx_scp(j,i)
12925         enddo
12926       enddo
12927 !******************************************************************************
12928 !
12929 !                              N O T E !!!
12930 !
12931 ! To save time the factor EXPON has been extracted from ALL components
12932 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12933 ! use!
12934 !
12935 !******************************************************************************
12936       return
12937       end subroutine escp_short
12938 !-----------------------------------------------------------------------------
12939 ! energy_p_new-sep_barrier.F
12940 !-----------------------------------------------------------------------------
12941       subroutine sc_grad_scale(scalfac)
12942 !      implicit real*8 (a-h,o-z)
12943       use calc_data
12944 !      include 'DIMENSIONS'
12945 !      include 'COMMON.CHAIN'
12946 !      include 'COMMON.DERIV'
12947 !      include 'COMMON.CALC'
12948 !      include 'COMMON.IOUNITS'
12949       real(kind=8),dimension(3) :: dcosom1,dcosom2
12950       real(kind=8) :: scalfac
12951 !el local variables
12952 !      integer :: i,j,k,l
12953
12954       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
12955       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
12956       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12957            -2.0D0*alf12*eps3der+sigder*sigsq_om12
12958 ! diagnostics only
12959 !      eom1=0.0d0
12960 !      eom2=0.0d0
12961 !      eom12=evdwij*eps1_om12
12962 ! end diagnostics
12963 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
12964 !     &  " sigder",sigder
12965 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
12966 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
12967       do k=1,3
12968         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12969         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
12970       enddo
12971       do k=1,3
12972         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac
12973       enddo
12974 !      write (iout,*) "gg",(gg(k),k=1,3)
12975       do k=1,3
12976         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
12977                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12978                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac
12979         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
12980                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12981                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac
12982 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
12983 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12984 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
12985 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12986       enddo
12987 !
12988 ! Calculate the components of the gradient in DC and X
12989 !
12990       do l=1,3
12991         gvdwc(l,i)=gvdwc(l,i)-gg(l)
12992         gvdwc(l,j)=gvdwc(l,j)+gg(l)
12993       enddo
12994       return
12995       end subroutine sc_grad_scale
12996 !-----------------------------------------------------------------------------
12997 ! energy_split-sep.F
12998 !-----------------------------------------------------------------------------
12999       subroutine etotal_long(energia)
13000 !
13001 ! Compute the long-range slow-varying contributions to the energy
13002 !
13003 !      implicit real*8 (a-h,o-z)
13004 !      include 'DIMENSIONS'
13005       use MD_data, only: totT
13006 #ifndef ISNAN
13007       external proc_proc
13008 #ifdef WINPGI
13009 !MS$ATTRIBUTES C ::  proc_proc
13010 #endif
13011 #endif
13012 #ifdef MPI
13013       include "mpif.h"
13014       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13015 #endif
13016 !      include 'COMMON.SETUP'
13017 !      include 'COMMON.IOUNITS'
13018 !      include 'COMMON.FFIELD'
13019 !      include 'COMMON.DERIV'
13020 !      include 'COMMON.INTERACT'
13021 !      include 'COMMON.SBRIDGE'
13022 !      include 'COMMON.CHAIN'
13023 !      include 'COMMON.VAR'
13024 !      include 'COMMON.LOCAL'
13025 !      include 'COMMON.MD'
13026       real(kind=8),dimension(0:n_ene) :: energia
13027 !el local variables
13028       integer :: i,n_corr,n_corr1,ierror,ierr
13029       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13030                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13031                   ecorr,ecorr5,ecorr6,eturn6,time00
13032 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13033 !elwrite(iout,*)"in etotal long"
13034
13035       if (modecalc.eq.12.or.modecalc.eq.14) then
13036 #ifdef MPI
13037 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13038 #else
13039         call int_from_cart1(.false.)
13040 #endif
13041       endif
13042 !elwrite(iout,*)"in etotal long"
13043
13044 #ifdef MPI
13045 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13046 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13047       call flush(iout)
13048       if (nfgtasks.gt.1) then
13049         time00=MPI_Wtime()
13050 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13051         if (fg_rank.eq.0) then
13052           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13053 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13054 !          call flush(iout)
13055 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13056 ! FG slaves as WEIGHTS array.
13057           weights_(1)=wsc
13058           weights_(2)=wscp
13059           weights_(3)=welec
13060           weights_(4)=wcorr
13061           weights_(5)=wcorr5
13062           weights_(6)=wcorr6
13063           weights_(7)=wel_loc
13064           weights_(8)=wturn3
13065           weights_(9)=wturn4
13066           weights_(10)=wturn6
13067           weights_(11)=wang
13068           weights_(12)=wscloc
13069           weights_(13)=wtor
13070           weights_(14)=wtor_d
13071           weights_(15)=wstrain
13072           weights_(16)=wvdwpp
13073           weights_(17)=wbond
13074           weights_(18)=scal14
13075           weights_(21)=wsccor
13076 ! FG Master broadcasts the WEIGHTS_ array
13077           call MPI_Bcast(weights_(1),n_ene,&
13078               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13079         else
13080 ! FG slaves receive the WEIGHTS array
13081           call MPI_Bcast(weights(1),n_ene,&
13082               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13083           wsc=weights(1)
13084           wscp=weights(2)
13085           welec=weights(3)
13086           wcorr=weights(4)
13087           wcorr5=weights(5)
13088           wcorr6=weights(6)
13089           wel_loc=weights(7)
13090           wturn3=weights(8)
13091           wturn4=weights(9)
13092           wturn6=weights(10)
13093           wang=weights(11)
13094           wscloc=weights(12)
13095           wtor=weights(13)
13096           wtor_d=weights(14)
13097           wstrain=weights(15)
13098           wvdwpp=weights(16)
13099           wbond=weights(17)
13100           scal14=weights(18)
13101           wsccor=weights(21)
13102         endif
13103         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13104           king,FG_COMM,IERR)
13105          time_Bcast=time_Bcast+MPI_Wtime()-time00
13106          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13107 !        call chainbuild_cart
13108 !        call int_from_cart1(.false.)
13109       endif
13110 !      write (iout,*) 'Processor',myrank,
13111 !     &  ' calling etotal_short ipot=',ipot
13112 !      call flush(iout)
13113 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13114 #endif
13115 !d    print *,'nnt=',nnt,' nct=',nct
13116 !
13117 !elwrite(iout,*)"in etotal long"
13118 ! Compute the side-chain and electrostatic interaction energy
13119 !
13120       goto (101,102,103,104,105,106) ipot
13121 ! Lennard-Jones potential.
13122   101 call elj_long(evdw)
13123 !d    print '(a)','Exit ELJ'
13124       goto 107
13125 ! Lennard-Jones-Kihara potential (shifted).
13126   102 call eljk_long(evdw)
13127       goto 107
13128 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13129   103 call ebp_long(evdw)
13130       goto 107
13131 ! Gay-Berne potential (shifted LJ, angular dependence).
13132   104 call egb_long(evdw)
13133       goto 107
13134 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13135   105 call egbv_long(evdw)
13136       goto 107
13137 ! Soft-sphere potential
13138   106 call e_softsphere(evdw)
13139 !
13140 ! Calculate electrostatic (H-bonding) energy of the main chain.
13141 !
13142   107 continue
13143       call vec_and_deriv
13144       if (ipot.lt.6) then
13145 #ifdef SPLITELE
13146          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13147              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13148              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13149              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13150 #else
13151          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13152              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13153              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13154              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13155 #endif
13156            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13157          else
13158             ees=0
13159             evdw1=0
13160             eel_loc=0
13161             eello_turn3=0
13162             eello_turn4=0
13163          endif
13164       else
13165 !        write (iout,*) "Soft-spheer ELEC potential"
13166         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13167          eello_turn4)
13168       endif
13169 !
13170 ! Calculate excluded-volume interaction energy between peptide groups
13171 ! and side chains.
13172 !
13173       if (ipot.lt.6) then
13174        if(wscp.gt.0d0) then
13175         call escp_long(evdw2,evdw2_14)
13176        else
13177         evdw2=0
13178         evdw2_14=0
13179        endif
13180       else
13181         call escp_soft_sphere(evdw2,evdw2_14)
13182       endif
13183 !
13184 ! 12/1/95 Multi-body terms
13185 !
13186       n_corr=0
13187       n_corr1=0
13188       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13189           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13190          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13191 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13192 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13193       else
13194          ecorr=0.0d0
13195          ecorr5=0.0d0
13196          ecorr6=0.0d0
13197          eturn6=0.0d0
13198       endif
13199       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13200          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13201       endif
13202 !
13203 ! If performing constraint dynamics, call the constraint energy
13204 !  after the equilibration time
13205       if(usampl.and.totT.gt.eq_time) then
13206          call EconstrQ
13207          call Econstr_back
13208       else
13209          Uconst=0.0d0
13210          Uconst_back=0.0d0
13211       endif
13212 !
13213 ! Sum the energies
13214 !
13215       do i=1,n_ene
13216         energia(i)=0.0d0
13217       enddo
13218       energia(1)=evdw
13219 #ifdef SCP14
13220       energia(2)=evdw2-evdw2_14
13221       energia(18)=evdw2_14
13222 #else
13223       energia(2)=evdw2
13224       energia(18)=0.0d0
13225 #endif
13226 #ifdef SPLITELE
13227       energia(3)=ees
13228       energia(16)=evdw1
13229 #else
13230       energia(3)=ees+evdw1
13231       energia(16)=0.0d0
13232 #endif
13233       energia(4)=ecorr
13234       energia(5)=ecorr5
13235       energia(6)=ecorr6
13236       energia(7)=eel_loc
13237       energia(8)=eello_turn3
13238       energia(9)=eello_turn4
13239       energia(10)=eturn6
13240       energia(20)=Uconst+Uconst_back
13241       call sum_energy(energia,.true.)
13242 !      write (iout,*) "Exit ETOTAL_LONG"
13243       call flush(iout)
13244       return
13245       end subroutine etotal_long
13246 !-----------------------------------------------------------------------------
13247       subroutine etotal_short(energia)
13248 !
13249 ! Compute the short-range fast-varying contributions to the energy
13250 !
13251 !      implicit real*8 (a-h,o-z)
13252 !      include 'DIMENSIONS'
13253 #ifndef ISNAN
13254       external proc_proc
13255 #ifdef WINPGI
13256 !MS$ATTRIBUTES C ::  proc_proc
13257 #endif
13258 #endif
13259 #ifdef MPI
13260       include "mpif.h"
13261       integer :: ierror,ierr
13262       real(kind=8),dimension(n_ene) :: weights_
13263       real(kind=8) :: time00
13264 #endif
13265 !      include 'COMMON.SETUP'
13266 !      include 'COMMON.IOUNITS'
13267 !      include 'COMMON.FFIELD'
13268 !      include 'COMMON.DERIV'
13269 !      include 'COMMON.INTERACT'
13270 !      include 'COMMON.SBRIDGE'
13271 !      include 'COMMON.CHAIN'
13272 !      include 'COMMON.VAR'
13273 !      include 'COMMON.LOCAL'
13274       real(kind=8),dimension(0:n_ene) :: energia
13275 !el local variables
13276       integer :: i,nres6
13277       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13278       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13279       nres6=6*nres
13280
13281 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13282 !      call flush(iout)
13283       if (modecalc.eq.12.or.modecalc.eq.14) then
13284 #ifdef MPI
13285         if (fg_rank.eq.0) call int_from_cart1(.false.)
13286 #else
13287         call int_from_cart1(.false.)
13288 #endif
13289       endif
13290 #ifdef MPI
13291 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13292 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13293 !      call flush(iout)
13294       if (nfgtasks.gt.1) then
13295         time00=MPI_Wtime()
13296 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13297         if (fg_rank.eq.0) then
13298           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13299 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13300 !          call flush(iout)
13301 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13302 ! FG slaves as WEIGHTS array.
13303           weights_(1)=wsc
13304           weights_(2)=wscp
13305           weights_(3)=welec
13306           weights_(4)=wcorr
13307           weights_(5)=wcorr5
13308           weights_(6)=wcorr6
13309           weights_(7)=wel_loc
13310           weights_(8)=wturn3
13311           weights_(9)=wturn4
13312           weights_(10)=wturn6
13313           weights_(11)=wang
13314           weights_(12)=wscloc
13315           weights_(13)=wtor
13316           weights_(14)=wtor_d
13317           weights_(15)=wstrain
13318           weights_(16)=wvdwpp
13319           weights_(17)=wbond
13320           weights_(18)=scal14
13321           weights_(21)=wsccor
13322 ! FG Master broadcasts the WEIGHTS_ array
13323           call MPI_Bcast(weights_(1),n_ene,&
13324               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13325         else
13326 ! FG slaves receive the WEIGHTS array
13327           call MPI_Bcast(weights(1),n_ene,&
13328               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13329           wsc=weights(1)
13330           wscp=weights(2)
13331           welec=weights(3)
13332           wcorr=weights(4)
13333           wcorr5=weights(5)
13334           wcorr6=weights(6)
13335           wel_loc=weights(7)
13336           wturn3=weights(8)
13337           wturn4=weights(9)
13338           wturn6=weights(10)
13339           wang=weights(11)
13340           wscloc=weights(12)
13341           wtor=weights(13)
13342           wtor_d=weights(14)
13343           wstrain=weights(15)
13344           wvdwpp=weights(16)
13345           wbond=weights(17)
13346           scal14=weights(18)
13347           wsccor=weights(21)
13348         endif
13349 !        write (iout,*),"Processor",myrank," BROADCAST weights"
13350         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
13351           king,FG_COMM,IERR)
13352 !        write (iout,*) "Processor",myrank," BROADCAST c"
13353         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
13354           king,FG_COMM,IERR)
13355 !        write (iout,*) "Processor",myrank," BROADCAST dc"
13356         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
13357           king,FG_COMM,IERR)
13358 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
13359         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
13360           king,FG_COMM,IERR)
13361 !        write (iout,*) "Processor",myrank," BROADCAST theta"
13362         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
13363           king,FG_COMM,IERR)
13364 !        write (iout,*) "Processor",myrank," BROADCAST phi"
13365         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
13366           king,FG_COMM,IERR)
13367 !        write (iout,*) "Processor",myrank," BROADCAST alph"
13368         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
13369           king,FG_COMM,IERR)
13370 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
13371         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
13372           king,FG_COMM,IERR)
13373 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
13374         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
13375           king,FG_COMM,IERR)
13376          time_Bcast=time_Bcast+MPI_Wtime()-time00
13377 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
13378       endif
13379 !      write (iout,*) 'Processor',myrank,
13380 !     &  ' calling etotal_short ipot=',ipot
13381 !      call flush(iout)
13382 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13383 #endif
13384 !      call int_from_cart1(.false.)
13385 !
13386 ! Compute the side-chain and electrostatic interaction energy
13387 !
13388       goto (101,102,103,104,105,106) ipot
13389 ! Lennard-Jones potential.
13390   101 call elj_short(evdw)
13391 !d    print '(a)','Exit ELJ'
13392       goto 107
13393 ! Lennard-Jones-Kihara potential (shifted).
13394   102 call eljk_short(evdw)
13395       goto 107
13396 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13397   103 call ebp_short(evdw)
13398       goto 107
13399 ! Gay-Berne potential (shifted LJ, angular dependence).
13400   104 call egb_short(evdw)
13401       goto 107
13402 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13403   105 call egbv_short(evdw)
13404       goto 107
13405 ! Soft-sphere potential - already dealt with in the long-range part
13406   106 evdw=0.0d0
13407 !  106 call e_softsphere_short(evdw)
13408 !
13409 ! Calculate electrostatic (H-bonding) energy of the main chain.
13410 !
13411   107 continue
13412 !
13413 ! Calculate the short-range part of Evdwpp
13414 !
13415       call evdwpp_short(evdw1)
13416 !
13417 ! Calculate the short-range part of ESCp
13418 !
13419       if (ipot.lt.6) then
13420         call escp_short(evdw2,evdw2_14)
13421       endif
13422 !
13423 ! Calculate the bond-stretching energy
13424 !
13425       call ebond(estr)
13426 !
13427 ! Calculate the disulfide-bridge and other energy and the contributions
13428 ! from other distance constraints.
13429       call edis(ehpb)
13430 !
13431 ! Calculate the virtual-bond-angle energy.
13432 !
13433       call ebend(ebe)
13434 !
13435 ! Calculate the SC local energy.
13436 !
13437       call vec_and_deriv
13438       call esc(escloc)
13439 !
13440 ! Calculate the virtual-bond torsional energy.
13441 !
13442       call etor(etors,edihcnstr)
13443 !
13444 ! 6/23/01 Calculate double-torsional energy
13445 !
13446       call etor_d(etors_d)
13447 !
13448 ! 21/5/07 Calculate local sicdechain correlation energy
13449 !
13450       if (wsccor.gt.0.0d0) then
13451         call eback_sc_corr(esccor)
13452       else
13453         esccor=0.0d0
13454       endif
13455 !
13456 ! Put energy components into an array
13457 !
13458       do i=1,n_ene
13459         energia(i)=0.0d0
13460       enddo
13461       energia(1)=evdw
13462 #ifdef SCP14
13463       energia(2)=evdw2-evdw2_14
13464       energia(18)=evdw2_14
13465 #else
13466       energia(2)=evdw2
13467       energia(18)=0.0d0
13468 #endif
13469 #ifdef SPLITELE
13470       energia(16)=evdw1
13471 #else
13472       energia(3)=evdw1
13473 #endif
13474       energia(11)=ebe
13475       energia(12)=escloc
13476       energia(13)=etors
13477       energia(14)=etors_d
13478       energia(15)=ehpb
13479       energia(17)=estr
13480       energia(19)=edihcnstr
13481       energia(21)=esccor
13482 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
13483       call flush(iout)
13484       call sum_energy(energia,.true.)
13485 !      write (iout,*) "Exit ETOTAL_SHORT"
13486       call flush(iout)
13487       return
13488       end subroutine etotal_short
13489 !-----------------------------------------------------------------------------
13490 ! gnmr1.f
13491 !-----------------------------------------------------------------------------
13492       real(kind=8) function gnmr1(y,ymin,ymax)
13493 !      implicit none
13494       real(kind=8) :: y,ymin,ymax
13495       real(kind=8) :: wykl=4.0d0
13496       if (y.lt.ymin) then
13497         gnmr1=(ymin-y)**wykl/wykl
13498       else if (y.gt.ymax) then
13499         gnmr1=(y-ymax)**wykl/wykl
13500       else
13501         gnmr1=0.0d0
13502       endif
13503       return
13504       end function gnmr1
13505 !-----------------------------------------------------------------------------
13506       real(kind=8) function gnmr1prim(y,ymin,ymax)
13507 !      implicit none
13508       real(kind=8) :: y,ymin,ymax
13509       real(kind=8) :: wykl=4.0d0
13510       if (y.lt.ymin) then
13511         gnmr1prim=-(ymin-y)**(wykl-1)
13512       else if (y.gt.ymax) then
13513         gnmr1prim=(y-ymax)**(wykl-1)
13514       else
13515         gnmr1prim=0.0d0
13516       endif
13517       return
13518       end function gnmr1prim
13519 !-----------------------------------------------------------------------------
13520       real(kind=8) function harmonic(y,ymax)
13521 !      implicit none
13522       real(kind=8) :: y,ymax
13523       real(kind=8) :: wykl=2.0d0
13524       harmonic=(y-ymax)**wykl
13525       return
13526       end function harmonic
13527 !-----------------------------------------------------------------------------
13528       real(kind=8) function harmonicprim(y,ymax)
13529       real(kind=8) :: y,ymin,ymax
13530       real(kind=8) :: wykl=2.0d0
13531       harmonicprim=(y-ymax)*wykl
13532       return
13533       end function harmonicprim
13534 !-----------------------------------------------------------------------------
13535 ! gradient_p.F
13536 !-----------------------------------------------------------------------------
13537       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
13538
13539       use io_base, only:intout,briefout
13540 !      implicit real*8 (a-h,o-z)
13541 !      include 'DIMENSIONS'
13542 !      include 'COMMON.CHAIN'
13543 !      include 'COMMON.DERIV'
13544 !      include 'COMMON.VAR'
13545 !      include 'COMMON.INTERACT'
13546 !      include 'COMMON.FFIELD'
13547 !      include 'COMMON.MD'
13548 !      include 'COMMON.IOUNITS'
13549       real(kind=8),external :: ufparm
13550       integer :: uiparm(1)
13551       real(kind=8) :: urparm(1)
13552       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13553       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
13554       integer :: n,nf,ind,ind1,i,k,j
13555 !
13556 ! This subroutine calculates total internal coordinate gradient.
13557 ! Depending on the number of function evaluations, either whole energy
13558 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
13559 ! internal coordinates are reevaluated or only the cartesian-in-internal
13560 ! coordinate derivatives are evaluated. The subroutine was designed to work
13561 ! with SUMSL.
13562 !
13563 !
13564       icg=mod(nf,2)+1
13565
13566 !d      print *,'grad',nf,icg
13567       if (nf-nfl+1) 20,30,40
13568    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
13569 !    write (iout,*) 'grad 20'
13570       if (nf.eq.0) return
13571       goto 40
13572    30 call var_to_geom(n,x)
13573       call chainbuild
13574 !    write (iout,*) 'grad 30'
13575 !
13576 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
13577 !
13578    40 call cartder
13579 !     write (iout,*) 'grad 40'
13580 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
13581 !
13582 ! Convert the Cartesian gradient into internal-coordinate gradient.
13583 !
13584       ind=0
13585       ind1=0
13586       do i=1,nres-2
13587         gthetai=0.0D0
13588         gphii=0.0D0
13589         do j=i+1,nres-1
13590           ind=ind+1
13591 !         ind=indmat(i,j)
13592 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
13593           do k=1,3
13594             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
13595           enddo
13596           do k=1,3
13597             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
13598           enddo
13599         enddo
13600         do j=i+1,nres-1
13601           ind1=ind1+1
13602 !         ind1=indmat(i,j)
13603 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
13604           do k=1,3
13605             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
13606             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
13607           enddo
13608         enddo
13609         if (i.gt.1) g(i-1)=gphii
13610         if (n.gt.nphi) g(nphi+i)=gthetai
13611       enddo
13612       if (n.le.nphi+ntheta) goto 10
13613       do i=2,nres-1
13614         if (itype(i).ne.10) then
13615           galphai=0.0D0
13616           gomegai=0.0D0
13617           do k=1,3
13618             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
13619           enddo
13620           do k=1,3
13621             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
13622           enddo
13623           g(ialph(i,1))=galphai
13624           g(ialph(i,1)+nside)=gomegai
13625         endif
13626       enddo
13627 !
13628 ! Add the components corresponding to local energy terms.
13629 !
13630    10 continue
13631       do i=1,nvar
13632 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
13633         g(i)=g(i)+gloc(i,icg)
13634       enddo
13635 ! Uncomment following three lines for diagnostics.
13636 !d    call intout
13637 !elwrite(iout,*) "in gradient after calling intout"
13638 !d    call briefout(0,0.0d0)
13639 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
13640       return
13641       end subroutine gradient
13642 !-----------------------------------------------------------------------------
13643       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
13644
13645       use comm_chu
13646 !      implicit real*8 (a-h,o-z)
13647 !      include 'DIMENSIONS'
13648 !      include 'COMMON.DERIV'
13649 !      include 'COMMON.IOUNITS'
13650 !      include 'COMMON.GEO'
13651       integer :: n,nf
13652 !el      integer :: jjj
13653 !el      common /chuju/ jjj
13654       real(kind=8) :: energia(0:n_ene)
13655       integer :: uiparm(1)
13656       real(kind=8) :: urparm(1)
13657       real(kind=8) :: f
13658       real(kind=8),external :: ufparm
13659       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
13660 !     if (jjj.gt.0) then
13661 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13662 !     endif
13663       nfl=nf
13664       icg=mod(nf,2)+1
13665 !d      print *,'func',nf,nfl,icg
13666       call var_to_geom(n,x)
13667       call zerograd
13668       call chainbuild
13669 !d    write (iout,*) 'ETOTAL called from FUNC'
13670       call etotal(energia)
13671       call sum_gradient
13672       f=energia(0)
13673 !     if (jjj.gt.0) then
13674 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
13675 !       write (iout,*) 'f=',etot
13676 !       jjj=0
13677 !     endif
13678       return
13679       end subroutine func
13680 !-----------------------------------------------------------------------------
13681       subroutine cartgrad
13682 !      implicit real*8 (a-h,o-z)
13683 !      include 'DIMENSIONS'
13684       use energy_data
13685       use MD_data, only: totT
13686 #ifdef MPI
13687       include 'mpif.h'
13688 #endif
13689 !      include 'COMMON.CHAIN'
13690 !      include 'COMMON.DERIV'
13691 !      include 'COMMON.VAR'
13692 !      include 'COMMON.INTERACT'
13693 !      include 'COMMON.FFIELD'
13694 !      include 'COMMON.MD'
13695 !      include 'COMMON.IOUNITS'
13696 !      include 'COMMON.TIME1'
13697 !
13698       integer :: i,j
13699
13700 ! This subrouting calculates total Cartesian coordinate gradient.
13701 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
13702 !
13703 !el#define DEBUG
13704 #ifdef TIMING
13705       time00=MPI_Wtime()
13706 #endif
13707       icg=1
13708       call sum_gradient
13709 #ifdef TIMING
13710 #endif
13711 #ifdef DEBUG
13712       do i=1,nres-1
13713         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
13714         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
13715       enddo
13716 #endif
13717 ! If performing constraint dynamics, add the gradients of the constraint energy
13718       if(usampl.and.totT.gt.eq_time) then
13719          do i=1,nct
13720            do j=1,3
13721              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
13722              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
13723            enddo
13724          enddo
13725          do i=1,nres-3
13726            gloc(i,icg)=gloc(i,icg)+dugamma(i)
13727          enddo
13728          do i=1,nres-2
13729            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
13730          enddo
13731       endif
13732 #ifdef TIMING
13733       time01=MPI_Wtime()
13734 #endif
13735       call intcartderiv
13736 #ifdef TIMING
13737       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
13738 #endif
13739 !     call checkintcartgrad
13740 !     write(iout,*) 'calling int_to_cart'
13741 #ifdef DEBUG
13742       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
13743 #endif
13744       do i=1,nct
13745         do j=1,3
13746           gcart(j,i)=gradc(j,i,icg)
13747           gxcart(j,i)=gradx(j,i,icg)
13748         enddo
13749 #ifdef DEBUG
13750         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
13751           (gxcart(j,i),j=1,3),gloc(i,icg)
13752 #endif
13753       enddo
13754 #ifdef TIMING
13755       time01=MPI_Wtime()
13756 #endif
13757       call int_to_cart
13758 #ifdef TIMING
13759       time_inttocart=time_inttocart+MPI_Wtime()-time01
13760 #endif
13761 #ifdef DEBUG
13762       write (iout,*) "gcart and gxcart after int_to_cart"
13763       do i=0,nres-1
13764         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13765             (gxcart(j,i),j=1,3)
13766       enddo
13767 #endif
13768 #ifdef TIMING
13769       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
13770 #endif
13771 !el#undef DEBUG
13772       return
13773       end subroutine cartgrad
13774 !-----------------------------------------------------------------------------
13775       subroutine zerograd
13776 !      implicit real*8 (a-h,o-z)
13777 !      include 'DIMENSIONS'
13778 !      include 'COMMON.DERIV'
13779 !      include 'COMMON.CHAIN'
13780 !      include 'COMMON.VAR'
13781 !      include 'COMMON.MD'
13782 !      include 'COMMON.SCCOR'
13783 !
13784 !el local variables
13785       integer :: i,j,intertyp
13786 ! Initialize Cartesian-coordinate gradient
13787 !
13788 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
13789 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
13790
13791 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
13792 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
13793 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
13794 !      allocate(gradcorr_long(3,nres))
13795 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
13796 !      allocate(gcorr6_turn_long(3,nres))
13797 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
13798
13799 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
13800
13801 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
13802 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
13803
13804 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
13805 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
13806
13807 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
13808 !      allocate(gscloc(3,nres)) !(3,maxres)
13809 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
13810
13811
13812
13813 !      common /deriv_scloc/
13814 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
13815 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
13816 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
13817 !      common /mpgrad/
13818 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
13819
13820
13821
13822 !          gradc(j,i,icg)=0.0d0
13823 !          gradx(j,i,icg)=0.0d0
13824
13825 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
13826 !elwrite(iout,*) "icg",icg
13827       do i=1,nres
13828         do j=1,3
13829           gvdwx(j,i)=0.0D0
13830           gradx_scp(j,i)=0.0D0
13831           gvdwc(j,i)=0.0D0
13832           gvdwc_scp(j,i)=0.0D0
13833           gvdwc_scpp(j,i)=0.0d0
13834           gelc(j,i)=0.0D0
13835           gelc_long(j,i)=0.0D0
13836           gradb(j,i)=0.0d0
13837           gradbx(j,i)=0.0d0
13838           gvdwpp(j,i)=0.0d0
13839           gel_loc(j,i)=0.0d0
13840           gel_loc_long(j,i)=0.0d0
13841           ghpbc(j,i)=0.0D0
13842           ghpbx(j,i)=0.0D0
13843           gcorr3_turn(j,i)=0.0d0
13844           gcorr4_turn(j,i)=0.0d0
13845           gradcorr(j,i)=0.0d0
13846           gradcorr_long(j,i)=0.0d0
13847           gradcorr5_long(j,i)=0.0d0
13848           gradcorr6_long(j,i)=0.0d0
13849           gcorr6_turn_long(j,i)=0.0d0
13850           gradcorr5(j,i)=0.0d0
13851           gradcorr6(j,i)=0.0d0
13852           gcorr6_turn(j,i)=0.0d0
13853           gsccorc(j,i)=0.0d0
13854           gsccorx(j,i)=0.0d0
13855           gradc(j,i,icg)=0.0d0
13856           gradx(j,i,icg)=0.0d0
13857           gscloc(j,i)=0.0d0
13858           gsclocx(j,i)=0.0d0
13859           do intertyp=1,3
13860            gloc_sc(intertyp,i,icg)=0.0d0
13861           enddo
13862         enddo
13863       enddo
13864 !
13865 ! Initialize the gradient of local energy terms.
13866 !
13867 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
13868 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13869 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13870 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
13871 !      allocate(gel_loc_turn3(nres))
13872 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
13873 !      allocate(gsccor_loc(nres))       !(maxres)
13874
13875       do i=1,4*nres
13876         gloc(i,icg)=0.0D0
13877       enddo
13878       do i=1,nres
13879         gel_loc_loc(i)=0.0d0
13880         gcorr_loc(i)=0.0d0
13881         g_corr5_loc(i)=0.0d0
13882         g_corr6_loc(i)=0.0d0
13883         gel_loc_turn3(i)=0.0d0
13884         gel_loc_turn4(i)=0.0d0
13885         gel_loc_turn6(i)=0.0d0
13886         gsccor_loc(i)=0.0d0
13887       enddo
13888 ! initialize gcart and gxcart
13889 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
13890       do i=0,nres
13891         do j=1,3
13892           gcart(j,i)=0.0d0
13893           gxcart(j,i)=0.0d0
13894         enddo
13895       enddo
13896       return
13897       end subroutine zerograd
13898 !-----------------------------------------------------------------------------
13899       real(kind=8) function fdum()
13900       fdum=0.0D0
13901       return
13902       end function fdum
13903 !-----------------------------------------------------------------------------
13904 ! intcartderiv.F
13905 !-----------------------------------------------------------------------------
13906       subroutine intcartderiv
13907 !      implicit real*8 (a-h,o-z)
13908 !      include 'DIMENSIONS'
13909 #ifdef MPI
13910       include 'mpif.h'
13911 #endif
13912 !      include 'COMMON.SETUP'
13913 !      include 'COMMON.CHAIN'
13914 !      include 'COMMON.VAR'
13915 !      include 'COMMON.GEO'
13916 !      include 'COMMON.INTERACT'
13917 !      include 'COMMON.DERIV'
13918 !      include 'COMMON.IOUNITS'
13919 !      include 'COMMON.LOCAL'
13920 !      include 'COMMON.SCCOR'
13921       real(kind=8) :: pi4,pi34
13922       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
13923       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
13924                     dcosomega,dsinomega !(3,3,maxres)
13925       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
13926
13927       integer :: i,j,k
13928       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
13929                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
13930                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
13931                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
13932       integer :: nres2
13933       nres2=2*nres
13934
13935 !el from module energy-------------
13936 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
13937 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
13938 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
13939
13940 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
13941 !el      allocate(dsintau(3,3,3,0:nres2))
13942 !el      allocate(dtauangle(3,3,3,0:nres2))
13943 !el      allocate(domicron(3,2,2,0:nres2))
13944 !el      allocate(dcosomicron(3,2,2,0:nres2))
13945
13946
13947
13948 #if defined(MPI) && defined(PARINTDER)
13949       if (nfgtasks.gt.1 .and. me.eq.king) &
13950         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
13951 #endif
13952       pi4 = 0.5d0*pipol
13953       pi34 = 3*pi4
13954
13955 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
13956 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
13957
13958 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
13959       do i=1,nres
13960         do j=1,3
13961           dtheta(j,1,i)=0.0d0
13962           dtheta(j,2,i)=0.0d0
13963           dphi(j,1,i)=0.0d0
13964           dphi(j,2,i)=0.0d0
13965           dphi(j,3,i)=0.0d0
13966         enddo
13967       enddo
13968 ! Derivatives of theta's
13969 #if defined(MPI) && defined(PARINTDER)
13970 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
13971       do i=max0(ithet_start-1,3),ithet_end
13972 #else
13973       do i=3,nres
13974 #endif
13975         cost=dcos(theta(i))
13976         sint=sqrt(1-cost*cost)
13977         do j=1,3
13978           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
13979           vbld(i-1)
13980           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
13981           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
13982           vbld(i)
13983           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
13984         enddo
13985       enddo
13986 #if defined(MPI) && defined(PARINTDER)
13987 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
13988       do i=max0(ithet_start-1,3),ithet_end
13989 #else
13990       do i=3,nres
13991 #endif
13992       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
13993         cost1=dcos(omicron(1,i))
13994         sint1=sqrt(1-cost1*cost1)
13995         cost2=dcos(omicron(2,i))
13996         sint2=sqrt(1-cost2*cost2)
13997        do j=1,3
13998 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
13999           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14000           cost1*dc_norm(j,i-2))/ &
14001           vbld(i-1)
14002           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14003           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14004           +cost1*(dc_norm(j,i-1+nres)))/ &
14005           vbld(i-1+nres)
14006           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14007 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14008 !C Looks messy but better than if in loop
14009           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14010           +cost2*dc_norm(j,i-1))/ &
14011           vbld(i)
14012           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14013           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14014            +cost2*(-dc_norm(j,i-1+nres)))/ &
14015           vbld(i-1+nres)
14016 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14017           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14018         enddo
14019        endif
14020       enddo
14021 !elwrite(iout,*) "after vbld write"
14022 ! Derivatives of phi:
14023 ! If phi is 0 or 180 degrees, then the formulas
14024 ! have to be derived by power series expansion of the
14025 ! conventional formulas around 0 and 180.
14026 #ifdef PARINTDER
14027       do i=iphi1_start,iphi1_end
14028 #else
14029       do i=4,nres
14030 #endif
14031 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14032 ! the conventional case
14033         sint=dsin(theta(i))
14034         sint1=dsin(theta(i-1))
14035         sing=dsin(phi(i))
14036         cost=dcos(theta(i))
14037         cost1=dcos(theta(i-1))
14038         cosg=dcos(phi(i))
14039         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14040         fac0=1.0d0/(sint1*sint)
14041         fac1=cost*fac0
14042         fac2=cost1*fac0
14043         fac3=cosg*cost1/(sint1*sint1)
14044         fac4=cosg*cost/(sint*sint)
14045 !    Obtaining the gamma derivatives from sine derivative
14046        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14047            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14048            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14049          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14050          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14051          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14052          do j=1,3
14053             ctgt=cost/sint
14054             ctgt1=cost1/sint1
14055             cosg_inv=1.0d0/cosg
14056             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14057             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14058               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14059             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14060             dsinphi(j,2,i)= &
14061               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14062               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14063             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14064             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14065               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14066 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14067             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14068             endif
14069 ! Bug fixed 3/24/05 (AL)
14070          enddo
14071 !   Obtaining the gamma derivatives from cosine derivative
14072         else
14073            do j=1,3
14074            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14075            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14076            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14077            dc_norm(j,i-3))/vbld(i-2)
14078            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14079            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14080            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14081            dcostheta(j,1,i)
14082            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14083            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14084            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14085            dc_norm(j,i-1))/vbld(i)
14086            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14087            endif
14088          enddo
14089         endif
14090       enddo
14091 !alculate derivative of Tauangle
14092 #ifdef PARINTDER
14093       do i=itau_start,itau_end
14094 #else
14095       do i=3,nres
14096 !elwrite(iout,*) " vecpr",i,nres
14097 #endif
14098        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14099 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14100 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14101 !c dtauangle(j,intertyp,dervityp,residue number)
14102 !c INTERTYP=1 SC...Ca...Ca..Ca
14103 ! the conventional case
14104         sint=dsin(theta(i))
14105         sint1=dsin(omicron(2,i-1))
14106         sing=dsin(tauangle(1,i))
14107         cost=dcos(theta(i))
14108         cost1=dcos(omicron(2,i-1))
14109         cosg=dcos(tauangle(1,i))
14110         do j=1,3
14111         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14112 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14113         enddo
14114         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14115         fac0=1.0d0/(sint1*sint)
14116         fac1=cost*fac0
14117         fac2=cost1*fac0
14118         fac3=cosg*cost1/(sint1*sint1)
14119         fac4=cosg*cost/(sint*sint)
14120 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14121 !    Obtaining the gamma derivatives from sine derivative
14122        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14123            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14124            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14125          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14126          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14127          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14128         do j=1,3
14129             ctgt=cost/sint
14130             ctgt1=cost1/sint1
14131             cosg_inv=1.0d0/cosg
14132             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14133        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14134        *vbld_inv(i-2+nres)
14135             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14136             dsintau(j,1,2,i)= &
14137               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14138               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14139 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14140             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14141 ! Bug fixed 3/24/05 (AL)
14142             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14143               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14144 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14145             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14146          enddo
14147 !   Obtaining the gamma derivatives from cosine derivative
14148         else
14149            do j=1,3
14150            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14151            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14152            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14153            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14154            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14155            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14156            dcostheta(j,1,i)
14157            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14158            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14159            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14160            dc_norm(j,i-1))/vbld(i)
14161            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14162 !         write (iout,*) "else",i
14163          enddo
14164         endif
14165 !        do k=1,3
14166 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14167 !        enddo
14168       enddo
14169 !C Second case Ca...Ca...Ca...SC
14170 #ifdef PARINTDER
14171       do i=itau_start,itau_end
14172 #else
14173       do i=4,nres
14174 #endif
14175        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14176           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14177 ! the conventional case
14178         sint=dsin(omicron(1,i))
14179         sint1=dsin(theta(i-1))
14180         sing=dsin(tauangle(2,i))
14181         cost=dcos(omicron(1,i))
14182         cost1=dcos(theta(i-1))
14183         cosg=dcos(tauangle(2,i))
14184 !        do j=1,3
14185 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14186 !        enddo
14187         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14188         fac0=1.0d0/(sint1*sint)
14189         fac1=cost*fac0
14190         fac2=cost1*fac0
14191         fac3=cosg*cost1/(sint1*sint1)
14192         fac4=cosg*cost/(sint*sint)
14193 !    Obtaining the gamma derivatives from sine derivative
14194        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14195            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14196            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14197          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14198          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14199          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14200         do j=1,3
14201             ctgt=cost/sint
14202             ctgt1=cost1/sint1
14203             cosg_inv=1.0d0/cosg
14204             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14205               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14206 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14207 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14208             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14209             dsintau(j,2,2,i)= &
14210               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14211               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14212 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14213 !     & sing*ctgt*domicron(j,1,2,i),
14214 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14215             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14216 ! Bug fixed 3/24/05 (AL)
14217             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14218              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14219 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14220             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14221          enddo
14222 !   Obtaining the gamma derivatives from cosine derivative
14223         else
14224            do j=1,3
14225            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14226            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14227            dc_norm(j,i-3))/vbld(i-2)
14228            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14229            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14230            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14231            dcosomicron(j,1,1,i)
14232            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14233            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14234            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14235            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14236            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14237 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14238          enddo
14239         endif
14240       enddo
14241
14242 !CC third case SC...Ca...Ca...SC
14243 #ifdef PARINTDER
14244
14245       do i=itau_start,itau_end
14246 #else
14247       do i=3,nres
14248 #endif
14249 ! the conventional case
14250       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14251       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14252         sint=dsin(omicron(1,i))
14253         sint1=dsin(omicron(2,i-1))
14254         sing=dsin(tauangle(3,i))
14255         cost=dcos(omicron(1,i))
14256         cost1=dcos(omicron(2,i-1))
14257         cosg=dcos(tauangle(3,i))
14258         do j=1,3
14259         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14260 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14261         enddo
14262         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14263         fac0=1.0d0/(sint1*sint)
14264         fac1=cost*fac0
14265         fac2=cost1*fac0
14266         fac3=cosg*cost1/(sint1*sint1)
14267         fac4=cosg*cost/(sint*sint)
14268 !    Obtaining the gamma derivatives from sine derivative
14269        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14270            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14271            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14272          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14273          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14274          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14275         do j=1,3
14276             ctgt=cost/sint
14277             ctgt1=cost1/sint1
14278             cosg_inv=1.0d0/cosg
14279             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14280               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14281               *vbld_inv(i-2+nres)
14282             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14283             dsintau(j,3,2,i)= &
14284               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14285               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14286             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14287 ! Bug fixed 3/24/05 (AL)
14288             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14289               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14290               *vbld_inv(i-1+nres)
14291 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14292             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
14293          enddo
14294 !   Obtaining the gamma derivatives from cosine derivative
14295         else
14296            do j=1,3
14297            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14298            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14299            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
14300            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
14301            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14302            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14303            dcosomicron(j,1,1,i)
14304            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
14305            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14306            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
14307            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14308            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
14309 !          write(iout,*) "else",i
14310          enddo
14311         endif
14312       enddo
14313
14314 #ifdef CRYST_SC
14315 !   Derivatives of side-chain angles alpha and omega
14316 #if defined(MPI) && defined(PARINTDER)
14317         do i=ibond_start,ibond_end
14318 #else
14319         do i=2,nres-1
14320 #endif
14321           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
14322              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
14323              fac6=fac5/vbld(i)
14324              fac7=fac5*fac5
14325              fac8=fac5/vbld(i+1)
14326              fac9=fac5/vbld(i+nres)
14327              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
14328              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
14329              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
14330              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
14331              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
14332              sina=sqrt(1-cosa*cosa)
14333              sino=dsin(omeg(i))
14334 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
14335              do j=1,3
14336                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
14337                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
14338                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
14339                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
14340                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
14341                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
14342                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
14343                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
14344                 vbld(i+nres))
14345                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
14346             enddo
14347 ! obtaining the derivatives of omega from sines
14348             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
14349                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
14350                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
14351                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
14352                dsin(theta(i+1)))
14353                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
14354                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
14355                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
14356                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
14357                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
14358                coso_inv=1.0d0/dcos(omeg(i))
14359                do j=1,3
14360                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
14361                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
14362                  (sino*dc_norm(j,i-1))/vbld(i)
14363                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
14364                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
14365                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
14366                  -sino*dc_norm(j,i)/vbld(i+1)
14367                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
14368                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
14369                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
14370                  vbld(i+nres)
14371                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
14372               enddo
14373            else
14374 !   obtaining the derivatives of omega from cosines
14375              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
14376              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
14377              fac12=fac10*sina
14378              fac13=fac12*fac12
14379              fac14=sina*sina
14380              do j=1,3
14381                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
14382                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
14383                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
14384                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
14385                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
14386                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
14387                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
14388                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
14389                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
14390                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
14391                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
14392                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
14393                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
14394                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
14395                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
14396             enddo
14397           endif
14398          else
14399            do j=1,3
14400              do k=1,3
14401                dalpha(k,j,i)=0.0d0
14402                domega(k,j,i)=0.0d0
14403              enddo
14404            enddo
14405          endif
14406        enddo
14407 #endif
14408 #if defined(MPI) && defined(PARINTDER)
14409       if (nfgtasks.gt.1) then
14410 #ifdef DEBUG
14411 !d      write (iout,*) "Gather dtheta"
14412 !d      call flush(iout)
14413       write (iout,*) "dtheta before gather"
14414       do i=1,nres
14415         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
14416       enddo
14417 #endif
14418       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
14419         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
14420         king,FG_COMM,IERROR)
14421 #ifdef DEBUG
14422 !d      write (iout,*) "Gather dphi"
14423 !d      call flush(iout)
14424       write (iout,*) "dphi before gather"
14425       do i=1,nres
14426         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
14427       enddo
14428 #endif
14429       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
14430         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
14431         king,FG_COMM,IERROR)
14432 !d      write (iout,*) "Gather dalpha"
14433 !d      call flush(iout)
14434 #ifdef CRYST_SC
14435       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
14436         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14437         king,FG_COMM,IERROR)
14438 !d      write (iout,*) "Gather domega"
14439 !d      call flush(iout)
14440       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
14441         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
14442         king,FG_COMM,IERROR)
14443 #endif
14444       endif
14445 #endif
14446 #ifdef DEBUG
14447       write (iout,*) "dtheta after gather"
14448       do i=1,nres
14449         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
14450       enddo
14451       write (iout,*) "dphi after gather"
14452       do i=1,nres
14453         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
14454       enddo
14455       write (iout,*) "dalpha after gather"
14456       do i=1,nres
14457         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
14458       enddo
14459       write (iout,*) "domega after gather"
14460       do i=1,nres
14461         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
14462       enddo
14463 #endif
14464       return
14465       end subroutine intcartderiv
14466 !-----------------------------------------------------------------------------
14467       subroutine checkintcartgrad
14468 !      implicit real*8 (a-h,o-z)
14469 !      include 'DIMENSIONS'
14470 #ifdef MPI
14471       include 'mpif.h'
14472 #endif
14473 !      include 'COMMON.CHAIN'
14474 !      include 'COMMON.VAR'
14475 !      include 'COMMON.GEO'
14476 !      include 'COMMON.INTERACT'
14477 !      include 'COMMON.DERIV'
14478 !      include 'COMMON.IOUNITS'
14479 !      include 'COMMON.SETUP'
14480       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
14481       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
14482       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
14483       real(kind=8),dimension(3) :: dc_norm_s
14484       real(kind=8) :: aincr=1.0d-5
14485       integer :: i,j
14486       real(kind=8) :: dcji
14487       do i=1,nres
14488         phi_s(i)=phi(i)
14489         theta_s(i)=theta(i)
14490         alph_s(i)=alph(i)
14491         omeg_s(i)=omeg(i)
14492       enddo
14493 ! Check theta gradient
14494       write (iout,*) &
14495        "Analytical (upper) and numerical (lower) gradient of theta"
14496       write (iout,*)
14497       do i=3,nres
14498         do j=1,3
14499           dcji=dc(j,i-2)
14500           dc(j,i-2)=dcji+aincr
14501           call chainbuild_cart
14502           call int_from_cart1(.false.)
14503           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
14504           dc(j,i-2)=dcji
14505           dcji=dc(j,i-1)
14506           dc(j,i-1)=dc(j,i-1)+aincr
14507           call chainbuild_cart
14508           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
14509           dc(j,i-1)=dcji
14510         enddo
14511 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
14512 !el          (dtheta(j,2,i),j=1,3)
14513 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
14514 !el          (dthetanum(j,2,i),j=1,3)
14515 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
14516 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
14517 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
14518 !el        write (iout,*)
14519       enddo
14520 ! Check gamma gradient
14521       write (iout,*) &
14522        "Analytical (upper) and numerical (lower) gradient of gamma"
14523       do i=4,nres
14524         do j=1,3
14525           dcji=dc(j,i-3)
14526           dc(j,i-3)=dcji+aincr
14527           call chainbuild_cart
14528           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
14529           dc(j,i-3)=dcji
14530           dcji=dc(j,i-2)
14531           dc(j,i-2)=dcji+aincr
14532           call chainbuild_cart
14533           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
14534           dc(j,i-2)=dcji
14535           dcji=dc(j,i-1)
14536           dc(j,i-1)=dc(j,i-1)+aincr
14537           call chainbuild_cart
14538           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
14539           dc(j,i-1)=dcji
14540         enddo
14541 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
14542 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
14543 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
14544 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
14545 !el        write (iout,'(5x,3(3f10.5,5x))') &
14546 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
14547 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
14548 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
14549 !el        write (iout,*)
14550       enddo
14551 ! Check alpha gradient
14552       write (iout,*) &
14553        "Analytical (upper) and numerical (lower) gradient of alpha"
14554       do i=2,nres-1
14555        if(itype(i).ne.10) then
14556             do j=1,3
14557               dcji=dc(j,i-1)
14558               dc(j,i-1)=dcji+aincr
14559               call chainbuild_cart
14560               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
14561               /aincr
14562               dc(j,i-1)=dcji
14563               dcji=dc(j,i)
14564               dc(j,i)=dcji+aincr
14565               call chainbuild_cart
14566               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
14567               /aincr
14568               dc(j,i)=dcji
14569               dcji=dc(j,i+nres)
14570               dc(j,i+nres)=dc(j,i+nres)+aincr
14571               call chainbuild_cart
14572               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
14573               /aincr
14574              dc(j,i+nres)=dcji
14575             enddo
14576           endif
14577 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
14578 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
14579 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
14580 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
14581 !el        write (iout,'(5x,3(3f10.5,5x))') &
14582 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
14583 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
14584 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
14585 !el        write (iout,*)
14586       enddo
14587 !     Check omega gradient
14588       write (iout,*) &
14589        "Analytical (upper) and numerical (lower) gradient of omega"
14590       do i=2,nres-1
14591        if(itype(i).ne.10) then
14592             do j=1,3
14593               dcji=dc(j,i-1)
14594               dc(j,i-1)=dcji+aincr
14595               call chainbuild_cart
14596               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
14597               /aincr
14598               dc(j,i-1)=dcji
14599               dcji=dc(j,i)
14600               dc(j,i)=dcji+aincr
14601               call chainbuild_cart
14602               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
14603               /aincr
14604               dc(j,i)=dcji
14605               dcji=dc(j,i+nres)
14606               dc(j,i+nres)=dc(j,i+nres)+aincr
14607               call chainbuild_cart
14608               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
14609               /aincr
14610              dc(j,i+nres)=dcji
14611             enddo
14612           endif
14613 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
14614 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
14615 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
14616 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
14617 !el        write (iout,'(5x,3(3f10.5,5x))') &
14618 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
14619 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
14620 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
14621 !el        write (iout,*)
14622       enddo
14623       return
14624       end subroutine checkintcartgrad
14625 !-----------------------------------------------------------------------------
14626 ! q_measure.F
14627 !-----------------------------------------------------------------------------
14628       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
14629 !      implicit real*8 (a-h,o-z)
14630 !      include 'DIMENSIONS'
14631 !      include 'COMMON.IOUNITS'
14632 !      include 'COMMON.CHAIN'
14633 !      include 'COMMON.INTERACT'
14634 !      include 'COMMON.VAR'
14635       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
14636       integer :: kkk,nsep=3
14637       real(kind=8) :: qm        !dist,
14638       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
14639       logical :: lprn=.false.
14640       logical :: flag
14641 !      real(kind=8) :: sigm,x
14642
14643 !el      sigm(x)=0.25d0*x     ! local function
14644       qqmax=1.0d10
14645       do kkk=1,nperm
14646       qq = 0.0d0
14647       nl=0
14648        if(flag) then
14649         do il=seg1+nsep,seg2
14650           do jl=seg1,il-nsep
14651             nl=nl+1
14652             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
14653                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
14654                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14655             dij=dist(il,jl)
14656             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
14657             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14658               nl=nl+1
14659               d0ijCM=dsqrt( &
14660                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14661                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14662                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14663               dijCM=dist(il+nres,jl+nres)
14664               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
14665             endif
14666             qq = qq+qqij+qqijCM
14667           enddo
14668         enddo
14669         qq = qq/nl
14670       else
14671       do il=seg1,seg2
14672         if((seg3-il).lt.3) then
14673              secseg=il+3
14674         else
14675              secseg=seg3
14676         endif
14677           do jl=secseg,seg4
14678             nl=nl+1
14679             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14680                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14681                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14682             dij=dist(il,jl)
14683             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
14684             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14685               nl=nl+1
14686               d0ijCM=dsqrt( &
14687                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14688                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14689                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14690               dijCM=dist(il+nres,jl+nres)
14691               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
14692             endif
14693             qq = qq+qqij+qqijCM
14694           enddo
14695         enddo
14696       qq = qq/nl
14697       endif
14698       if (qqmax.le.qq) qqmax=qq
14699       enddo
14700       qwolynes=1.0d0-qqmax
14701       return
14702       end function qwolynes
14703 !-----------------------------------------------------------------------------
14704       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
14705 !      implicit real*8 (a-h,o-z)
14706 !      include 'DIMENSIONS'
14707 !      include 'COMMON.IOUNITS'
14708 !      include 'COMMON.CHAIN'
14709 !      include 'COMMON.INTERACT'
14710 !      include 'COMMON.VAR'
14711 !      include 'COMMON.MD'
14712       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
14713       integer :: nsep=3, kkk
14714 !el      real(kind=8) :: dist
14715       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
14716       logical :: lprn=.false.
14717       logical :: flag
14718       real(kind=8) :: sim,dd0,fac,ddqij
14719 !el      sigm(x)=0.25d0*x            ! local function
14720       do kkk=1,nperm
14721       do i=0,nres
14722         do j=1,3
14723           dqwol(j,i)=0.0d0
14724           dxqwol(j,i)=0.0d0
14725         enddo
14726       enddo
14727       nl=0
14728        if(flag) then
14729         do il=seg1+nsep,seg2
14730           do jl=seg1,il-nsep
14731             nl=nl+1
14732             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14733                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14734                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14735             dij=dist(il,jl)
14736             sim = 1.0d0/sigm(d0ij)
14737             sim = sim*sim
14738             dd0 = dij-d0ij
14739             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
14740             do k=1,3
14741               ddqij = (c(k,il)-c(k,jl))*fac
14742               dqwol(k,il)=dqwol(k,il)+ddqij
14743               dqwol(k,jl)=dqwol(k,jl)-ddqij
14744             enddo
14745
14746             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14747               nl=nl+1
14748               d0ijCM=dsqrt( &
14749                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14750                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14751                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14752               dijCM=dist(il+nres,jl+nres)
14753               sim = 1.0d0/sigm(d0ijCM)
14754               sim = sim*sim
14755               dd0=dijCM-d0ijCM
14756               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
14757               do k=1,3
14758                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
14759                 dxqwol(k,il)=dxqwol(k,il)+ddqij
14760                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
14761               enddo
14762             endif
14763           enddo
14764         enddo
14765        else
14766         do il=seg1,seg2
14767         if((seg3-il).lt.3) then
14768              secseg=il+3
14769         else
14770              secseg=seg3
14771         endif
14772           do jl=secseg,seg4
14773             nl=nl+1
14774             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
14775                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
14776                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
14777             dij=dist(il,jl)
14778             sim = 1.0d0/sigm(d0ij)
14779             sim = sim*sim
14780             dd0 = dij-d0ij
14781             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
14782             do k=1,3
14783               ddqij = (c(k,il)-c(k,jl))*fac
14784               dqwol(k,il)=dqwol(k,il)+ddqij
14785               dqwol(k,jl)=dqwol(k,jl)-ddqij
14786             enddo
14787             if (itype(il).ne.10 .or. itype(jl).ne.10) then
14788               nl=nl+1
14789               d0ijCM=dsqrt( &
14790                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
14791                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
14792                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
14793               dijCM=dist(il+nres,jl+nres)
14794               sim = 1.0d0/sigm(d0ijCM)
14795               sim=sim*sim
14796               dd0 = dijCM-d0ijCM
14797               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
14798               do k=1,3
14799                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
14800                dxqwol(k,il)=dxqwol(k,il)+ddqij
14801                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
14802               enddo
14803             endif
14804           enddo
14805         enddo
14806       endif
14807       enddo
14808        do i=0,nres
14809          do j=1,3
14810            dqwol(j,i)=dqwol(j,i)/nl
14811            dxqwol(j,i)=dxqwol(j,i)/nl
14812          enddo
14813        enddo
14814       return
14815       end subroutine qwolynes_prim
14816 !-----------------------------------------------------------------------------
14817       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
14818 !      implicit real*8 (a-h,o-z)
14819 !      include 'DIMENSIONS'
14820 !      include 'COMMON.IOUNITS'
14821 !      include 'COMMON.CHAIN'
14822 !      include 'COMMON.INTERACT'
14823 !      include 'COMMON.VAR'
14824       integer :: seg1,seg2,seg3,seg4
14825       logical :: flag
14826       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
14827       real(kind=8),dimension(3,0:2*nres) :: cdummy
14828       real(kind=8) :: q1,q2
14829       real(kind=8) :: delta=1.0d-10
14830       integer :: i,j
14831
14832       do i=0,nres
14833         do j=1,3
14834           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
14835           cdummy(j,i)=c(j,i)
14836           c(j,i)=c(j,i)+delta
14837           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
14838           qwolan(j,i)=(q2-q1)/delta
14839           c(j,i)=cdummy(j,i)
14840         enddo
14841       enddo
14842       do i=0,nres
14843         do j=1,3
14844           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
14845           cdummy(j,i+nres)=c(j,i+nres)
14846           c(j,i+nres)=c(j,i+nres)+delta
14847           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
14848           qwolxan(j,i)=(q2-q1)/delta
14849           c(j,i+nres)=cdummy(j,i+nres)
14850         enddo
14851       enddo
14852 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
14853 !      do i=0,nct
14854 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
14855 !      enddo
14856 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
14857 !      do i=0,nct
14858 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
14859 !      enddo
14860       return
14861       end subroutine qwol_num
14862 !-----------------------------------------------------------------------------
14863       subroutine EconstrQ
14864 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
14865 !      implicit real*8 (a-h,o-z)
14866 !      include 'DIMENSIONS'
14867 !      include 'COMMON.CONTROL'
14868 !      include 'COMMON.VAR'
14869 !      include 'COMMON.MD'
14870       use MD_data
14871 !#ifndef LANG0
14872 !      include 'COMMON.LANGEVIN'
14873 !#else
14874 !      include 'COMMON.LANGEVIN.lang0'
14875 !#endif
14876 !      include 'COMMON.CHAIN'
14877 !      include 'COMMON.DERIV'
14878 !      include 'COMMON.GEO'
14879 !      include 'COMMON.LOCAL'
14880 !      include 'COMMON.INTERACT'
14881 !      include 'COMMON.IOUNITS'
14882 !      include 'COMMON.NAMES'
14883 !      include 'COMMON.TIME1'
14884       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
14885       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
14886                    duconst,duxconst
14887       integer :: kstart,kend,lstart,lend,idummy
14888       real(kind=8) :: delta=1.0d-7
14889       integer :: i,j,k,ii
14890       do i=0,nres
14891          do j=1,3
14892             duconst(j,i)=0.0d0
14893             dudconst(j,i)=0.0d0
14894             duxconst(j,i)=0.0d0
14895             dudxconst(j,i)=0.0d0
14896          enddo
14897       enddo
14898       Uconst=0.0d0
14899       do i=1,nfrag
14900          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
14901            idummy,idummy)
14902          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
14903 ! Calculating the derivatives of Constraint energy with respect to Q
14904          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
14905            qinfrag(i,iset))
14906 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
14907 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
14908 !         hmnum=(hm2-hm1)/delta
14909 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
14910 !     &   qinfrag(i,iset))
14911 !         write(iout,*) "harmonicnum frag", hmnum
14912 ! Calculating the derivatives of Q with respect to cartesian coordinates
14913          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
14914           idummy,idummy)
14915 !         write(iout,*) "dqwol "
14916 !         do ii=1,nres
14917 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
14918 !         enddo
14919 !         write(iout,*) "dxqwol "
14920 !         do ii=1,nres
14921 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
14922 !         enddo
14923 ! Calculating numerical gradients of dU/dQi and dQi/dxi
14924 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
14925 !     &  ,idummy,idummy)
14926 !  The gradients of Uconst in Cs
14927          do ii=0,nres
14928             do j=1,3
14929                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
14930                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
14931             enddo
14932          enddo
14933       enddo
14934       do i=1,npair
14935          kstart=ifrag(1,ipair(1,i,iset),iset)
14936          kend=ifrag(2,ipair(1,i,iset),iset)
14937          lstart=ifrag(1,ipair(2,i,iset),iset)
14938          lend=ifrag(2,ipair(2,i,iset),iset)
14939          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
14940          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
14941 !  Calculating dU/dQ
14942          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
14943 !         hm1=harmonic(qpair(i),qinpair(i,iset))
14944 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
14945 !         hmnum=(hm2-hm1)/delta
14946 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
14947 !     &   qinpair(i,iset))
14948 !         write(iout,*) "harmonicnum pair ", hmnum
14949 ! Calculating dQ/dXi
14950          call qwolynes_prim(kstart,kend,.false.,&
14951           lstart,lend)
14952 !         write(iout,*) "dqwol "
14953 !         do ii=1,nres
14954 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
14955 !         enddo
14956 !         write(iout,*) "dxqwol "
14957 !         do ii=1,nres
14958 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
14959 !        enddo
14960 ! Calculating numerical gradients
14961 !        call qwol_num(kstart,kend,.false.
14962 !     &  ,lstart,lend)
14963 ! The gradients of Uconst in Cs
14964          do ii=0,nres
14965             do j=1,3
14966                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
14967                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
14968             enddo
14969          enddo
14970       enddo
14971 !      write(iout,*) "Uconst inside subroutine ", Uconst
14972 ! Transforming the gradients from Cs to dCs for the backbone
14973       do i=0,nres
14974          do j=i+1,nres
14975            do k=1,3
14976              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
14977            enddo
14978          enddo
14979       enddo
14980 !  Transforming the gradients from Cs to dCs for the side chains
14981       do i=1,nres
14982          do j=1,3
14983            dudxconst(j,i)=duxconst(j,i)
14984          enddo
14985       enddo
14986 !      write(iout,*) "dU/ddc backbone "
14987 !       do ii=0,nres
14988 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
14989 !      enddo
14990 !      write(iout,*) "dU/ddX side chain "
14991 !      do ii=1,nres
14992 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
14993 !      enddo
14994 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
14995 !      call dEconstrQ_num
14996       return
14997       end subroutine EconstrQ
14998 !-----------------------------------------------------------------------------
14999       subroutine dEconstrQ_num
15000 ! Calculating numerical dUconst/ddc and dUconst/ddx
15001 !      implicit real*8 (a-h,o-z)
15002 !      include 'DIMENSIONS'
15003 !      include 'COMMON.CONTROL'
15004 !      include 'COMMON.VAR'
15005 !      include 'COMMON.MD'
15006       use MD_data
15007 !#ifndef LANG0
15008 !      include 'COMMON.LANGEVIN'
15009 !#else
15010 !      include 'COMMON.LANGEVIN.lang0'
15011 !#endif
15012 !      include 'COMMON.CHAIN'
15013 !      include 'COMMON.DERIV'
15014 !      include 'COMMON.GEO'
15015 !      include 'COMMON.LOCAL'
15016 !      include 'COMMON.INTERACT'
15017 !      include 'COMMON.IOUNITS'
15018 !      include 'COMMON.NAMES'
15019 !      include 'COMMON.TIME1'
15020       real(kind=8) :: uzap1,uzap2
15021       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15022       integer :: kstart,kend,lstart,lend,idummy
15023       real(kind=8) :: delta=1.0d-7
15024 !el local variables
15025      integer :: i,ii,j
15026 !     real(kind=8) ::
15027 !     For the backbone
15028       do i=0,nres-1
15029          do j=1,3
15030             dUcartan(j,i)=0.0d0
15031             cdummy(j,i)=dc(j,i)
15032             dc(j,i)=dc(j,i)+delta
15033             call chainbuild_cart
15034             uzap2=0.0d0
15035             do ii=1,nfrag
15036              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15037                 idummy,idummy)
15038                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15039                 qinfrag(ii,iset))
15040             enddo
15041             do ii=1,npair
15042                kstart=ifrag(1,ipair(1,ii,iset),iset)
15043                kend=ifrag(2,ipair(1,ii,iset),iset)
15044                lstart=ifrag(1,ipair(2,ii,iset),iset)
15045                lend=ifrag(2,ipair(2,ii,iset),iset)
15046                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15047                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15048                  qinpair(ii,iset))
15049             enddo
15050             dc(j,i)=cdummy(j,i)
15051             call chainbuild_cart
15052             uzap1=0.0d0
15053              do ii=1,nfrag
15054              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15055                 idummy,idummy)
15056                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15057                 qinfrag(ii,iset))
15058             enddo
15059             do ii=1,npair
15060                kstart=ifrag(1,ipair(1,ii,iset),iset)
15061                kend=ifrag(2,ipair(1,ii,iset),iset)
15062                lstart=ifrag(1,ipair(2,ii,iset),iset)
15063                lend=ifrag(2,ipair(2,ii,iset),iset)
15064                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15065                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15066                 qinpair(ii,iset))
15067             enddo
15068             ducartan(j,i)=(uzap2-uzap1)/(delta)
15069          enddo
15070       enddo
15071 ! Calculating numerical gradients for dU/ddx
15072       do i=0,nres-1
15073          duxcartan(j,i)=0.0d0
15074          do j=1,3
15075             cdummy(j,i)=dc(j,i+nres)
15076             dc(j,i+nres)=dc(j,i+nres)+delta
15077             call chainbuild_cart
15078             uzap2=0.0d0
15079             do ii=1,nfrag
15080              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15081                 idummy,idummy)
15082                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15083                 qinfrag(ii,iset))
15084             enddo
15085             do ii=1,npair
15086                kstart=ifrag(1,ipair(1,ii,iset),iset)
15087                kend=ifrag(2,ipair(1,ii,iset),iset)
15088                lstart=ifrag(1,ipair(2,ii,iset),iset)
15089                lend=ifrag(2,ipair(2,ii,iset),iset)
15090                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15091                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15092                 qinpair(ii,iset))
15093             enddo
15094             dc(j,i+nres)=cdummy(j,i)
15095             call chainbuild_cart
15096             uzap1=0.0d0
15097              do ii=1,nfrag
15098                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15099                 ifrag(2,ii,iset),.true.,idummy,idummy)
15100                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15101                 qinfrag(ii,iset))
15102             enddo
15103             do ii=1,npair
15104                kstart=ifrag(1,ipair(1,ii,iset),iset)
15105                kend=ifrag(2,ipair(1,ii,iset),iset)
15106                lstart=ifrag(1,ipair(2,ii,iset),iset)
15107                lend=ifrag(2,ipair(2,ii,iset),iset)
15108                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15109                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15110                 qinpair(ii,iset))
15111             enddo
15112             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15113          enddo
15114       enddo
15115       write(iout,*) "Numerical dUconst/ddc backbone "
15116       do ii=0,nres
15117         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15118       enddo
15119 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15120 !      do ii=1,nres
15121 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15122 !      enddo
15123       return
15124       end subroutine dEconstrQ_num
15125 !-----------------------------------------------------------------------------
15126 ! ssMD.F
15127 !-----------------------------------------------------------------------------
15128       subroutine check_energies
15129
15130 !      use random, only: ran_number
15131
15132 !      implicit none
15133 !     Includes
15134 !      include 'DIMENSIONS'
15135 !      include 'COMMON.CHAIN'
15136 !      include 'COMMON.VAR'
15137 !      include 'COMMON.IOUNITS'
15138 !      include 'COMMON.SBRIDGE'
15139 !      include 'COMMON.LOCAL'
15140 !      include 'COMMON.GEO'
15141
15142 !     External functions
15143 !EL      double precision ran_number
15144 !EL      external ran_number
15145
15146 !     Local variables
15147       integer :: i,j,k,l,lmax,p,pmax
15148       real(kind=8) :: rmin,rmax
15149       real(kind=8) :: eij
15150
15151       real(kind=8) :: d
15152       real(kind=8) :: wi,rij,tj,pj
15153 !      return
15154
15155       i=5
15156       j=14
15157
15158       d=dsc(1)
15159       rmin=2.0D0
15160       rmax=12.0D0
15161
15162       lmax=10000
15163       pmax=1
15164
15165       do k=1,3
15166         c(k,i)=0.0D0
15167         c(k,j)=0.0D0
15168         c(k,nres+i)=0.0D0
15169         c(k,nres+j)=0.0D0
15170       enddo
15171
15172       do l=1,lmax
15173
15174 !t        wi=ran_number(0.0D0,pi)
15175 !        wi=ran_number(0.0D0,pi/6.0D0)
15176 !        wi=0.0D0
15177 !t        tj=ran_number(0.0D0,pi)
15178 !t        pj=ran_number(0.0D0,pi)
15179 !        pj=ran_number(0.0D0,pi/6.0D0)
15180 !        pj=0.0D0
15181
15182         do p=1,pmax
15183 !t           rij=ran_number(rmin,rmax)
15184
15185            c(1,j)=d*sin(pj)*cos(tj)
15186            c(2,j)=d*sin(pj)*sin(tj)
15187            c(3,j)=d*cos(pj)
15188
15189            c(3,nres+i)=-rij
15190
15191            c(1,i)=d*sin(wi)
15192            c(3,i)=-rij-d*cos(wi)
15193
15194            do k=1,3
15195               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15196               dc_norm(k,nres+i)=dc(k,nres+i)/d
15197               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15198               dc_norm(k,nres+j)=dc(k,nres+j)/d
15199            enddo
15200
15201            call dyn_ssbond_ene(i,j,eij)
15202         enddo
15203       enddo
15204       call exit(1)
15205       return
15206       end subroutine check_energies
15207 !-----------------------------------------------------------------------------
15208       subroutine dyn_ssbond_ene(resi,resj,eij)
15209 !      implicit none
15210 !      Includes
15211       use calc_data
15212       use comm_sschecks
15213 !      include 'DIMENSIONS'
15214 !      include 'COMMON.SBRIDGE'
15215 !      include 'COMMON.CHAIN'
15216 !      include 'COMMON.DERIV'
15217 !      include 'COMMON.LOCAL'
15218 !      include 'COMMON.INTERACT'
15219 !      include 'COMMON.VAR'
15220 !      include 'COMMON.IOUNITS'
15221 !      include 'COMMON.CALC'
15222 #ifndef CLUST
15223 #ifndef WHAM
15224        use MD_data
15225 !      include 'COMMON.MD'
15226 !      use MD, only: totT,t_bath
15227 #endif
15228 #endif
15229 !     External functions
15230 !EL      double precision h_base
15231 !EL      external h_base
15232
15233 !     Input arguments
15234       integer :: resi,resj
15235
15236 !     Output arguments
15237       real(kind=8) :: eij
15238
15239 !     Local variables
15240       logical :: havebond
15241       integer itypi,itypj
15242       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15243       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15244       real(kind=8),dimension(3) :: dcosom1,dcosom2
15245       real(kind=8) :: ed
15246       real(kind=8) :: pom1,pom2
15247       real(kind=8) :: ljA,ljB,ljXs
15248       real(kind=8),dimension(1:3) :: d_ljB
15249       real(kind=8) :: ssA,ssB,ssC,ssXs
15250       real(kind=8) :: ssxm,ljxm,ssm,ljm
15251       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15252       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15253       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15254 !-------FIRST METHOD
15255       real(kind=8) :: xm
15256       real(kind=8),dimension(1:3) :: d_xm
15257 !-------END FIRST METHOD
15258 !-------SECOND METHOD
15259 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15260 !-------END SECOND METHOD
15261
15262 !-------TESTING CODE
15263 !el      logical :: checkstop,transgrad
15264 !el      common /sschecks/ checkstop,transgrad
15265
15266       integer :: icheck,nicheck,jcheck,njcheck
15267       real(kind=8),dimension(-1:1) :: echeck
15268       real(kind=8) :: deps,ssx0,ljx0
15269 !-------END TESTING CODE
15270
15271       i=resi
15272       j=resj
15273
15274 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15275 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15276
15277       itypi=itype(i)
15278       dxi=dc_norm(1,nres+i)
15279       dyi=dc_norm(2,nres+i)
15280       dzi=dc_norm(3,nres+i)
15281       dsci_inv=vbld_inv(i+nres)
15282
15283       itypj=itype(j)
15284       xj=c(1,nres+j)-c(1,nres+i)
15285       yj=c(2,nres+j)-c(2,nres+i)
15286       zj=c(3,nres+j)-c(3,nres+i)
15287       dxj=dc_norm(1,nres+j)
15288       dyj=dc_norm(2,nres+j)
15289       dzj=dc_norm(3,nres+j)
15290       dscj_inv=vbld_inv(j+nres)
15291
15292       chi1=chi(itypi,itypj)
15293       chi2=chi(itypj,itypi)
15294       chi12=chi1*chi2
15295       chip1=chip(itypi)
15296       chip2=chip(itypj)
15297       chip12=chip1*chip2
15298       alf1=alp(itypi)
15299       alf2=alp(itypj)
15300       alf12=0.5D0*(alf1+alf2)
15301
15302       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15303       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
15304 !     The following are set in sc_angular
15305 !      erij(1)=xj*rij
15306 !      erij(2)=yj*rij
15307 !      erij(3)=zj*rij
15308 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
15309 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
15310 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
15311       call sc_angular
15312       rij=1.0D0/rij  ! Reset this so it makes sense
15313
15314       sig0ij=sigma(itypi,itypj)
15315       sig=sig0ij*dsqrt(1.0D0/sigsq)
15316
15317       ljXs=sig-sig0ij
15318       ljA=eps1*eps2rt**2*eps3rt**2
15319       ljB=ljA*bb(itypi,itypj)
15320       ljA=ljA*aa(itypi,itypj)
15321       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15322
15323       ssXs=d0cm
15324       deltat1=1.0d0-om1
15325       deltat2=1.0d0+om2
15326       deltat12=om2-om1+2.0d0
15327       cosphi=om12-om1*om2
15328       ssA=akcm
15329       ssB=akct*deltat12
15330       ssC=ss_depth &
15331            +akth*(deltat1*deltat1+deltat2*deltat2) &
15332            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
15333       ssxm=ssXs-0.5D0*ssB/ssA
15334
15335 !-------TESTING CODE
15336 !$$$c     Some extra output
15337 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
15338 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15339 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
15340 !$$$      if (ssx0.gt.0.0d0) then
15341 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
15342 !$$$      else
15343 !$$$        ssx0=ssxm
15344 !$$$      endif
15345 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15346 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
15347 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
15348 !$$$      return
15349 !-------END TESTING CODE
15350
15351 !-------TESTING CODE
15352 !     Stop and plot energy and derivative as a function of distance
15353       if (checkstop) then
15354         ssm=ssC-0.25D0*ssB*ssB/ssA
15355         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15356         if (ssm.lt.ljm .and. &
15357              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
15358           nicheck=1000
15359           njcheck=1
15360           deps=0.5d-7
15361         else
15362           checkstop=.false.
15363         endif
15364       endif
15365       if (.not.checkstop) then
15366         nicheck=0
15367         njcheck=-1
15368       endif
15369
15370       do icheck=0,nicheck
15371       do jcheck=-1,njcheck
15372       if (checkstop) rij=(ssxm-1.0d0)+ &
15373              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
15374 !-------END TESTING CODE
15375
15376       if (rij.gt.ljxm) then
15377         havebond=.false.
15378         ljd=rij-ljXs
15379         fac=(1.0D0/ljd)**expon
15380         e1=fac*fac*aa(itypi,itypj)
15381         e2=fac*bb(itypi,itypj)
15382         eij=eps1*eps2rt*eps3rt*(e1+e2)
15383         eps2der=eij*eps3rt
15384         eps3der=eij*eps2rt
15385         eij=eij*eps2rt*eps3rt
15386
15387         sigder=-sig/sigsq
15388         e1=e1*eps1*eps2rt**2*eps3rt**2
15389         ed=-expon*(e1+eij)/ljd
15390         sigder=ed*sigder
15391         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15392         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15393         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
15394              -2.0D0*alf12*eps3der+sigder*sigsq_om12
15395       else if (rij.lt.ssxm) then
15396         havebond=.true.
15397         ssd=rij-ssXs
15398         eij=ssA*ssd*ssd+ssB*ssd+ssC
15399
15400         ed=2*akcm*ssd+akct*deltat12
15401         pom1=akct*ssd
15402         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
15403         eom1=-2*akth*deltat1-pom1-om2*pom2
15404         eom2= 2*akth*deltat2+pom1-om1*pom2
15405         eom12=pom2
15406       else
15407         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
15408
15409         d_ssxm(1)=0.5D0*akct/ssA
15410         d_ssxm(2)=-d_ssxm(1)
15411         d_ssxm(3)=0.0D0
15412
15413         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
15414         d_ljxm(2)=d_ljxm(1)*sigsq_om2
15415         d_ljxm(3)=d_ljxm(1)*sigsq_om12
15416         d_ljxm(1)=d_ljxm(1)*sigsq_om1
15417
15418 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15419         xm=0.5d0*(ssxm+ljxm)
15420         do k=1,3
15421           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
15422         enddo
15423         if (rij.lt.xm) then
15424           havebond=.true.
15425           ssm=ssC-0.25D0*ssB*ssB/ssA
15426           d_ssm(1)=0.5D0*akct*ssB/ssA
15427           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15428           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15429           d_ssm(3)=omega
15430           f1=(rij-xm)/(ssxm-xm)
15431           f2=(rij-ssxm)/(xm-ssxm)
15432           h1=h_base(f1,hd1)
15433           h2=h_base(f2,hd2)
15434           eij=ssm*h1+Ht*h2
15435           delta_inv=1.0d0/(xm-ssxm)
15436           deltasq_inv=delta_inv*delta_inv
15437           fac=ssm*hd1-Ht*hd2
15438           fac1=deltasq_inv*fac*(xm-rij)
15439           fac2=deltasq_inv*fac*(rij-ssxm)
15440           ed=delta_inv*(Ht*hd2-ssm*hd1)
15441           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
15442           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
15443           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
15444         else
15445           havebond=.false.
15446           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15447           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
15448           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
15449           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
15450                alf12/eps3rt)
15451           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
15452           f1=(rij-ljxm)/(xm-ljxm)
15453           f2=(rij-xm)/(ljxm-xm)
15454           h1=h_base(f1,hd1)
15455           h2=h_base(f2,hd2)
15456           eij=Ht*h1+ljm*h2
15457           delta_inv=1.0d0/(ljxm-xm)
15458           deltasq_inv=delta_inv*delta_inv
15459           fac=Ht*hd1-ljm*hd2
15460           fac1=deltasq_inv*fac*(ljxm-rij)
15461           fac2=deltasq_inv*fac*(rij-xm)
15462           ed=delta_inv*(ljm*hd2-Ht*hd1)
15463           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
15464           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
15465           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
15466         endif
15467 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
15468
15469 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15470 !$$$        ssd=rij-ssXs
15471 !$$$        ljd=rij-ljXs
15472 !$$$        fac1=rij-ljxm
15473 !$$$        fac2=rij-ssxm
15474 !$$$
15475 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
15476 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
15477 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
15478 !$$$
15479 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
15480 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
15481 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
15482 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
15483 !$$$        d_ssm(3)=omega
15484 !$$$
15485 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
15486 !$$$        do k=1,3
15487 !$$$          d_ljm(k)=ljm*d_ljB(k)
15488 !$$$        enddo
15489 !$$$        ljm=ljm*ljB
15490 !$$$
15491 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
15492 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
15493 !$$$        d_ss(2)=akct*ssd
15494 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
15495 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
15496 !$$$        d_ss(3)=omega
15497 !$$$
15498 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
15499 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
15500 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
15501 !$$$        do k=1,3
15502 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
15503 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
15504 !$$$        enddo
15505 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
15506 !$$$
15507 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
15508 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
15509 !$$$        h1=h_base(f1,hd1)
15510 !$$$        h2=h_base(f2,hd2)
15511 !$$$        eij=ss*h1+ljf*h2
15512 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
15513 !$$$        deltasq_inv=delta_inv*delta_inv
15514 !$$$        fac=ljf*hd2-ss*hd1
15515 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
15516 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
15517 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
15518 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
15519 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
15520 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
15521 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
15522 !$$$
15523 !$$$        havebond=.false.
15524 !$$$        if (ed.gt.0.0d0) havebond=.true.
15525 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
15526
15527       endif
15528
15529       if (havebond) then
15530 #ifndef CLUST
15531 #ifndef WHAM
15532 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
15533 !          write(iout,'(a15,f12.2,f8.1,2i5)')
15534 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
15535 !        endif
15536 #endif
15537 #endif
15538         dyn_ssbond_ij(i,j)=eij
15539       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
15540         dyn_ssbond_ij(i,j)=1.0d300
15541 #ifndef CLUST
15542 #ifndef WHAM
15543 !        write(iout,'(a15,f12.2,f8.1,2i5)')
15544 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
15545 #endif
15546 #endif
15547       endif
15548
15549 !-------TESTING CODE
15550       if (checkstop) then
15551         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
15552              "CHECKSTOP",rij,eij,ed
15553         echeck(jcheck)=eij
15554       endif
15555       enddo
15556       if (checkstop) then
15557         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
15558       endif
15559       enddo
15560       if (checkstop) then
15561         transgrad=.true.
15562         checkstop=.false.
15563       endif
15564 !-------END TESTING CODE
15565
15566       do k=1,3
15567         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
15568         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
15569       enddo
15570       do k=1,3
15571         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
15572       enddo
15573       do k=1,3
15574         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15575              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15576              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15577         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15578              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15579              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15580       enddo
15581 !grad      do k=i,j-1
15582 !grad        do l=1,3
15583 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
15584 !grad        enddo
15585 !grad      enddo
15586
15587       do l=1,3
15588         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15589         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15590       enddo
15591
15592       return
15593       end subroutine dyn_ssbond_ene
15594 !-----------------------------------------------------------------------------
15595       real(kind=8) function h_base(x,deriv)
15596 !     A smooth function going 0->1 in range [0,1]
15597 !     It should NOT be called outside range [0,1], it will not work there.
15598       implicit none
15599
15600 !     Input arguments
15601       real(kind=8) :: x
15602
15603 !     Output arguments
15604       real(kind=8) :: deriv
15605
15606 !     Local variables
15607       real(kind=8) :: xsq
15608
15609
15610 !     Two parabolas put together.  First derivative zero at extrema
15611 !$$$      if (x.lt.0.5D0) then
15612 !$$$        h_base=2.0D0*x*x
15613 !$$$        deriv=4.0D0*x
15614 !$$$      else
15615 !$$$        deriv=1.0D0-x
15616 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
15617 !$$$        deriv=4.0D0*deriv
15618 !$$$      endif
15619
15620 !     Third degree polynomial.  First derivative zero at extrema
15621       h_base=x*x*(3.0d0-2.0d0*x)
15622       deriv=6.0d0*x*(1.0d0-x)
15623
15624 !     Fifth degree polynomial.  First and second derivatives zero at extrema
15625 !$$$      xsq=x*x
15626 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
15627 !$$$      deriv=x-1.0d0
15628 !$$$      deriv=deriv*deriv
15629 !$$$      deriv=30.0d0*xsq*deriv
15630
15631       return
15632       end function h_base
15633 !-----------------------------------------------------------------------------
15634       subroutine dyn_set_nss
15635 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
15636 !      implicit none
15637       use MD_data, only: totT,t_bath
15638 !     Includes
15639 !      include 'DIMENSIONS'
15640 #ifdef MPI
15641       include "mpif.h"
15642 #endif
15643 !      include 'COMMON.SBRIDGE'
15644 !      include 'COMMON.CHAIN'
15645 !      include 'COMMON.IOUNITS'
15646 !      include 'COMMON.SETUP'
15647 #ifndef CLUST
15648 #ifndef WHAM
15649 !      include 'COMMON.MD'
15650 #endif
15651 #endif
15652 !     Local variables
15653       real(kind=8) :: emin
15654       integer :: i,j,imin,ierr
15655       integer :: diff,allnss,newnss
15656       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
15657                 newihpb,newjhpb
15658       logical :: found
15659       integer,dimension(0:nfgtasks) :: i_newnss
15660       integer,dimension(0:nfgtasks) :: displ
15661       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
15662       integer :: g_newnss
15663
15664       allnss=0
15665       do i=1,nres-1
15666         do j=i+1,nres
15667           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
15668             allnss=allnss+1
15669             allflag(allnss)=0
15670             allihpb(allnss)=i
15671             alljhpb(allnss)=j
15672           endif
15673         enddo
15674       enddo
15675
15676 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
15677
15678  1    emin=1.0d300
15679       do i=1,allnss
15680         if (allflag(i).eq.0 .and. &
15681              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
15682           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
15683           imin=i
15684         endif
15685       enddo
15686       if (emin.lt.1.0d300) then
15687         allflag(imin)=1
15688         do i=1,allnss
15689           if (allflag(i).eq.0 .and. &
15690                (allihpb(i).eq.allihpb(imin) .or. &
15691                alljhpb(i).eq.allihpb(imin) .or. &
15692                allihpb(i).eq.alljhpb(imin) .or. &
15693                alljhpb(i).eq.alljhpb(imin))) then
15694             allflag(i)=-1
15695           endif
15696         enddo
15697         goto 1
15698       endif
15699
15700 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
15701
15702       newnss=0
15703       do i=1,allnss
15704         if (allflag(i).eq.1) then
15705           newnss=newnss+1
15706           newihpb(newnss)=allihpb(i)
15707           newjhpb(newnss)=alljhpb(i)
15708         endif
15709       enddo
15710
15711 #ifdef MPI
15712       if (nfgtasks.gt.1)then
15713
15714         call MPI_Reduce(newnss,g_newnss,1,&
15715           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
15716         call MPI_Gather(newnss,1,MPI_INTEGER,&
15717                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
15718         displ(0)=0
15719         do i=1,nfgtasks-1,1
15720           displ(i)=i_newnss(i-1)+displ(i-1)
15721         enddo
15722         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
15723                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
15724                          king,FG_COMM,IERR)
15725         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
15726                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
15727                          king,FG_COMM,IERR)
15728         if(fg_rank.eq.0) then
15729 !         print *,'g_newnss',g_newnss
15730 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
15731 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
15732          newnss=g_newnss
15733          do i=1,newnss
15734           newihpb(i)=g_newihpb(i)
15735           newjhpb(i)=g_newjhpb(i)
15736          enddo
15737         endif
15738       endif
15739 #endif
15740
15741       diff=newnss-nss
15742
15743 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
15744
15745       do i=1,nss
15746         found=.false.
15747         do j=1,newnss
15748           if (idssb(i).eq.newihpb(j) .and. &
15749                jdssb(i).eq.newjhpb(j)) found=.true.
15750         enddo
15751 #ifndef CLUST
15752 #ifndef WHAM
15753         if (.not.found.and.fg_rank.eq.0) &
15754             write(iout,'(a15,f12.2,f8.1,2i5)') &
15755              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
15756 #endif
15757 #endif
15758       enddo
15759
15760       do i=1,newnss
15761         found=.false.
15762         do j=1,nss
15763           if (newihpb(i).eq.idssb(j) .and. &
15764                newjhpb(i).eq.jdssb(j)) found=.true.
15765         enddo
15766 #ifndef CLUST
15767 #ifndef WHAM
15768         if (.not.found.and.fg_rank.eq.0) &
15769             write(iout,'(a15,f12.2,f8.1,2i5)') &
15770              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
15771 #endif
15772 #endif
15773       enddo
15774
15775       nss=newnss
15776       do i=1,nss
15777         idssb(i)=newihpb(i)
15778         jdssb(i)=newjhpb(i)
15779       enddo
15780
15781       return
15782       end subroutine dyn_set_nss
15783 !-----------------------------------------------------------------------------
15784 #ifdef WHAM
15785       subroutine read_ssHist
15786       implicit none
15787 !      Includes
15788 !      include 'DIMENSIONS'
15789 !      include "DIMENSIONS.FREE"
15790 !      include 'COMMON.FREE'
15791 !     Local variables
15792       integer :: i,j
15793       character(len=80) :: controlcard
15794
15795       do i=1,dyn_nssHist
15796         call card_concat(controlcard,.true.)
15797         read(controlcard,*) &
15798              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
15799       enddo
15800
15801       return
15802       end subroutine read_ssHist
15803 #endif
15804 !-----------------------------------------------------------------------------
15805       integer function indmat(i,j)
15806 !el
15807 ! get the position of the jth ijth fragment of the chain coordinate system
15808 ! in the fromto array.
15809         integer :: i,j
15810
15811         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
15812       return
15813       end function indmat
15814 !-----------------------------------------------------------------------------
15815       real(kind=8) function sigm(x)
15816 !el
15817        real(kind=8) :: x
15818         sigm=0.25d0*x
15819       return
15820       end function sigm
15821 !-----------------------------------------------------------------------------
15822 !-----------------------------------------------------------------------------
15823       subroutine alloc_ener_arrays
15824 !EL Allocation of arrays used by module energy
15825
15826 !el local variables
15827       integer :: i,j
15828
15829       if(nres.lt.100) then
15830         maxconts=nres
15831       elseif(nres.lt.200) then
15832         maxconts=0.8*nres       ! Max. number of contacts per residue
15833       else
15834         maxconts=0.6*nres ! (maxconts=maxres/4)
15835       endif
15836       maxcont=12*nres   ! Max. number of SC contacts
15837       maxvar=6*nres     ! Max. number of variables
15838 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
15839       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
15840 !----------------------
15841 ! arrays in subroutine init_int_table
15842       allocate(nint_gr(nres))
15843       allocate(nscp_gr(nres))
15844       allocate(ielstart(nres))
15845       allocate(ielend(nres)) !(maxres)
15846       allocate(istart(nres,maxint_gr))
15847       allocate(iend(nres,maxint_gr)) !(maxres,maxint_gr)
15848       allocate(iscpstart(nres,maxint_gr))
15849       allocate(iscpend(nres,maxint_gr)) !(maxres,maxint_gr)
15850       allocate(ielstart_vdw(nres))
15851       allocate(ielend_vdw(nres)) !(maxres)
15852
15853       allocate(lentyp(0:nfgtasks-1)) !(0:maxprocs-1)
15854 !----------------------
15855 ! commom.contacts
15856 !      common /contacts/
15857       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
15858       allocate(icont(2,maxcont)) !(2,maxcont)
15859 !      common /contacts1/
15860       allocate(num_cont(0:nres+4)) !(maxres)
15861       allocate(jcont(maxconts,nres)) !(maxconts,maxres)
15862       allocate(facont(maxconts,nres)) !(maxconts,maxres)
15863       allocate(gacont(3,maxconts,nres)) !(3,maxconts,maxres)
15864 !      common /contacts_hb/
15865       allocate(gacontp_hb1(3,maxconts,nres))
15866       allocate(gacontp_hb2(3,maxconts,nres))
15867       allocate(gacontp_hb3(3,maxconts,nres))
15868       allocate(gacontm_hb1(3,maxconts,nres))
15869       allocate(gacontm_hb2(3,maxconts,nres))
15870       allocate(gacontm_hb3(3,maxconts,nres))
15871       allocate(gacont_hbr(3,maxconts,nres))
15872       allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)
15873       allocate(facont_hb(maxconts,nres))
15874       allocate(ees0p(maxconts,nres))
15875       allocate(ees0m(maxconts,nres))
15876       allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15877       allocate(num_cont_hb(nres)) !(maxres)
15878       allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15879 !      common /rotat/
15880       allocate(Ug(2,2,nres))
15881       allocate(Ugder(2,2,nres))
15882       allocate(Ug2(2,2,nres))
15883       allocate(Ug2der(2,2,nres)) !(2,2,maxres)
15884       allocate(obrot(2,nres))
15885       allocate(obrot2(2,nres))
15886       allocate(obrot_der(2,nres))
15887       allocate(obrot2_der(2,nres)) !(2,maxres)
15888 !      common /precomp1/
15889       allocate(mu(2,nres))
15890       allocate(muder(2,nres))
15891       allocate(Ub2(2,nres))
15892       allocate(Ub2der(2,nres))
15893       allocate(Ctobr(2,nres))
15894       allocate(Ctobrder(2,nres))
15895       allocate(Dtobr2(2,nres))
15896       allocate(Dtobr2der(2,nres)) !(2,maxres)
15897       allocate(EUg(2,2,nres))
15898       allocate(EUgder(2,2,nres))
15899       allocate(CUg(2,2,nres))
15900       allocate(CUgder(2,2,nres))
15901       allocate(DUg(2,2,nres))
15902       allocate(Dugder(2,2,nres))
15903       allocate(DtUg2(2,2,nres))
15904       allocate(DtUg2der(2,2,nres)) !(2,2,maxres)
15905 !      common /precomp2/
15906       allocate(Ug2Db1t(2,nres))
15907       allocate(Ug2Db1tder(2,nres))
15908       allocate(CUgb2(2,nres))
15909       allocate(CUgb2der(2,nres)) !(2,maxres)
15910       allocate(EUgC(2,2,nres))
15911       allocate(EUgCder(2,2,nres))
15912       allocate(EUgD(2,2,nres))
15913       allocate(EUgDder(2,2,nres))
15914       allocate(DtUg2EUg(2,2,nres))
15915       allocate(Ug2DtEUg(2,2,nres)) !(2,2,maxres)
15916       allocate(Ug2DtEUgder(2,2,2,nres))
15917       allocate(DtUg2EUgder(2,2,2,nres)) !(2,2,2,maxres)
15918 !      common /rotat_old/
15919       allocate(costab(nres))
15920       allocate(sintab(nres))
15921       allocate(costab2(nres))
15922       allocate(sintab2(nres)) !(maxres)
15923 !      common /dipmat/
15924       allocate(a_chuj(2,2,maxconts,nres))
15925 !(2,2,maxconts,maxres)(maxconts=maxres/4)
15926       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
15927 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
15928 !      common /contdistrib/
15929       allocate(ncont_sent(nres))
15930       allocate(ncont_recv(nres))
15931
15932       allocate(iat_sent(nres)) !(maxres)
15933       allocate(iint_sent(4,nres,nres))
15934       allocate(iint_sent_local(4,nres,nres)) !(4,maxres,maxres)
15935       allocate(iturn3_sent(4,0:nres+4))
15936       allocate(iturn4_sent(4,0:nres+4))
15937       allocate(iturn3_sent_local(4,nres))
15938       allocate(iturn4_sent_local(4,nres)) !(4,maxres)
15939       allocate(itask_cont_from(0:nfgtasks-1))
15940       allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
15941
15942 !----------------------
15943 ! commom.deriv;
15944 !      common /derivat/
15945       allocate(dcdv(6,maxdim))
15946       allocate(dxdv(6,maxdim)) !(6,maxdim)
15947       allocate(dxds(6,nres)) !(6,maxres)
15948       allocate(gradx(3,nres,0:2))
15949       allocate(gradc(3,nres,0:2)) !(3,maxres,2)
15950       allocate(gvdwx(3,nres))
15951       allocate(gvdwc(3,nres))
15952       allocate(gelc(3,nres))
15953       allocate(gelc_long(3,nres))
15954       allocate(gvdwpp(3,nres))
15955       allocate(gvdwc_scpp(3,nres))
15956       allocate(gradx_scp(3,nres))
15957       allocate(gvdwc_scp(3,nres))
15958       allocate(ghpbx(3,nres))
15959       allocate(ghpbc(3,nres))
15960       allocate(gradcorr(3,nres))
15961       allocate(gradcorr_long(3,nres))
15962       allocate(gradcorr5_long(3,nres))
15963       allocate(gradcorr6_long(3,nres))
15964       allocate(gcorr6_turn_long(3,nres))
15965       allocate(gradxorr(3,nres))
15966       allocate(gradcorr5(3,nres))
15967       allocate(gradcorr6(3,nres)) !(3,maxres)
15968       allocate(gloc(0:maxvar,0:2))
15969       allocate(gloc_x(0:maxvar,2)) !(maxvar,2)
15970       allocate(gel_loc(3,nres))
15971       allocate(gel_loc_long(3,nres))
15972       allocate(gcorr3_turn(3,nres))
15973       allocate(gcorr4_turn(3,nres))
15974       allocate(gcorr6_turn(3,nres))
15975       allocate(gradb(3,nres))
15976       allocate(gradbx(3,nres)) !(3,maxres)
15977       allocate(gel_loc_loc(maxvar))
15978       allocate(gel_loc_turn3(maxvar))
15979       allocate(gel_loc_turn4(maxvar))
15980       allocate(gel_loc_turn6(maxvar))
15981       allocate(gcorr_loc(maxvar))
15982       allocate(g_corr5_loc(maxvar))
15983       allocate(g_corr6_loc(maxvar)) !(maxvar)
15984       allocate(gsccorc(3,nres))
15985       allocate(gsccorx(3,nres)) !(3,maxres)
15986       allocate(gsccor_loc(nres)) !(maxres)
15987       allocate(dtheta(3,2,nres)) !(3,2,maxres)
15988       allocate(gscloc(3,nres))
15989       allocate(gsclocx(3,nres)) !(3,maxres)
15990       allocate(dphi(3,3,nres))
15991       allocate(dalpha(3,3,nres))
15992       allocate(domega(3,3,nres)) !(3,3,maxres)
15993 !      common /deriv_scloc/
15994       allocate(dXX_C1tab(3,nres))
15995       allocate(dYY_C1tab(3,nres))
15996       allocate(dZZ_C1tab(3,nres))
15997       allocate(dXX_Ctab(3,nres))
15998       allocate(dYY_Ctab(3,nres))
15999       allocate(dZZ_Ctab(3,nres))
16000       allocate(dXX_XYZtab(3,nres))
16001       allocate(dYY_XYZtab(3,nres))
16002       allocate(dZZ_XYZtab(3,nres)) !(3,maxres)
16003 !      common /mpgrad/
16004       allocate(jgrad_start(nres))
16005       allocate(jgrad_end(nres)) !(maxres)
16006
16007 !      common /indices/
16008       allocate(ibond_displ(0:nfgtasks-1))
16009       allocate(ibond_count(0:nfgtasks-1))
16010       allocate(ithet_displ(0:nfgtasks-1))
16011       allocate(ithet_count(0:nfgtasks-1))
16012       allocate(iphi_displ(0:nfgtasks-1))
16013       allocate(iphi_count(0:nfgtasks-1))
16014       allocate(iphi1_displ(0:nfgtasks-1))
16015       allocate(iphi1_count(0:nfgtasks-1))
16016       allocate(ivec_displ(0:nfgtasks-1))
16017       allocate(ivec_count(0:nfgtasks-1))
16018       allocate(iset_displ(0:nfgtasks-1))
16019       allocate(iset_count(0:nfgtasks-1))
16020       allocate(iint_count(0:nfgtasks-1))
16021       allocate(iint_displ(0:nfgtasks-1)) !(0:max_fg_procs-1)
16022 !----------------------
16023 ! common.MD
16024 !      common /mdgrad/
16025       allocate(gcart(3,0:nres))
16026       allocate(gxcart(3,0:nres)) !(3,0:MAXRES)
16027       allocate(gradcag(3,nres))
16028       allocate(gradxag(3,nres)) !(3,MAXRES)
16029 !      common /back_constr/
16030 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16031       allocate(dutheta(nres))
16032       allocate(dugamma(nres)) !(maxres)
16033       allocate(duscdiff(3,nres))
16034       allocate(duscdiffx(3,nres)) !(3,maxres)
16035 !el i io:read_fragments
16036 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16037 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16038 !      common /qmeas/
16039 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16040 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16041       allocate(mset(0:nprocs))  !(maxprocs/20)
16042       do i=0,nprocs
16043         mset(i)=0
16044       enddo
16045 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16046 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16047       allocate(dUdconst(3,0:nres))
16048       allocate(dUdxconst(3,0:nres))
16049       allocate(dqwol(3,0:nres))
16050       allocate(dxqwol(3,0:nres)) !(3,0:MAXRES)
16051 !----------------------
16052 ! common.sbridge
16053 !      common /sbridge/ in io_common: read_bridge
16054 !el    allocate((:),allocatable :: iss  !(maxss)
16055 !      common /links/  in io_common: read_bridge
16056 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16057 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16058 !      common /dyn_ssbond/
16059 ! and side-chain vectors in theta or phi.
16060       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4)) !(maxres,maxres)
16061       do i=1,nres
16062         do j=i+1,nres
16063           dyn_ssbond_ij(i,j)=1.0d300
16064         enddo
16065       enddo
16066
16067       if (nss.gt.0) then
16068         allocate(idssb(nss),jdssb(nss)) !(maxdim)
16069       endif
16070       allocate(dyn_ss_mask(nres)) !(maxres)
16071       do i=1,nres
16072         dyn_ss_mask(i)=.false.
16073       enddo
16074 !----------------------
16075 ! common.sccor
16076 ! Parameters of the SCCOR term
16077 !      common/sccor/
16078 !el in io_conf: parmread
16079 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16080 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16081 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16082 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16083 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16084 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16085 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16086 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16087 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16088 !----------------
16089       allocate(gloc_sc(3,0:2*nres,0:10)) !(3,0:maxres2,10)maxres2=2*maxres
16090       allocate(dcostau(3,3,3,2*nres))
16091       allocate(dsintau(3,3,3,2*nres))
16092       allocate(dtauangle(3,3,3,2*nres))
16093       allocate(dcosomicron(3,3,3,2*nres))
16094       allocate(domicron(3,3,3,2*nres)) !(3,3,3,maxres2)maxres2=2*maxres
16095 !----------------------
16096 ! common.scrot
16097 ! Parameters of the SC rotamers (local) term
16098 !      common/scrot/    in io_conf: parmread
16099 !      allocate((:,:),allocatable :: sc_parmin !(maxsccoef,ntyp)
16100 !----------------------
16101 ! common.torcnstr
16102 !      common /torcnstr/
16103 !el in io_conf:molread
16104 !      allocate((:),allocatable :: idih_constr,idih_nconstr !(maxdih_constr)
16105 !      allocate((:),allocatable :: phi0,drange !(maxdih_constr)
16106 !----------------------
16107 ! common.torsion
16108 !      common/torsion/          in io_conf: parmread
16109 !      allocate((:,:,:),allocatable :: v0 !(-maxtor:maxtor,-maxtor:maxtor,2)
16110 !      allocate((:,:,:,:),allocatable :: v1,v2 !(maxterm,-maxtor:maxtor,-maxtor:maxtor,2)
16111 !      allocate((:,:,:),allocatable :: vlor1 !(maxlor,-maxtor:maxtor,-maxtor:maxtor)
16112 !      allocate((:,:,:),allocatable :: vlor2,vlor3 !(maxlor,maxtor,maxtor)
16113 !      allocate((:),allocatable :: itortyp !(-ntyp1:ntyp1)
16114 !      allocate((:,:,:),allocatable :: nterm,nlor !(-maxtor:maxtor,-maxtor:maxtor,2)
16115 !
16116 !      common /torsiond/         in io_conf: parmread
16117 !      allocate((:,:,:,:,:,:),allocatable :: v1c,v1s
16118         !(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2)
16119 !      allocate((:,:,:,:,:,:),allocatable :: v2c,v2s
16120         !(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2)
16121 !      allocate((:,:,:,:),allocatable :: ntermd_1,ntermd_2
16122         !(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2)
16123 !      common/fourier/          in io_conf: parmread
16124 !      allocate((:,:),allocatable :: b1,b2,&
16125 !       b1tilde !(2,-maxtor:maxtor)
16126 !      allocate((:,:,:),allocatable :: cc,dd,ee,&
16127 !       ctilde,dtilde !(2,2,-maxtor:maxtor)
16128 !----------------------
16129 ! common.var
16130 !      common /restr/
16131       allocate(varall(maxvar)) !(maxvar)(maxvar=6*maxres)
16132       allocate(mask_theta(nres))
16133       allocate(mask_phi(nres))
16134       allocate(mask_side(nres)) !(maxres)
16135 !----------------------
16136 ! common.vectors
16137 !      common /vectors/
16138       allocate(uy(3,nres))
16139       allocate(uz(3,nres)) !(3,maxres)
16140       allocate(uygrad(3,3,2,nres))
16141       allocate(uzgrad(3,3,2,nres)) !(3,3,2,maxres)
16142
16143       return
16144       end subroutine alloc_ener_arrays
16145 !-----------------------------------------------------------------------------
16146 !-----------------------------------------------------------------------------
16147       end module energy