source/unres/energy.f90

   1       module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 ! Maximum number of local shielding effectors
  33       integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont       !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist       !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont       !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48 !
  49 ! 12/26/95 - H-bonding contacts
  50 !      common /contacts_hb/
  51       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  52        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont  !(3,maxconts,maxres)
  53       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  54         ees0m,d_cont    !(maxconts,maxres)
  55       integer,dimension(:),allocatable :: num_cont_hb   !(maxres)
  56       integer,dimension(:,:),allocatable :: jcont_hb    !(maxconts,maxres)
  57 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  58 !         interactions
  59 ! 7/25/08 commented out; not needed when cumulants used
  60 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  61 !  common /dipint/
  62       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  63          dipderg        !(4,maxconts,maxres)
  64       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  65 ! 10/30/99 Added other pre-computed vectors and matrices needed
  66 !          to calculate three - six-order el-loc correlation terms
  67 ! common /rotat/
  68       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der  !(2,2,maxres)
  69       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  70        obrot2_der       !(2,maxres)
  71 !
  72 ! This common block contains vectors and matrices dependent on a single
  73 ! amino-acid residue.
  74 !      common /precomp1/
  75       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  76        Ctobr,Ctobrder,Dtobr2,Dtobr2der  !(2,maxres)
  77       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  78        CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres)
  79 ! This common block contains vectors and matrices dependent on two
  80 ! consecutive amino-acid residues.
  81 !      common /precomp2/
  82       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  83        CUgb2,CUgb2der   !(2,maxres)
  84       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  85        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg   !(2,2,maxres)
  86       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  87        DtUg2EUgder      !(2,2,2,maxres)
  88 !      common /rotat_old/
  89       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  90        costab2,sintab2  !(maxres)
  91 ! This common block contains dipole-interaction matrices and their
  92 ! Cartesian derivatives.
  93 !      common /dipmat/
  94       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj     !(2,2,maxconts,maxres)
  95       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der     !(2,2,3,5,maxconts,maxres)
  96 !      common /diploc/
  97       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  98        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
  99       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 100        ADtEA1derg,AEAb2derg
 101       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 102        AECAderx,ADtEAderx,ADtEA1derx
 103       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 104       real(kind=8),dimension(3,2) :: g_contij
 105       real(kind=8) :: ekont
 106 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 107 !   RE: Parallelization of 4th and higher order loc-el correlations
 108 !      common /contdistrib/
 109       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 110 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 111 !-----------------------------------------------------------------------------
 112 ! commom.deriv;
 113 !      common /derivat/
 114 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 115 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 116 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 117       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 118         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 119         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 120         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 121         gliptranx, &
 122         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 123         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 124         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 125         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 126         grad_shield,gg_tube,gg_tube_sc !(3,maxres)
 127 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 128       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 129         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 130       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 131         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 132         g_corr6_loc     !(maxvar)
 133       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 134       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 135 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 136       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 137 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 138       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 139          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 140 !      integer :: nfl,icg
 141 !      common /deriv_loc/
 142       real(kind=8), dimension(:),allocatable :: fac_shield
 143       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 144 !      common /deriv_scloc/
 145       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 146        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 147        dZZ_XYZtab       !(3,maxres)
 148 !-----------------------------------------------------------------------------
 149 ! common.maxgrad
 150 !      common /maxgrad/
 151       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 152        gradb_max,ghpbc_max,&
 153        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 154        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 155        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 156        gsccorx_max,gsclocx_max
 157 !-----------------------------------------------------------------------------
 158 ! common.MD
 159 !      common /back_constr/
 160       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 161       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 162 !      common /qmeas/
 163       real(kind=8) :: Ucdfrag,Ucdpair
 164       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 165        dqwol,dxqwol     !(3,0:MAXRES)
 166 !-----------------------------------------------------------------------------
 167 ! common.sbridge
 168 !      common /dyn_ssbond/
 169       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 170 !-----------------------------------------------------------------------------
 171 ! common.sccor
 172 ! Parameters of the SCCOR term
 173 !      common/sccor/
 174       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 175        dcosomicron,domicron     !(3,3,3,maxres2)
 176 !-----------------------------------------------------------------------------
 177 ! common.vectors
 178 !      common /vectors/
 179       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 180       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 181 !-----------------------------------------------------------------------------
 182 ! common /przechowalnia/
 183       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 184       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 185 !-----------------------------------------------------------------------------
 186 !-----------------------------------------------------------------------------
 187 !
 188 !
 189 !-----------------------------------------------------------------------------
 190       contains
 191 !-----------------------------------------------------------------------------
 192 ! energy_p_new_barrier.F
 193 !-----------------------------------------------------------------------------
 194       subroutine etotal(energia)
 195 !      implicit real*8 (a-h,o-z)
 196 !      include 'DIMENSIONS'
 197       use MD_data
 198 #ifndef ISNAN
 199       external proc_proc
 200 #ifdef WINPGI
 201 !MS$ATTRIBUTES C ::  proc_proc
 202 #endif
 203 #endif
 204 #ifdef MPI
 205       include "mpif.h"
 206 #endif
 207 !      include 'COMMON.SETUP'
 208 !      include 'COMMON.IOUNITS'
 209       real(kind=8),dimension(0:n_ene) :: energia
 210 !      include 'COMMON.LOCAL'
 211 !      include 'COMMON.FFIELD'
 212 !      include 'COMMON.DERIV'
 213 !      include 'COMMON.INTERACT'
 214 !      include 'COMMON.SBRIDGE'
 215 !      include 'COMMON.CHAIN'
 216 !      include 'COMMON.VAR'
 217 !      include 'COMMON.MD'
 218 !      include 'COMMON.CONTROL'
 219 !      include 'COMMON.TIME1'
 220       real(kind=8) :: time00
 221 !el local variables
 222       integer :: n_corr,n_corr1,ierror
 223       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 224       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 225       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube
 226       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 227
 228 #ifdef MPI
 229       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 230 ! shielding effect varibles for MPI
 231 !      real(kind=8)   fac_shieldbuf(maxres),
 232 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 233 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 234 !     & grad_shieldbuf(3,-1:maxres)
 235 !       integer ishield_listbuf(maxres),
 236 !     &shield_listbuf(maxcontsshi,maxres)
 237
 238 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 239 !     & " nfgtasks",nfgtasks
 240       if (nfgtasks.gt.1) then
 241         time00=MPI_Wtime()
 242 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 243         if (fg_rank.eq.0) then
 244           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 245 !          print *,"Processor",myrank," BROADCAST iorder"
 246 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 247 ! FG slaves as WEIGHTS array.
 248           weights_(1)=wsc
 249           weights_(2)=wscp
 250           weights_(3)=welec
 251           weights_(4)=wcorr
 252           weights_(5)=wcorr5
 253           weights_(6)=wcorr6
 254           weights_(7)=wel_loc
 255           weights_(8)=wturn3
 256           weights_(9)=wturn4
 257           weights_(10)=wturn6
 258           weights_(11)=wang
 259           weights_(12)=wscloc
 260           weights_(13)=wtor
 261           weights_(14)=wtor_d
 262           weights_(15)=wstrain
 263           weights_(16)=wvdwpp
 264           weights_(17)=wbond
 265           weights_(18)=scal14
 266           weights_(21)=wsccor
 267 ! FG Master broadcasts the WEIGHTS_ array
 268           call MPI_Bcast(weights_(1),n_ene,&
 269              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 270         else
 271 ! FG slaves receive the WEIGHTS array
 272           call MPI_Bcast(weights(1),n_ene,&
 273               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 274           wsc=weights(1)
 275           wscp=weights(2)
 276           welec=weights(3)
 277           wcorr=weights(4)
 278           wcorr5=weights(5)
 279           wcorr6=weights(6)
 280           wel_loc=weights(7)
 281           wturn3=weights(8)
 282           wturn4=weights(9)
 283           wturn6=weights(10)
 284           wang=weights(11)
 285           wscloc=weights(12)
 286           wtor=weights(13)
 287           wtor_d=weights(14)
 288           wstrain=weights(15)
 289           wvdwpp=weights(16)
 290           wbond=weights(17)
 291           scal14=weights(18)
 292           wsccor=weights(21)
 293         endif
 294         time_Bcast=time_Bcast+MPI_Wtime()-time00
 295         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 296 !        call chainbuild_cart
 297       endif
 298 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 299 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 300 #else
 301 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 302 !        call int_from_cart1(.false.)
 303 !      endif
 304 #endif
 305 #ifdef TIMING
 306       time00=MPI_Wtime()
 307 #endif
 308 !
 309 ! Compute the side-chain and electrostatic interaction energy
 310         print *, "Before EVDW"
 311 !      goto (101,102,103,104,105,106) ipot
 312       select case(ipot)
 313 ! Lennard-Jones potential.
 314 !  101 call elj(evdw)
 315        case (1)
 316          call elj(evdw)
 317 !d    print '(a)','Exit ELJcall el'
 318 !      goto 107
 319 ! Lennard-Jones-Kihara potential (shifted).
 320 !  102 call eljk(evdw)
 321        case (2)
 322          call eljk(evdw)
 323 !      goto 107
 324 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 325 !  103 call ebp(evdw)
 326        case (3)
 327          call ebp(evdw)
 328 !      goto 107
 329 ! Gay-Berne potential (shifted LJ, angular dependence).
 330 !  104 call egb(evdw)
 331        case (4)
 332          call egb(evdw)
 333 !      goto 107
 334 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 335 !  105 call egbv(evdw)
 336        case (5)
 337          call egbv(evdw)
 338 !      goto 107
 339 ! Soft-sphere potential
 340 !  106 call e_softsphere(evdw)
 341        case (6)
 342          call e_softsphere(evdw)
 343 !
 344 ! Calculate electrostatic (H-bonding) energy of the main chain.
 345 !
 346 !  107 continue
 347        case default
 348          write(iout,*)"Wrong ipot"
 349 !         return
 350 !   50 continue
 351       end select
 352 !      continue
 353 !        print *,"after EGB"
 354 ! shielding effect
 355        if (shield_mode.eq.2) then
 356                  call set_shield_fac2
 357        endif
 358 !mc
 359 !mc Sep-06: egb takes care of dynamic ss bonds too
 360 !mc
 361 !      if (dyn_ss) call dyn_set_nss
 362 !      print *,"Processor",myrank," computed USCSC"
 363 #ifdef TIMING
 364       time01=MPI_Wtime()
 365 #endif
 366       call vec_and_deriv
 367 #ifdef TIMING
 368       time_vec=time_vec+MPI_Wtime()-time01
 369 #endif
 370 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 371       if (ipot.lt.6) then
 372 #ifdef SPLITELE
 373          print *,"after ipot if", ipot
 374          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 375              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 376              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 377              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 378 #else
 379          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 380              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 381              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 382              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 383 #endif
 384 !            print *,"just befor eelec call"
 385             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 386 !         write (iout,*) "ELEC calc"
 387          else
 388             ees=0.0d0
 389             evdw1=0.0d0
 390             eel_loc=0.0d0
 391             eello_turn3=0.0d0
 392             eello_turn4=0.0d0
 393          endif
 394       else
 395 !        write (iout,*) "Soft-spheer ELEC potential"
 396         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 397          eello_turn4)
 398       endif
 399 !      print *,"Processor",myrank," computed UELEC"
 400 !
 401 ! Calculate excluded-volume interaction energy between peptide groups
 402 ! and side chains.
 403 !
 404 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 405
 406       if (ipot.lt.6) then
 407        if(wscp.gt.0d0) then
 408         call escp(evdw2,evdw2_14)
 409        else
 410         evdw2=0
 411         evdw2_14=0
 412        endif
 413       else
 414 !        write (iout,*) "Soft-sphere SCP potential"
 415         call escp_soft_sphere(evdw2,evdw2_14)
 416       endif
 417 !       write(iout,*) "in etotal before ebond",ipot
 418
 419 !
 420 ! Calculate the bond-stretching energy
 421 !
 422       call ebond(estr)
 423 !       write(iout,*) "in etotal afer ebond",ipot
 424
 425 !
 426 ! Calculate the disulfide-bridge and other energy and the contributions
 427 ! from other distance constraints.
 428 !      print *,'Calling EHPB'
 429       call edis(ehpb)
 430 !elwrite(iout,*) "in etotal afer edis",ipot
 431 !      print *,'EHPB exitted succesfully.'
 432 !
 433 ! Calculate the virtual-bond-angle energy.
 434 !
 435       if (wang.gt.0d0) then
 436         call ebend(ebe)
 437       else
 438         ebe=0
 439       endif
 440 !      print *,"Processor",myrank," computed UB"
 441 !
 442 ! Calculate the SC local energy.
 443 !
 444       call esc(escloc)
 445 !elwrite(iout,*) "in etotal afer esc",ipot
 446 !      print *,"Processor",myrank," computed USC"
 447 !
 448 ! Calculate the virtual-bond torsional energy.
 449 !
 450 !d    print *,'nterm=',nterm
 451       if (wtor.gt.0) then
 452        call etor(etors,edihcnstr)
 453       else
 454        etors=0
 455        edihcnstr=0
 456       endif
 457 !      print *,"Processor",myrank," computed Utor"
 458 !
 459 ! 6/23/01 Calculate double-torsional energy
 460 !
 461 !elwrite(iout,*) "in etotal",ipot
 462       if (wtor_d.gt.0) then
 463        call etor_d(etors_d)
 464       else
 465        etors_d=0
 466       endif
 467 !      print *,"Processor",myrank," computed Utord"
 468 !
 469 ! 21/5/07 Calculate local sicdechain correlation energy
 470 !
 471       if (wsccor.gt.0.0d0) then
 472         call eback_sc_corr(esccor)
 473       else
 474         esccor=0.0d0
 475       endif
 476 !      print *,"Processor",myrank," computed Usccorr"
 477 !
 478 ! 12/1/95 Multi-body terms
 479 !
 480       n_corr=0
 481       n_corr1=0
 482       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 483           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 484          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 485 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 486 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 487       else
 488          ecorr=0.0d0
 489          ecorr5=0.0d0
 490          ecorr6=0.0d0
 491          eturn6=0.0d0
 492       endif
 493 !elwrite(iout,*) "in etotal",ipot
 494       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 495          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 496 !d         write (iout,*) "multibody_hb ecorr",ecorr
 497       endif
 498 !elwrite(iout,*) "afeter  multibody hb"
 499
 500 !      print *,"Processor",myrank," computed Ucorr"
 501 !
 502 ! If performing constraint dynamics, call the constraint energy
 503 !  after the equilibration time
 504       if(usampl.and.totT.gt.eq_time) then
 505 !elwrite(iout,*) "afeter  multibody hb"
 506          call EconstrQ
 507 !elwrite(iout,*) "afeter  multibody hb"
 508          call Econstr_back
 509 !elwrite(iout,*) "afeter  multibody hb"
 510       else
 511          Uconst=0.0d0
 512          Uconst_back=0.0d0
 513       endif
 514       call flush(iout)
 515 !         write(iout,*) "after Econstr"
 516
 517       if (wliptran.gt.0) then
 518 !        print *,"PRZED WYWOLANIEM"
 519         call Eliptransfer(eliptran)
 520       else
 521        eliptran=0.0d0
 522       endif
 523       if (tubemode.eq.1) then
 524        call calctube(etube)
 525       else if (tubemode.eq.2) then
 526        call calctube2(etube)
 527       elseif (tubemode.eq.3) then
 528        call calcnano(etube)
 529       else
 530        etube=0.0d0
 531       endif
 532
 533 #ifdef TIMING
 534       time_enecalc=time_enecalc+MPI_Wtime()-time00
 535 #endif
 536 !      print *,"Processor",myrank," computed Uconstr"
 537 #ifdef TIMING
 538       time00=MPI_Wtime()
 539 #endif
 540 !
 541 ! Sum the energies
 542 !
 543       energia(1)=evdw
 544 #ifdef SCP14
 545       energia(2)=evdw2-evdw2_14
 546       energia(18)=evdw2_14
 547 #else
 548       energia(2)=evdw2
 549       energia(18)=0.0d0
 550 #endif
 551 #ifdef SPLITELE
 552       energia(3)=ees
 553       energia(16)=evdw1
 554 #else
 555       energia(3)=ees+evdw1
 556       energia(16)=0.0d0
 557 #endif
 558       energia(4)=ecorr
 559       energia(5)=ecorr5
 560       energia(6)=ecorr6
 561       energia(7)=eel_loc
 562       energia(8)=eello_turn3
 563       energia(9)=eello_turn4
 564       energia(10)=eturn6
 565       energia(11)=ebe
 566       energia(12)=escloc
 567       energia(13)=etors
 568       energia(14)=etors_d
 569       energia(15)=ehpb
 570       energia(19)=edihcnstr
 571       energia(17)=estr
 572       energia(20)=Uconst+Uconst_back
 573       energia(21)=esccor
 574       energia(22)=eliptran
 575       energia(25)=etube
 576 !    Here are the energies showed per procesor if the are more processors
 577 !    per molecule then we sum it up in sum_energy subroutine
 578 !      print *," Processor",myrank," calls SUM_ENERGY"
 579       call sum_energy(energia,.true.)
 580       if (dyn_ss) call dyn_set_nss
 581 !      print *," Processor",myrank," left SUM_ENERGY"
 582 #ifdef TIMING
 583       time_sumene=time_sumene+MPI_Wtime()-time00
 584 #endif
 585 !el        call enerprint(energia)
 586 !elwrite(iout,*)"finish etotal"
 587       return
 588       end subroutine etotal
 589 !-----------------------------------------------------------------------------
 590       subroutine sum_energy(energia,reduce)
 591 !      implicit real*8 (a-h,o-z)
 592 !      include 'DIMENSIONS'
 593 #ifndef ISNAN
 594       external proc_proc
 595 #ifdef WINPGI
 596 !MS$ATTRIBUTES C ::  proc_proc
 597 #endif
 598 #endif
 599 #ifdef MPI
 600       include "mpif.h"
 601 #endif
 602 !      include 'COMMON.SETUP'
 603 !      include 'COMMON.IOUNITS'
 604       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 605 !      include 'COMMON.FFIELD'
 606 !      include 'COMMON.DERIV'
 607 !      include 'COMMON.INTERACT'
 608 !      include 'COMMON.SBRIDGE'
 609 !      include 'COMMON.CHAIN'
 610 !      include 'COMMON.VAR'
 611 !      include 'COMMON.CONTROL'
 612 !      include 'COMMON.TIME1'
 613       logical :: reduce
 614       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 615       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 616       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 617         eliptran,etube
 618       integer :: i
 619 #ifdef MPI
 620       integer :: ierr
 621       real(kind=8) :: time00
 622       if (nfgtasks.gt.1 .and. reduce) then
 623
 624 #ifdef DEBUG
 625         write (iout,*) "energies before REDUCE"
 626         call enerprint(energia)
 627         call flush(iout)
 628 #endif
 629         do i=0,n_ene
 630           enebuff(i)=energia(i)
 631         enddo
 632         time00=MPI_Wtime()
 633         call MPI_Barrier(FG_COMM,IERR)
 634         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 635         time00=MPI_Wtime()
 636         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 637           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 638 #ifdef DEBUG
 639         write (iout,*) "energies after REDUCE"
 640         call enerprint(energia)
 641         call flush(iout)
 642 #endif
 643         time_Reduce=time_Reduce+MPI_Wtime()-time00
 644       endif
 645       if (fg_rank.eq.0) then
 646 #endif
 647       evdw=energia(1)
 648 #ifdef SCP14
 649       evdw2=energia(2)+energia(18)
 650       evdw2_14=energia(18)
 651 #else
 652       evdw2=energia(2)
 653 #endif
 654 #ifdef SPLITELE
 655       ees=energia(3)
 656       evdw1=energia(16)
 657 #else
 658       ees=energia(3)
 659       evdw1=0.0d0
 660 #endif
 661       ecorr=energia(4)
 662       ecorr5=energia(5)
 663       ecorr6=energia(6)
 664       eel_loc=energia(7)
 665       eello_turn3=energia(8)
 666       eello_turn4=energia(9)
 667       eturn6=energia(10)
 668       ebe=energia(11)
 669       escloc=energia(12)
 670       etors=energia(13)
 671       etors_d=energia(14)
 672       ehpb=energia(15)
 673       edihcnstr=energia(19)
 674       estr=energia(17)
 675       Uconst=energia(20)
 676       esccor=energia(21)
 677       eliptran=energia(22)
 678       etube=energia(25)
 679 #ifdef SPLITELE
 680       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 681        +wang*ebe+wtor*etors+wscloc*escloc &
 682        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 683        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 684        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 685        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube
 686 #else
 687       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 688        +wang*ebe+wtor*etors+wscloc*escloc &
 689        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 690        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 691        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 692        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube
 693 #endif
 694       energia(0)=etot
 695 ! detecting NaNQ
 696 #ifdef ISNAN
 697 #ifdef AIX
 698       if (isnan(etot).ne.0) energia(0)=1.0d+99
 699 #else
 700       if (isnan(etot)) energia(0)=1.0d+99
 701 #endif
 702 #else
 703       i=0
 704 #ifdef WINPGI
 705       idumm=proc_proc(etot,i)
 706 #else
 707       call proc_proc(etot,i)
 708 #endif
 709       if(i.eq.1)energia(0)=1.0d+99
 710 #endif
 711 #ifdef MPI
 712       endif
 713 #endif
 714 !      call enerprint(energia)
 715       call flush(iout)
 716       return
 717       end subroutine sum_energy
 718 !-----------------------------------------------------------------------------
 719       subroutine rescale_weights(t_bath)
 720 !      implicit real*8 (a-h,o-z)
 721 #ifdef MPI
 722       include 'mpif.h'
 723 #endif
 724 !      include 'DIMENSIONS'
 725 !      include 'COMMON.IOUNITS'
 726 !      include 'COMMON.FFIELD'
 727 !      include 'COMMON.SBRIDGE'
 728       real(kind=8) :: kfac=2.4d0
 729       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 730 !el local variables
 731       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 732       real(kind=8) :: T0=3.0d2
 733       integer :: ierror
 734 !      facT=temp0/t_bath
 735 !      facT=2*temp0/(t_bath+temp0)
 736       if (rescale_mode.eq.0) then
 737         facT(1)=1.0d0
 738         facT(2)=1.0d0
 739         facT(3)=1.0d0
 740         facT(4)=1.0d0
 741         facT(5)=1.0d0
 742         facT(6)=1.0d0
 743       else if (rescale_mode.eq.1) then
 744         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 745         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 746         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 747         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 748         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 749 #ifdef WHAM_RUN
 750 !#if defined(WHAM_RUN) || defined(CLUSTER)
 751 #if defined(FUNCTH)
 752 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 753         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 754 #elif defined(FUNCT)
 755         facT(6)=t_bath/T0
 756 #else
 757         facT(6)=1.0d0
 758 #endif
 759 #endif
 760       else if (rescale_mode.eq.2) then
 761         x=t_bath/temp0
 762         x2=x*x
 763         x3=x2*x
 764         x4=x3*x
 765         x5=x4*x
 766         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 767         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 768         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 769         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 770         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 771 #ifdef WHAM_RUN
 772 !#if defined(WHAM_RUN) || defined(CLUSTER)
 773 #if defined(FUNCTH)
 774         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 775 #elif defined(FUNCT)
 776         facT(6)=t_bath/T0
 777 #else
 778         facT(6)=1.0d0
 779 #endif
 780 #endif
 781       else
 782         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 783         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 784 #ifdef MPI
 785        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 786 #endif
 787        stop 555
 788       endif
 789       welec=weights(3)*fact(1)
 790       wcorr=weights(4)*fact(3)
 791       wcorr5=weights(5)*fact(4)
 792       wcorr6=weights(6)*fact(5)
 793       wel_loc=weights(7)*fact(2)
 794       wturn3=weights(8)*fact(2)
 795       wturn4=weights(9)*fact(3)
 796       wturn6=weights(10)*fact(5)
 797       wtor=weights(13)*fact(1)
 798       wtor_d=weights(14)*fact(2)
 799       wsccor=weights(21)*fact(1)
 800
 801       return
 802       end subroutine rescale_weights
 803 !-----------------------------------------------------------------------------
 804       subroutine enerprint(energia)
 805 !      implicit real*8 (a-h,o-z)
 806 !      include 'DIMENSIONS'
 807 !      include 'COMMON.IOUNITS'
 808 !      include 'COMMON.FFIELD'
 809 !      include 'COMMON.SBRIDGE'
 810 !      include 'COMMON.MD'
 811       real(kind=8) :: energia(0:n_ene)
 812 !el local variables
 813       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 814       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 815       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 816        etube
 817
 818       etot=energia(0)
 819       evdw=energia(1)
 820       evdw2=energia(2)
 821 #ifdef SCP14
 822       evdw2=energia(2)+energia(18)
 823 #else
 824       evdw2=energia(2)
 825 #endif
 826       ees=energia(3)
 827 #ifdef SPLITELE
 828       evdw1=energia(16)
 829 #endif
 830       ecorr=energia(4)
 831       ecorr5=energia(5)
 832       ecorr6=energia(6)
 833       eel_loc=energia(7)
 834       eello_turn3=energia(8)
 835       eello_turn4=energia(9)
 836       eello_turn6=energia(10)
 837       ebe=energia(11)
 838       escloc=energia(12)
 839       etors=energia(13)
 840       etors_d=energia(14)
 841       ehpb=energia(15)
 842       edihcnstr=energia(19)
 843       estr=energia(17)
 844       Uconst=energia(20)
 845       esccor=energia(21)
 846       eliptran=energia(22)
 847       etube=energia(25)
 848 #ifdef SPLITELE
 849       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 850         estr,wbond,ebe,wang,&
 851         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 852         ecorr,wcorr,&
 853         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 854         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 855         edihcnstr,ebr*nss,&
 856         Uconst,eliptran,wliptran,etube,wtube,etot
 857    10 format (/'Virtual-chain energies:'// &
 858        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 859        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 860        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 861        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 862        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 863        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 864        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 865        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 866        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 867        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 868        ' (SS bridges & dist. cnstr.)'/ &
 869        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 870        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 871        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 872        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 873        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 874        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 875        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 876        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 877        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 878        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 879        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 880        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
 881        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 882        'ETOT=  ',1pE16.6,' (total)')
 883 #else
 884       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 885         estr,wbond,ebe,wang,&
 886         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 887         ecorr,wcorr,&
 888         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 889         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 890         ebr*nss,Uconst,eliptran,wliptran,etube,wtube,etot
 891    10 format (/'Virtual-chain energies:'// &
 892        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 893        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 894        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 895        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 896        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 897        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 898        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 899        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 900        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 901        ' (SS bridges & dist. cnstr.)'/ &
 902        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 903        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 904        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 905        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 906        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 907        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 908        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 909        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 910        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 911        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 912        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 913        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
 914        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 915        'ETOT=  ',1pE16.6,' (total)')
 916 #endif
 917       return
 918       end subroutine enerprint
 919 !-----------------------------------------------------------------------------
 920       subroutine elj(evdw)
 921 !
 922 ! This subroutine calculates the interaction energy of nonbonded side chains
 923 ! assuming the LJ potential of interaction.
 924 !
 925 !      implicit real*8 (a-h,o-z)
 926 !      include 'DIMENSIONS'
 927       real(kind=8),parameter :: accur=1.0d-10
 928 !      include 'COMMON.GEO'
 929 !      include 'COMMON.VAR'
 930 !      include 'COMMON.LOCAL'
 931 !      include 'COMMON.CHAIN'
 932 !      include 'COMMON.DERIV'
 933 !      include 'COMMON.INTERACT'
 934 !      include 'COMMON.TORSION'
 935 !      include 'COMMON.SBRIDGE'
 936 !      include 'COMMON.NAMES'
 937 !      include 'COMMON.IOUNITS'
 938 !      include 'COMMON.CONTACTS'
 939       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
 940       integer :: num_conti
 941 !el local variables
 942       integer :: i,itypi,iint,j,itypi1,itypj,k
 943       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 944       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 945       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 946
 947 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 948       evdw=0.0D0
 949 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 950 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 951 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 952 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 953
 954       do i=iatsc_s,iatsc_e
 955         itypi=iabs(itype(i))
 956         if (itypi.eq.ntyp1) cycle
 957         itypi1=iabs(itype(i+1))
 958         xi=c(1,nres+i)
 959         yi=c(2,nres+i)
 960         zi=c(3,nres+i)
 961 ! Change 12/1/95
 962         num_conti=0
 963 !
 964 ! Calculate SC interaction energy.
 965 !
 966         do iint=1,nint_gr(i)
 967 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 968 !d   &                  'iend=',iend(i,iint)
 969           do j=istart(i,iint),iend(i,iint)
 970             itypj=iabs(itype(j))
 971             if (itypj.eq.ntyp1) cycle
 972             xj=c(1,nres+j)-xi
 973             yj=c(2,nres+j)-yi
 974             zj=c(3,nres+j)-zi
 975 ! Change 12/1/95 to calculate four-body interactions
 976             rij=xj*xj+yj*yj+zj*zj
 977             rrij=1.0D0/rij
 978 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 979             eps0ij=eps(itypi,itypj)
 980             fac=rrij**expon2
 981             e1=fac*fac*aa_aq(itypi,itypj)
 982             e2=fac*bb_aq(itypi,itypj)
 983             evdwij=e1+e2
 984 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 985 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 986 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 987 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 988 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 989 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 990             evdw=evdw+evdwij
 991 !
 992 ! Calculate the components of the gradient in DC and X
 993 !
 994             fac=-rrij*(e1+evdwij)
 995             gg(1)=xj*fac
 996             gg(2)=yj*fac
 997             gg(3)=zj*fac
 998             do k=1,3
 999               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1000               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1001               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1002               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1003             enddo
1004 !grad            do k=i,j-1
1005 !grad              do l=1,3
1006 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1007 !grad              enddo
1008 !grad            enddo
1009 !
1010 ! 12/1/95, revised on 5/20/97
1011 !
1012 ! Calculate the contact function. The ith column of the array JCONT will
1013 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1014 ! greater than I). The arrays FACONT and GACONT will contain the values of
1015 ! the contact function and its derivative.
1016 !
1017 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1018 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1019 ! Uncomment next line, if the correlation interactions are contact function only
1020             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1021               rij=dsqrt(rij)
1022               sigij=sigma(itypi,itypj)
1023               r0ij=rs0(itypi,itypj)
1024 !
1025 ! Check whether the SC's are not too far to make a contact.
1026 !
1027               rcut=1.5d0*r0ij
1028               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1029 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1030 !
1031               if (fcont.gt.0.0D0) then
1032 ! If the SC-SC distance if close to sigma, apply spline.
1033 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1034 !Adam &             fcont1,fprimcont1)
1035 !Adam           fcont1=1.0d0-fcont1
1036 !Adam           if (fcont1.gt.0.0d0) then
1037 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1038 !Adam             fcont=fcont*fcont1
1039 !Adam           endif
1040 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1041 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1042 !ga             do k=1,3
1043 !ga               gg(k)=gg(k)*eps0ij
1044 !ga             enddo
1045 !ga             eps0ij=-evdwij*eps0ij
1046 ! Uncomment for AL's type of SC correlation interactions.
1047 !adam           eps0ij=-evdwij
1048                 num_conti=num_conti+1
1049                 jcont(num_conti,i)=j
1050                 facont(num_conti,i)=fcont*eps0ij
1051                 fprimcont=eps0ij*fprimcont/rij
1052                 fcont=expon*fcont
1053 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1054 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1055 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1056 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1057                 gacont(1,num_conti,i)=-fprimcont*xj
1058                 gacont(2,num_conti,i)=-fprimcont*yj
1059                 gacont(3,num_conti,i)=-fprimcont*zj
1060 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1061 !d              write (iout,'(2i3,3f10.5)')
1062 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1063               endif
1064             endif
1065           enddo      ! j
1066         enddo        ! iint
1067 ! Change 12/1/95
1068         num_cont(i)=num_conti
1069       enddo          ! i
1070       do i=1,nct
1071         do j=1,3
1072           gvdwc(j,i)=expon*gvdwc(j,i)
1073           gvdwx(j,i)=expon*gvdwx(j,i)
1074         enddo
1075       enddo
1076 !******************************************************************************
1077 !
1078 !                              N O T E !!!
1079 !
1080 ! To save time, the factor of EXPON has been extracted from ALL components
1081 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1082 ! use!
1083 !
1084 !******************************************************************************
1085       return
1086       end subroutine elj
1087 !-----------------------------------------------------------------------------
1088       subroutine eljk(evdw)
1089 !
1090 ! This subroutine calculates the interaction energy of nonbonded side chains
1091 ! assuming the LJK potential of interaction.
1092 !
1093 !      implicit real*8 (a-h,o-z)
1094 !      include 'DIMENSIONS'
1095 !      include 'COMMON.GEO'
1096 !      include 'COMMON.VAR'
1097 !      include 'COMMON.LOCAL'
1098 !      include 'COMMON.CHAIN'
1099 !      include 'COMMON.DERIV'
1100 !      include 'COMMON.INTERACT'
1101 !      include 'COMMON.IOUNITS'
1102 !      include 'COMMON.NAMES'
1103       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1104       logical :: scheck
1105 !el local variables
1106       integer :: i,iint,j,itypi,itypi1,k,itypj
1107       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1108       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1109
1110 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1111       evdw=0.0D0
1112       do i=iatsc_s,iatsc_e
1113         itypi=iabs(itype(i))
1114         if (itypi.eq.ntyp1) cycle
1115         itypi1=iabs(itype(i+1))
1116         xi=c(1,nres+i)
1117         yi=c(2,nres+i)
1118         zi=c(3,nres+i)
1119 !
1120 ! Calculate SC interaction energy.
1121 !
1122         do iint=1,nint_gr(i)
1123           do j=istart(i,iint),iend(i,iint)
1124             itypj=iabs(itype(j))
1125             if (itypj.eq.ntyp1) cycle
1126             xj=c(1,nres+j)-xi
1127             yj=c(2,nres+j)-yi
1128             zj=c(3,nres+j)-zi
1129             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1130             fac_augm=rrij**expon
1131             e_augm=augm(itypi,itypj)*fac_augm
1132             r_inv_ij=dsqrt(rrij)
1133             rij=1.0D0/r_inv_ij
1134             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1135             fac=r_shift_inv**expon
1136             e1=fac*fac*aa_aq(itypi,itypj)
1137             e2=fac*bb_aq(itypi,itypj)
1138             evdwij=e_augm+e1+e2
1139 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1140 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1141 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1142 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1143 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1144 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1145 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1146             evdw=evdw+evdwij
1147 !
1148 ! Calculate the components of the gradient in DC and X
1149 !
1150             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1151             gg(1)=xj*fac
1152             gg(2)=yj*fac
1153             gg(3)=zj*fac
1154             do k=1,3
1155               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1156               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1157               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1158               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1159             enddo
1160 !grad            do k=i,j-1
1161 !grad              do l=1,3
1162 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1163 !grad              enddo
1164 !grad            enddo
1165           enddo      ! j
1166         enddo        ! iint
1167       enddo          ! i
1168       do i=1,nct
1169         do j=1,3
1170           gvdwc(j,i)=expon*gvdwc(j,i)
1171           gvdwx(j,i)=expon*gvdwx(j,i)
1172         enddo
1173       enddo
1174       return
1175       end subroutine eljk
1176 !-----------------------------------------------------------------------------
1177       subroutine ebp(evdw)
1178 !
1179 ! This subroutine calculates the interaction energy of nonbonded side chains
1180 ! assuming the Berne-Pechukas potential of interaction.
1181 !
1182       use comm_srutu
1183       use calc_data
1184 !      implicit real*8 (a-h,o-z)
1185 !      include 'DIMENSIONS'
1186 !      include 'COMMON.GEO'
1187 !      include 'COMMON.VAR'
1188 !      include 'COMMON.LOCAL'
1189 !      include 'COMMON.CHAIN'
1190 !      include 'COMMON.DERIV'
1191 !      include 'COMMON.NAMES'
1192 !      include 'COMMON.INTERACT'
1193 !      include 'COMMON.IOUNITS'
1194 !      include 'COMMON.CALC'
1195       use comm_srutu
1196 !el      integer :: icall
1197 !el      common /srutu/ icall
1198 !     double precision rrsave(maxdim)
1199       logical :: lprn
1200 !el local variables
1201       integer :: iint,itypi,itypi1,itypj
1202       real(kind=8) :: rrij,xi,yi,zi
1203       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1204
1205 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1206       evdw=0.0D0
1207 !     if (icall.eq.0) then
1208 !       lprn=.true.
1209 !     else
1210         lprn=.false.
1211 !     endif
1212 !el      ind=0
1213       do i=iatsc_s,iatsc_e
1214         itypi=iabs(itype(i))
1215         if (itypi.eq.ntyp1) cycle
1216         itypi1=iabs(itype(i+1))
1217         xi=c(1,nres+i)
1218         yi=c(2,nres+i)
1219         zi=c(3,nres+i)
1220         dxi=dc_norm(1,nres+i)
1221         dyi=dc_norm(2,nres+i)
1222         dzi=dc_norm(3,nres+i)
1223 !        dsci_inv=dsc_inv(itypi)
1224         dsci_inv=vbld_inv(i+nres)
1225 !
1226 ! Calculate SC interaction energy.
1227 !
1228         do iint=1,nint_gr(i)
1229           do j=istart(i,iint),iend(i,iint)
1230 !el            ind=ind+1
1231             itypj=iabs(itype(j))
1232             if (itypj.eq.ntyp1) cycle
1233 !            dscj_inv=dsc_inv(itypj)
1234             dscj_inv=vbld_inv(j+nres)
1235             chi1=chi(itypi,itypj)
1236             chi2=chi(itypj,itypi)
1237             chi12=chi1*chi2
1238             chip1=chip(itypi)
1239             chip2=chip(itypj)
1240             chip12=chip1*chip2
1241             alf1=alp(itypi)
1242             alf2=alp(itypj)
1243             alf12=0.5D0*(alf1+alf2)
1244 ! For diagnostics only!!!
1245 !           chi1=0.0D0
1246 !           chi2=0.0D0
1247 !           chi12=0.0D0
1248 !           chip1=0.0D0
1249 !           chip2=0.0D0
1250 !           chip12=0.0D0
1251 !           alf1=0.0D0
1252 !           alf2=0.0D0
1253 !           alf12=0.0D0
1254             xj=c(1,nres+j)-xi
1255             yj=c(2,nres+j)-yi
1256             zj=c(3,nres+j)-zi
1257             dxj=dc_norm(1,nres+j)
1258             dyj=dc_norm(2,nres+j)
1259             dzj=dc_norm(3,nres+j)
1260             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1261 !d          if (icall.eq.0) then
1262 !d            rrsave(ind)=rrij
1263 !d          else
1264 !d            rrij=rrsave(ind)
1265 !d          endif
1266             rij=dsqrt(rrij)
1267 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1268             call sc_angular
1269 ! Calculate whole angle-dependent part of epsilon and contributions
1270 ! to its derivatives
1271             fac=(rrij*sigsq)**expon2
1272             e1=fac*fac*aa_aq(itypi,itypj)
1273             e2=fac*bb_aq(itypi,itypj)
1274             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1275             eps2der=evdwij*eps3rt
1276             eps3der=evdwij*eps2rt
1277             evdwij=evdwij*eps2rt*eps3rt
1278             evdw=evdw+evdwij
1279             if (lprn) then
1280             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1281             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1282 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1283 !d     &        restyp(itypi),i,restyp(itypj),j,
1284 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1285 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1286 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1287 !d     &        evdwij
1288             endif
1289 ! Calculate gradient components.
1290             e1=e1*eps1*eps2rt**2*eps3rt**2
1291             fac=-expon*(e1+evdwij)
1292             sigder=fac/sigsq
1293             fac=rrij*fac
1294 ! Calculate radial part of the gradient
1295             gg(1)=xj*fac
1296             gg(2)=yj*fac
1297             gg(3)=zj*fac
1298 ! Calculate the angular part of the gradient and sum add the contributions
1299 ! to the appropriate components of the Cartesian gradient.
1300             call sc_grad
1301           enddo      ! j
1302         enddo        ! iint
1303       enddo          ! i
1304 !     stop
1305       return
1306       end subroutine ebp
1307 !-----------------------------------------------------------------------------
1308       subroutine egb(evdw)
1309 !
1310 ! This subroutine calculates the interaction energy of nonbonded side chains
1311 ! assuming the Gay-Berne potential of interaction.
1312 !
1313       use calc_data
1314 !      implicit real*8 (a-h,o-z)
1315 !      include 'DIMENSIONS'
1316 !      include 'COMMON.GEO'
1317 !      include 'COMMON.VAR'
1318 !      include 'COMMON.LOCAL'
1319 !      include 'COMMON.CHAIN'
1320 !      include 'COMMON.DERIV'
1321 !      include 'COMMON.NAMES'
1322 !      include 'COMMON.INTERACT'
1323 !      include 'COMMON.IOUNITS'
1324 !      include 'COMMON.CALC'
1325 !      include 'COMMON.CONTROL'
1326 !      include 'COMMON.SBRIDGE'
1327       logical :: lprn
1328 !el local variables
1329       integer :: iint,itypi,itypi1,itypj,subchap
1330       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1331       real(kind=8) :: evdw,sig0ij
1332       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1333                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1334                     sslipi,sslipj,faclip
1335       integer :: ii
1336       real(kind=8) :: fracinbuf
1337
1338 !cccc      energy_dec=.false.
1339 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1340       evdw=0.0D0
1341       lprn=.false.
1342 !     if (icall.eq.0) lprn=.false.
1343 !el      ind=0
1344       do i=iatsc_s,iatsc_e
1345 !C        print *,"I am in EVDW",i
1346         itypi=iabs(itype(i))
1347 !        if (i.ne.47) cycle
1348         if (itypi.eq.ntyp1) cycle
1349         itypi1=iabs(itype(i+1))
1350         xi=c(1,nres+i)
1351         yi=c(2,nres+i)
1352         zi=c(3,nres+i)
1353           xi=dmod(xi,boxxsize)
1354           if (xi.lt.0) xi=xi+boxxsize
1355           yi=dmod(yi,boxysize)
1356           if (yi.lt.0) yi=yi+boxysize
1357           zi=dmod(zi,boxzsize)
1358           if (zi.lt.0) zi=zi+boxzsize
1359
1360        if ((zi.gt.bordlipbot)  &
1361         .and.(zi.lt.bordliptop)) then
1362 !C the energy transfer exist
1363         if (zi.lt.buflipbot) then
1364 !C what fraction I am in
1365          fracinbuf=1.0d0-  &
1366               ((zi-bordlipbot)/lipbufthick)
1367 !C lipbufthick is thickenes of lipid buffore
1368          sslipi=sscalelip(fracinbuf)
1369          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1370         elseif (zi.gt.bufliptop) then
1371          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1372          sslipi=sscalelip(fracinbuf)
1373          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1374         else
1375          sslipi=1.0d0
1376          ssgradlipi=0.0
1377         endif
1378        else
1379          sslipi=0.0d0
1380          ssgradlipi=0.0
1381        endif
1382        print *, sslipi,ssgradlipi
1383         dxi=dc_norm(1,nres+i)
1384         dyi=dc_norm(2,nres+i)
1385         dzi=dc_norm(3,nres+i)
1386 !        dsci_inv=dsc_inv(itypi)
1387         dsci_inv=vbld_inv(i+nres)
1388 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1389 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1390 !
1391 ! Calculate SC interaction energy.
1392 !
1393         do iint=1,nint_gr(i)
1394           do j=istart(i,iint),iend(i,iint)
1395             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1396               call dyn_ssbond_ene(i,j,evdwij)
1397               evdw=evdw+evdwij
1398               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1399                               'evdw',i,j,evdwij,' ss'
1400 !              if (energy_dec) write (iout,*) &
1401 !                              'evdw',i,j,evdwij,' ss'
1402             ELSE
1403 !el            ind=ind+1
1404             itypj=iabs(itype(j))
1405             if (itypj.eq.ntyp1) cycle
1406 !             if (j.ne.78) cycle
1407 !            dscj_inv=dsc_inv(itypj)
1408             dscj_inv=vbld_inv(j+nres)
1409 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1410 !              1.0d0/vbld(j+nres) !d
1411 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1412             sig0ij=sigma(itypi,itypj)
1413             chi1=chi(itypi,itypj)
1414             chi2=chi(itypj,itypi)
1415             chi12=chi1*chi2
1416             chip1=chip(itypi)
1417             chip2=chip(itypj)
1418             chip12=chip1*chip2
1419             alf1=alp(itypi)
1420             alf2=alp(itypj)
1421             alf12=0.5D0*(alf1+alf2)
1422 ! For diagnostics only!!!
1423 !           chi1=0.0D0
1424 !           chi2=0.0D0
1425 !           chi12=0.0D0
1426 !           chip1=0.0D0
1427 !           chip2=0.0D0
1428 !           chip12=0.0D0
1429 !           alf1=0.0D0
1430 !           alf2=0.0D0
1431 !           alf12=0.0D0
1432            xj=c(1,nres+j)
1433            yj=c(2,nres+j)
1434            zj=c(3,nres+j)
1435           xj=dmod(xj,boxxsize)
1436           if (xj.lt.0) xj=xj+boxxsize
1437           yj=dmod(yj,boxysize)
1438           if (yj.lt.0) yj=yj+boxysize
1439           zj=dmod(zj,boxzsize)
1440           if (zj.lt.0) zj=zj+boxzsize
1441 !          print *,"tu",xi,yi,zi,xj,yj,zj
1442 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1443 ! this fragment set correct epsilon for lipid phase
1444        if ((zj.gt.bordlipbot)  &
1445        .and.(zj.lt.bordliptop)) then
1446 !C the energy transfer exist
1447         if (zj.lt.buflipbot) then
1448 !C what fraction I am in
1449          fracinbuf=1.0d0-     &
1450              ((zj-bordlipbot)/lipbufthick)
1451 !C lipbufthick is thickenes of lipid buffore
1452          sslipj=sscalelip(fracinbuf)
1453          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1454         elseif (zj.gt.bufliptop) then
1455          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1456          sslipj=sscalelip(fracinbuf)
1457          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1458         else
1459          sslipj=1.0d0
1460          ssgradlipj=0.0
1461         endif
1462        else
1463          sslipj=0.0d0
1464          ssgradlipj=0.0
1465        endif
1466       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1467        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1468       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1469        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1470 !------------------------------------------------
1471       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1472       xj_safe=xj
1473       yj_safe=yj
1474       zj_safe=zj
1475       subchap=0
1476       do xshift=-1,1
1477       do yshift=-1,1
1478       do zshift=-1,1
1479           xj=xj_safe+xshift*boxxsize
1480           yj=yj_safe+yshift*boxysize
1481           zj=zj_safe+zshift*boxzsize
1482           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1483           if(dist_temp.lt.dist_init) then
1484             dist_init=dist_temp
1485             xj_temp=xj
1486             yj_temp=yj
1487             zj_temp=zj
1488             subchap=1
1489           endif
1490        enddo
1491        enddo
1492        enddo
1493        if (subchap.eq.1) then
1494           xj=xj_temp-xi
1495           yj=yj_temp-yi
1496           zj=zj_temp-zi
1497        else
1498           xj=xj_safe-xi
1499           yj=yj_safe-yi
1500           zj=zj_safe-zi
1501        endif
1502             dxj=dc_norm(1,nres+j)
1503             dyj=dc_norm(2,nres+j)
1504             dzj=dc_norm(3,nres+j)
1505 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1506 !            write (iout,*) "j",j," dc_norm",& !d
1507 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1508 !          write(iout,*)"rrij ",rrij
1509 !          write(iout,*)"xj yj zj ", xj, yj, zj
1510 !          write(iout,*)"xi yi zi ", xi, yi, zi
1511 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1512             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1513             rij=dsqrt(rrij)
1514             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1515             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1516 !            print *,sss_ele_cut,sss_ele_grad,&
1517 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1518             if (sss_ele_cut.le.0.0) cycle
1519 ! Calculate angle-dependent terms of energy and contributions to their
1520 ! derivatives.
1521             call sc_angular
1522             sigsq=1.0D0/sigsq
1523             sig=sig0ij*dsqrt(sigsq)
1524             rij_shift=1.0D0/rij-sig+sig0ij
1525 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1526 !            "sig0ij",sig0ij
1527 ! for diagnostics; uncomment
1528 !            rij_shift=1.2*sig0ij
1529 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1530             if (rij_shift.le.0.0D0) then
1531               evdw=1.0D20
1532 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1533 !d     &        restyp(itypi),i,restyp(itypj),j,
1534 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1535               return
1536             endif
1537             sigder=-sig*sigsq
1538 !---------------------------------------------------------------
1539             rij_shift=1.0D0/rij_shift
1540             fac=rij_shift**expon
1541             faclip=fac
1542             e1=fac*fac*aa!(itypi,itypj)
1543             e2=fac*bb!(itypi,itypj)
1544             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1545             eps2der=evdwij*eps3rt
1546             eps3der=evdwij*eps2rt
1547 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1548 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1549 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1550             evdwij=evdwij*eps2rt*eps3rt
1551             evdw=evdw+evdwij*sss_ele_cut
1552             if (lprn) then
1553             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1554             epsi=bb**2/aa!(itypi,itypj)
1555             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1556               restyp(itypi),i,restyp(itypj),j, &
1557               epsi,sigm,chi1,chi2,chip1,chip2, &
1558               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1559               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1560               evdwij
1561             endif
1562
1563             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1564                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1565 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1566 !            if (energy_dec) write (iout,*) &
1567 !                             'evdw',i,j,evdwij
1568
1569 ! Calculate gradient components.
1570             e1=e1*eps1*eps2rt**2*eps3rt**2
1571             fac=-expon*(e1+evdwij)*rij_shift
1572             sigder=fac*sigder
1573             fac=rij*fac
1574 !            print *,'before fac',fac,rij,evdwij
1575             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1576             /sigma(itypi,itypj)*rij
1577 !            print *,'grad part scale',fac,   &
1578 !             evdwij*sss_ele_grad/sss_ele_cut &
1579 !            /sigma(itypi,itypj)*rij
1580 !            fac=0.0d0
1581 ! Calculate the radial part of the gradient
1582             gg(1)=xj*fac
1583             gg(2)=yj*fac
1584             gg(3)=zj*fac
1585 !C Calculate the radial part of the gradient
1586             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1587        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1588         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1589        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1590             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1591             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1592
1593 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1594 ! Calculate angular part of the gradient.
1595             call sc_grad
1596             ENDIF    ! dyn_ss
1597           enddo      ! j
1598         enddo        ! iint
1599       enddo          ! i
1600 !      write (iout,*) "Number of loop steps in EGB:",ind
1601 !ccc      energy_dec=.false.
1602       return
1603       end subroutine egb
1604 !-----------------------------------------------------------------------------
1605       subroutine egbv(evdw)
1606 !
1607 ! This subroutine calculates the interaction energy of nonbonded side chains
1608 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1609 !
1610       use comm_srutu
1611       use calc_data
1612 !      implicit real*8 (a-h,o-z)
1613 !      include 'DIMENSIONS'
1614 !      include 'COMMON.GEO'
1615 !      include 'COMMON.VAR'
1616 !      include 'COMMON.LOCAL'
1617 !      include 'COMMON.CHAIN'
1618 !      include 'COMMON.DERIV'
1619 !      include 'COMMON.NAMES'
1620 !      include 'COMMON.INTERACT'
1621 !      include 'COMMON.IOUNITS'
1622 !      include 'COMMON.CALC'
1623       use comm_srutu
1624 !el      integer :: icall
1625 !el      common /srutu/ icall
1626       logical :: lprn
1627 !el local variables
1628       integer :: iint,itypi,itypi1,itypj
1629       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1630       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1631
1632 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1633       evdw=0.0D0
1634       lprn=.false.
1635 !     if (icall.eq.0) lprn=.true.
1636 !el      ind=0
1637       do i=iatsc_s,iatsc_e
1638         itypi=iabs(itype(i))
1639         if (itypi.eq.ntyp1) cycle
1640         itypi1=iabs(itype(i+1))
1641         xi=c(1,nres+i)
1642         yi=c(2,nres+i)
1643         zi=c(3,nres+i)
1644         dxi=dc_norm(1,nres+i)
1645         dyi=dc_norm(2,nres+i)
1646         dzi=dc_norm(3,nres+i)
1647 !        dsci_inv=dsc_inv(itypi)
1648         dsci_inv=vbld_inv(i+nres)
1649 !
1650 ! Calculate SC interaction energy.
1651 !
1652         do iint=1,nint_gr(i)
1653           do j=istart(i,iint),iend(i,iint)
1654 !el            ind=ind+1
1655             itypj=iabs(itype(j))
1656             if (itypj.eq.ntyp1) cycle
1657 !            dscj_inv=dsc_inv(itypj)
1658             dscj_inv=vbld_inv(j+nres)
1659             sig0ij=sigma(itypi,itypj)
1660             r0ij=r0(itypi,itypj)
1661             chi1=chi(itypi,itypj)
1662             chi2=chi(itypj,itypi)
1663             chi12=chi1*chi2
1664             chip1=chip(itypi)
1665             chip2=chip(itypj)
1666             chip12=chip1*chip2
1667             alf1=alp(itypi)
1668             alf2=alp(itypj)
1669             alf12=0.5D0*(alf1+alf2)
1670 ! For diagnostics only!!!
1671 !           chi1=0.0D0
1672 !           chi2=0.0D0
1673 !           chi12=0.0D0
1674 !           chip1=0.0D0
1675 !           chip2=0.0D0
1676 !           chip12=0.0D0
1677 !           alf1=0.0D0
1678 !           alf2=0.0D0
1679 !           alf12=0.0D0
1680             xj=c(1,nres+j)-xi
1681             yj=c(2,nres+j)-yi
1682             zj=c(3,nres+j)-zi
1683             dxj=dc_norm(1,nres+j)
1684             dyj=dc_norm(2,nres+j)
1685             dzj=dc_norm(3,nres+j)
1686             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1687             rij=dsqrt(rrij)
1688 ! Calculate angle-dependent terms of energy and contributions to their
1689 ! derivatives.
1690             call sc_angular
1691             sigsq=1.0D0/sigsq
1692             sig=sig0ij*dsqrt(sigsq)
1693             rij_shift=1.0D0/rij-sig+r0ij
1694 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1695             if (rij_shift.le.0.0D0) then
1696               evdw=1.0D20
1697               return
1698             endif
1699             sigder=-sig*sigsq
1700 !---------------------------------------------------------------
1701             rij_shift=1.0D0/rij_shift
1702             fac=rij_shift**expon
1703             e1=fac*fac*aa_aq(itypi,itypj)
1704             e2=fac*bb_aq(itypi,itypj)
1705             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1706             eps2der=evdwij*eps3rt
1707             eps3der=evdwij*eps2rt
1708             fac_augm=rrij**expon
1709             e_augm=augm(itypi,itypj)*fac_augm
1710             evdwij=evdwij*eps2rt*eps3rt
1711             evdw=evdw+evdwij+e_augm
1712             if (lprn) then
1713             sigm=dabs(aa_aq(itypi,itypj)/&
1714             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1715             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1716             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1717               restyp(itypi),i,restyp(itypj),j,&
1718               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1719               chi1,chi2,chip1,chip2,&
1720               eps1,eps2rt**2,eps3rt**2,&
1721               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1722               evdwij+e_augm
1723             endif
1724 ! Calculate gradient components.
1725             e1=e1*eps1*eps2rt**2*eps3rt**2
1726             fac=-expon*(e1+evdwij)*rij_shift
1727             sigder=fac*sigder
1728             fac=rij*fac-2*expon*rrij*e_augm
1729 ! Calculate the radial part of the gradient
1730             gg(1)=xj*fac
1731             gg(2)=yj*fac
1732             gg(3)=zj*fac
1733 ! Calculate angular part of the gradient.
1734             call sc_grad
1735           enddo      ! j
1736         enddo        ! iint
1737       enddo          ! i
1738       end subroutine egbv
1739 !-----------------------------------------------------------------------------
1740 !el      subroutine sc_angular in module geometry
1741 !-----------------------------------------------------------------------------
1742       subroutine e_softsphere(evdw)
1743 !
1744 ! This subroutine calculates the interaction energy of nonbonded side chains
1745 ! assuming the LJ potential of interaction.
1746 !
1747 !      implicit real*8 (a-h,o-z)
1748 !      include 'DIMENSIONS'
1749       real(kind=8),parameter :: accur=1.0d-10
1750 !      include 'COMMON.GEO'
1751 !      include 'COMMON.VAR'
1752 !      include 'COMMON.LOCAL'
1753 !      include 'COMMON.CHAIN'
1754 !      include 'COMMON.DERIV'
1755 !      include 'COMMON.INTERACT'
1756 !      include 'COMMON.TORSION'
1757 !      include 'COMMON.SBRIDGE'
1758 !      include 'COMMON.NAMES'
1759 !      include 'COMMON.IOUNITS'
1760 !      include 'COMMON.CONTACTS'
1761       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1762 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1763 !el local variables
1764       integer :: i,iint,j,itypi,itypi1,itypj,k
1765       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1766       real(kind=8) :: fac
1767
1768       evdw=0.0D0
1769       do i=iatsc_s,iatsc_e
1770         itypi=iabs(itype(i))
1771         if (itypi.eq.ntyp1) cycle
1772         itypi1=iabs(itype(i+1))
1773         xi=c(1,nres+i)
1774         yi=c(2,nres+i)
1775         zi=c(3,nres+i)
1776 !
1777 ! Calculate SC interaction energy.
1778 !
1779         do iint=1,nint_gr(i)
1780 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1781 !d   &                  'iend=',iend(i,iint)
1782           do j=istart(i,iint),iend(i,iint)
1783             itypj=iabs(itype(j))
1784             if (itypj.eq.ntyp1) cycle
1785             xj=c(1,nres+j)-xi
1786             yj=c(2,nres+j)-yi
1787             zj=c(3,nres+j)-zi
1788             rij=xj*xj+yj*yj+zj*zj
1789 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1790             r0ij=r0(itypi,itypj)
1791             r0ijsq=r0ij*r0ij
1792 !            print *,i,j,r0ij,dsqrt(rij)
1793             if (rij.lt.r0ijsq) then
1794               evdwij=0.25d0*(rij-r0ijsq)**2
1795               fac=rij-r0ijsq
1796             else
1797               evdwij=0.0d0
1798               fac=0.0d0
1799             endif
1800             evdw=evdw+evdwij
1801 !
1802 ! Calculate the components of the gradient in DC and X
1803 !
1804             gg(1)=xj*fac
1805             gg(2)=yj*fac
1806             gg(3)=zj*fac
1807             do k=1,3
1808               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1809               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1810               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1811               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1812             enddo
1813 !grad            do k=i,j-1
1814 !grad              do l=1,3
1815 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1816 !grad              enddo
1817 !grad            enddo
1818           enddo ! j
1819         enddo ! iint
1820       enddo ! i
1821       return
1822       end subroutine e_softsphere
1823 !-----------------------------------------------------------------------------
1824       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1825 !
1826 ! Soft-sphere potential of p-p interaction
1827 !
1828 !      implicit real*8 (a-h,o-z)
1829 !      include 'DIMENSIONS'
1830 !      include 'COMMON.CONTROL'
1831 !      include 'COMMON.IOUNITS'
1832 !      include 'COMMON.GEO'
1833 !      include 'COMMON.VAR'
1834 !      include 'COMMON.LOCAL'
1835 !      include 'COMMON.CHAIN'
1836 !      include 'COMMON.DERIV'
1837 !      include 'COMMON.INTERACT'
1838 !      include 'COMMON.CONTACTS'
1839 !      include 'COMMON.TORSION'
1840 !      include 'COMMON.VECTORS'
1841 !      include 'COMMON.FFIELD'
1842       real(kind=8),dimension(3) :: ggg
1843 !d      write(iout,*) 'In EELEC_soft_sphere'
1844 !el local variables
1845       integer :: i,j,k,num_conti,iteli,itelj
1846       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1847       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1848       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1849
1850       ees=0.0D0
1851       evdw1=0.0D0
1852       eel_loc=0.0d0
1853       eello_turn3=0.0d0
1854       eello_turn4=0.0d0
1855 !el      ind=0
1856       do i=iatel_s,iatel_e
1857         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1858         dxi=dc(1,i)
1859         dyi=dc(2,i)
1860         dzi=dc(3,i)
1861         xmedi=c(1,i)+0.5d0*dxi
1862         ymedi=c(2,i)+0.5d0*dyi
1863         zmedi=c(3,i)+0.5d0*dzi
1864         num_conti=0
1865 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1866         do j=ielstart(i),ielend(i)
1867           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1868 !el          ind=ind+1
1869           iteli=itel(i)
1870           itelj=itel(j)
1871           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1872           r0ij=rpp(iteli,itelj)
1873           r0ijsq=r0ij*r0ij
1874           dxj=dc(1,j)
1875           dyj=dc(2,j)
1876           dzj=dc(3,j)
1877           xj=c(1,j)+0.5D0*dxj-xmedi
1878           yj=c(2,j)+0.5D0*dyj-ymedi
1879           zj=c(3,j)+0.5D0*dzj-zmedi
1880           rij=xj*xj+yj*yj+zj*zj
1881           if (rij.lt.r0ijsq) then
1882             evdw1ij=0.25d0*(rij-r0ijsq)**2
1883             fac=rij-r0ijsq
1884           else
1885             evdw1ij=0.0d0
1886             fac=0.0d0
1887           endif
1888           evdw1=evdw1+evdw1ij
1889 !
1890 ! Calculate contributions to the Cartesian gradient.
1891 !
1892           ggg(1)=fac*xj
1893           ggg(2)=fac*yj
1894           ggg(3)=fac*zj
1895           do k=1,3
1896             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1897             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1898           enddo
1899 !
1900 ! Loop over residues i+1 thru j-1.
1901 !
1902 !grad          do k=i+1,j-1
1903 !grad            do l=1,3
1904 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1905 !grad            enddo
1906 !grad          enddo
1907         enddo ! j
1908       enddo   ! i
1909 !grad      do i=nnt,nct-1
1910 !grad        do k=1,3
1911 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1912 !grad        enddo
1913 !grad        do j=i+1,nct-1
1914 !grad          do k=1,3
1915 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1916 !grad          enddo
1917 !grad        enddo
1918 !grad      enddo
1919       return
1920       end subroutine eelec_soft_sphere
1921 !-----------------------------------------------------------------------------
1922       subroutine vec_and_deriv
1923 !      implicit real*8 (a-h,o-z)
1924 !      include 'DIMENSIONS'
1925 #ifdef MPI
1926       include 'mpif.h'
1927 #endif
1928 !      include 'COMMON.IOUNITS'
1929 !      include 'COMMON.GEO'
1930 !      include 'COMMON.VAR'
1931 !      include 'COMMON.LOCAL'
1932 !      include 'COMMON.CHAIN'
1933 !      include 'COMMON.VECTORS'
1934 !      include 'COMMON.SETUP'
1935 !      include 'COMMON.TIME1'
1936       real(kind=8),dimension(3,3,2) :: uyder,uzder
1937       real(kind=8),dimension(2) :: vbld_inv_temp
1938 ! Compute the local reference systems. For reference system (i), the
1939 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1940 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1941 !el local variables
1942       integer :: i,j,k,l
1943       real(kind=8) :: facy,fac,costh
1944
1945 #ifdef PARVEC
1946       do i=ivec_start,ivec_end
1947 #else
1948       do i=1,nres-1
1949 #endif
1950           if (i.eq.nres-1) then
1951 ! Case of the last full residue
1952 ! Compute the Z-axis
1953             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1954             costh=dcos(pi-theta(nres))
1955             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1956             do k=1,3
1957               uz(k,i)=fac*uz(k,i)
1958             enddo
1959 ! Compute the derivatives of uz
1960             uzder(1,1,1)= 0.0d0
1961             uzder(2,1,1)=-dc_norm(3,i-1)
1962             uzder(3,1,1)= dc_norm(2,i-1)
1963             uzder(1,2,1)= dc_norm(3,i-1)
1964             uzder(2,2,1)= 0.0d0
1965             uzder(3,2,1)=-dc_norm(1,i-1)
1966             uzder(1,3,1)=-dc_norm(2,i-1)
1967             uzder(2,3,1)= dc_norm(1,i-1)
1968             uzder(3,3,1)= 0.0d0
1969             uzder(1,1,2)= 0.0d0
1970             uzder(2,1,2)= dc_norm(3,i)
1971             uzder(3,1,2)=-dc_norm(2,i)
1972             uzder(1,2,2)=-dc_norm(3,i)
1973             uzder(2,2,2)= 0.0d0
1974             uzder(3,2,2)= dc_norm(1,i)
1975             uzder(1,3,2)= dc_norm(2,i)
1976             uzder(2,3,2)=-dc_norm(1,i)
1977             uzder(3,3,2)= 0.0d0
1978 ! Compute the Y-axis
1979             facy=fac
1980             do k=1,3
1981               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1982             enddo
1983 ! Compute the derivatives of uy
1984             do j=1,3
1985               do k=1,3
1986                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
1987                               -dc_norm(k,i)*dc_norm(j,i-1)
1988                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1989               enddo
1990               uyder(j,j,1)=uyder(j,j,1)-costh
1991               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1992             enddo
1993             do j=1,2
1994               do k=1,3
1995                 do l=1,3
1996                   uygrad(l,k,j,i)=uyder(l,k,j)
1997                   uzgrad(l,k,j,i)=uzder(l,k,j)
1998                 enddo
1999               enddo
2000             enddo
2001             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2002             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2003             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2004             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2005           else
2006 ! Other residues
2007 ! Compute the Z-axis
2008             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2009             costh=dcos(pi-theta(i+2))
2010             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2011             do k=1,3
2012               uz(k,i)=fac*uz(k,i)
2013             enddo
2014 ! Compute the derivatives of uz
2015             uzder(1,1,1)= 0.0d0
2016             uzder(2,1,1)=-dc_norm(3,i+1)
2017             uzder(3,1,1)= dc_norm(2,i+1)
2018             uzder(1,2,1)= dc_norm(3,i+1)
2019             uzder(2,2,1)= 0.0d0
2020             uzder(3,2,1)=-dc_norm(1,i+1)
2021             uzder(1,3,1)=-dc_norm(2,i+1)
2022             uzder(2,3,1)= dc_norm(1,i+1)
2023             uzder(3,3,1)= 0.0d0
2024             uzder(1,1,2)= 0.0d0
2025             uzder(2,1,2)= dc_norm(3,i)
2026             uzder(3,1,2)=-dc_norm(2,i)
2027             uzder(1,2,2)=-dc_norm(3,i)
2028             uzder(2,2,2)= 0.0d0
2029             uzder(3,2,2)= dc_norm(1,i)
2030             uzder(1,3,2)= dc_norm(2,i)
2031             uzder(2,3,2)=-dc_norm(1,i)
2032             uzder(3,3,2)= 0.0d0
2033 ! Compute the Y-axis
2034             facy=fac
2035             do k=1,3
2036               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2037             enddo
2038 ! Compute the derivatives of uy
2039             do j=1,3
2040               do k=1,3
2041                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2042                               -dc_norm(k,i)*dc_norm(j,i+1)
2043                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2044               enddo
2045               uyder(j,j,1)=uyder(j,j,1)-costh
2046               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2047             enddo
2048             do j=1,2
2049               do k=1,3
2050                 do l=1,3
2051                   uygrad(l,k,j,i)=uyder(l,k,j)
2052                   uzgrad(l,k,j,i)=uzder(l,k,j)
2053                 enddo
2054               enddo
2055             enddo
2056             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2057             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2058             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2059             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2060           endif
2061       enddo
2062       do i=1,nres-1
2063         vbld_inv_temp(1)=vbld_inv(i+1)
2064         if (i.lt.nres-1) then
2065           vbld_inv_temp(2)=vbld_inv(i+2)
2066           else
2067           vbld_inv_temp(2)=vbld_inv(i)
2068           endif
2069         do j=1,2
2070           do k=1,3
2071             do l=1,3
2072               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2073               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2074             enddo
2075           enddo
2076         enddo
2077       enddo
2078 #if defined(PARVEC) && defined(MPI)
2079       if (nfgtasks1.gt.1) then
2080         time00=MPI_Wtime()
2081 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2082 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2083 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2084         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2085          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2086          FG_COMM1,IERR)
2087         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2088          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2089          FG_COMM1,IERR)
2090         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2091          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2092          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2093         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2094          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2095          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2096         time_gather=time_gather+MPI_Wtime()-time00
2097       endif
2098 !      if (fg_rank.eq.0) then
2099 !        write (iout,*) "Arrays UY and UZ"
2100 !        do i=1,nres-1
2101 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2102 !     &     (uz(k,i),k=1,3)
2103 !        enddo
2104 !      endif
2105 #endif
2106       return
2107       end subroutine vec_and_deriv
2108 !-----------------------------------------------------------------------------
2109       subroutine check_vecgrad
2110 !      implicit real*8 (a-h,o-z)
2111 !      include 'DIMENSIONS'
2112 !      include 'COMMON.IOUNITS'
2113 !      include 'COMMON.GEO'
2114 !      include 'COMMON.VAR'
2115 !      include 'COMMON.LOCAL'
2116 !      include 'COMMON.CHAIN'
2117 !      include 'COMMON.VECTORS'
2118       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2119       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2120       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2121       real(kind=8),dimension(3) :: erij
2122       real(kind=8) :: delta=1.0d-7
2123 !el local variables
2124       integer :: i,j,k,l
2125
2126       call vec_and_deriv
2127 !d      do i=1,nres
2128 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2129 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2130 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2131 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2132 !d     &     (dc_norm(if90,i),if90=1,3)
2133 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2134 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2135 !d          write(iout,'(a)')
2136 !d      enddo
2137       do i=1,nres
2138         do j=1,2
2139           do k=1,3
2140             do l=1,3
2141               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2142               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2143             enddo
2144           enddo
2145         enddo
2146       enddo
2147       call vec_and_deriv
2148       do i=1,nres
2149         do j=1,3
2150           uyt(j,i)=uy(j,i)
2151           uzt(j,i)=uz(j,i)
2152         enddo
2153       enddo
2154       do i=1,nres
2155 !d        write (iout,*) 'i=',i
2156         do k=1,3
2157           erij(k)=dc_norm(k,i)
2158         enddo
2159         do j=1,3
2160           do k=1,3
2161             dc_norm(k,i)=erij(k)
2162           enddo
2163           dc_norm(j,i)=dc_norm(j,i)+delta
2164 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2165 !          do k=1,3
2166 !            dc_norm(k,i)=dc_norm(k,i)/fac
2167 !          enddo
2168 !          write (iout,*) (dc_norm(k,i),k=1,3)
2169 !          write (iout,*) (erij(k),k=1,3)
2170           call vec_and_deriv
2171           do k=1,3
2172             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2173             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2174             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2175             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2176           enddo
2177 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2178 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2179 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2180         enddo
2181         do k=1,3
2182           dc_norm(k,i)=erij(k)
2183         enddo
2184 !d        do k=1,3
2185 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2186 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2187 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2188 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2189 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2190 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2191 !d          write (iout,'(a)')
2192 !d        enddo
2193       enddo
2194       return
2195       end subroutine check_vecgrad
2196 !-----------------------------------------------------------------------------
2197       subroutine set_matrices
2198 !      implicit real*8 (a-h,o-z)
2199 !      include 'DIMENSIONS'
2200 #ifdef MPI
2201       include "mpif.h"
2202 !      include "COMMON.SETUP"
2203       integer :: IERR
2204       integer :: status(MPI_STATUS_SIZE)
2205 #endif
2206 !      include 'COMMON.IOUNITS'
2207 !      include 'COMMON.GEO'
2208 !      include 'COMMON.VAR'
2209 !      include 'COMMON.LOCAL'
2210 !      include 'COMMON.CHAIN'
2211 !      include 'COMMON.DERIV'
2212 !      include 'COMMON.INTERACT'
2213 !      include 'COMMON.CONTACTS'
2214 !      include 'COMMON.TORSION'
2215 !      include 'COMMON.VECTORS'
2216 !      include 'COMMON.FFIELD'
2217       real(kind=8) :: auxvec(2),auxmat(2,2)
2218       integer :: i,iti1,iti,k,l
2219       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2220 !       print *,"in set matrices"
2221 !
2222 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2223 ! to calculate the el-loc multibody terms of various order.
2224 !
2225 !AL el      mu=0.0d0
2226 #ifdef PARMAT
2227       do i=ivec_start+2,ivec_end+2
2228 #else
2229       do i=3,nres+1
2230 #endif
2231 !      print *,i,"i"
2232         if (i .lt. nres+1) then
2233           sin1=dsin(phi(i))
2234           cos1=dcos(phi(i))
2235           sintab(i-2)=sin1
2236           costab(i-2)=cos1
2237           obrot(1,i-2)=cos1
2238           obrot(2,i-2)=sin1
2239           sin2=dsin(2*phi(i))
2240           cos2=dcos(2*phi(i))
2241           sintab2(i-2)=sin2
2242           costab2(i-2)=cos2
2243           obrot2(1,i-2)=cos2
2244           obrot2(2,i-2)=sin2
2245           Ug(1,1,i-2)=-cos1
2246           Ug(1,2,i-2)=-sin1
2247           Ug(2,1,i-2)=-sin1
2248           Ug(2,2,i-2)= cos1
2249           Ug2(1,1,i-2)=-cos2
2250           Ug2(1,2,i-2)=-sin2
2251           Ug2(2,1,i-2)=-sin2
2252           Ug2(2,2,i-2)= cos2
2253         else
2254           costab(i-2)=1.0d0
2255           sintab(i-2)=0.0d0
2256           obrot(1,i-2)=1.0d0
2257           obrot(2,i-2)=0.0d0
2258           obrot2(1,i-2)=0.0d0
2259           obrot2(2,i-2)=0.0d0
2260           Ug(1,1,i-2)=1.0d0
2261           Ug(1,2,i-2)=0.0d0
2262           Ug(2,1,i-2)=0.0d0
2263           Ug(2,2,i-2)=1.0d0
2264           Ug2(1,1,i-2)=0.0d0
2265           Ug2(1,2,i-2)=0.0d0
2266           Ug2(2,1,i-2)=0.0d0
2267           Ug2(2,2,i-2)=0.0d0
2268         endif
2269         if (i .gt. 3 .and. i .lt. nres+1) then
2270           obrot_der(1,i-2)=-sin1
2271           obrot_der(2,i-2)= cos1
2272           Ugder(1,1,i-2)= sin1
2273           Ugder(1,2,i-2)=-cos1
2274           Ugder(2,1,i-2)=-cos1
2275           Ugder(2,2,i-2)=-sin1
2276           dwacos2=cos2+cos2
2277           dwasin2=sin2+sin2
2278           obrot2_der(1,i-2)=-dwasin2
2279           obrot2_der(2,i-2)= dwacos2
2280           Ug2der(1,1,i-2)= dwasin2
2281           Ug2der(1,2,i-2)=-dwacos2
2282           Ug2der(2,1,i-2)=-dwacos2
2283           Ug2der(2,2,i-2)=-dwasin2
2284         else
2285           obrot_der(1,i-2)=0.0d0
2286           obrot_der(2,i-2)=0.0d0
2287           Ugder(1,1,i-2)=0.0d0
2288           Ugder(1,2,i-2)=0.0d0
2289           Ugder(2,1,i-2)=0.0d0
2290           Ugder(2,2,i-2)=0.0d0
2291           obrot2_der(1,i-2)=0.0d0
2292           obrot2_der(2,i-2)=0.0d0
2293           Ug2der(1,1,i-2)=0.0d0
2294           Ug2der(1,2,i-2)=0.0d0
2295           Ug2der(2,1,i-2)=0.0d0
2296           Ug2der(2,2,i-2)=0.0d0
2297         endif
2298 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2299         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2300           iti = itortyp(itype(i-2))
2301         else
2302           iti=ntortyp+1
2303         endif
2304 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2305         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2306           iti1 = itortyp(itype(i-1))
2307         else
2308           iti1=ntortyp+1
2309         endif
2310 !          print *,iti,i,"iti",iti1,itype(i-1),itype(i-2)
2311 !d        write (iout,*) '*******i',i,' iti1',iti
2312 !d        write (iout,*) 'b1',b1(:,iti)
2313 !d        write (iout,*) 'b2',b2(:,iti)
2314 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2315 !        if (i .gt. iatel_s+2) then
2316         if (i .gt. nnt+2) then
2317           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2318           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2319           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2320           then
2321           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2322           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2323           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2324           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2325           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2326           endif
2327         else
2328           do k=1,2
2329             Ub2(k,i-2)=0.0d0
2330             Ctobr(k,i-2)=0.0d0
2331             Dtobr2(k,i-2)=0.0d0
2332             do l=1,2
2333               EUg(l,k,i-2)=0.0d0
2334               CUg(l,k,i-2)=0.0d0
2335               DUg(l,k,i-2)=0.0d0
2336               DtUg2(l,k,i-2)=0.0d0
2337             enddo
2338           enddo
2339         endif
2340         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2341         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2342         do k=1,2
2343           muder(k,i-2)=Ub2der(k,i-2)
2344         enddo
2345 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2346         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2347           if (itype(i-1).le.ntyp) then
2348             iti1 = itortyp(itype(i-1))
2349           else
2350             iti1=ntortyp+1
2351           endif
2352         else
2353           iti1=ntortyp+1
2354         endif
2355         do k=1,2
2356           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2357         enddo
2358 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2359 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2360 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2361 !d        write (iout,*) 'mu1',mu1(:,i-2)
2362 !d        write (iout,*) 'mu2',mu2(:,i-2)
2363         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2364         then
2365         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2366         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2367         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2368         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2369         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2370 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2371         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2372         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2373         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2374         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2375         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2376         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2377         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2378         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2379         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2380         endif
2381       enddo
2382 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2383 ! The order of matrices is from left to right.
2384       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2385       then
2386 !      do i=max0(ivec_start,2),ivec_end
2387       do i=2,nres-1
2388         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2389         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2390         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2391         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2392         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2393         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2394         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2395         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2396       enddo
2397       endif
2398 #if defined(MPI) && defined(PARMAT)
2399 #ifdef DEBUG
2400 !      if (fg_rank.eq.0) then
2401         write (iout,*) "Arrays UG and UGDER before GATHER"
2402         do i=1,nres-1
2403           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2404            ((ug(l,k,i),l=1,2),k=1,2),&
2405            ((ugder(l,k,i),l=1,2),k=1,2)
2406         enddo
2407         write (iout,*) "Arrays UG2 and UG2DER"
2408         do i=1,nres-1
2409           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2410            ((ug2(l,k,i),l=1,2),k=1,2),&
2411            ((ug2der(l,k,i),l=1,2),k=1,2)
2412         enddo
2413         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2414         do i=1,nres-1
2415           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2416            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2417            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2418         enddo
2419         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2420         do i=1,nres-1
2421           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2422            costab(i),sintab(i),costab2(i),sintab2(i)
2423         enddo
2424         write (iout,*) "Array MUDER"
2425         do i=1,nres-1
2426           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2427         enddo
2428 !      endif
2429 #endif
2430       if (nfgtasks.gt.1) then
2431         time00=MPI_Wtime()
2432 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2433 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2434 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2435 #ifdef MATGATHER
2436         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2437          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2438          FG_COMM1,IERR)
2439         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2440          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2441          FG_COMM1,IERR)
2442         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2443          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2444          FG_COMM1,IERR)
2445         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2446          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2447          FG_COMM1,IERR)
2448         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2449          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2450          FG_COMM1,IERR)
2451         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2452          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2453          FG_COMM1,IERR)
2454         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2455          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2456          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2457         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2458          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2459          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2460         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2461          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2462          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2463         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2464          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2465          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2466         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2467         then
2468         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2469          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2470          FG_COMM1,IERR)
2471         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2472          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2473          FG_COMM1,IERR)
2474         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2475          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2476          FG_COMM1,IERR)
2477        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2478          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2479          FG_COMM1,IERR)
2480         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2481          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2482          FG_COMM1,IERR)
2483         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2484          ivec_count(fg_rank1),&
2485          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2486          FG_COMM1,IERR)
2487         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2488          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2489          FG_COMM1,IERR)
2490         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2491          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2492          FG_COMM1,IERR)
2493         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2494          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2495          FG_COMM1,IERR)
2496         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2497          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2498          FG_COMM1,IERR)
2499         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2500          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2501          FG_COMM1,IERR)
2502         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2503          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2504          FG_COMM1,IERR)
2505         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2506          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2507          FG_COMM1,IERR)
2508         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2509          ivec_count(fg_rank1),&
2510          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2511          FG_COMM1,IERR)
2512         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2513          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2514          FG_COMM1,IERR)
2515        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2516          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2517          FG_COMM1,IERR)
2518         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2519          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2520          FG_COMM1,IERR)
2521        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2522          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2523          FG_COMM1,IERR)
2524         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2525          ivec_count(fg_rank1),&
2526          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2527          FG_COMM1,IERR)
2528         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2529          ivec_count(fg_rank1),&
2530          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2531          FG_COMM1,IERR)
2532         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2533          ivec_count(fg_rank1),&
2534          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2535          MPI_MAT2,FG_COMM1,IERR)
2536         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2537          ivec_count(fg_rank1),&
2538          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2539          MPI_MAT2,FG_COMM1,IERR)
2540         endif
2541 #else
2542 ! Passes matrix info through the ring
2543       isend=fg_rank1
2544       irecv=fg_rank1-1
2545       if (irecv.lt.0) irecv=nfgtasks1-1
2546       iprev=irecv
2547       inext=fg_rank1+1
2548       if (inext.ge.nfgtasks1) inext=0
2549       do i=1,nfgtasks1-1
2550 !        write (iout,*) "isend",isend," irecv",irecv
2551 !        call flush(iout)
2552         lensend=lentyp(isend)
2553         lenrecv=lentyp(irecv)
2554 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2555 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2556 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2557 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2558 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2559 !        write (iout,*) "Gather ROTAT1"
2560 !        call flush(iout)
2561 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2562 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2563 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2564 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2565 !        write (iout,*) "Gather ROTAT2"
2566 !        call flush(iout)
2567         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2568          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2569          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2570          iprev,4400+irecv,FG_COMM,status,IERR)
2571 !        write (iout,*) "Gather ROTAT_OLD"
2572 !        call flush(iout)
2573         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2574          MPI_PRECOMP11(lensend),inext,5500+isend,&
2575          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2576          iprev,5500+irecv,FG_COMM,status,IERR)
2577 !        write (iout,*) "Gather PRECOMP11"
2578 !        call flush(iout)
2579         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2580          MPI_PRECOMP12(lensend),inext,6600+isend,&
2581          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2582          iprev,6600+irecv,FG_COMM,status,IERR)
2583 !        write (iout,*) "Gather PRECOMP12"
2584 !        call flush(iout)
2585         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2586         then
2587         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2588          MPI_ROTAT2(lensend),inext,7700+isend,&
2589          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2590          iprev,7700+irecv,FG_COMM,status,IERR)
2591 !        write (iout,*) "Gather PRECOMP21"
2592 !        call flush(iout)
2593         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2594          MPI_PRECOMP22(lensend),inext,8800+isend,&
2595          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2596          iprev,8800+irecv,FG_COMM,status,IERR)
2597 !        write (iout,*) "Gather PRECOMP22"
2598 !        call flush(iout)
2599         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2600          MPI_PRECOMP23(lensend),inext,9900+isend,&
2601          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2602          MPI_PRECOMP23(lenrecv),&
2603          iprev,9900+irecv,FG_COMM,status,IERR)
2604 !        write (iout,*) "Gather PRECOMP23"
2605 !        call flush(iout)
2606         endif
2607         isend=irecv
2608         irecv=irecv-1
2609         if (irecv.lt.0) irecv=nfgtasks1-1
2610       enddo
2611 #endif
2612         time_gather=time_gather+MPI_Wtime()-time00
2613       endif
2614 #ifdef DEBUG
2615 !      if (fg_rank.eq.0) then
2616         write (iout,*) "Arrays UG and UGDER"
2617         do i=1,nres-1
2618           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2619            ((ug(l,k,i),l=1,2),k=1,2),&
2620            ((ugder(l,k,i),l=1,2),k=1,2)
2621         enddo
2622         write (iout,*) "Arrays UG2 and UG2DER"
2623         do i=1,nres-1
2624           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2625            ((ug2(l,k,i),l=1,2),k=1,2),&
2626            ((ug2der(l,k,i),l=1,2),k=1,2)
2627         enddo
2628         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2629         do i=1,nres-1
2630           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2631            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2632            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2633         enddo
2634         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2635         do i=1,nres-1
2636           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2637            costab(i),sintab(i),costab2(i),sintab2(i)
2638         enddo
2639         write (iout,*) "Array MUDER"
2640         do i=1,nres-1
2641           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2642         enddo
2643 !      endif
2644 #endif
2645 #endif
2646 !d      do i=1,nres
2647 !d        iti = itortyp(itype(i))
2648 !d        write (iout,*) i
2649 !d        do j=1,2
2650 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2651 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2652 !d        enddo
2653 !d      enddo
2654       return
2655       end subroutine set_matrices
2656 !-----------------------------------------------------------------------------
2657       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2658 !
2659 ! This subroutine calculates the average interaction energy and its gradient
2660 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2661 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2662 ! The potential depends both on the distance of peptide-group centers and on
2663 ! the orientation of the CA-CA virtual bonds.
2664 !
2665       use comm_locel
2666 !      implicit real*8 (a-h,o-z)
2667 #ifdef MPI
2668       include 'mpif.h'
2669 #endif
2670 !      include 'DIMENSIONS'
2671 !      include 'COMMON.CONTROL'
2672 !      include 'COMMON.SETUP'
2673 !      include 'COMMON.IOUNITS'
2674 !      include 'COMMON.GEO'
2675 !      include 'COMMON.VAR'
2676 !      include 'COMMON.LOCAL'
2677 !      include 'COMMON.CHAIN'
2678 !      include 'COMMON.DERIV'
2679 !      include 'COMMON.INTERACT'
2680 !      include 'COMMON.CONTACTS'
2681 !      include 'COMMON.TORSION'
2682 !      include 'COMMON.VECTORS'
2683 !      include 'COMMON.FFIELD'
2684 !      include 'COMMON.TIME1'
2685       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2686       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2687       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2688 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2689       real(kind=8),dimension(4) :: muij
2690 !el      integer :: num_conti,j1,j2
2691 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2692 !el        dz_normi,xmedi,ymedi,zmedi
2693
2694 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2695 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2696 !el          num_conti,j1,j2
2697
2698 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2699 #ifdef MOMENT
2700       real(kind=8) :: scal_el=1.0d0
2701 #else
2702       real(kind=8) :: scal_el=0.5d0
2703 #endif
2704 ! 12/13/98
2705 ! 13-go grudnia roku pamietnego...
2706       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2707                                              0.0d0,1.0d0,0.0d0,&
2708                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2709 !el local variables
2710       integer :: i,k,j
2711       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2712       real(kind=8) :: fac,t_eelecij,fracinbuf
2713
2714
2715 !d      write(iout,*) 'In EELEC'
2716 !        print *,"IN EELEC"
2717 !d      do i=1,nloctyp
2718 !d        write(iout,*) 'Type',i
2719 !d        write(iout,*) 'B1',B1(:,i)
2720 !d        write(iout,*) 'B2',B2(:,i)
2721 !d        write(iout,*) 'CC',CC(:,:,i)
2722 !d        write(iout,*) 'DD',DD(:,:,i)
2723 !d        write(iout,*) 'EE',EE(:,:,i)
2724 !d      enddo
2725 !d      call check_vecgrad
2726 !d      stop
2727 !      ees=0.0d0  !AS
2728 !      evdw1=0.0d0
2729 !      eel_loc=0.0d0
2730 !      eello_turn3=0.0d0
2731 !      eello_turn4=0.0d0
2732       t_eelecij=0.0d0
2733       ees=0.0D0
2734       evdw1=0.0D0
2735       eel_loc=0.0d0
2736       eello_turn3=0.0d0
2737       eello_turn4=0.0d0
2738 !
2739
2740       if (icheckgrad.eq.1) then
2741 !el
2742 !        do i=0,2*nres+2
2743 !          dc_norm(1,i)=0.0d0
2744 !          dc_norm(2,i)=0.0d0
2745 !          dc_norm(3,i)=0.0d0
2746 !        enddo
2747         do i=1,nres-1
2748           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2749           do k=1,3
2750             dc_norm(k,i)=dc(k,i)*fac
2751           enddo
2752 !          write (iout,*) 'i',i,' fac',fac
2753         enddo
2754       endif
2755       print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2756         wturn6
2757       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2758           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2759           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2760 !        call vec_and_deriv
2761 #ifdef TIMING
2762         time01=MPI_Wtime()
2763 #endif
2764 !        print *, "before set matrices"
2765         call set_matrices
2766 !        print *, "after set matrices"
2767
2768 #ifdef TIMING
2769         time_mat=time_mat+MPI_Wtime()-time01
2770 #endif
2771       endif
2772 !       print *, "after set matrices"
2773 !d      do i=1,nres-1
2774 !d        write (iout,*) 'i=',i
2775 !d        do k=1,3
2776 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2777 !d        enddo
2778 !d        do k=1,3
2779 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2780 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2781 !d        enddo
2782 !d      enddo
2783       t_eelecij=0.0d0
2784       ees=0.0D0
2785       evdw1=0.0D0
2786       eel_loc=0.0d0
2787       eello_turn3=0.0d0
2788       eello_turn4=0.0d0
2789 !el      ind=0
2790       do i=1,nres
2791         num_cont_hb(i)=0
2792       enddo
2793 !d      print '(a)','Enter EELEC'
2794 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2795 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2796 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2797       do i=1,nres
2798         gel_loc_loc(i)=0.0d0
2799         gcorr_loc(i)=0.0d0
2800       enddo
2801 !
2802 !
2803 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2804 !
2805 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2806 !
2807
2808
2809 !        print *,"before iturn3 loop"
2810       do i=iturn3_start,iturn3_end
2811         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2812         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2813         dxi=dc(1,i)
2814         dyi=dc(2,i)
2815         dzi=dc(3,i)
2816         dx_normi=dc_norm(1,i)
2817         dy_normi=dc_norm(2,i)
2818         dz_normi=dc_norm(3,i)
2819         xmedi=c(1,i)+0.5d0*dxi
2820         ymedi=c(2,i)+0.5d0*dyi
2821         zmedi=c(3,i)+0.5d0*dzi
2822           xmedi=dmod(xmedi,boxxsize)
2823           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2824           ymedi=dmod(ymedi,boxysize)
2825           if (ymedi.lt.0) ymedi=ymedi+boxysize
2826           zmedi=dmod(zmedi,boxzsize)
2827           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2828         num_conti=0
2829        if ((zmedi.gt.bordlipbot) &
2830         .and.(zmedi.lt.bordliptop)) then
2831 !C the energy transfer exist
2832         if (zmedi.lt.buflipbot) then
2833 !C what fraction I am in
2834          fracinbuf=1.0d0- &
2835                ((zmedi-bordlipbot)/lipbufthick)
2836 !C lipbufthick is thickenes of lipid buffore
2837          sslipi=sscalelip(fracinbuf)
2838          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2839         elseif (zmedi.gt.bufliptop) then
2840          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2841          sslipi=sscalelip(fracinbuf)
2842          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2843         else
2844          sslipi=1.0d0
2845          ssgradlipi=0.0
2846         endif
2847        else
2848          sslipi=0.0d0
2849          ssgradlipi=0.0
2850        endif
2851 !       print *,i,sslipi,ssgradlipi
2852        call eelecij(i,i+2,ees,evdw1,eel_loc)
2853         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2854         num_cont_hb(i)=num_conti
2855       enddo
2856       do i=iturn4_start,iturn4_end
2857         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2858           .or. itype(i+3).eq.ntyp1 &
2859           .or. itype(i+4).eq.ntyp1) cycle
2860         dxi=dc(1,i)
2861         dyi=dc(2,i)
2862         dzi=dc(3,i)
2863         dx_normi=dc_norm(1,i)
2864         dy_normi=dc_norm(2,i)
2865         dz_normi=dc_norm(3,i)
2866         xmedi=c(1,i)+0.5d0*dxi
2867         ymedi=c(2,i)+0.5d0*dyi
2868         zmedi=c(3,i)+0.5d0*dzi
2869           xmedi=dmod(xmedi,boxxsize)
2870           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2871           ymedi=dmod(ymedi,boxysize)
2872           if (ymedi.lt.0) ymedi=ymedi+boxysize
2873           zmedi=dmod(zmedi,boxzsize)
2874           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2875        if ((zmedi.gt.bordlipbot)  &
2876        .and.(zmedi.lt.bordliptop)) then
2877 !C the energy transfer exist
2878         if (zmedi.lt.buflipbot) then
2879 !C what fraction I am in
2880          fracinbuf=1.0d0- &
2881              ((zmedi-bordlipbot)/lipbufthick)
2882 !C lipbufthick is thickenes of lipid buffore
2883          sslipi=sscalelip(fracinbuf)
2884          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2885         elseif (zmedi.gt.bufliptop) then
2886          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2887          sslipi=sscalelip(fracinbuf)
2888          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2889         else
2890          sslipi=1.0d0
2891          ssgradlipi=0.0
2892         endif
2893        else
2894          sslipi=0.0d0
2895          ssgradlipi=0.0
2896        endif
2897
2898         num_conti=num_cont_hb(i)
2899         call eelecij(i,i+3,ees,evdw1,eel_loc)
2900         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2901          call eturn4(i,eello_turn4)
2902         num_cont_hb(i)=num_conti
2903       enddo   ! i
2904 !
2905 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2906 !
2907       do i=iatel_s,iatel_e
2908         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2909         dxi=dc(1,i)
2910         dyi=dc(2,i)
2911         dzi=dc(3,i)
2912         dx_normi=dc_norm(1,i)
2913         dy_normi=dc_norm(2,i)
2914         dz_normi=dc_norm(3,i)
2915         xmedi=c(1,i)+0.5d0*dxi
2916         ymedi=c(2,i)+0.5d0*dyi
2917         zmedi=c(3,i)+0.5d0*dzi
2918           xmedi=dmod(xmedi,boxxsize)
2919           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2920           ymedi=dmod(ymedi,boxysize)
2921           if (ymedi.lt.0) ymedi=ymedi+boxysize
2922           zmedi=dmod(zmedi,boxzsize)
2923           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2924        if ((zmedi.gt.bordlipbot)  &
2925         .and.(zmedi.lt.bordliptop)) then
2926 !C the energy transfer exist
2927         if (zmedi.lt.buflipbot) then
2928 !C what fraction I am in
2929          fracinbuf=1.0d0- &
2930              ((zmedi-bordlipbot)/lipbufthick)
2931 !C lipbufthick is thickenes of lipid buffore
2932          sslipi=sscalelip(fracinbuf)
2933          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2934         elseif (zmedi.gt.bufliptop) then
2935          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2936          sslipi=sscalelip(fracinbuf)
2937          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2938         else
2939          sslipi=1.0d0
2940          ssgradlipi=0.0
2941         endif
2942        else
2943          sslipi=0.0d0
2944          ssgradlipi=0.0
2945        endif
2946
2947 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2948         num_conti=num_cont_hb(i)
2949         do j=ielstart(i),ielend(i)
2950 !          write (iout,*) i,j,itype(i),itype(j)
2951           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2952           call eelecij(i,j,ees,evdw1,eel_loc)
2953         enddo ! j
2954         num_cont_hb(i)=num_conti
2955       enddo   ! i
2956 !      write (iout,*) "Number of loop steps in EELEC:",ind
2957 !d      do i=1,nres
2958 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2959 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2960 !d      enddo
2961 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2962 !cc      eel_loc=eel_loc+eello_turn3
2963 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2964       return
2965       end subroutine eelec
2966 !-----------------------------------------------------------------------------
2967       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2968
2969       use comm_locel
2970 !      implicit real*8 (a-h,o-z)
2971 !      include 'DIMENSIONS'
2972 #ifdef MPI
2973       include "mpif.h"
2974 #endif
2975 !      include 'COMMON.CONTROL'
2976 !      include 'COMMON.IOUNITS'
2977 !      include 'COMMON.GEO'
2978 !      include 'COMMON.VAR'
2979 !      include 'COMMON.LOCAL'
2980 !      include 'COMMON.CHAIN'
2981 !      include 'COMMON.DERIV'
2982 !      include 'COMMON.INTERACT'
2983 !      include 'COMMON.CONTACTS'
2984 !      include 'COMMON.TORSION'
2985 !      include 'COMMON.VECTORS'
2986 !      include 'COMMON.FFIELD'
2987 !      include 'COMMON.TIME1'
2988       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
2989       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2990       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2991 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2992       real(kind=8),dimension(4) :: muij
2993       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
2994                     dist_temp, dist_init,rlocshield,fracinbuf
2995       integer xshift,yshift,zshift,ilist,iresshield
2996 !el      integer :: num_conti,j1,j2
2997 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2998 !el        dz_normi,xmedi,ymedi,zmedi
2999
3000 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3001 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3002 !el          num_conti,j1,j2
3003
3004 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3005 #ifdef MOMENT
3006       real(kind=8) :: scal_el=1.0d0
3007 #else
3008       real(kind=8) :: scal_el=0.5d0
3009 #endif
3010 ! 12/13/98
3011 ! 13-go grudnia roku pamietnego...
3012       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3013                                              0.0d0,1.0d0,0.0d0,&
3014                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3015 !      integer :: maxconts=nres/4
3016 !el local variables
3017       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3018       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3019       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3020       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3021                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3022                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3023                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3024                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3025                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3026                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3027                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3028 !      maxconts=nres/4
3029 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3030 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3031
3032 !          time00=MPI_Wtime()
3033 !d      write (iout,*) "eelecij",i,j
3034 !          ind=ind+1
3035           iteli=itel(i)
3036           itelj=itel(j)
3037           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3038           aaa=app(iteli,itelj)
3039           bbb=bpp(iteli,itelj)
3040           ael6i=ael6(iteli,itelj)
3041           ael3i=ael3(iteli,itelj)
3042           dxj=dc(1,j)
3043           dyj=dc(2,j)
3044           dzj=dc(3,j)
3045           dx_normj=dc_norm(1,j)
3046           dy_normj=dc_norm(2,j)
3047           dz_normj=dc_norm(3,j)
3048 !          xj=c(1,j)+0.5D0*dxj-xmedi
3049 !          yj=c(2,j)+0.5D0*dyj-ymedi
3050 !          zj=c(3,j)+0.5D0*dzj-zmedi
3051           xj=c(1,j)+0.5D0*dxj
3052           yj=c(2,j)+0.5D0*dyj
3053           zj=c(3,j)+0.5D0*dzj
3054           xj=mod(xj,boxxsize)
3055           if (xj.lt.0) xj=xj+boxxsize
3056           yj=mod(yj,boxysize)
3057           if (yj.lt.0) yj=yj+boxysize
3058           zj=mod(zj,boxzsize)
3059           if (zj.lt.0) zj=zj+boxzsize
3060        if ((zj.gt.bordlipbot)  &
3061        .and.(zj.lt.bordliptop)) then
3062 !C the energy transfer exist
3063         if (zj.lt.buflipbot) then
3064 !C what fraction I am in
3065          fracinbuf=1.0d0-     &
3066              ((zj-bordlipbot)/lipbufthick)
3067 !C lipbufthick is thickenes of lipid buffore
3068          sslipj=sscalelip(fracinbuf)
3069          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3070         elseif (zj.gt.bufliptop) then
3071          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3072          sslipj=sscalelip(fracinbuf)
3073          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3074         else
3075          sslipj=1.0d0
3076          ssgradlipj=0.0
3077         endif
3078        else
3079          sslipj=0.0d0
3080          ssgradlipj=0.0
3081        endif
3082
3083       isubchap=0
3084       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3085       xj_safe=xj
3086       yj_safe=yj
3087       zj_safe=zj
3088       do xshift=-1,1
3089       do yshift=-1,1
3090       do zshift=-1,1
3091           xj=xj_safe+xshift*boxxsize
3092           yj=yj_safe+yshift*boxysize
3093           zj=zj_safe+zshift*boxzsize
3094           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3095           if(dist_temp.lt.dist_init) then
3096             dist_init=dist_temp
3097             xj_temp=xj
3098             yj_temp=yj
3099             zj_temp=zj
3100             isubchap=1
3101           endif
3102        enddo
3103        enddo
3104        enddo
3105        if (isubchap.eq.1) then
3106 !C          print *,i,j
3107           xj=xj_temp-xmedi
3108           yj=yj_temp-ymedi
3109           zj=zj_temp-zmedi
3110        else
3111           xj=xj_safe-xmedi
3112           yj=yj_safe-ymedi
3113           zj=zj_safe-zmedi
3114        endif
3115
3116           rij=xj*xj+yj*yj+zj*zj
3117           rrmij=1.0D0/rij
3118           rij=dsqrt(rij)
3119 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3120             sss_ele_cut=sscale_ele(rij)
3121             sss_ele_grad=sscagrad_ele(rij)
3122 !             sss_ele_cut=1.0d0
3123 !             sss_ele_grad=0.0d0
3124 !            print *,sss_ele_cut,sss_ele_grad,&
3125 !            (rij),r_cut_ele,rlamb_ele
3126 !            if (sss_ele_cut.le.0.0) go to 128
3127
3128           rmij=1.0D0/rij
3129           r3ij=rrmij*rmij
3130           r6ij=r3ij*r3ij
3131           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3132           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3133           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3134           fac=cosa-3.0D0*cosb*cosg
3135           ev1=aaa*r6ij*r6ij
3136 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3137           if (j.eq.i+2) ev1=scal_el*ev1
3138           ev2=bbb*r6ij
3139           fac3=ael6i*r6ij
3140           fac4=ael3i*r3ij
3141           evdwij=ev1+ev2
3142           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3143           el2=fac4*fac
3144 !          eesij=el1+el2
3145           if (shield_mode.gt.0) then
3146 !C          fac_shield(i)=0.4
3147 !C          fac_shield(j)=0.6
3148           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3149           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3150           eesij=(el1+el2)
3151           ees=ees+eesij*sss_ele_cut
3152 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3153 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3154           else
3155           fac_shield(i)=1.0
3156           fac_shield(j)=1.0
3157           eesij=(el1+el2)
3158           ees=ees+eesij   &
3159             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3160 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3161           endif
3162
3163 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3164           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3165 !          ees=ees+eesij*sss_ele_cut
3166           evdw1=evdw1+evdwij*sss_ele_cut  &
3167            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3168 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3169 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3170 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3171 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3172
3173           if (energy_dec) then
3174 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3175 !                  'evdw1',i,j,evdwij,&
3176 !                  iteli,itelj,aaa,evdw1
3177               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3178               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3179           endif
3180 !
3181 ! Calculate contributions to the Cartesian gradient.
3182 !
3183 #ifdef SPLITELE
3184           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3185               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3186           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3187              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3188           fac1=fac
3189           erij(1)=xj*rmij
3190           erij(2)=yj*rmij
3191           erij(3)=zj*rmij
3192 !
3193 ! Radial derivatives. First process both termini of the fragment (i,j)
3194 !
3195           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3196           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3197           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3198            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3199           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3200             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3201
3202           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3203           (shield_mode.gt.0)) then
3204 !C          print *,i,j
3205           do ilist=1,ishield_list(i)
3206            iresshield=shield_list(ilist,i)
3207            do k=1,3
3208            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3209            *2.0*sss_ele_cut
3210            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3211                    rlocshield &
3212             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3213             *sss_ele_cut
3214             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3215            enddo
3216           enddo
3217           do ilist=1,ishield_list(j)
3218            iresshield=shield_list(ilist,j)
3219            do k=1,3
3220            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3221           *2.0*sss_ele_cut
3222            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3223                    rlocshield &
3224            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3225            *sss_ele_cut
3226            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3227            enddo
3228           enddo
3229           do k=1,3
3230             gshieldc(k,i)=gshieldc(k,i)+ &
3231                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3232            *sss_ele_cut
3233
3234             gshieldc(k,j)=gshieldc(k,j)+ &
3235                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3236            *sss_ele_cut
3237
3238             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3239                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3240            *sss_ele_cut
3241
3242             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3243                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3244            *sss_ele_cut
3245
3246            enddo
3247            endif
3248
3249
3250 !          do k=1,3
3251 !            ghalf=0.5D0*ggg(k)
3252 !            gelc(k,i)=gelc(k,i)+ghalf
3253 !            gelc(k,j)=gelc(k,j)+ghalf
3254 !          enddo
3255 ! 9/28/08 AL Gradient compotents will be summed only at the end
3256           do k=1,3
3257             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3258             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3259           enddo
3260             gelc_long(3,j)=gelc_long(3,j)+  &
3261           ssgradlipj*eesij/2.0d0*lipscale**2&
3262            *sss_ele_cut
3263
3264             gelc_long(3,i)=gelc_long(3,i)+  &
3265           ssgradlipi*eesij/2.0d0*lipscale**2&
3266            *sss_ele_cut
3267
3268
3269 !
3270 ! Loop over residues i+1 thru j-1.
3271 !
3272 !grad          do k=i+1,j-1
3273 !grad            do l=1,3
3274 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3275 !grad            enddo
3276 !grad          enddo
3277           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3278            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3279           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3280            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3281           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3282            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3283
3284 !          do k=1,3
3285 !            ghalf=0.5D0*ggg(k)
3286 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3287 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3288 !          enddo
3289 ! 9/28/08 AL Gradient compotents will be summed only at the end
3290           do k=1,3
3291             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3292             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3293           enddo
3294
3295 !C Lipidic part for scaling weight
3296            gvdwpp(3,j)=gvdwpp(3,j)+ &
3297           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3298            gvdwpp(3,i)=gvdwpp(3,i)+ &
3299           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3300 !! Loop over residues i+1 thru j-1.
3301 !
3302 !grad          do k=i+1,j-1
3303 !grad            do l=1,3
3304 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3305 !grad            enddo
3306 !grad          enddo
3307 #else
3308           facvdw=(ev1+evdwij)*sss_ele_cut &
3309            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3310
3311           facel=(el1+eesij)*sss_ele_cut
3312           fac1=fac
3313           fac=-3*rrmij*(facvdw+facvdw+facel)
3314           erij(1)=xj*rmij
3315           erij(2)=yj*rmij
3316           erij(3)=zj*rmij
3317 !
3318 ! Radial derivatives. First process both termini of the fragment (i,j)
3319 !
3320           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3321           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3322           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3323 !          do k=1,3
3324 !            ghalf=0.5D0*ggg(k)
3325 !            gelc(k,i)=gelc(k,i)+ghalf
3326 !            gelc(k,j)=gelc(k,j)+ghalf
3327 !          enddo
3328 ! 9/28/08 AL Gradient compotents will be summed only at the end
3329           do k=1,3
3330             gelc_long(k,j)=gelc(k,j)+ggg(k)
3331             gelc_long(k,i)=gelc(k,i)-ggg(k)
3332           enddo
3333 !
3334 ! Loop over residues i+1 thru j-1.
3335 !
3336 !grad          do k=i+1,j-1
3337 !grad            do l=1,3
3338 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3339 !grad            enddo
3340 !grad          enddo
3341 ! 9/28/08 AL Gradient compotents will be summed only at the end
3342           ggg(1)=facvdw*xj &
3343            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3344           ggg(2)=facvdw*yj &
3345            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3346           ggg(3)=facvdw*zj &
3347            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3348
3349           do k=1,3
3350             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3351             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3352           enddo
3353            gvdwpp(3,j)=gvdwpp(3,j)+ &
3354           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3355            gvdwpp(3,i)=gvdwpp(3,i)+ &
3356           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3357
3358 #endif
3359 !
3360 ! Angular part
3361 !
3362           ecosa=2.0D0*fac3*fac1+fac4
3363           fac4=-3.0D0*fac4
3364           fac3=-6.0D0*fac3
3365           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3366           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3367           do k=1,3
3368             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3369             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3370           enddo
3371 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3372 !d   &          (dcosg(k),k=1,3)
3373           do k=1,3
3374             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3375              *fac_shield(i)**2*fac_shield(j)**2 &
3376              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3377
3378           enddo
3379 !          do k=1,3
3380 !            ghalf=0.5D0*ggg(k)
3381 !            gelc(k,i)=gelc(k,i)+ghalf
3382 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3383 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3384 !            gelc(k,j)=gelc(k,j)+ghalf
3385 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3386 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3387 !          enddo
3388 !grad          do k=i+1,j-1
3389 !grad            do l=1,3
3390 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3391 !grad            enddo
3392 !grad          enddo
3393           do k=1,3
3394             gelc(k,i)=gelc(k,i) &
3395                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3396                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3397                      *sss_ele_cut &
3398                      *fac_shield(i)**2*fac_shield(j)**2 &
3399                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3400
3401             gelc(k,j)=gelc(k,j) &
3402                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3403                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3404                      *sss_ele_cut  &
3405                      *fac_shield(i)**2*fac_shield(j)**2  &
3406                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3407
3408             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3409             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3410           enddo
3411
3412           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3413               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3414               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3415 !
3416 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3417 !   energy of a peptide unit is assumed in the form of a second-order
3418 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3419 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3420 !   are computed for EVERY pair of non-contiguous peptide groups.
3421 !
3422           if (j.lt.nres-1) then
3423             j1=j+1
3424             j2=j-1
3425           else
3426             j1=j-1
3427             j2=j-2
3428           endif
3429           kkk=0
3430           do k=1,2
3431             do l=1,2
3432               kkk=kkk+1
3433               muij(kkk)=mu(k,i)*mu(l,j)
3434             enddo
3435           enddo
3436 !d         write (iout,*) 'EELEC: i',i,' j',j
3437 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3438 !d          write(iout,*) 'muij',muij
3439           ury=scalar(uy(1,i),erij)
3440           urz=scalar(uz(1,i),erij)
3441           vry=scalar(uy(1,j),erij)
3442           vrz=scalar(uz(1,j),erij)
3443           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3444           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3445           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3446           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3447           fac=dsqrt(-ael6i)*r3ij
3448           a22=a22*fac
3449           a23=a23*fac
3450           a32=a32*fac
3451           a33=a33*fac
3452 !d          write (iout,'(4i5,4f10.5)')
3453 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3454 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3455 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3456 !d     &      uy(:,j),uz(:,j)
3457 !d          write (iout,'(4f10.5)')
3458 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3459 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3460 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3461 !d           write (iout,'(9f10.5/)')
3462 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3463 ! Derivatives of the elements of A in virtual-bond vectors
3464           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3465           do k=1,3
3466             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3467             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3468             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3469             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3470             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3471             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3472             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3473             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3474             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3475             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3476             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3477             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3478           enddo
3479 ! Compute radial contributions to the gradient
3480           facr=-3.0d0*rrmij
3481           a22der=a22*facr
3482           a23der=a23*facr
3483           a32der=a32*facr
3484           a33der=a33*facr
3485           agg(1,1)=a22der*xj
3486           agg(2,1)=a22der*yj
3487           agg(3,1)=a22der*zj
3488           agg(1,2)=a23der*xj
3489           agg(2,2)=a23der*yj
3490           agg(3,2)=a23der*zj
3491           agg(1,3)=a32der*xj
3492           agg(2,3)=a32der*yj
3493           agg(3,3)=a32der*zj
3494           agg(1,4)=a33der*xj
3495           agg(2,4)=a33der*yj
3496           agg(3,4)=a33der*zj
3497 ! Add the contributions coming from er
3498           fac3=-3.0d0*fac
3499           do k=1,3
3500             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3501             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3502             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3503             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3504           enddo
3505           do k=1,3
3506 ! Derivatives in DC(i)
3507 !grad            ghalf1=0.5d0*agg(k,1)
3508 !grad            ghalf2=0.5d0*agg(k,2)
3509 !grad            ghalf3=0.5d0*agg(k,3)
3510 !grad            ghalf4=0.5d0*agg(k,4)
3511             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3512             -3.0d0*uryg(k,2)*vry)!+ghalf1
3513             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3514             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3515             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3516             -3.0d0*urzg(k,2)*vry)!+ghalf3
3517             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3518             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3519 ! Derivatives in DC(i+1)
3520             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3521             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3522             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3523             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3524             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3525             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3526             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3527             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3528 ! Derivatives in DC(j)
3529             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3530             -3.0d0*vryg(k,2)*ury)!+ghalf1
3531             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3532             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3533             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3534             -3.0d0*vryg(k,2)*urz)!+ghalf3
3535             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3536             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3537 ! Derivatives in DC(j+1) or DC(nres-1)
3538             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3539             -3.0d0*vryg(k,3)*ury)
3540             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3541             -3.0d0*vrzg(k,3)*ury)
3542             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3543             -3.0d0*vryg(k,3)*urz)
3544             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3545             -3.0d0*vrzg(k,3)*urz)
3546 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3547 !grad              do l=1,4
3548 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3549 !grad              enddo
3550 !grad            endif
3551           enddo
3552           acipa(1,1)=a22
3553           acipa(1,2)=a23
3554           acipa(2,1)=a32
3555           acipa(2,2)=a33
3556           a22=-a22
3557           a23=-a23
3558           do l=1,2
3559             do k=1,3
3560               agg(k,l)=-agg(k,l)
3561               aggi(k,l)=-aggi(k,l)
3562               aggi1(k,l)=-aggi1(k,l)
3563               aggj(k,l)=-aggj(k,l)
3564               aggj1(k,l)=-aggj1(k,l)
3565             enddo
3566           enddo
3567           if (j.lt.nres-1) then
3568             a22=-a22
3569             a32=-a32
3570             do l=1,3,2
3571               do k=1,3
3572                 agg(k,l)=-agg(k,l)
3573                 aggi(k,l)=-aggi(k,l)
3574                 aggi1(k,l)=-aggi1(k,l)
3575                 aggj(k,l)=-aggj(k,l)
3576                 aggj1(k,l)=-aggj1(k,l)
3577               enddo
3578             enddo
3579           else
3580             a22=-a22
3581             a23=-a23
3582             a32=-a32
3583             a33=-a33
3584             do l=1,4
3585               do k=1,3
3586                 agg(k,l)=-agg(k,l)
3587                 aggi(k,l)=-aggi(k,l)
3588                 aggi1(k,l)=-aggi1(k,l)
3589                 aggj(k,l)=-aggj(k,l)
3590                 aggj1(k,l)=-aggj1(k,l)
3591               enddo
3592             enddo
3593           endif
3594           ENDIF ! WCORR
3595           IF (wel_loc.gt.0.0d0) THEN
3596 ! Contribution to the local-electrostatic energy coming from the i-j pair
3597           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3598            +a33*muij(4)
3599           if (shield_mode.eq.0) then
3600            fac_shield(i)=1.0
3601            fac_shield(j)=1.0
3602           endif
3603           eel_loc_ij=eel_loc_ij &
3604          *fac_shield(i)*fac_shield(j) &
3605          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3606 !C Now derivative over eel_loc
3607           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3608          (shield_mode.gt.0)) then
3609 !C          print *,i,j
3610
3611           do ilist=1,ishield_list(i)
3612            iresshield=shield_list(ilist,i)
3613            do k=1,3
3614            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3615                                                 /fac_shield(i)&
3616            *sss_ele_cut
3617            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3618                    rlocshield  &
3619           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3620           *sss_ele_cut
3621
3622             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3623            +rlocshield
3624            enddo
3625           enddo
3626           do ilist=1,ishield_list(j)
3627            iresshield=shield_list(ilist,j)
3628            do k=1,3
3629            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3630                                             /fac_shield(j)   &
3631             *sss_ele_cut
3632            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3633                    rlocshield  &
3634       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3635        *sss_ele_cut
3636
3637            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3638                   +rlocshield
3639
3640            enddo
3641           enddo
3642
3643           do k=1,3
3644             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3645                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3646                     *sss_ele_cut
3647             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3648                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3649                     *sss_ele_cut
3650             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3651                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3652                     *sss_ele_cut
3653             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3654                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3655                     *sss_ele_cut
3656
3657            enddo
3658            endif
3659
3660
3661 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3662 !           eel_loc_ij=0.0
3663           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3664                   'eelloc',i,j,eel_loc_ij
3665 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3666 !          if (energy_dec) write (iout,*) "muij",muij
3667 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3668
3669           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3670 ! Partial derivatives in virtual-bond dihedral angles gamma
3671           if (i.gt.1) &
3672           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3673                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3674                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3675                  *sss_ele_cut  &
3676           *fac_shield(i)*fac_shield(j) &
3677           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3678
3679           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3680                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3681                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3682                  *sss_ele_cut &
3683           *fac_shield(i)*fac_shield(j) &
3684           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3685 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3686 !          do l=1,3
3687 !            ggg(1)=(agg(1,1)*muij(1)+ &
3688 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3689 !            *sss_ele_cut &
3690 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3691 !            ggg(2)=(agg(2,1)*muij(1)+ &
3692 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3693 !            *sss_ele_cut &
3694 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3695 !            ggg(3)=(agg(3,1)*muij(1)+ &
3696 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3697 !            *sss_ele_cut &
3698 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3699            xtemp(1)=xj
3700            xtemp(2)=yj
3701            xtemp(3)=zj
3702
3703            do l=1,3
3704             ggg(l)=(agg(l,1)*muij(1)+ &
3705                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3706             *sss_ele_cut &
3707           *fac_shield(i)*fac_shield(j) &
3708           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3709              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3710
3711
3712             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3713             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3714 !grad            ghalf=0.5d0*ggg(l)
3715 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3716 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3717           enddo
3718             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3719           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3720           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3721
3722             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3723           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3724           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3725
3726 !grad          do k=i+1,j2
3727 !grad            do l=1,3
3728 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3729 !grad            enddo
3730 !grad          enddo
3731 ! Remaining derivatives of eello
3732           do l=1,3
3733             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3734                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3735             *sss_ele_cut &
3736           *fac_shield(i)*fac_shield(j) &
3737           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3738
3739 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3740             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3741                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3742             +aggi1(l,4)*muij(4))&
3743             *sss_ele_cut &
3744           *fac_shield(i)*fac_shield(j) &
3745           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3746
3747 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3748             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3749                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3750             *sss_ele_cut &
3751           *fac_shield(i)*fac_shield(j) &
3752           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3753
3754 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3755             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3756                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3757             +aggj1(l,4)*muij(4))&
3758             *sss_ele_cut &
3759           *fac_shield(i)*fac_shield(j) &
3760           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3761
3762 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3763           enddo
3764           ENDIF
3765 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3766 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3767           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3768              .and. num_conti.le.maxconts) then
3769 !            write (iout,*) i,j," entered corr"
3770 !
3771 ! Calculate the contact function. The ith column of the array JCONT will
3772 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3773 ! greater than I). The arrays FACONT and GACONT will contain the values of
3774 ! the contact function and its derivative.
3775 !           r0ij=1.02D0*rpp(iteli,itelj)
3776 !           r0ij=1.11D0*rpp(iteli,itelj)
3777             r0ij=2.20D0*rpp(iteli,itelj)
3778 !           r0ij=1.55D0*rpp(iteli,itelj)
3779             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3780 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3781             if (fcont.gt.0.0D0) then
3782               num_conti=num_conti+1
3783               if (num_conti.gt.maxconts) then
3784 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3785 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3786                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3787                                ' will skip next contacts for this conf.', num_conti
3788               else
3789                 jcont_hb(num_conti,i)=j
3790 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3791 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3792                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3793                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3794 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3795 !  terms.
3796                 d_cont(num_conti,i)=rij
3797 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3798 !     --- Electrostatic-interaction matrix ---
3799                 a_chuj(1,1,num_conti,i)=a22
3800                 a_chuj(1,2,num_conti,i)=a23
3801                 a_chuj(2,1,num_conti,i)=a32
3802                 a_chuj(2,2,num_conti,i)=a33
3803 !     --- Gradient of rij
3804                 do kkk=1,3
3805                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3806                 enddo
3807                 kkll=0
3808                 do k=1,2
3809                   do l=1,2
3810                     kkll=kkll+1
3811                     do m=1,3
3812                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3813                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3814                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3815                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3816                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3817                     enddo
3818                   enddo
3819                 enddo
3820                 ENDIF
3821                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3822 ! Calculate contact energies
3823                 cosa4=4.0D0*cosa
3824                 wij=cosa-3.0D0*cosb*cosg
3825                 cosbg1=cosb+cosg
3826                 cosbg2=cosb-cosg
3827 !               fac3=dsqrt(-ael6i)/r0ij**3
3828                 fac3=dsqrt(-ael6i)*r3ij
3829 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3830                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3831                 if (ees0tmp.gt.0) then
3832                   ees0pij=dsqrt(ees0tmp)
3833                 else
3834                   ees0pij=0
3835                 endif
3836                 if (shield_mode.eq.0) then
3837                 fac_shield(i)=1.0d0
3838                 fac_shield(j)=1.0d0
3839                 else
3840                 ees0plist(num_conti,i)=j
3841                 endif
3842 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3843                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3844                 if (ees0tmp.gt.0) then
3845                   ees0mij=dsqrt(ees0tmp)
3846                 else
3847                   ees0mij=0
3848                 endif
3849 !               ees0mij=0.0D0
3850                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
3851                      *sss_ele_cut &
3852                      *fac_shield(i)*fac_shield(j)
3853
3854                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
3855                      *sss_ele_cut &
3856                      *fac_shield(i)*fac_shield(j)
3857
3858 ! Diagnostics. Comment out or remove after debugging!
3859 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3860 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3861 !               ees0m(num_conti,i)=0.0D0
3862 ! End diagnostics.
3863 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3864 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3865 ! Angular derivatives of the contact function
3866                 ees0pij1=fac3/ees0pij
3867                 ees0mij1=fac3/ees0mij
3868                 fac3p=-3.0D0*fac3*rrmij
3869                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3870                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3871 !               ees0mij1=0.0D0
3872                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3873                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3874                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3875                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3876                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3877                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3878                 ecosap=ecosa1+ecosa2
3879                 ecosbp=ecosb1+ecosb2
3880                 ecosgp=ecosg1+ecosg2
3881                 ecosam=ecosa1-ecosa2
3882                 ecosbm=ecosb1-ecosb2
3883                 ecosgm=ecosg1-ecosg2
3884 ! Diagnostics
3885 !               ecosap=ecosa1
3886 !               ecosbp=ecosb1
3887 !               ecosgp=ecosg1
3888 !               ecosam=0.0D0
3889 !               ecosbm=0.0D0
3890 !               ecosgm=0.0D0
3891 ! End diagnostics
3892                 facont_hb(num_conti,i)=fcont
3893                 fprimcont=fprimcont/rij
3894 !d              facont_hb(num_conti,i)=1.0D0
3895 ! Following line is for diagnostics.
3896 !d              fprimcont=0.0D0
3897                 do k=1,3
3898                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3899                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3900                 enddo
3901                 do k=1,3
3902                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3903                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3904                 enddo
3905                 gggp(1)=gggp(1)+ees0pijp*xj &
3906                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3907                 gggp(2)=gggp(2)+ees0pijp*yj &
3908                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3909                 gggp(3)=gggp(3)+ees0pijp*zj &
3910                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3911
3912                 gggm(1)=gggm(1)+ees0mijp*xj &
3913                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3914
3915                 gggm(2)=gggm(2)+ees0mijp*yj &
3916                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3917
3918                 gggm(3)=gggm(3)+ees0mijp*zj &
3919                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3920
3921 ! Derivatives due to the contact function
3922                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3923                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3924                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3925                 do k=1,3
3926 !
3927 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3928 !          following the change of gradient-summation algorithm.
3929 !
3930 !grad                  ghalfp=0.5D0*gggp(k)
3931 !grad                  ghalfm=0.5D0*gggm(k)
3932                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3933                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3934                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3935                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3936
3937                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3938                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3939                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3940                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3941
3942                   gacontp_hb3(k,num_conti,i)=gggp(k) &
3943                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3944
3945                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3946                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3947                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3948                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3949
3950                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3951                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3952                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
3953                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3954
3955                   gacontm_hb3(k,num_conti,i)=gggm(k) &
3956                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3957
3958                 enddo
3959 ! Diagnostics. Comment out or remove after debugging!
3960 !diag           do k=1,3
3961 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3962 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3963 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3964 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3965 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3966 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3967 !diag           enddo
3968               ENDIF ! wcorr
3969               endif  ! num_conti.le.maxconts
3970             endif  ! fcont.gt.0
3971           endif    ! j.gt.i+1
3972           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3973             do k=1,4
3974               do l=1,3
3975                 ghalf=0.5d0*agg(l,k)
3976                 aggi(l,k)=aggi(l,k)+ghalf
3977                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3978                 aggj(l,k)=aggj(l,k)+ghalf
3979               enddo
3980             enddo
3981             if (j.eq.nres-1 .and. i.lt.j-2) then
3982               do k=1,4
3983                 do l=1,3
3984                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3985                 enddo
3986               enddo
3987             endif
3988           endif
3989  128  continue
3990 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3991       return
3992       end subroutine eelecij
3993 !-----------------------------------------------------------------------------
3994       subroutine eturn3(i,eello_turn3)
3995 ! Third- and fourth-order contributions from turns
3996
3997       use comm_locel
3998 !      implicit real*8 (a-h,o-z)
3999 !      include 'DIMENSIONS'
4000 !      include 'COMMON.IOUNITS'
4001 !      include 'COMMON.GEO'
4002 !      include 'COMMON.VAR'
4003 !      include 'COMMON.LOCAL'
4004 !      include 'COMMON.CHAIN'
4005 !      include 'COMMON.DERIV'
4006 !      include 'COMMON.INTERACT'
4007 !      include 'COMMON.CONTACTS'
4008 !      include 'COMMON.TORSION'
4009 !      include 'COMMON.VECTORS'
4010 !      include 'COMMON.FFIELD'
4011 !      include 'COMMON.CONTROL'
4012       real(kind=8),dimension(3) :: ggg
4013       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4014         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4015       real(kind=8),dimension(2) :: auxvec,auxvec1
4016 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4017       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4018 !el      integer :: num_conti,j1,j2
4019 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4020 !el        dz_normi,xmedi,ymedi,zmedi
4021
4022 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4023 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4024 !el         num_conti,j1,j2
4025 !el local variables
4026       integer :: i,j,l,k,ilist,iresshield
4027       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4028
4029       j=i+2
4030 !      write (iout,*) "eturn3",i,j,j1,j2
4031           zj=(c(3,j)+c(3,j+1))/2.0d0
4032           zj=mod(zj,boxzsize)
4033           if (zj.lt.0) zj=zj+boxzsize
4034           if ((zj.lt.0)) write (*,*) "CHUJ"
4035        if ((zj.gt.bordlipbot)  &
4036         .and.(zj.lt.bordliptop)) then
4037 !C the energy transfer exist
4038         if (zj.lt.buflipbot) then
4039 !C what fraction I am in
4040          fracinbuf=1.0d0-     &
4041              ((zj-bordlipbot)/lipbufthick)
4042 !C lipbufthick is thickenes of lipid buffore
4043          sslipj=sscalelip(fracinbuf)
4044          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4045         elseif (zj.gt.bufliptop) then
4046          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4047          sslipj=sscalelip(fracinbuf)
4048          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4049         else
4050          sslipj=1.0d0
4051          ssgradlipj=0.0
4052         endif
4053        else
4054          sslipj=0.0d0
4055          ssgradlipj=0.0
4056        endif
4057
4058       a_temp(1,1)=a22
4059       a_temp(1,2)=a23
4060       a_temp(2,1)=a32
4061       a_temp(2,2)=a33
4062 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4063 !
4064 !               Third-order contributions
4065 !
4066 !                 (i+2)o----(i+3)
4067 !                      | |
4068 !                      | |
4069 !                 (i+1)o----i
4070 !
4071 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4072 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4073         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4074         call transpose2(auxmat(1,1),auxmat1(1,1))
4075         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4076         if (shield_mode.eq.0) then
4077         fac_shield(i)=1.0d0
4078         fac_shield(j)=1.0d0
4079         endif
4080
4081         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4082          *fac_shield(i)*fac_shield(j)  &
4083          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4084         eello_t3= &
4085         0.5d0*(pizda(1,1)+pizda(2,2)) &
4086         *fac_shield(i)*fac_shield(j)
4087
4088         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4089                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4090           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4091        (shield_mode.gt.0)) then
4092 !C          print *,i,j
4093
4094           do ilist=1,ishield_list(i)
4095            iresshield=shield_list(ilist,i)
4096            do k=1,3
4097            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4098            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4099                    rlocshield &
4100            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4101             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4102              +rlocshield
4103            enddo
4104           enddo
4105           do ilist=1,ishield_list(j)
4106            iresshield=shield_list(ilist,j)
4107            do k=1,3
4108            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4109            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4110                    rlocshield &
4111            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4112            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4113                   +rlocshield
4114
4115            enddo
4116           enddo
4117
4118           do k=1,3
4119             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4120                    grad_shield(k,i)*eello_t3/fac_shield(i)
4121             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4122                    grad_shield(k,j)*eello_t3/fac_shield(j)
4123             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4124                    grad_shield(k,i)*eello_t3/fac_shield(i)
4125             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4126                    grad_shield(k,j)*eello_t3/fac_shield(j)
4127            enddo
4128            endif
4129
4130 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4131 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4132 !d     &    ' eello_turn3_num',4*eello_turn3_num
4133 ! Derivatives in gamma(i)
4134         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4135         call transpose2(auxmat2(1,1),auxmat3(1,1))
4136         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4137         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4138           *fac_shield(i)*fac_shield(j)        &
4139           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4140 ! Derivatives in gamma(i+1)
4141         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4142         call transpose2(auxmat2(1,1),auxmat3(1,1))
4143         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4144         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4145           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4146           *fac_shield(i)*fac_shield(j)        &
4147           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4148
4149 ! Cartesian derivatives
4150         do l=1,3
4151 !            ghalf1=0.5d0*agg(l,1)
4152 !            ghalf2=0.5d0*agg(l,2)
4153 !            ghalf3=0.5d0*agg(l,3)
4154 !            ghalf4=0.5d0*agg(l,4)
4155           a_temp(1,1)=aggi(l,1)!+ghalf1
4156           a_temp(1,2)=aggi(l,2)!+ghalf2
4157           a_temp(2,1)=aggi(l,3)!+ghalf3
4158           a_temp(2,2)=aggi(l,4)!+ghalf4
4159           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4160           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4161             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4162           *fac_shield(i)*fac_shield(j)      &
4163           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4164
4165           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4166           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4167           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4168           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4169           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4170           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4171             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4172           *fac_shield(i)*fac_shield(j)        &
4173           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4174
4175           a_temp(1,1)=aggj(l,1)!+ghalf1
4176           a_temp(1,2)=aggj(l,2)!+ghalf2
4177           a_temp(2,1)=aggj(l,3)!+ghalf3
4178           a_temp(2,2)=aggj(l,4)!+ghalf4
4179           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4180           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4181             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4182           *fac_shield(i)*fac_shield(j)      &
4183           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4184
4185           a_temp(1,1)=aggj1(l,1)
4186           a_temp(1,2)=aggj1(l,2)
4187           a_temp(2,1)=aggj1(l,3)
4188           a_temp(2,2)=aggj1(l,4)
4189           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4190           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4191             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4192           *fac_shield(i)*fac_shield(j)        &
4193           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4194         enddo
4195          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4196           ssgradlipi*eello_t3/4.0d0*lipscale
4197          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4198           ssgradlipj*eello_t3/4.0d0*lipscale
4199          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4200           ssgradlipi*eello_t3/4.0d0*lipscale
4201          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4202           ssgradlipj*eello_t3/4.0d0*lipscale
4203
4204       return
4205       end subroutine eturn3
4206 !-----------------------------------------------------------------------------
4207       subroutine eturn4(i,eello_turn4)
4208 ! Third- and fourth-order contributions from turns
4209
4210       use comm_locel
4211 !      implicit real*8 (a-h,o-z)
4212 !      include 'DIMENSIONS'
4213 !      include 'COMMON.IOUNITS'
4214 !      include 'COMMON.GEO'
4215 !      include 'COMMON.VAR'
4216 !      include 'COMMON.LOCAL'
4217 !      include 'COMMON.CHAIN'
4218 !      include 'COMMON.DERIV'
4219 !      include 'COMMON.INTERACT'
4220 !      include 'COMMON.CONTACTS'
4221 !      include 'COMMON.TORSION'
4222 !      include 'COMMON.VECTORS'
4223 !      include 'COMMON.FFIELD'
4224 !      include 'COMMON.CONTROL'
4225       real(kind=8),dimension(3) :: ggg
4226       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4227         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4228       real(kind=8),dimension(2) :: auxvec,auxvec1
4229 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4230       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4231 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4232 !el        dz_normi,xmedi,ymedi,zmedi
4233 !el      integer :: num_conti,j1,j2
4234 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4235 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4236 !el          num_conti,j1,j2
4237 !el local variables
4238       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4239       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4240          rlocshield
4241
4242       j=i+3
4243 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4244 !
4245 !               Fourth-order contributions
4246 !
4247 !                 (i+3)o----(i+4)
4248 !                     /  |
4249 !               (i+2)o   |
4250 !                     \  |
4251 !                 (i+1)o----i
4252 !
4253 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4254 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4255 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4256           zj=(c(3,j)+c(3,j+1))/2.0d0
4257           zj=mod(zj,boxzsize)
4258           if (zj.lt.0) zj=zj+boxzsize
4259        if ((zj.gt.bordlipbot)  &
4260         .and.(zj.lt.bordliptop)) then
4261 !C the energy transfer exist
4262         if (zj.lt.buflipbot) then
4263 !C what fraction I am in
4264          fracinbuf=1.0d0-     &
4265              ((zj-bordlipbot)/lipbufthick)
4266 !C lipbufthick is thickenes of lipid buffore
4267          sslipj=sscalelip(fracinbuf)
4268          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4269         elseif (zj.gt.bufliptop) then
4270          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4271          sslipj=sscalelip(fracinbuf)
4272          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4273         else
4274          sslipj=1.0d0
4275          ssgradlipj=0.0
4276         endif
4277        else
4278          sslipj=0.0d0
4279          ssgradlipj=0.0
4280        endif
4281
4282         a_temp(1,1)=a22
4283         a_temp(1,2)=a23
4284         a_temp(2,1)=a32
4285         a_temp(2,2)=a33
4286         iti1=itortyp(itype(i+1))
4287         iti2=itortyp(itype(i+2))
4288         iti3=itortyp(itype(i+3))
4289 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4290         call transpose2(EUg(1,1,i+1),e1t(1,1))
4291         call transpose2(Eug(1,1,i+2),e2t(1,1))
4292         call transpose2(Eug(1,1,i+3),e3t(1,1))
4293         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4294         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4295         s1=scalar2(b1(1,iti2),auxvec(1))
4296         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4297         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4298         s2=scalar2(b1(1,iti1),auxvec(1))
4299         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4300         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4301         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4302         if (shield_mode.eq.0) then
4303         fac_shield(i)=1.0
4304         fac_shield(j)=1.0
4305         endif
4306
4307         eello_turn4=eello_turn4-(s1+s2+s3) &
4308         *fac_shield(i)*fac_shield(j)       &
4309         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4310         eello_t4=-(s1+s2+s3)  &
4311           *fac_shield(i)*fac_shield(j)
4312 !C Now derivative over shield:
4313           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4314          (shield_mode.gt.0)) then
4315 !C          print *,i,j
4316
4317           do ilist=1,ishield_list(i)
4318            iresshield=shield_list(ilist,i)
4319            do k=1,3
4320            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4321            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4322                    rlocshield &
4323             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4324             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4325            +rlocshield
4326            enddo
4327           enddo
4328           do ilist=1,ishield_list(j)
4329            iresshield=shield_list(ilist,j)
4330            do k=1,3
4331            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4332            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4333                    rlocshield  &
4334            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4335            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4336                   +rlocshield
4337
4338            enddo
4339           enddo
4340
4341           do k=1,3
4342             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4343                    grad_shield(k,i)*eello_t4/fac_shield(i)
4344             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4345                    grad_shield(k,j)*eello_t4/fac_shield(j)
4346             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4347                    grad_shield(k,i)*eello_t4/fac_shield(i)
4348             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4349                    grad_shield(k,j)*eello_t4/fac_shield(j)
4350            enddo
4351            endif
4352
4353         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4354            'eturn4',i,j,-(s1+s2+s3)
4355 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4356 !d     &    ' eello_turn4_num',8*eello_turn4_num
4357 ! Derivatives in gamma(i)
4358         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4359         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4360         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4361         s1=scalar2(b1(1,iti2),auxvec(1))
4362         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4363         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4364         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4365        *fac_shield(i)*fac_shield(j)  &
4366        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4367
4368 ! Derivatives in gamma(i+1)
4369         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4370         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4371         s2=scalar2(b1(1,iti1),auxvec(1))
4372         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4373         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4374         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4375         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4376        *fac_shield(i)*fac_shield(j)  &
4377        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4378
4379 ! Derivatives in gamma(i+2)
4380         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4381         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4382         s1=scalar2(b1(1,iti2),auxvec(1))
4383         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4384         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4385         s2=scalar2(b1(1,iti1),auxvec(1))
4386         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4387         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4388         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4389         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4390        *fac_shield(i)*fac_shield(j)  &
4391        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4392
4393 ! Cartesian derivatives
4394 ! Derivatives of this turn contributions in DC(i+2)
4395         if (j.lt.nres-1) then
4396           do l=1,3
4397             a_temp(1,1)=agg(l,1)
4398             a_temp(1,2)=agg(l,2)
4399             a_temp(2,1)=agg(l,3)
4400             a_temp(2,2)=agg(l,4)
4401             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4402             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4403             s1=scalar2(b1(1,iti2),auxvec(1))
4404             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4405             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4406             s2=scalar2(b1(1,iti1),auxvec(1))
4407             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4408             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4409             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4410             ggg(l)=-(s1+s2+s3)
4411             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4412        *fac_shield(i)*fac_shield(j)  &
4413        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4414
4415           enddo
4416         endif
4417 ! Remaining derivatives of this turn contribution
4418         do l=1,3
4419           a_temp(1,1)=aggi(l,1)
4420           a_temp(1,2)=aggi(l,2)
4421           a_temp(2,1)=aggi(l,3)
4422           a_temp(2,2)=aggi(l,4)
4423           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4424           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4425           s1=scalar2(b1(1,iti2),auxvec(1))
4426           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4427           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4428           s2=scalar2(b1(1,iti1),auxvec(1))
4429           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4430           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4431           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4432           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4433          *fac_shield(i)*fac_shield(j)  &
4434          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4435
4436
4437           a_temp(1,1)=aggi1(l,1)
4438           a_temp(1,2)=aggi1(l,2)
4439           a_temp(2,1)=aggi1(l,3)
4440           a_temp(2,2)=aggi1(l,4)
4441           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4442           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4443           s1=scalar2(b1(1,iti2),auxvec(1))
4444           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4445           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4446           s2=scalar2(b1(1,iti1),auxvec(1))
4447           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4448           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4449           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4450           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4451          *fac_shield(i)*fac_shield(j)  &
4452          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4453
4454
4455           a_temp(1,1)=aggj(l,1)
4456           a_temp(1,2)=aggj(l,2)
4457           a_temp(2,1)=aggj(l,3)
4458           a_temp(2,2)=aggj(l,4)
4459           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4460           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4461           s1=scalar2(b1(1,iti2),auxvec(1))
4462           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4463           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4464           s2=scalar2(b1(1,iti1),auxvec(1))
4465           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4466           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4467           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4468           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4469          *fac_shield(i)*fac_shield(j)  &
4470          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4471
4472
4473           a_temp(1,1)=aggj1(l,1)
4474           a_temp(1,2)=aggj1(l,2)
4475           a_temp(2,1)=aggj1(l,3)
4476           a_temp(2,2)=aggj1(l,4)
4477           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4478           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4479           s1=scalar2(b1(1,iti2),auxvec(1))
4480           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4481           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4482           s2=scalar2(b1(1,iti1),auxvec(1))
4483           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4484           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4485           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4486 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4487           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4488          *fac_shield(i)*fac_shield(j)  &
4489          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4490
4491         enddo
4492          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4493           ssgradlipi*eello_t4/4.0d0*lipscale
4494          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4495           ssgradlipj*eello_t4/4.0d0*lipscale
4496          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4497           ssgradlipi*eello_t4/4.0d0*lipscale
4498          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4499           ssgradlipj*eello_t4/4.0d0*lipscale
4500
4501       return
4502       end subroutine eturn4
4503 !-----------------------------------------------------------------------------
4504       subroutine unormderiv(u,ugrad,unorm,ungrad)
4505 ! This subroutine computes the derivatives of a normalized vector u, given
4506 ! the derivatives computed without normalization conditions, ugrad. Returns
4507 ! ungrad.
4508 !      implicit none
4509       real(kind=8),dimension(3) :: u,vec
4510       real(kind=8),dimension(3,3) ::ugrad,ungrad
4511       real(kind=8) :: unorm     !,scalar
4512       integer :: i,j
4513 !      write (2,*) 'ugrad',ugrad
4514 !      write (2,*) 'u',u
4515       do i=1,3
4516         vec(i)=scalar(ugrad(1,i),u(1))
4517       enddo
4518 !      write (2,*) 'vec',vec
4519       do i=1,3
4520         do j=1,3
4521           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4522         enddo
4523       enddo
4524 !      write (2,*) 'ungrad',ungrad
4525       return
4526       end subroutine unormderiv
4527 !-----------------------------------------------------------------------------
4528       subroutine escp_soft_sphere(evdw2,evdw2_14)
4529 !
4530 ! This subroutine calculates the excluded-volume interaction energy between
4531 ! peptide-group centers and side chains and its gradient in virtual-bond and
4532 ! side-chain vectors.
4533 !
4534 !      implicit real*8 (a-h,o-z)
4535 !      include 'DIMENSIONS'
4536 !      include 'COMMON.GEO'
4537 !      include 'COMMON.VAR'
4538 !      include 'COMMON.LOCAL'
4539 !      include 'COMMON.CHAIN'
4540 !      include 'COMMON.DERIV'
4541 !      include 'COMMON.INTERACT'
4542 !      include 'COMMON.FFIELD'
4543 !      include 'COMMON.IOUNITS'
4544 !      include 'COMMON.CONTROL'
4545       real(kind=8),dimension(3) :: ggg
4546 !el local variables
4547       integer :: i,iint,j,k,iteli,itypj
4548       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4549                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4550
4551       evdw2=0.0D0
4552       evdw2_14=0.0d0
4553       r0_scp=4.5d0
4554 !d    print '(a)','Enter ESCP'
4555 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4556       do i=iatscp_s,iatscp_e
4557         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4558         iteli=itel(i)
4559         xi=0.5D0*(c(1,i)+c(1,i+1))
4560         yi=0.5D0*(c(2,i)+c(2,i+1))
4561         zi=0.5D0*(c(3,i)+c(3,i+1))
4562
4563         do iint=1,nscp_gr(i)
4564
4565         do j=iscpstart(i,iint),iscpend(i,iint)
4566           if (itype(j).eq.ntyp1) cycle
4567           itypj=iabs(itype(j))
4568 ! Uncomment following three lines for SC-p interactions
4569 !         xj=c(1,nres+j)-xi
4570 !         yj=c(2,nres+j)-yi
4571 !         zj=c(3,nres+j)-zi
4572 ! Uncomment following three lines for Ca-p interactions
4573           xj=c(1,j)-xi
4574           yj=c(2,j)-yi
4575           zj=c(3,j)-zi
4576           rij=xj*xj+yj*yj+zj*zj
4577           r0ij=r0_scp
4578           r0ijsq=r0ij*r0ij
4579           if (rij.lt.r0ijsq) then
4580             evdwij=0.25d0*(rij-r0ijsq)**2
4581             fac=rij-r0ijsq
4582           else
4583             evdwij=0.0d0
4584             fac=0.0d0
4585           endif
4586           evdw2=evdw2+evdwij
4587 !
4588 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4589 !
4590           ggg(1)=xj*fac
4591           ggg(2)=yj*fac
4592           ggg(3)=zj*fac
4593 !grad          if (j.lt.i) then
4594 !d          write (iout,*) 'j<i'
4595 ! Uncomment following three lines for SC-p interactions
4596 !           do k=1,3
4597 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4598 !           enddo
4599 !grad          else
4600 !d          write (iout,*) 'j>i'
4601 !grad            do k=1,3
4602 !grad              ggg(k)=-ggg(k)
4603 ! Uncomment following line for SC-p interactions
4604 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4605 !grad            enddo
4606 !grad          endif
4607 !grad          do k=1,3
4608 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4609 !grad          enddo
4610 !grad          kstart=min0(i+1,j)
4611 !grad          kend=max0(i-1,j-1)
4612 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4613 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4614 !grad          do k=kstart,kend
4615 !grad            do l=1,3
4616 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4617 !grad            enddo
4618 !grad          enddo
4619           do k=1,3
4620             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4621             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4622           enddo
4623         enddo
4624
4625         enddo ! iint
4626       enddo ! i
4627       return
4628       end subroutine escp_soft_sphere
4629 !-----------------------------------------------------------------------------
4630       subroutine escp(evdw2,evdw2_14)
4631 !
4632 ! This subroutine calculates the excluded-volume interaction energy between
4633 ! peptide-group centers and side chains and its gradient in virtual-bond and
4634 ! side-chain vectors.
4635 !
4636 !      implicit real*8 (a-h,o-z)
4637 !      include 'DIMENSIONS'
4638 !      include 'COMMON.GEO'
4639 !      include 'COMMON.VAR'
4640 !      include 'COMMON.LOCAL'
4641 !      include 'COMMON.CHAIN'
4642 !      include 'COMMON.DERIV'
4643 !      include 'COMMON.INTERACT'
4644 !      include 'COMMON.FFIELD'
4645 !      include 'COMMON.IOUNITS'
4646 !      include 'COMMON.CONTROL'
4647       real(kind=8),dimension(3) :: ggg
4648 !el local variables
4649       integer :: i,iint,j,k,iteli,itypj,subchap
4650       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4651                    e1,e2,evdwij,rij
4652       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4653                     dist_temp, dist_init
4654       integer xshift,yshift,zshift
4655
4656       evdw2=0.0D0
4657       evdw2_14=0.0d0
4658 !d    print '(a)','Enter ESCP'
4659 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4660       do i=iatscp_s,iatscp_e
4661         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4662         iteli=itel(i)
4663         xi=0.5D0*(c(1,i)+c(1,i+1))
4664         yi=0.5D0*(c(2,i)+c(2,i+1))
4665         zi=0.5D0*(c(3,i)+c(3,i+1))
4666           xi=mod(xi,boxxsize)
4667           if (xi.lt.0) xi=xi+boxxsize
4668           yi=mod(yi,boxysize)
4669           if (yi.lt.0) yi=yi+boxysize
4670           zi=mod(zi,boxzsize)
4671           if (zi.lt.0) zi=zi+boxzsize
4672
4673         do iint=1,nscp_gr(i)
4674
4675         do j=iscpstart(i,iint),iscpend(i,iint)
4676           itypj=iabs(itype(j))
4677           if (itypj.eq.ntyp1) cycle
4678 ! Uncomment following three lines for SC-p interactions
4679 !         xj=c(1,nres+j)-xi
4680 !         yj=c(2,nres+j)-yi
4681 !         zj=c(3,nres+j)-zi
4682 ! Uncomment following three lines for Ca-p interactions
4683 !          xj=c(1,j)-xi
4684 !          yj=c(2,j)-yi
4685 !          zj=c(3,j)-zi
4686           xj=c(1,j)
4687           yj=c(2,j)
4688           zj=c(3,j)
4689           xj=mod(xj,boxxsize)
4690           if (xj.lt.0) xj=xj+boxxsize
4691           yj=mod(yj,boxysize)
4692           if (yj.lt.0) yj=yj+boxysize
4693           zj=mod(zj,boxzsize)
4694           if (zj.lt.0) zj=zj+boxzsize
4695       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4696       xj_safe=xj
4697       yj_safe=yj
4698       zj_safe=zj
4699       subchap=0
4700       do xshift=-1,1
4701       do yshift=-1,1
4702       do zshift=-1,1
4703           xj=xj_safe+xshift*boxxsize
4704           yj=yj_safe+yshift*boxysize
4705           zj=zj_safe+zshift*boxzsize
4706           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4707           if(dist_temp.lt.dist_init) then
4708             dist_init=dist_temp
4709             xj_temp=xj
4710             yj_temp=yj
4711             zj_temp=zj
4712             subchap=1
4713           endif
4714        enddo
4715        enddo
4716        enddo
4717        if (subchap.eq.1) then
4718           xj=xj_temp-xi
4719           yj=yj_temp-yi
4720           zj=zj_temp-zi
4721        else
4722           xj=xj_safe-xi
4723           yj=yj_safe-yi
4724           zj=zj_safe-zi
4725        endif
4726
4727           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4728           rij=dsqrt(1.0d0/rrij)
4729             sss_ele_cut=sscale_ele(rij)
4730             sss_ele_grad=sscagrad_ele(rij)
4731 !            print *,sss_ele_cut,sss_ele_grad,&
4732 !            (rij),r_cut_ele,rlamb_ele
4733             if (sss_ele_cut.le.0.0) cycle
4734           fac=rrij**expon2
4735           e1=fac*fac*aad(itypj,iteli)
4736           e2=fac*bad(itypj,iteli)
4737           if (iabs(j-i) .le. 2) then
4738             e1=scal14*e1
4739             e2=scal14*e2
4740             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4741           endif
4742           evdwij=e1+e2
4743           evdw2=evdw2+evdwij*sss_ele_cut
4744 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4745 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4746           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4747              'evdw2',i,j,evdwij
4748 !
4749 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4750 !
4751           fac=-(evdwij+e1)*rrij*sss_ele_cut
4752           fac=fac+evdwij*sss_ele_grad/rij/expon
4753           ggg(1)=xj*fac
4754           ggg(2)=yj*fac
4755           ggg(3)=zj*fac
4756 !grad          if (j.lt.i) then
4757 !d          write (iout,*) 'j<i'
4758 ! Uncomment following three lines for SC-p interactions
4759 !           do k=1,3
4760 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4761 !           enddo
4762 !grad          else
4763 !d          write (iout,*) 'j>i'
4764 !grad            do k=1,3
4765 !grad              ggg(k)=-ggg(k)
4766 ! Uncomment following line for SC-p interactions
4767 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4768 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4769 !grad            enddo
4770 !grad          endif
4771 !grad          do k=1,3
4772 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4773 !grad          enddo
4774 !grad          kstart=min0(i+1,j)
4775 !grad          kend=max0(i-1,j-1)
4776 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4777 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4778 !grad          do k=kstart,kend
4779 !grad            do l=1,3
4780 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4781 !grad            enddo
4782 !grad          enddo
4783           do k=1,3
4784             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4785             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4786           enddo
4787         enddo
4788
4789         enddo ! iint
4790       enddo ! i
4791       do i=1,nct
4792         do j=1,3
4793           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4794           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4795           gradx_scp(j,i)=expon*gradx_scp(j,i)
4796         enddo
4797       enddo
4798 !******************************************************************************
4799 !
4800 !                              N O T E !!!
4801 !
4802 ! To save time the factor EXPON has been extracted from ALL components
4803 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4804 ! use!
4805 !
4806 !******************************************************************************
4807       return
4808       end subroutine escp
4809 !-----------------------------------------------------------------------------
4810       subroutine edis(ehpb)
4811 !
4812 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4813 !
4814 !      implicit real*8 (a-h,o-z)
4815 !      include 'DIMENSIONS'
4816 !      include 'COMMON.SBRIDGE'
4817 !      include 'COMMON.CHAIN'
4818 !      include 'COMMON.DERIV'
4819 !      include 'COMMON.VAR'
4820 !      include 'COMMON.INTERACT'
4821 !      include 'COMMON.IOUNITS'
4822       real(kind=8),dimension(3) :: ggg
4823 !el local variables
4824       integer :: i,j,ii,jj,iii,jjj,k
4825       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4826
4827       ehpb=0.0D0
4828 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4829 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4830       if (link_end.eq.0) return
4831       do i=link_start,link_end
4832 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4833 ! CA-CA distance used in regularization of structure.
4834         ii=ihpb(i)
4835         jj=jhpb(i)
4836 ! iii and jjj point to the residues for which the distance is assigned.
4837         if (ii.gt.nres) then
4838           iii=ii-nres
4839           jjj=jj-nres
4840         else
4841           iii=ii
4842           jjj=jj
4843         endif
4844 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4845 !     &    dhpb(i),dhpb1(i),forcon(i)
4846 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4847 !    distance and angle dependent SS bond potential.
4848 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4849 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4850         if (.not.dyn_ss .and. i.le.nss) then
4851 ! 15/02/13 CC dynamic SSbond - additional check
4852          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4853         iabs(itype(jjj)).eq.1) then
4854           call ssbond_ene(iii,jjj,eij)
4855           ehpb=ehpb+2*eij
4856 !d          write (iout,*) "eij",eij
4857          endif
4858         else
4859 ! Calculate the distance between the two points and its difference from the
4860 ! target distance.
4861         dd=dist(ii,jj)
4862         rdis=dd-dhpb(i)
4863 ! Get the force constant corresponding to this distance.
4864         waga=forcon(i)
4865 ! Calculate the contribution to energy.
4866         ehpb=ehpb+waga*rdis*rdis
4867 !
4868 ! Evaluate gradient.
4869 !
4870         fac=waga*rdis/dd
4871 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4872 !d   &   ' waga=',waga,' fac=',fac
4873         do j=1,3
4874           ggg(j)=fac*(c(j,jj)-c(j,ii))
4875         enddo
4876 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4877 ! If this is a SC-SC distance, we need to calculate the contributions to the
4878 ! Cartesian gradient in the SC vectors (ghpbx).
4879         if (iii.lt.ii) then
4880           do j=1,3
4881             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4882             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4883           enddo
4884         endif
4885 !grad        do j=iii,jjj-1
4886 !grad          do k=1,3
4887 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4888 !grad          enddo
4889 !grad        enddo
4890         do k=1,3
4891           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4892           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4893         enddo
4894         endif
4895       enddo
4896       ehpb=0.5D0*ehpb
4897       return
4898       end subroutine edis
4899 !-----------------------------------------------------------------------------
4900       subroutine ssbond_ene(i,j,eij)
4901 !
4902 ! Calculate the distance and angle dependent SS-bond potential energy
4903 ! using a free-energy function derived based on RHF/6-31G** ab initio
4904 ! calculations of diethyl disulfide.
4905 !
4906 ! A. Liwo and U. Kozlowska, 11/24/03
4907 !
4908 !      implicit real*8 (a-h,o-z)
4909 !      include 'DIMENSIONS'
4910 !      include 'COMMON.SBRIDGE'
4911 !      include 'COMMON.CHAIN'
4912 !      include 'COMMON.DERIV'
4913 !      include 'COMMON.LOCAL'
4914 !      include 'COMMON.INTERACT'
4915 !      include 'COMMON.VAR'
4916 !      include 'COMMON.IOUNITS'
4917       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4918 !el local variables
4919       integer :: i,j,itypi,itypj,k
4920       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4921                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4922                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4923                    cosphi,ggk
4924
4925       itypi=iabs(itype(i))
4926       xi=c(1,nres+i)
4927       yi=c(2,nres+i)
4928       zi=c(3,nres+i)
4929       dxi=dc_norm(1,nres+i)
4930       dyi=dc_norm(2,nres+i)
4931       dzi=dc_norm(3,nres+i)
4932 !      dsci_inv=dsc_inv(itypi)
4933       dsci_inv=vbld_inv(nres+i)
4934       itypj=iabs(itype(j))
4935 !      dscj_inv=dsc_inv(itypj)
4936       dscj_inv=vbld_inv(nres+j)
4937       xj=c(1,nres+j)-xi
4938       yj=c(2,nres+j)-yi
4939       zj=c(3,nres+j)-zi
4940       dxj=dc_norm(1,nres+j)
4941       dyj=dc_norm(2,nres+j)
4942       dzj=dc_norm(3,nres+j)
4943       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4944       rij=dsqrt(rrij)
4945       erij(1)=xj*rij
4946       erij(2)=yj*rij
4947       erij(3)=zj*rij
4948       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4949       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4950       om12=dxi*dxj+dyi*dyj+dzi*dzj
4951       do k=1,3
4952         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4953         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4954       enddo
4955       rij=1.0d0/rij
4956       deltad=rij-d0cm
4957       deltat1=1.0d0-om1
4958       deltat2=1.0d0+om2
4959       deltat12=om2-om1+2.0d0
4960       cosphi=om12-om1*om2
4961       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4962         +akct*deltad*deltat12 &
4963         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4964 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4965 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4966 !     &  " deltat12",deltat12," eij",eij
4967       ed=2*akcm*deltad+akct*deltat12
4968       pom1=akct*deltad
4969       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4970       eom1=-2*akth*deltat1-pom1-om2*pom2
4971       eom2= 2*akth*deltat2+pom1-om1*pom2
4972       eom12=pom2
4973       do k=1,3
4974         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4975         ghpbx(k,i)=ghpbx(k,i)-ggk &
4976                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4977                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4978         ghpbx(k,j)=ghpbx(k,j)+ggk &
4979                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4980                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4981         ghpbc(k,i)=ghpbc(k,i)-ggk
4982         ghpbc(k,j)=ghpbc(k,j)+ggk
4983       enddo
4984 !
4985 ! Calculate the components of the gradient in DC and X
4986 !
4987 !grad      do k=i,j-1
4988 !grad        do l=1,3
4989 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4990 !grad        enddo
4991 !grad      enddo
4992       return
4993       end subroutine ssbond_ene
4994 !-----------------------------------------------------------------------------
4995       subroutine ebond(estr)
4996 !
4997 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4998 !
4999 !      implicit real*8 (a-h,o-z)
5000 !      include 'DIMENSIONS'
5001 !      include 'COMMON.LOCAL'
5002 !      include 'COMMON.GEO'
5003 !      include 'COMMON.INTERACT'
5004 !      include 'COMMON.DERIV'
5005 !      include 'COMMON.VAR'
5006 !      include 'COMMON.CHAIN'
5007 !      include 'COMMON.IOUNITS'
5008 !      include 'COMMON.NAMES'
5009 !      include 'COMMON.FFIELD'
5010 !      include 'COMMON.CONTROL'
5011 !      include 'COMMON.SETUP'
5012       real(kind=8),dimension(3) :: u,ud
5013 !el local variables
5014       integer :: i,j,iti,nbi,k
5015       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5016                    uprod1,uprod2
5017
5018       estr=0.0d0
5019       estr1=0.0d0
5020 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5021 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5022
5023       do i=ibondp_start,ibondp_end
5024         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5025         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5026 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5027 !C          do j=1,3
5028 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5029 !C            *dc(j,i-1)/vbld(i)
5030 !C          enddo
5031 !C          if (energy_dec) write(iout,*) &
5032 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5033         diff = vbld(i)-vbldpDUM
5034         else
5035         diff = vbld(i)-vbldp0
5036         endif
5037         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5038            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5039         estr=estr+diff*diff
5040         do j=1,3
5041           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5042         enddo
5043 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5044 !        endif
5045       enddo
5046       estr=0.5d0*AKP*estr+estr1
5047 !
5048 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5049 !
5050       do i=ibond_start,ibond_end
5051         iti=iabs(itype(i))
5052         if (iti.ne.10 .and. iti.ne.ntyp1) then
5053           nbi=nbondterm(iti)
5054           if (nbi.eq.1) then
5055             diff=vbld(i+nres)-vbldsc0(1,iti)
5056             if (energy_dec) write (iout,*) &
5057             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5058             AKSC(1,iti),AKSC(1,iti)*diff*diff
5059             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5060             do j=1,3
5061               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5062             enddo
5063           else
5064             do j=1,nbi
5065               diff=vbld(i+nres)-vbldsc0(j,iti)
5066               ud(j)=aksc(j,iti)*diff
5067               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5068             enddo
5069             uprod=u(1)
5070             do j=2,nbi
5071               uprod=uprod*u(j)
5072             enddo
5073             usum=0.0d0
5074             usumsqder=0.0d0
5075             do j=1,nbi
5076               uprod1=1.0d0
5077               uprod2=1.0d0
5078               do k=1,nbi
5079                 if (k.ne.j) then
5080                   uprod1=uprod1*u(k)
5081                   uprod2=uprod2*u(k)*u(k)
5082                 endif
5083               enddo
5084               usum=usum+uprod1
5085               usumsqder=usumsqder+ud(j)*uprod2
5086             enddo
5087             estr=estr+uprod/usum
5088             do j=1,3
5089              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5090             enddo
5091           endif
5092         endif
5093       enddo
5094       return
5095       end subroutine ebond
5096 #ifdef CRYST_THETA
5097 !-----------------------------------------------------------------------------
5098       subroutine ebend(etheta)
5099 !
5100 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5101 ! angles gamma and its derivatives in consecutive thetas and gammas.
5102 !
5103       use comm_calcthet
5104 !      implicit real*8 (a-h,o-z)
5105 !      include 'DIMENSIONS'
5106 !      include 'COMMON.LOCAL'
5107 !      include 'COMMON.GEO'
5108 !      include 'COMMON.INTERACT'
5109 !      include 'COMMON.DERIV'
5110 !      include 'COMMON.VAR'
5111 !      include 'COMMON.CHAIN'
5112 !      include 'COMMON.IOUNITS'
5113 !      include 'COMMON.NAMES'
5114 !      include 'COMMON.FFIELD'
5115 !      include 'COMMON.CONTROL'
5116 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5117 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5118 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5119 !el      integer :: it
5120 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5121 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5122 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5123 !el local variables
5124       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5125        ichir21,ichir22
5126       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5127        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5128        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5129       real(kind=8),dimension(2) :: y,z
5130
5131       delta=0.02d0*pi
5132 !      time11=dexp(-2*time)
5133 !      time12=1.0d0
5134       etheta=0.0D0
5135 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5136       do i=ithet_start,ithet_end
5137         if (itype(i-1).eq.ntyp1) cycle
5138 ! Zero the energy function and its derivative at 0 or pi.
5139         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5140         it=itype(i-1)
5141         ichir1=isign(1,itype(i-2))
5142         ichir2=isign(1,itype(i))
5143          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5144          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5145          if (itype(i-1).eq.10) then
5146           itype1=isign(10,itype(i-2))
5147           ichir11=isign(1,itype(i-2))
5148           ichir12=isign(1,itype(i-2))
5149           itype2=isign(10,itype(i))
5150           ichir21=isign(1,itype(i))
5151           ichir22=isign(1,itype(i))
5152          endif
5153
5154         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
5155 #ifdef OSF
5156           phii=phi(i)
5157           if (phii.ne.phii) phii=150.0
5158 #else
5159           phii=phi(i)
5160 #endif
5161           y(1)=dcos(phii)
5162           y(2)=dsin(phii)
5163         else
5164           y(1)=0.0D0
5165           y(2)=0.0D0
5166         endif
5167         if (i.lt.nres .and. itype(i).ne.ntyp1) then
5168 #ifdef OSF
5169           phii1=phi(i+1)
5170           if (phii1.ne.phii1) phii1=150.0
5171           phii1=pinorm(phii1)
5172           z(1)=cos(phii1)
5173 #else
5174           phii1=phi(i+1)
5175           z(1)=dcos(phii1)
5176 #endif
5177           z(2)=dsin(phii1)
5178         else
5179           z(1)=0.0D0
5180           z(2)=0.0D0
5181         endif
5182 ! Calculate the "mean" value of theta from the part of the distribution
5183 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5184 ! In following comments this theta will be referred to as t_c.
5185         thet_pred_mean=0.0d0
5186         do k=1,2
5187             athetk=athet(k,it,ichir1,ichir2)
5188             bthetk=bthet(k,it,ichir1,ichir2)
5189           if (it.eq.10) then
5190              athetk=athet(k,itype1,ichir11,ichir12)
5191              bthetk=bthet(k,itype2,ichir21,ichir22)
5192           endif
5193          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5194         enddo
5195         dthett=thet_pred_mean*ssd
5196         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5197 ! Derivatives of the "mean" values in gamma1 and gamma2.
5198         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5199                +athet(2,it,ichir1,ichir2)*y(1))*ss
5200         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5201                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5202          if (it.eq.10) then
5203         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5204              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5205         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5206                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5207          endif
5208         if (theta(i).gt.pi-delta) then
5209           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5210                E_tc0)
5211           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5212           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5213           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5214               E_theta)
5215           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5216               E_tc)
5217         else if (theta(i).lt.delta) then
5218           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5219           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5220           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5221               E_theta)
5222           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5223           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5224               E_tc)
5225         else
5226           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5227               E_theta,E_tc)
5228         endif
5229         etheta=etheta+ethetai
5230         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5231             'ebend',i,ethetai
5232         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5233         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5234         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5235       enddo
5236 ! Ufff.... We've done all this!!!
5237       return
5238       end subroutine ebend
5239 !-----------------------------------------------------------------------------
5240       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5241
5242       use comm_calcthet
5243 !      implicit real*8 (a-h,o-z)
5244 !      include 'DIMENSIONS'
5245 !      include 'COMMON.LOCAL'
5246 !      include 'COMMON.IOUNITS'
5247 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5248 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5249 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5250       integer :: i,j,k
5251       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5252 !el      integer :: it
5253 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5254 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5255 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5256 !el local variables
5257       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5258        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5259
5260 ! Calculate the contributions to both Gaussian lobes.
5261 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5262 ! The "polynomial part" of the "standard deviation" of this part of
5263 ! the distribution.
5264         sig=polthet(3,it)
5265         do j=2,0,-1
5266           sig=sig*thet_pred_mean+polthet(j,it)
5267         enddo
5268 ! Derivative of the "interior part" of the "standard deviation of the"
5269 ! gamma-dependent Gaussian lobe in t_c.
5270         sigtc=3*polthet(3,it)
5271         do j=2,1,-1
5272           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5273         enddo
5274         sigtc=sig*sigtc
5275 ! Set the parameters of both Gaussian lobes of the distribution.
5276 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5277         fac=sig*sig+sigc0(it)
5278         sigcsq=fac+fac
5279         sigc=1.0D0/sigcsq
5280 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5281         sigsqtc=-4.0D0*sigcsq*sigtc
5282 !       print *,i,sig,sigtc,sigsqtc
5283 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5284         sigtc=-sigtc/(fac*fac)
5285 ! Following variable is sigma(t_c)**(-2)
5286         sigcsq=sigcsq*sigcsq
5287         sig0i=sig0(it)
5288         sig0inv=1.0D0/sig0i**2
5289         delthec=thetai-thet_pred_mean
5290         delthe0=thetai-theta0i
5291         term1=-0.5D0*sigcsq*delthec*delthec
5292         term2=-0.5D0*sig0inv*delthe0*delthe0
5293 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5294 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5295 ! to the energy (this being the log of the distribution) at the end of energy
5296 ! term evaluation for this virtual-bond angle.
5297         if (term1.gt.term2) then
5298           termm=term1
5299           term2=dexp(term2-termm)
5300           term1=1.0d0
5301         else
5302           termm=term2
5303           term1=dexp(term1-termm)
5304           term2=1.0d0
5305         endif
5306 ! The ratio between the gamma-independent and gamma-dependent lobes of
5307 ! the distribution is a Gaussian function of thet_pred_mean too.
5308         diffak=gthet(2,it)-thet_pred_mean
5309         ratak=diffak/gthet(3,it)**2
5310         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5311 ! Let's differentiate it in thet_pred_mean NOW.
5312         aktc=ak*ratak
5313 ! Now put together the distribution terms to make complete distribution.
5314         termexp=term1+ak*term2
5315         termpre=sigc+ak*sig0i
5316 ! Contribution of the bending energy from this theta is just the -log of
5317 ! the sum of the contributions from the two lobes and the pre-exponential
5318 ! factor. Simple enough, isn't it?
5319         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5320 ! NOW the derivatives!!!
5321 ! 6/6/97 Take into account the deformation.
5322         E_theta=(delthec*sigcsq*term1 &
5323              +ak*delthe0*sig0inv*term2)/termexp
5324         E_tc=((sigtc+aktc*sig0i)/termpre &
5325             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5326              aktc*term2)/termexp)
5327       return
5328       end subroutine theteng
5329 #else
5330 !-----------------------------------------------------------------------------
5331       subroutine ebend(etheta)
5332 !
5333 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5334 ! angles gamma and its derivatives in consecutive thetas and gammas.
5335 ! ab initio-derived potentials from
5336 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5337 !
5338 !      implicit real*8 (a-h,o-z)
5339 !      include 'DIMENSIONS'
5340 !      include 'COMMON.LOCAL'
5341 !      include 'COMMON.GEO'
5342 !      include 'COMMON.INTERACT'
5343 !      include 'COMMON.DERIV'
5344 !      include 'COMMON.VAR'
5345 !      include 'COMMON.CHAIN'
5346 !      include 'COMMON.IOUNITS'
5347 !      include 'COMMON.NAMES'
5348 !      include 'COMMON.FFIELD'
5349 !      include 'COMMON.CONTROL'
5350       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5351       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5352       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5353       logical :: lprn=.false., lprn1=.false.
5354 !el local variables
5355       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5356       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5357       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
5358
5359       etheta=0.0D0
5360       do i=ithet_start,ithet_end
5361         if (itype(i-1).eq.ntyp1) cycle
5362         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
5363         if (iabs(itype(i+1)).eq.20) iblock=2
5364         if (iabs(itype(i+1)).ne.20) iblock=1
5365         dethetai=0.0d0
5366         dephii=0.0d0
5367         dephii1=0.0d0
5368         theti2=0.5d0*theta(i)
5369         ityp2=ithetyp((itype(i-1)))
5370         do k=1,nntheterm
5371           coskt(k)=dcos(k*theti2)
5372           sinkt(k)=dsin(k*theti2)
5373         enddo
5374         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5375 #ifdef OSF
5376           phii=phi(i)
5377           if (phii.ne.phii) phii=150.0
5378 #else
5379           phii=phi(i)
5380 #endif
5381           ityp1=ithetyp((itype(i-2)))
5382 ! propagation of chirality for glycine type
5383           do k=1,nsingle
5384             cosph1(k)=dcos(k*phii)
5385             sinph1(k)=dsin(k*phii)
5386           enddo
5387         else
5388           phii=0.0d0
5389           ityp1=ithetyp(itype(i-2))
5390           do k=1,nsingle
5391             cosph1(k)=0.0d0
5392             sinph1(k)=0.0d0
5393           enddo
5394         endif
5395         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5396 #ifdef OSF
5397           phii1=phi(i+1)
5398           if (phii1.ne.phii1) phii1=150.0
5399           phii1=pinorm(phii1)
5400 #else
5401           phii1=phi(i+1)
5402 #endif
5403           ityp3=ithetyp((itype(i)))
5404           do k=1,nsingle
5405             cosph2(k)=dcos(k*phii1)
5406             sinph2(k)=dsin(k*phii1)
5407           enddo
5408         else
5409           phii1=0.0d0
5410           ityp3=ithetyp(itype(i))
5411           do k=1,nsingle
5412             cosph2(k)=0.0d0
5413             sinph2(k)=0.0d0
5414           enddo
5415         endif
5416         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5417         do k=1,ndouble
5418           do l=1,k-1
5419             ccl=cosph1(l)*cosph2(k-l)
5420             ssl=sinph1(l)*sinph2(k-l)
5421             scl=sinph1(l)*cosph2(k-l)
5422             csl=cosph1(l)*sinph2(k-l)
5423             cosph1ph2(l,k)=ccl-ssl
5424             cosph1ph2(k,l)=ccl+ssl
5425             sinph1ph2(l,k)=scl+csl
5426             sinph1ph2(k,l)=scl-csl
5427           enddo
5428         enddo
5429         if (lprn) then
5430         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5431           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5432         write (iout,*) "coskt and sinkt"
5433         do k=1,nntheterm
5434           write (iout,*) k,coskt(k),sinkt(k)
5435         enddo
5436         endif
5437         do k=1,ntheterm
5438           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5439           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5440             *coskt(k)
5441           if (lprn) &
5442           write (iout,*) "k",k,&
5443            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5444            " ethetai",ethetai
5445         enddo
5446         if (lprn) then
5447         write (iout,*) "cosph and sinph"
5448         do k=1,nsingle
5449           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5450         enddo
5451         write (iout,*) "cosph1ph2 and sinph2ph2"
5452         do k=2,ndouble
5453           do l=1,k-1
5454             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5455                sinph1ph2(l,k),sinph1ph2(k,l)
5456           enddo
5457         enddo
5458         write(iout,*) "ethetai",ethetai
5459         endif
5460         do m=1,ntheterm2
5461           do k=1,nsingle
5462             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5463                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5464                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5465                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5466             ethetai=ethetai+sinkt(m)*aux
5467             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5468             dephii=dephii+k*sinkt(m)* &
5469                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5470                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5471             dephii1=dephii1+k*sinkt(m)* &
5472                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5473                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5474             if (lprn) &
5475             write (iout,*) "m",m," k",k," bbthet", &
5476                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5477                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5478                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5479                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5480           enddo
5481         enddo
5482         if (lprn) &
5483         write(iout,*) "ethetai",ethetai
5484         do m=1,ntheterm3
5485           do k=2,ndouble
5486             do l=1,k-1
5487               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5488                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5489                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5490                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5491               ethetai=ethetai+sinkt(m)*aux
5492               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5493               dephii=dephii+l*sinkt(m)* &
5494                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5495                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5496                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5497                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5498               dephii1=dephii1+(k-l)*sinkt(m)* &
5499                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5500                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5501                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5502                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5503               if (lprn) then
5504               write (iout,*) "m",m," k",k," l",l," ffthet",&
5505                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5506                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5507                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5508                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5509                   " ethetai",ethetai
5510               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5511                   cosph1ph2(k,l)*sinkt(m),&
5512                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5513               endif
5514             enddo
5515           enddo
5516         enddo
5517 10      continue
5518 !        lprn1=.true.
5519         if (lprn1) &
5520           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5521          i,theta(i)*rad2deg,phii*rad2deg,&
5522          phii1*rad2deg,ethetai
5523 !        lprn1=.false.
5524         etheta=etheta+ethetai
5525         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5526                                     'ebend',i,ethetai
5527         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5528         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5529         gloc(nphi+i-2,icg)=wang*dethetai
5530       enddo
5531       return
5532       end subroutine ebend
5533 #endif
5534 #ifdef CRYST_SC
5535 !-----------------------------------------------------------------------------
5536       subroutine esc(escloc)
5537 ! Calculate the local energy of a side chain and its derivatives in the
5538 ! corresponding virtual-bond valence angles THETA and the spherical angles
5539 ! ALPHA and OMEGA.
5540 !
5541       use comm_sccalc
5542 !      implicit real*8 (a-h,o-z)
5543 !      include 'DIMENSIONS'
5544 !      include 'COMMON.GEO'
5545 !      include 'COMMON.LOCAL'
5546 !      include 'COMMON.VAR'
5547 !      include 'COMMON.INTERACT'
5548 !      include 'COMMON.DERIV'
5549 !      include 'COMMON.CHAIN'
5550 !      include 'COMMON.IOUNITS'
5551 !      include 'COMMON.NAMES'
5552 !      include 'COMMON.FFIELD'
5553 !      include 'COMMON.CONTROL'
5554       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5555          ddersc0,ddummy,xtemp,temp
5556 !el      real(kind=8) :: time11,time12,time112,theti
5557       real(kind=8) :: escloc,delta
5558 !el      integer :: it,nlobit
5559 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5560 !el local variables
5561       integer :: i,k
5562       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5563        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5564       delta=0.02d0*pi
5565       escloc=0.0D0
5566 !     write (iout,'(a)') 'ESC'
5567       do i=loc_start,loc_end
5568         it=itype(i)
5569         if (it.eq.ntyp1) cycle
5570         if (it.eq.10) goto 1
5571         nlobit=nlob(iabs(it))
5572 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5573 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5574         theti=theta(i+1)-pipol
5575         x(1)=dtan(theti)
5576         x(2)=alph(i)
5577         x(3)=omeg(i)
5578
5579         if (x(2).gt.pi-delta) then
5580           xtemp(1)=x(1)
5581           xtemp(2)=pi-delta
5582           xtemp(3)=x(3)
5583           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5584           xtemp(2)=pi
5585           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5586           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5587               escloci,dersc(2))
5588           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5589               ddersc0(1),dersc(1))
5590           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5591               ddersc0(3),dersc(3))
5592           xtemp(2)=pi-delta
5593           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5594           xtemp(2)=pi
5595           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5596           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5597                   dersc0(2),esclocbi,dersc02)
5598           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5599                   dersc12,dersc01)
5600           call splinthet(x(2),0.5d0*delta,ss,ssd)
5601           dersc0(1)=dersc01
5602           dersc0(2)=dersc02
5603           dersc0(3)=0.0d0
5604           do k=1,3
5605             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5606           enddo
5607           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5608 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5609 !    &             esclocbi,ss,ssd
5610           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5611 !         escloci=esclocbi
5612 !         write (iout,*) escloci
5613         else if (x(2).lt.delta) then
5614           xtemp(1)=x(1)
5615           xtemp(2)=delta
5616           xtemp(3)=x(3)
5617           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5618           xtemp(2)=0.0d0
5619           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5620           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5621               escloci,dersc(2))
5622           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5623               ddersc0(1),dersc(1))
5624           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5625               ddersc0(3),dersc(3))
5626           xtemp(2)=delta
5627           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5628           xtemp(2)=0.0d0
5629           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5630           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5631                   dersc0(2),esclocbi,dersc02)
5632           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5633                   dersc12,dersc01)
5634           dersc0(1)=dersc01
5635           dersc0(2)=dersc02
5636           dersc0(3)=0.0d0
5637           call splinthet(x(2),0.5d0*delta,ss,ssd)
5638           do k=1,3
5639             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5640           enddo
5641           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5642 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5643 !    &             esclocbi,ss,ssd
5644           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5645 !         write (iout,*) escloci
5646         else
5647           call enesc(x,escloci,dersc,ddummy,.false.)
5648         endif
5649
5650         escloc=escloc+escloci
5651         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5652            'escloc',i,escloci
5653 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5654
5655         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5656          wscloc*dersc(1)
5657         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5658         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5659     1   continue
5660       enddo
5661       return
5662       end subroutine esc
5663 !-----------------------------------------------------------------------------
5664       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5665
5666       use comm_sccalc
5667 !      implicit real*8 (a-h,o-z)
5668 !      include 'DIMENSIONS'
5669 !      include 'COMMON.GEO'
5670 !      include 'COMMON.LOCAL'
5671 !      include 'COMMON.IOUNITS'
5672 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5673       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5674       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5675       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5676       real(kind=8) :: escloci
5677       logical :: mixed
5678 !el local variables
5679       integer :: j,iii,l,k !el,it,nlobit
5680       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5681 !el       time11,time12,time112
5682 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5683         escloc_i=0.0D0
5684         do j=1,3
5685           dersc(j)=0.0D0
5686           if (mixed) ddersc(j)=0.0d0
5687         enddo
5688         x3=x(3)
5689
5690 ! Because of periodicity of the dependence of the SC energy in omega we have
5691 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5692 ! To avoid underflows, first compute & store the exponents.
5693
5694         do iii=-1,1
5695
5696           x(3)=x3+iii*dwapi
5697
5698           do j=1,nlobit
5699             do k=1,3
5700               z(k)=x(k)-censc(k,j,it)
5701             enddo
5702             do k=1,3
5703               Axk=0.0D0
5704               do l=1,3
5705                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5706               enddo
5707               Ax(k,j,iii)=Axk
5708             enddo
5709             expfac=0.0D0
5710             do k=1,3
5711               expfac=expfac+Ax(k,j,iii)*z(k)
5712             enddo
5713             contr(j,iii)=expfac
5714           enddo ! j
5715
5716         enddo ! iii
5717
5718         x(3)=x3
5719 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5720 ! subsequent NaNs and INFs in energy calculation.
5721 ! Find the largest exponent
5722         emin=contr(1,-1)
5723         do iii=-1,1
5724           do j=1,nlobit
5725             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5726           enddo
5727         enddo
5728         emin=0.5D0*emin
5729 !d      print *,'it=',it,' emin=',emin
5730
5731 ! Compute the contribution to SC energy and derivatives
5732         do iii=-1,1
5733
5734           do j=1,nlobit
5735 #ifdef OSF
5736             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5737             if(adexp.ne.adexp) adexp=1.0
5738             expfac=dexp(adexp)
5739 #else
5740             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5741 #endif
5742 !d          print *,'j=',j,' expfac=',expfac
5743             escloc_i=escloc_i+expfac
5744             do k=1,3
5745               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5746             enddo
5747             if (mixed) then
5748               do k=1,3,2
5749                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5750                   +gaussc(k,2,j,it))*expfac
5751               enddo
5752             endif
5753           enddo
5754
5755         enddo ! iii
5756
5757         dersc(1)=dersc(1)/cos(theti)**2
5758         ddersc(1)=ddersc(1)/cos(theti)**2
5759         ddersc(3)=ddersc(3)
5760
5761         escloci=-(dlog(escloc_i)-emin)
5762         do j=1,3
5763           dersc(j)=dersc(j)/escloc_i
5764         enddo
5765         if (mixed) then
5766           do j=1,3,2
5767             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5768           enddo
5769         endif
5770       return
5771       end subroutine enesc
5772 !-----------------------------------------------------------------------------
5773       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5774
5775       use comm_sccalc
5776 !      implicit real*8 (a-h,o-z)
5777 !      include 'DIMENSIONS'
5778 !      include 'COMMON.GEO'
5779 !      include 'COMMON.LOCAL'
5780 !      include 'COMMON.IOUNITS'
5781 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5782       real(kind=8),dimension(3) :: x,z,dersc
5783       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5784       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5785       real(kind=8) :: escloci,dersc12,emin
5786       logical :: mixed
5787 !el local varables
5788       integer :: j,k,l !el,it,nlobit
5789       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5790
5791       escloc_i=0.0D0
5792
5793       do j=1,3
5794         dersc(j)=0.0D0
5795       enddo
5796
5797       do j=1,nlobit
5798         do k=1,2
5799           z(k)=x(k)-censc(k,j,it)
5800         enddo
5801         z(3)=dwapi
5802         do k=1,3
5803           Axk=0.0D0
5804           do l=1,3
5805             Axk=Axk+gaussc(l,k,j,it)*z(l)
5806           enddo
5807           Ax(k,j)=Axk
5808         enddo
5809         expfac=0.0D0
5810         do k=1,3
5811           expfac=expfac+Ax(k,j)*z(k)
5812         enddo
5813         contr(j)=expfac
5814       enddo ! j
5815
5816 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5817 ! subsequent NaNs and INFs in energy calculation.
5818 ! Find the largest exponent
5819       emin=contr(1)
5820       do j=1,nlobit
5821         if (emin.gt.contr(j)) emin=contr(j)
5822       enddo
5823       emin=0.5D0*emin
5824
5825 ! Compute the contribution to SC energy and derivatives
5826
5827       dersc12=0.0d0
5828       do j=1,nlobit
5829         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5830         escloc_i=escloc_i+expfac
5831         do k=1,2
5832           dersc(k)=dersc(k)+Ax(k,j)*expfac
5833         enddo
5834         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5835                   +gaussc(1,2,j,it))*expfac
5836         dersc(3)=0.0d0
5837       enddo
5838
5839       dersc(1)=dersc(1)/cos(theti)**2
5840       dersc12=dersc12/cos(theti)**2
5841       escloci=-(dlog(escloc_i)-emin)
5842       do j=1,2
5843         dersc(j)=dersc(j)/escloc_i
5844       enddo
5845       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5846       return
5847       end subroutine enesc_bound
5848 #else
5849 !-----------------------------------------------------------------------------
5850       subroutine esc(escloc)
5851 ! Calculate the local energy of a side chain and its derivatives in the
5852 ! corresponding virtual-bond valence angles THETA and the spherical angles
5853 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5854 ! added by Urszula Kozlowska. 07/11/2007
5855 !
5856       use comm_sccalc
5857 !      implicit real*8 (a-h,o-z)
5858 !      include 'DIMENSIONS'
5859 !      include 'COMMON.GEO'
5860 !      include 'COMMON.LOCAL'
5861 !      include 'COMMON.VAR'
5862 !      include 'COMMON.SCROT'
5863 !      include 'COMMON.INTERACT'
5864 !      include 'COMMON.DERIV'
5865 !      include 'COMMON.CHAIN'
5866 !      include 'COMMON.IOUNITS'
5867 !      include 'COMMON.NAMES'
5868 !      include 'COMMON.FFIELD'
5869 !      include 'COMMON.CONTROL'
5870 !      include 'COMMON.VECTORS'
5871       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5872       real(kind=8),dimension(65) :: x
5873       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5874          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5875       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5876       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5877          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5878 !el local variables
5879       integer :: i,j,k !el,it,nlobit
5880       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5881 !el      real(kind=8) :: time11,time12,time112,theti
5882 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5883       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5884                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5885                    sumene1x,sumene2x,sumene3x,sumene4x,&
5886                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5887                    cosfac2xx,sinfac2yy
5888 #ifdef DEBUG
5889       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5890                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5891                    de_dt_num
5892 #endif
5893 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5894
5895       delta=0.02d0*pi
5896       escloc=0.0D0
5897       do i=loc_start,loc_end
5898         if (itype(i).eq.ntyp1) cycle
5899         costtab(i+1) =dcos(theta(i+1))
5900         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5901         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5902         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5903         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5904         cosfac=dsqrt(cosfac2)
5905         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5906         sinfac=dsqrt(sinfac2)
5907         it=iabs(itype(i))
5908         if (it.eq.10) goto 1
5909 !
5910 !  Compute the axes of tghe local cartesian coordinates system; store in
5911 !   x_prime, y_prime and z_prime
5912 !
5913         do j=1,3
5914           x_prime(j) = 0.00
5915           y_prime(j) = 0.00
5916           z_prime(j) = 0.00
5917         enddo
5918 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5919 !     &   dc_norm(3,i+nres)
5920         do j = 1,3
5921           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5922           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5923         enddo
5924         do j = 1,3
5925           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5926         enddo
5927 !       write (2,*) "i",i
5928 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5929 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5930 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5931 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5932 !      & " xy",scalar(x_prime(1),y_prime(1)),
5933 !      & " xz",scalar(x_prime(1),z_prime(1)),
5934 !      & " yy",scalar(y_prime(1),y_prime(1)),
5935 !      & " yz",scalar(y_prime(1),z_prime(1)),
5936 !      & " zz",scalar(z_prime(1),z_prime(1))
5937 !
5938 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5939 ! to local coordinate system. Store in xx, yy, zz.
5940 !
5941         xx=0.0d0
5942         yy=0.0d0
5943         zz=0.0d0
5944         do j = 1,3
5945           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5946           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5947           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5948         enddo
5949
5950         xxtab(i)=xx
5951         yytab(i)=yy
5952         zztab(i)=zz
5953 !
5954 ! Compute the energy of the ith side cbain
5955 !
5956 !        write (2,*) "xx",xx," yy",yy," zz",zz
5957         it=iabs(itype(i))
5958         do j = 1,65
5959           x(j) = sc_parmin(j,it)
5960         enddo
5961 #ifdef CHECK_COORD
5962 !c diagnostics - remove later
5963         xx1 = dcos(alph(2))
5964         yy1 = dsin(alph(2))*dcos(omeg(2))
5965         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5966         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5967           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5968           xx1,yy1,zz1
5969 !,"  --- ", xx_w,yy_w,zz_w
5970 ! end diagnostics
5971 #endif
5972         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5973          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5974          + x(10)*yy*zz
5975         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5976          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5977          + x(20)*yy*zz
5978         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5979          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5980          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5981          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5982          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5983          +x(40)*xx*yy*zz
5984         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5985          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5986          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5987          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5988          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5989          +x(60)*xx*yy*zz
5990         dsc_i   = 0.743d0+x(61)
5991         dp2_i   = 1.9d0+x(62)
5992         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5993                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5994         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5995                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5996         s1=(1+x(63))/(0.1d0 + dscp1)
5997         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5998         s2=(1+x(65))/(0.1d0 + dscp2)
5999         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6000         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6001       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6002 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6003 !     &   sumene4,
6004 !     &   dscp1,dscp2,sumene
6005 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6006         escloc = escloc + sumene
6007 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6008 !     & ,zz,xx,yy
6009 !#define DEBUG
6010 #ifdef DEBUG
6011 !
6012 ! This section to check the numerical derivatives of the energy of ith side
6013 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6014 ! #define DEBUG in the code to turn it on.
6015 !
6016         write (2,*) "sumene               =",sumene
6017         aincr=1.0d-7
6018         xxsave=xx
6019         xx=xx+aincr
6020         write (2,*) xx,yy,zz
6021         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6022         de_dxx_num=(sumenep-sumene)/aincr
6023         xx=xxsave
6024         write (2,*) "xx+ sumene from enesc=",sumenep
6025         yysave=yy
6026         yy=yy+aincr
6027         write (2,*) xx,yy,zz
6028         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6029         de_dyy_num=(sumenep-sumene)/aincr
6030         yy=yysave
6031         write (2,*) "yy+ sumene from enesc=",sumenep
6032         zzsave=zz
6033         zz=zz+aincr
6034         write (2,*) xx,yy,zz
6035         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6036         de_dzz_num=(sumenep-sumene)/aincr
6037         zz=zzsave
6038         write (2,*) "zz+ sumene from enesc=",sumenep
6039         costsave=cost2tab(i+1)
6040         sintsave=sint2tab(i+1)
6041         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6042         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6043         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6044         de_dt_num=(sumenep-sumene)/aincr
6045         write (2,*) " t+ sumene from enesc=",sumenep
6046         cost2tab(i+1)=costsave
6047         sint2tab(i+1)=sintsave
6048 ! End of diagnostics section.
6049 #endif
6050 !
6051 ! Compute the gradient of esc
6052 !
6053 !        zz=zz*dsign(1.0,dfloat(itype(i)))
6054         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6055         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6056         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6057         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6058         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6059         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6060         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6061         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6062         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6063            *(pom_s1/dscp1+pom_s16*dscp1**4)
6064         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6065            *(pom_s2/dscp2+pom_s26*dscp2**4)
6066         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6067         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6068         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6069         +x(40)*yy*zz
6070         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6071         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6072         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6073         +x(60)*yy*zz
6074         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6075               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6076               +(pom1+pom2)*pom_dx
6077 #ifdef DEBUG
6078         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6079 #endif
6080 !
6081         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6082         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6083         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6084         +x(40)*xx*zz
6085         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6086         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6087         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6088         +x(59)*zz**2 +x(60)*xx*zz
6089         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6090               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6091               +(pom1-pom2)*pom_dy
6092 #ifdef DEBUG
6093         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6094 #endif
6095 !
6096         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6097         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6098         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6099         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6100         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6101         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6102         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6103         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6104 #ifdef DEBUG
6105         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6106 #endif
6107 !
6108         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6109         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6110         +pom1*pom_dt1+pom2*pom_dt2
6111 #ifdef DEBUG
6112         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6113 #endif
6114 !
6115 !
6116        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6117        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6118        cosfac2xx=cosfac2*xx
6119        sinfac2yy=sinfac2*yy
6120        do k = 1,3
6121          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6122             vbld_inv(i+1)
6123          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6124             vbld_inv(i)
6125          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6126          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6127 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6128 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6129 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6130 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6131          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6132          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6133          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6134          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6135          dZZ_Ci1(k)=0.0d0
6136          dZZ_Ci(k)=0.0d0
6137          do j=1,3
6138            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6139            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6140            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6141            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6142          enddo
6143
6144          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6145          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6146          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6147          (z_prime(k)-zz*dC_norm(k,i+nres))
6148 !
6149          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6150          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6151        enddo
6152
6153        do k=1,3
6154          dXX_Ctab(k,i)=dXX_Ci(k)
6155          dXX_C1tab(k,i)=dXX_Ci1(k)
6156          dYY_Ctab(k,i)=dYY_Ci(k)
6157          dYY_C1tab(k,i)=dYY_Ci1(k)
6158          dZZ_Ctab(k,i)=dZZ_Ci(k)
6159          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6160          dXX_XYZtab(k,i)=dXX_XYZ(k)
6161          dYY_XYZtab(k,i)=dYY_XYZ(k)
6162          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6163        enddo
6164
6165        do k = 1,3
6166 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6167 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6168 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6169 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6170 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6171 !     &    dt_dci(k)
6172 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6173 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6174          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6175           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6176          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6177           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6178          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6179           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6180        enddo
6181 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6182 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6183
6184 ! to check gradient call subroutine check_grad
6185
6186     1 continue
6187       enddo
6188       return
6189       end subroutine esc
6190 !-----------------------------------------------------------------------------
6191       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6192 !      implicit none
6193       real(kind=8),dimension(65) :: x
6194       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6195         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6196
6197       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6198         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6199         + x(10)*yy*zz
6200       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6201         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6202         + x(20)*yy*zz
6203       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6204         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6205         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6206         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6207         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6208         +x(40)*xx*yy*zz
6209       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6210         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6211         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6212         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6213         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6214         +x(60)*xx*yy*zz
6215       dsc_i   = 0.743d0+x(61)
6216       dp2_i   = 1.9d0+x(62)
6217       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6218                 *(xx*cost2+yy*sint2))
6219       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6220                 *(xx*cost2-yy*sint2))
6221       s1=(1+x(63))/(0.1d0 + dscp1)
6222       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6223       s2=(1+x(65))/(0.1d0 + dscp2)
6224       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6225       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6226        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6227       enesc=sumene
6228       return
6229       end function enesc
6230 #endif
6231 !-----------------------------------------------------------------------------
6232       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6233 !
6234 ! This procedure calculates two-body contact function g(rij) and its derivative:
6235 !
6236 !           eps0ij                                     !       x < -1
6237 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6238 !            0                                         !       x > 1
6239 !
6240 ! where x=(rij-r0ij)/delta
6241 !
6242 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6243 !
6244 !      implicit none
6245       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6246       real(kind=8) :: x,x2,x4,delta
6247 !     delta=0.02D0*r0ij
6248 !      delta=0.2D0*r0ij
6249       x=(rij-r0ij)/delta
6250       if (x.lt.-1.0D0) then
6251         fcont=eps0ij
6252         fprimcont=0.0D0
6253       else if (x.le.1.0D0) then
6254         x2=x*x
6255         x4=x2*x2
6256         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6257         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6258       else
6259         fcont=0.0D0
6260         fprimcont=0.0D0
6261       endif
6262       return
6263       end subroutine gcont
6264 !-----------------------------------------------------------------------------
6265       subroutine splinthet(theti,delta,ss,ssder)
6266 !      implicit real*8 (a-h,o-z)
6267 !      include 'DIMENSIONS'
6268 !      include 'COMMON.VAR'
6269 !      include 'COMMON.GEO'
6270       real(kind=8) :: theti,delta,ss,ssder
6271       real(kind=8) :: thetup,thetlow
6272       thetup=pi-delta
6273       thetlow=delta
6274       if (theti.gt.pipol) then
6275         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6276       else
6277         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6278         ssder=-ssder
6279       endif
6280       return
6281       end subroutine splinthet
6282 !-----------------------------------------------------------------------------
6283       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6284 !      implicit none
6285       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6286       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6287       a1=fprim0*delta/(f1-f0)
6288       a2=3.0d0-2.0d0*a1
6289       a3=a1-2.0d0
6290       ksi=(x-x0)/delta
6291       ksi2=ksi*ksi
6292       ksi3=ksi2*ksi
6293       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6294       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6295       return
6296       end subroutine spline1
6297 !-----------------------------------------------------------------------------
6298       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6299 !      implicit none
6300       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6301       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6302       ksi=(x-x0)/delta
6303       ksi2=ksi*ksi
6304       ksi3=ksi2*ksi
6305       a1=fprim0x*delta
6306       a2=3*(f1x-f0x)-2*fprim0x*delta
6307       a3=fprim0x*delta-2*(f1x-f0x)
6308       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6309       return
6310       end subroutine spline2
6311 !-----------------------------------------------------------------------------
6312 #ifdef CRYST_TOR
6313 !-----------------------------------------------------------------------------
6314       subroutine etor(etors,edihcnstr)
6315 !      implicit real*8 (a-h,o-z)
6316 !      include 'DIMENSIONS'
6317 !      include 'COMMON.VAR'
6318 !      include 'COMMON.GEO'
6319 !      include 'COMMON.LOCAL'
6320 !      include 'COMMON.TORSION'
6321 !      include 'COMMON.INTERACT'
6322 !      include 'COMMON.DERIV'
6323 !      include 'COMMON.CHAIN'
6324 !      include 'COMMON.NAMES'
6325 !      include 'COMMON.IOUNITS'
6326 !      include 'COMMON.FFIELD'
6327 !      include 'COMMON.TORCNSTR'
6328 !      include 'COMMON.CONTROL'
6329       real(kind=8) :: etors,edihcnstr
6330       logical :: lprn
6331 !el local variables
6332       integer :: i,j,
6333       real(kind=8) :: phii,fac,etors_ii
6334
6335 ! Set lprn=.true. for debugging
6336       lprn=.false.
6337 !      lprn=.true.
6338       etors=0.0D0
6339       do i=iphi_start,iphi_end
6340       etors_ii=0.0D0
6341         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
6342             .or. itype(i).eq.ntyp1) cycle
6343         itori=itortyp(itype(i-2))
6344         itori1=itortyp(itype(i-1))
6345         phii=phi(i)
6346         gloci=0.0D0
6347 ! Proline-Proline pair is a special case...
6348         if (itori.eq.3 .and. itori1.eq.3) then
6349           if (phii.gt.-dwapi3) then
6350             cosphi=dcos(3*phii)
6351             fac=1.0D0/(1.0D0-cosphi)
6352             etorsi=v1(1,3,3)*fac
6353             etorsi=etorsi+etorsi
6354             etors=etors+etorsi-v1(1,3,3)
6355             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6356             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6357           endif
6358           do j=1,3
6359             v1ij=v1(j+1,itori,itori1)
6360             v2ij=v2(j+1,itori,itori1)
6361             cosphi=dcos(j*phii)
6362             sinphi=dsin(j*phii)
6363             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6364             if (energy_dec) etors_ii=etors_ii+ &
6365                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6366             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6367           enddo
6368         else
6369           do j=1,nterm_old
6370             v1ij=v1(j,itori,itori1)
6371             v2ij=v2(j,itori,itori1)
6372             cosphi=dcos(j*phii)
6373             sinphi=dsin(j*phii)
6374             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6375             if (energy_dec) etors_ii=etors_ii+ &
6376                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6377             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6378           enddo
6379         endif
6380         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6381              'etor',i,etors_ii
6382         if (lprn) &
6383         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6384         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
6385         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6386         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6387 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6388       enddo
6389 ! 6/20/98 - dihedral angle constraints
6390       edihcnstr=0.0d0
6391       do i=1,ndih_constr
6392         itori=idih_constr(i)
6393         phii=phi(itori)
6394         difi=phii-phi0(i)
6395         if (difi.gt.drange(i)) then
6396           difi=difi-drange(i)
6397           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6398           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6399         else if (difi.lt.-drange(i)) then
6400           difi=difi+drange(i)
6401           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6402           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6403         endif
6404 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6405 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6406       enddo
6407 !      write (iout,*) 'edihcnstr',edihcnstr
6408       return
6409       end subroutine etor
6410 !-----------------------------------------------------------------------------
6411       subroutine etor_d(etors_d)
6412       real(kind=8) :: etors_d
6413       etors_d=0.0d0
6414       return
6415       end subroutine etor_d
6416 #else
6417 !-----------------------------------------------------------------------------
6418       subroutine etor(etors,edihcnstr)
6419 !      implicit real*8 (a-h,o-z)
6420 !      include 'DIMENSIONS'
6421 !      include 'COMMON.VAR'
6422 !      include 'COMMON.GEO'
6423 !      include 'COMMON.LOCAL'
6424 !      include 'COMMON.TORSION'
6425 !      include 'COMMON.INTERACT'
6426 !      include 'COMMON.DERIV'
6427 !      include 'COMMON.CHAIN'
6428 !      include 'COMMON.NAMES'
6429 !      include 'COMMON.IOUNITS'
6430 !      include 'COMMON.FFIELD'
6431 !      include 'COMMON.TORCNSTR'
6432 !      include 'COMMON.CONTROL'
6433       real(kind=8) :: etors,edihcnstr
6434       logical :: lprn
6435 !el local variables
6436       integer :: i,j,iblock,itori,itori1
6437       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6438                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6439 ! Set lprn=.true. for debugging
6440       lprn=.false.
6441 !     lprn=.true.
6442       etors=0.0D0
6443       do i=iphi_start,iphi_end
6444         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
6445              .or. itype(i-3).eq.ntyp1 &
6446              .or. itype(i).eq.ntyp1) cycle
6447         etors_ii=0.0D0
6448          if (iabs(itype(i)).eq.20) then
6449          iblock=2
6450          else
6451          iblock=1
6452          endif
6453         itori=itortyp(itype(i-2))
6454         itori1=itortyp(itype(i-1))
6455         phii=phi(i)
6456         gloci=0.0D0
6457 ! Regular cosine and sine terms
6458         do j=1,nterm(itori,itori1,iblock)
6459           v1ij=v1(j,itori,itori1,iblock)
6460           v2ij=v2(j,itori,itori1,iblock)
6461           cosphi=dcos(j*phii)
6462           sinphi=dsin(j*phii)
6463           etors=etors+v1ij*cosphi+v2ij*sinphi
6464           if (energy_dec) etors_ii=etors_ii+ &
6465                      v1ij*cosphi+v2ij*sinphi
6466           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6467         enddo
6468 ! Lorentz terms
6469 !                         v1
6470 !  E = SUM ----------------------------------- - v1
6471 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6472 !
6473         cosphi=dcos(0.5d0*phii)
6474         sinphi=dsin(0.5d0*phii)
6475         do j=1,nlor(itori,itori1,iblock)
6476           vl1ij=vlor1(j,itori,itori1)
6477           vl2ij=vlor2(j,itori,itori1)
6478           vl3ij=vlor3(j,itori,itori1)
6479           pom=vl2ij*cosphi+vl3ij*sinphi
6480           pom1=1.0d0/(pom*pom+1.0d0)
6481           etors=etors+vl1ij*pom1
6482           if (energy_dec) etors_ii=etors_ii+ &
6483                      vl1ij*pom1
6484           pom=-pom*pom1*pom1
6485           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6486         enddo
6487 ! Subtract the constant term
6488         etors=etors-v0(itori,itori1,iblock)
6489           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6490                'etor',i,etors_ii-v0(itori,itori1,iblock)
6491         if (lprn) &
6492         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6493         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
6494         (v1(j,itori,itori1,iblock),j=1,6),&
6495         (v2(j,itori,itori1,iblock),j=1,6)
6496         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6497 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6498       enddo
6499 ! 6/20/98 - dihedral angle constraints
6500       edihcnstr=0.0d0
6501 !      do i=1,ndih_constr
6502       do i=idihconstr_start,idihconstr_end
6503         itori=idih_constr(i)
6504         phii=phi(itori)
6505         difi=pinorm(phii-phi0(i))
6506         if (difi.gt.drange(i)) then
6507           difi=difi-drange(i)
6508           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6509           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6510         else if (difi.lt.-drange(i)) then
6511           difi=difi+drange(i)
6512           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6513           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6514         else
6515           difi=0.0
6516         endif
6517 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6518 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6519 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6520       enddo
6521 !d       write (iout,*) 'edihcnstr',edihcnstr
6522       return
6523       end subroutine etor
6524 !-----------------------------------------------------------------------------
6525       subroutine etor_d(etors_d)
6526 ! 6/23/01 Compute double torsional energy
6527 !      implicit real*8 (a-h,o-z)
6528 !      include 'DIMENSIONS'
6529 !      include 'COMMON.VAR'
6530 !      include 'COMMON.GEO'
6531 !      include 'COMMON.LOCAL'
6532 !      include 'COMMON.TORSION'
6533 !      include 'COMMON.INTERACT'
6534 !      include 'COMMON.DERIV'
6535 !      include 'COMMON.CHAIN'
6536 !      include 'COMMON.NAMES'
6537 !      include 'COMMON.IOUNITS'
6538 !      include 'COMMON.FFIELD'
6539 !      include 'COMMON.TORCNSTR'
6540       real(kind=8) :: etors_d,etors_d_ii
6541       logical :: lprn
6542 !el local variables
6543       integer :: i,j,k,l,itori,itori1,itori2,iblock
6544       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6545                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6546                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6547                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6548 ! Set lprn=.true. for debugging
6549       lprn=.false.
6550 !     lprn=.true.
6551       etors_d=0.0D0
6552 !      write(iout,*) "a tu??"
6553       do i=iphid_start,iphid_end
6554         etors_d_ii=0.0D0
6555         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
6556             .or. itype(i-3).eq.ntyp1 &
6557             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6558         itori=itortyp(itype(i-2))
6559         itori1=itortyp(itype(i-1))
6560         itori2=itortyp(itype(i))
6561         phii=phi(i)
6562         phii1=phi(i+1)
6563         gloci1=0.0D0
6564         gloci2=0.0D0
6565         iblock=1
6566         if (iabs(itype(i+1)).eq.20) iblock=2
6567
6568 ! Regular cosine and sine terms
6569         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6570           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6571           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6572           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6573           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6574           cosphi1=dcos(j*phii)
6575           sinphi1=dsin(j*phii)
6576           cosphi2=dcos(j*phii1)
6577           sinphi2=dsin(j*phii1)
6578           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6579            v2cij*cosphi2+v2sij*sinphi2
6580           if (energy_dec) etors_d_ii=etors_d_ii+ &
6581            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6582           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6583           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6584         enddo
6585         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6586           do l=1,k-1
6587             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6588             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6589             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6590             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6591             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6592             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6593             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6594             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6595             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6596               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6597             if (energy_dec) etors_d_ii=etors_d_ii+ &
6598               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6599               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6600             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6601               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6602             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6603               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6604           enddo
6605         enddo
6606         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6607                             'etor_d',i,etors_d_ii
6608         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6609         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6610       enddo
6611       return
6612       end subroutine etor_d
6613 #endif
6614 !-----------------------------------------------------------------------------
6615       subroutine eback_sc_corr(esccor)
6616 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6617 !        conformational states; temporarily implemented as differences
6618 !        between UNRES torsional potentials (dependent on three types of
6619 !        residues) and the torsional potentials dependent on all 20 types
6620 !        of residues computed from AM1  energy surfaces of terminally-blocked
6621 !        amino-acid residues.
6622 !      implicit real*8 (a-h,o-z)
6623 !      include 'DIMENSIONS'
6624 !      include 'COMMON.VAR'
6625 !      include 'COMMON.GEO'
6626 !      include 'COMMON.LOCAL'
6627 !      include 'COMMON.TORSION'
6628 !      include 'COMMON.SCCOR'
6629 !      include 'COMMON.INTERACT'
6630 !      include 'COMMON.DERIV'
6631 !      include 'COMMON.CHAIN'
6632 !      include 'COMMON.NAMES'
6633 !      include 'COMMON.IOUNITS'
6634 !      include 'COMMON.FFIELD'
6635 !      include 'COMMON.CONTROL'
6636       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6637                    cosphi,sinphi
6638       logical :: lprn
6639       integer :: i,interty,j,isccori,isccori1,intertyp
6640 ! Set lprn=.true. for debugging
6641       lprn=.false.
6642 !      lprn=.true.
6643 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6644       esccor=0.0D0
6645       do i=itau_start,itau_end
6646         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6647         esccor_ii=0.0D0
6648         isccori=isccortyp(itype(i-2))
6649         isccori1=isccortyp(itype(i-1))
6650
6651 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6652         phii=phi(i)
6653         do intertyp=1,3 !intertyp
6654          esccor_ii=0.0D0
6655 !c Added 09 May 2012 (Adasko)
6656 !c  Intertyp means interaction type of backbone mainchain correlation:
6657 !   1 = SC...Ca...Ca...Ca
6658 !   2 = Ca...Ca...Ca...SC
6659 !   3 = SC...Ca...Ca...SCi
6660         gloci=0.0D0
6661         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
6662             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
6663             (itype(i-1).eq.ntyp1))) &
6664           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
6665            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
6666            .or.(itype(i).eq.ntyp1))) &
6667           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
6668             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
6669             (itype(i-3).eq.ntyp1)))) cycle
6670         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6671         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
6672        cycle
6673        do j=1,nterm_sccor(isccori,isccori1)
6674           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6675           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6676           cosphi=dcos(j*tauangle(intertyp,i))
6677           sinphi=dsin(j*tauangle(intertyp,i))
6678           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6679           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6680           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6681         enddo
6682         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6683                                 'esccor',i,intertyp,esccor_ii
6684 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6685         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6686         if (lprn) &
6687         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6688         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
6689         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6690         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6691         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6692        enddo !intertyp
6693       enddo
6694
6695       return
6696       end subroutine eback_sc_corr
6697 !-----------------------------------------------------------------------------
6698       subroutine multibody(ecorr)
6699 ! This subroutine calculates multi-body contributions to energy following
6700 ! the idea of Skolnick et al. If side chains I and J make a contact and
6701 ! at the same time side chains I+1 and J+1 make a contact, an extra
6702 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6703 !      implicit real*8 (a-h,o-z)
6704 !      include 'DIMENSIONS'
6705 !      include 'COMMON.IOUNITS'
6706 !      include 'COMMON.DERIV'
6707 !      include 'COMMON.INTERACT'
6708 !      include 'COMMON.CONTACTS'
6709       real(kind=8),dimension(3) :: gx,gx1
6710       logical :: lprn
6711       real(kind=8) :: ecorr
6712       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6713 ! Set lprn=.true. for debugging
6714       lprn=.false.
6715
6716       if (lprn) then
6717         write (iout,'(a)') 'Contact function values:'
6718         do i=nnt,nct-2
6719           write (iout,'(i2,20(1x,i2,f10.5))') &
6720               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6721         enddo
6722       endif
6723       ecorr=0.0D0
6724
6725 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6726 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6727       do i=nnt,nct
6728         do j=1,3
6729           gradcorr(j,i)=0.0D0
6730           gradxorr(j,i)=0.0D0
6731         enddo
6732       enddo
6733       do i=nnt,nct-2
6734
6735         DO ISHIFT = 3,4
6736
6737         i1=i+ishift
6738         num_conti=num_cont(i)
6739         num_conti1=num_cont(i1)
6740         do jj=1,num_conti
6741           j=jcont(jj,i)
6742           do kk=1,num_conti1
6743             j1=jcont(kk,i1)
6744             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6745 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6746 !d   &                   ' ishift=',ishift
6747 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6748 ! The system gains extra energy.
6749               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6750             endif   ! j1==j+-ishift
6751           enddo     ! kk
6752         enddo       ! jj
6753
6754         ENDDO ! ISHIFT
6755
6756       enddo         ! i
6757       return
6758       end subroutine multibody
6759 !-----------------------------------------------------------------------------
6760       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6761 !      implicit real*8 (a-h,o-z)
6762 !      include 'DIMENSIONS'
6763 !      include 'COMMON.IOUNITS'
6764 !      include 'COMMON.DERIV'
6765 !      include 'COMMON.INTERACT'
6766 !      include 'COMMON.CONTACTS'
6767       real(kind=8),dimension(3) :: gx,gx1
6768       logical :: lprn
6769       integer :: i,j,k,l,jj,kk,m,ll
6770       real(kind=8) :: eij,ekl
6771       lprn=.false.
6772       eij=facont(jj,i)
6773       ekl=facont(kk,k)
6774 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6775 ! Calculate the multi-body contribution to energy.
6776 ! Calculate multi-body contributions to the gradient.
6777 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6778 !d   & k,l,(gacont(m,kk,k),m=1,3)
6779       do m=1,3
6780         gx(m) =ekl*gacont(m,jj,i)
6781         gx1(m)=eij*gacont(m,kk,k)
6782         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6783         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6784         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6785         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6786       enddo
6787       do m=i,j-1
6788         do ll=1,3
6789           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6790         enddo
6791       enddo
6792       do m=k,l-1
6793         do ll=1,3
6794           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6795         enddo
6796       enddo
6797       esccorr=-eij*ekl
6798       return
6799       end function esccorr
6800 !-----------------------------------------------------------------------------
6801       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6802 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6803 !      implicit real*8 (a-h,o-z)
6804 !      include 'DIMENSIONS'
6805 !      include 'COMMON.IOUNITS'
6806 #ifdef MPI
6807       include "mpif.h"
6808 !      integer :: maxconts !max_cont=maxconts  =nres/4
6809       integer,parameter :: max_dim=26
6810       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6811       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6812 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6813 !el      common /przechowalnia/ zapas
6814       integer :: status(MPI_STATUS_SIZE)
6815       integer,dimension((nres/4)*2) :: req !maxconts*2
6816       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6817 #endif
6818 !      include 'COMMON.SETUP'
6819 !      include 'COMMON.FFIELD'
6820 !      include 'COMMON.DERIV'
6821 !      include 'COMMON.INTERACT'
6822 !      include 'COMMON.CONTACTS'
6823 !      include 'COMMON.CONTROL'
6824 !      include 'COMMON.LOCAL'
6825       real(kind=8),dimension(3) :: gx,gx1
6826       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6827       logical :: lprn,ldone
6828 !el local variables
6829       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6830               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6831
6832 ! Set lprn=.true. for debugging
6833       lprn=.false.
6834 #ifdef MPI
6835 !      maxconts=nres/4
6836       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6837       n_corr=0
6838       n_corr1=0
6839       if (nfgtasks.le.1) goto 30
6840       if (lprn) then
6841         write (iout,'(a)') 'Contact function values before RECEIVE:'
6842         do i=nnt,nct-2
6843           write (iout,'(2i3,50(1x,i2,f5.2))') &
6844           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6845           j=1,num_cont_hb(i))
6846         enddo
6847       endif
6848       call flush(iout)
6849       do i=1,ntask_cont_from
6850         ncont_recv(i)=0
6851       enddo
6852       do i=1,ntask_cont_to
6853         ncont_sent(i)=0
6854       enddo
6855 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6856 !     & ntask_cont_to
6857 ! Make the list of contacts to send to send to other procesors
6858 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6859 !      call flush(iout)
6860       do i=iturn3_start,iturn3_end
6861 !        write (iout,*) "make contact list turn3",i," num_cont",
6862 !     &    num_cont_hb(i)
6863         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6864       enddo
6865       do i=iturn4_start,iturn4_end
6866 !        write (iout,*) "make contact list turn4",i," num_cont",
6867 !     &   num_cont_hb(i)
6868         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6869       enddo
6870       do ii=1,nat_sent
6871         i=iat_sent(ii)
6872 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6873 !     &    num_cont_hb(i)
6874         do j=1,num_cont_hb(i)
6875         do k=1,4
6876           jjc=jcont_hb(j,i)
6877           iproc=iint_sent_local(k,jjc,ii)
6878 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6879           if (iproc.gt.0) then
6880             ncont_sent(iproc)=ncont_sent(iproc)+1
6881             nn=ncont_sent(iproc)
6882             zapas(1,nn,iproc)=i
6883             zapas(2,nn,iproc)=jjc
6884             zapas(3,nn,iproc)=facont_hb(j,i)
6885             zapas(4,nn,iproc)=ees0p(j,i)
6886             zapas(5,nn,iproc)=ees0m(j,i)
6887             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6888             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6889             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6890             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6891             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6892             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6893             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6894             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6895             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6896             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6897             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6898             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6899             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6900             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6901             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6902             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6903             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6904             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6905             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6906             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6907             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6908           endif
6909         enddo
6910         enddo
6911       enddo
6912       if (lprn) then
6913       write (iout,*) &
6914         "Numbers of contacts to be sent to other processors",&
6915         (ncont_sent(i),i=1,ntask_cont_to)
6916       write (iout,*) "Contacts sent"
6917       do ii=1,ntask_cont_to
6918         nn=ncont_sent(ii)
6919         iproc=itask_cont_to(ii)
6920         write (iout,*) nn," contacts to processor",iproc,&
6921          " of CONT_TO_COMM group"
6922         do i=1,nn
6923           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6924         enddo
6925       enddo
6926       call flush(iout)
6927       endif
6928       CorrelType=477
6929       CorrelID=fg_rank+1
6930       CorrelType1=478
6931       CorrelID1=nfgtasks+fg_rank+1
6932       ireq=0
6933 ! Receive the numbers of needed contacts from other processors
6934       do ii=1,ntask_cont_from
6935         iproc=itask_cont_from(ii)
6936         ireq=ireq+1
6937         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6938           FG_COMM,req(ireq),IERR)
6939       enddo
6940 !      write (iout,*) "IRECV ended"
6941 !      call flush(iout)
6942 ! Send the number of contacts needed by other processors
6943       do ii=1,ntask_cont_to
6944         iproc=itask_cont_to(ii)
6945         ireq=ireq+1
6946         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6947           FG_COMM,req(ireq),IERR)
6948       enddo
6949 !      write (iout,*) "ISEND ended"
6950 !      write (iout,*) "number of requests (nn)",ireq
6951       call flush(iout)
6952       if (ireq.gt.0) &
6953         call MPI_Waitall(ireq,req,status_array,ierr)
6954 !      write (iout,*)
6955 !     &  "Numbers of contacts to be received from other processors",
6956 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6957 !      call flush(iout)
6958 ! Receive contacts
6959       ireq=0
6960       do ii=1,ntask_cont_from
6961         iproc=itask_cont_from(ii)
6962         nn=ncont_recv(ii)
6963 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6964 !     &   " of CONT_TO_COMM group"
6965         call flush(iout)
6966         if (nn.gt.0) then
6967           ireq=ireq+1
6968           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6969           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6970 !          write (iout,*) "ireq,req",ireq,req(ireq)
6971         endif
6972       enddo
6973 ! Send the contacts to processors that need them
6974       do ii=1,ntask_cont_to
6975         iproc=itask_cont_to(ii)
6976         nn=ncont_sent(ii)
6977 !        write (iout,*) nn," contacts to processor",iproc,
6978 !     &   " of CONT_TO_COMM group"
6979         if (nn.gt.0) then
6980           ireq=ireq+1
6981           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6982             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6983 !          write (iout,*) "ireq,req",ireq,req(ireq)
6984 !          do i=1,nn
6985 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6986 !          enddo
6987         endif
6988       enddo
6989 !      write (iout,*) "number of requests (contacts)",ireq
6990 !      write (iout,*) "req",(req(i),i=1,4)
6991 !      call flush(iout)
6992       if (ireq.gt.0) &
6993        call MPI_Waitall(ireq,req,status_array,ierr)
6994       do iii=1,ntask_cont_from
6995         iproc=itask_cont_from(iii)
6996         nn=ncont_recv(iii)
6997         if (lprn) then
6998         write (iout,*) "Received",nn," contacts from processor",iproc,&
6999          " of CONT_FROM_COMM group"
7000         call flush(iout)
7001         do i=1,nn
7002           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7003         enddo
7004         call flush(iout)
7005         endif
7006         do i=1,nn
7007           ii=zapas_recv(1,i,iii)
7008 ! Flag the received contacts to prevent double-counting
7009           jj=-zapas_recv(2,i,iii)
7010 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7011 !          call flush(iout)
7012           nnn=num_cont_hb(ii)+1
7013           num_cont_hb(ii)=nnn
7014           jcont_hb(nnn,ii)=jj
7015           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7016           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7017           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7018           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7019           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7020           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7021           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7022           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7023           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7024           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7025           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7026           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7027           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7028           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7029           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7030           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7031           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7032           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7033           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7034           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7035           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7036           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7037           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7038           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7039         enddo
7040       enddo
7041       call flush(iout)
7042       if (lprn) then
7043         write (iout,'(a)') 'Contact function values after receive:'
7044         do i=nnt,nct-2
7045           write (iout,'(2i3,50(1x,i3,f5.2))') &
7046           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7047           j=1,num_cont_hb(i))
7048         enddo
7049         call flush(iout)
7050       endif
7051    30 continue
7052 #endif
7053       if (lprn) then
7054         write (iout,'(a)') 'Contact function values:'
7055         do i=nnt,nct-2
7056           write (iout,'(2i3,50(1x,i3,f5.2))') &
7057           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7058           j=1,num_cont_hb(i))
7059         enddo
7060       endif
7061       ecorr=0.0D0
7062
7063 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7064 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7065 ! Remove the loop below after debugging !!!
7066       do i=nnt,nct
7067         do j=1,3
7068           gradcorr(j,i)=0.0D0
7069           gradxorr(j,i)=0.0D0
7070         enddo
7071       enddo
7072 ! Calculate the local-electrostatic correlation terms
7073       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7074         i1=i+1
7075         num_conti=num_cont_hb(i)
7076         num_conti1=num_cont_hb(i+1)
7077         do jj=1,num_conti
7078           j=jcont_hb(jj,i)
7079           jp=iabs(j)
7080           do kk=1,num_conti1
7081             j1=jcont_hb(kk,i1)
7082             jp1=iabs(j1)
7083 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7084 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7085             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7086                 .or. j.lt.0 .and. j1.gt.0) .and. &
7087                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7088 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7089 ! The system gains extra energy.
7090               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7091               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7092                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7093               n_corr=n_corr+1
7094             else if (j1.eq.j) then
7095 ! Contacts I-J and I-(J+1) occur simultaneously.
7096 ! The system loses extra energy.
7097 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7098             endif
7099           enddo ! kk
7100           do kk=1,num_conti
7101             j1=jcont_hb(kk,i)
7102 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7103 !    &         ' jj=',jj,' kk=',kk
7104             if (j1.eq.j+1) then
7105 ! Contacts I-J and (I+1)-J occur simultaneously.
7106 ! The system loses extra energy.
7107 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7108             endif ! j1==j+1
7109           enddo ! kk
7110         enddo ! jj
7111       enddo ! i
7112       return
7113       end subroutine multibody_hb
7114 !-----------------------------------------------------------------------------
7115       subroutine add_hb_contact(ii,jj,itask)
7116 !      implicit real*8 (a-h,o-z)
7117 !      include "DIMENSIONS"
7118 !      include "COMMON.IOUNITS"
7119 !      include "COMMON.CONTACTS"
7120 !      integer,parameter :: maxconts=nres/4
7121       integer,parameter :: max_dim=26
7122       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7123 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7124 !      common /przechowalnia/ zapas
7125       integer :: i,j,ii,jj,iproc,nn,jjc
7126       integer,dimension(4) :: itask
7127 !      write (iout,*) "itask",itask
7128       do i=1,2
7129         iproc=itask(i)
7130         if (iproc.gt.0) then
7131           do j=1,num_cont_hb(ii)
7132             jjc=jcont_hb(j,ii)
7133 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7134             if (jjc.eq.jj) then
7135               ncont_sent(iproc)=ncont_sent(iproc)+1
7136               nn=ncont_sent(iproc)
7137               zapas(1,nn,iproc)=ii
7138               zapas(2,nn,iproc)=jjc
7139               zapas(3,nn,iproc)=facont_hb(j,ii)
7140               zapas(4,nn,iproc)=ees0p(j,ii)
7141               zapas(5,nn,iproc)=ees0m(j,ii)
7142               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7143               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7144               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7145               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7146               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7147               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7148               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7149               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7150               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7151               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7152               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7153               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7154               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7155               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7156               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7157               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7158               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7159               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7160               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7161               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7162               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7163               exit
7164             endif
7165           enddo
7166         endif
7167       enddo
7168       return
7169       end subroutine add_hb_contact
7170 !-----------------------------------------------------------------------------
7171       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7172 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7173 !      implicit real*8 (a-h,o-z)
7174 !      include 'DIMENSIONS'
7175 !      include 'COMMON.IOUNITS'
7176       integer,parameter :: max_dim=70
7177 #ifdef MPI
7178       include "mpif.h"
7179 !      integer :: maxconts !max_cont=maxconts=nres/4
7180       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7181       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7182 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7183 !      common /przechowalnia/ zapas
7184       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7185         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7186         ierr,iii,nnn
7187 #endif
7188 !      include 'COMMON.SETUP'
7189 !      include 'COMMON.FFIELD'
7190 !      include 'COMMON.DERIV'
7191 !      include 'COMMON.LOCAL'
7192 !      include 'COMMON.INTERACT'
7193 !      include 'COMMON.CONTACTS'
7194 !      include 'COMMON.CHAIN'
7195 !      include 'COMMON.CONTROL'
7196       real(kind=8),dimension(3) :: gx,gx1
7197       integer,dimension(nres) :: num_cont_hb_old
7198       logical :: lprn,ldone
7199 !EL      double precision eello4,eello5,eelo6,eello_turn6
7200 !EL      external eello4,eello5,eello6,eello_turn6
7201 !el local variables
7202       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7203               j1,jp1,i1,num_conti1
7204       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7205       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7206
7207 ! Set lprn=.true. for debugging
7208       lprn=.false.
7209       eturn6=0.0d0
7210 #ifdef MPI
7211 !      maxconts=nres/4
7212       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7213       do i=1,nres
7214         num_cont_hb_old(i)=num_cont_hb(i)
7215       enddo
7216       n_corr=0
7217       n_corr1=0
7218       if (nfgtasks.le.1) goto 30
7219       if (lprn) then
7220         write (iout,'(a)') 'Contact function values before RECEIVE:'
7221         do i=nnt,nct-2
7222           write (iout,'(2i3,50(1x,i2,f5.2))') &
7223           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7224           j=1,num_cont_hb(i))
7225         enddo
7226       endif
7227       call flush(iout)
7228       do i=1,ntask_cont_from
7229         ncont_recv(i)=0
7230       enddo
7231       do i=1,ntask_cont_to
7232         ncont_sent(i)=0
7233       enddo
7234 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7235 !     & ntask_cont_to
7236 ! Make the list of contacts to send to send to other procesors
7237       do i=iturn3_start,iturn3_end
7238 !        write (iout,*) "make contact list turn3",i," num_cont",
7239 !     &    num_cont_hb(i)
7240         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7241       enddo
7242       do i=iturn4_start,iturn4_end
7243 !        write (iout,*) "make contact list turn4",i," num_cont",
7244 !     &   num_cont_hb(i)
7245         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7246       enddo
7247       do ii=1,nat_sent
7248         i=iat_sent(ii)
7249 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7250 !     &    num_cont_hb(i)
7251         do j=1,num_cont_hb(i)
7252         do k=1,4
7253           jjc=jcont_hb(j,i)
7254           iproc=iint_sent_local(k,jjc,ii)
7255 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7256           if (iproc.ne.0) then
7257             ncont_sent(iproc)=ncont_sent(iproc)+1
7258             nn=ncont_sent(iproc)
7259             zapas(1,nn,iproc)=i
7260             zapas(2,nn,iproc)=jjc
7261             zapas(3,nn,iproc)=d_cont(j,i)
7262             ind=3
7263             do kk=1,3
7264               ind=ind+1
7265               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7266             enddo
7267             do kk=1,2
7268               do ll=1,2
7269                 ind=ind+1
7270                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7271               enddo
7272             enddo
7273             do jj=1,5
7274               do kk=1,3
7275                 do ll=1,2
7276                   do mm=1,2
7277                     ind=ind+1
7278                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7279                   enddo
7280                 enddo
7281               enddo
7282             enddo
7283           endif
7284         enddo
7285         enddo
7286       enddo
7287       if (lprn) then
7288       write (iout,*) &
7289         "Numbers of contacts to be sent to other processors",&
7290         (ncont_sent(i),i=1,ntask_cont_to)
7291       write (iout,*) "Contacts sent"
7292       do ii=1,ntask_cont_to
7293         nn=ncont_sent(ii)
7294         iproc=itask_cont_to(ii)
7295         write (iout,*) nn," contacts to processor",iproc,&
7296          " of CONT_TO_COMM group"
7297         do i=1,nn
7298           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7299         enddo
7300       enddo
7301       call flush(iout)
7302       endif
7303       CorrelType=477
7304       CorrelID=fg_rank+1
7305       CorrelType1=478
7306       CorrelID1=nfgtasks+fg_rank+1
7307       ireq=0
7308 ! Receive the numbers of needed contacts from other processors
7309       do ii=1,ntask_cont_from
7310         iproc=itask_cont_from(ii)
7311         ireq=ireq+1
7312         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7313           FG_COMM,req(ireq),IERR)
7314       enddo
7315 !      write (iout,*) "IRECV ended"
7316 !      call flush(iout)
7317 ! Send the number of contacts needed by other processors
7318       do ii=1,ntask_cont_to
7319         iproc=itask_cont_to(ii)
7320         ireq=ireq+1
7321         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7322           FG_COMM,req(ireq),IERR)
7323       enddo
7324 !      write (iout,*) "ISEND ended"
7325 !      write (iout,*) "number of requests (nn)",ireq
7326       call flush(iout)
7327       if (ireq.gt.0) &
7328         call MPI_Waitall(ireq,req,status_array,ierr)
7329 !      write (iout,*)
7330 !     &  "Numbers of contacts to be received from other processors",
7331 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7332 !      call flush(iout)
7333 ! Receive contacts
7334       ireq=0
7335       do ii=1,ntask_cont_from
7336         iproc=itask_cont_from(ii)
7337         nn=ncont_recv(ii)
7338 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7339 !     &   " of CONT_TO_COMM group"
7340         call flush(iout)
7341         if (nn.gt.0) then
7342           ireq=ireq+1
7343           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7344           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7345 !          write (iout,*) "ireq,req",ireq,req(ireq)
7346         endif
7347       enddo
7348 ! Send the contacts to processors that need them
7349       do ii=1,ntask_cont_to
7350         iproc=itask_cont_to(ii)
7351         nn=ncont_sent(ii)
7352 !        write (iout,*) nn," contacts to processor",iproc,
7353 !     &   " of CONT_TO_COMM group"
7354         if (nn.gt.0) then
7355           ireq=ireq+1
7356           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7357             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7358 !          write (iout,*) "ireq,req",ireq,req(ireq)
7359 !          do i=1,nn
7360 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7361 !          enddo
7362         endif
7363       enddo
7364 !      write (iout,*) "number of requests (contacts)",ireq
7365 !      write (iout,*) "req",(req(i),i=1,4)
7366 !      call flush(iout)
7367       if (ireq.gt.0) &
7368        call MPI_Waitall(ireq,req,status_array,ierr)
7369       do iii=1,ntask_cont_from
7370         iproc=itask_cont_from(iii)
7371         nn=ncont_recv(iii)
7372         if (lprn) then
7373         write (iout,*) "Received",nn," contacts from processor",iproc,&
7374          " of CONT_FROM_COMM group"
7375         call flush(iout)
7376         do i=1,nn
7377           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7378         enddo
7379         call flush(iout)
7380         endif
7381         do i=1,nn
7382           ii=zapas_recv(1,i,iii)
7383 ! Flag the received contacts to prevent double-counting
7384           jj=-zapas_recv(2,i,iii)
7385 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7386 !          call flush(iout)
7387           nnn=num_cont_hb(ii)+1
7388           num_cont_hb(ii)=nnn
7389           jcont_hb(nnn,ii)=jj
7390           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7391           ind=3
7392           do kk=1,3
7393             ind=ind+1
7394             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7395           enddo
7396           do kk=1,2
7397             do ll=1,2
7398               ind=ind+1
7399               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7400             enddo
7401           enddo
7402           do jj=1,5
7403             do kk=1,3
7404               do ll=1,2
7405                 do mm=1,2
7406                   ind=ind+1
7407                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7408                 enddo
7409               enddo
7410             enddo
7411           enddo
7412         enddo
7413       enddo
7414       call flush(iout)
7415       if (lprn) then
7416         write (iout,'(a)') 'Contact function values after receive:'
7417         do i=nnt,nct-2
7418           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7419           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7420           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7421         enddo
7422         call flush(iout)
7423       endif
7424    30 continue
7425 #endif
7426       if (lprn) then
7427         write (iout,'(a)') 'Contact function values:'
7428         do i=nnt,nct-2
7429           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7430           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7431           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7432         enddo
7433       endif
7434       ecorr=0.0D0
7435       ecorr5=0.0d0
7436       ecorr6=0.0d0
7437
7438 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7439 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7440 ! Remove the loop below after debugging !!!
7441       do i=nnt,nct
7442         do j=1,3
7443           gradcorr(j,i)=0.0D0
7444           gradxorr(j,i)=0.0D0
7445         enddo
7446       enddo
7447 ! Calculate the dipole-dipole interaction energies
7448       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7449       do i=iatel_s,iatel_e+1
7450         num_conti=num_cont_hb(i)
7451         do jj=1,num_conti
7452           j=jcont_hb(jj,i)
7453 #ifdef MOMENT
7454           call dipole(i,j,jj)
7455 #endif
7456         enddo
7457       enddo
7458       endif
7459 ! Calculate the local-electrostatic correlation terms
7460 !                write (iout,*) "gradcorr5 in eello5 before loop"
7461 !                do iii=1,nres
7462 !                  write (iout,'(i5,3f10.5)')
7463 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7464 !                enddo
7465       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7466 !        write (iout,*) "corr loop i",i
7467         i1=i+1
7468         num_conti=num_cont_hb(i)
7469         num_conti1=num_cont_hb(i+1)
7470         do jj=1,num_conti
7471           j=jcont_hb(jj,i)
7472           jp=iabs(j)
7473           do kk=1,num_conti1
7474             j1=jcont_hb(kk,i1)
7475             jp1=iabs(j1)
7476 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7477 !     &         ' jj=',jj,' kk=',kk
7478 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7479             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7480                 .or. j.lt.0 .and. j1.gt.0) .and. &
7481                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7482 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7483 ! The system gains extra energy.
7484               n_corr=n_corr+1
7485               sqd1=dsqrt(d_cont(jj,i))
7486               sqd2=dsqrt(d_cont(kk,i1))
7487               sred_geom = sqd1*sqd2
7488               IF (sred_geom.lt.cutoff_corr) THEN
7489                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7490                   ekont,fprimcont)
7491 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7492 !d     &         ' jj=',jj,' kk=',kk
7493                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7494                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7495                 do l=1,3
7496                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7497                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7498                 enddo
7499                 n_corr1=n_corr1+1
7500 !d               write (iout,*) 'sred_geom=',sred_geom,
7501 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7502 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7503 !d               write (iout,*) "g_contij",g_contij
7504 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7505 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7506                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7507                 if (wcorr4.gt.0.0d0) &
7508                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7509                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7510                        write (iout,'(a6,4i5,0pf7.3)') &
7511                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7512 !                write (iout,*) "gradcorr5 before eello5"
7513 !                do iii=1,nres
7514 !                  write (iout,'(i5,3f10.5)')
7515 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7516 !                enddo
7517                 if (wcorr5.gt.0.0d0) &
7518                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7519 !                write (iout,*) "gradcorr5 after eello5"
7520 !                do iii=1,nres
7521 !                  write (iout,'(i5,3f10.5)')
7522 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7523 !                enddo
7524                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7525                        write (iout,'(a6,4i5,0pf7.3)') &
7526                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7527 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7528 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7529                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7530                      .or. wturn6.eq.0.0d0))then
7531 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7532                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7533                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7534                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7535 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7536 !d     &            'ecorr6=',ecorr6
7537 !d                write (iout,'(4e15.5)') sred_geom,
7538 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7539 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7540 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7541                 else if (wturn6.gt.0.0d0 &
7542                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7543 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7544                   eturn6=eturn6+eello_turn6(i,jj,kk)
7545                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7546                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7547 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7548                 endif
7549               ENDIF
7550 1111          continue
7551             endif
7552           enddo ! kk
7553         enddo ! jj
7554       enddo ! i
7555       do i=1,nres
7556         num_cont_hb(i)=num_cont_hb_old(i)
7557       enddo
7558 !                write (iout,*) "gradcorr5 in eello5"
7559 !                do iii=1,nres
7560 !                  write (iout,'(i5,3f10.5)')
7561 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7562 !                enddo
7563       return
7564       end subroutine multibody_eello
7565 !-----------------------------------------------------------------------------
7566       subroutine add_hb_contact_eello(ii,jj,itask)
7567 !      implicit real*8 (a-h,o-z)
7568 !      include "DIMENSIONS"
7569 !      include "COMMON.IOUNITS"
7570 !      include "COMMON.CONTACTS"
7571 !      integer,parameter :: maxconts=nres/4
7572       integer,parameter :: max_dim=70
7573       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7574 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7575 !      common /przechowalnia/ zapas
7576
7577       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7578       integer,dimension(4) ::itask
7579 !      write (iout,*) "itask",itask
7580       do i=1,2
7581         iproc=itask(i)
7582         if (iproc.gt.0) then
7583           do j=1,num_cont_hb(ii)
7584             jjc=jcont_hb(j,ii)
7585 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7586             if (jjc.eq.jj) then
7587               ncont_sent(iproc)=ncont_sent(iproc)+1
7588               nn=ncont_sent(iproc)
7589               zapas(1,nn,iproc)=ii
7590               zapas(2,nn,iproc)=jjc
7591               zapas(3,nn,iproc)=d_cont(j,ii)
7592               ind=3
7593               do kk=1,3
7594                 ind=ind+1
7595                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7596               enddo
7597               do kk=1,2
7598                 do ll=1,2
7599                   ind=ind+1
7600                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7601                 enddo
7602               enddo
7603               do jj=1,5
7604                 do kk=1,3
7605                   do ll=1,2
7606                     do mm=1,2
7607                       ind=ind+1
7608                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7609                     enddo
7610                   enddo
7611                 enddo
7612               enddo
7613               exit
7614             endif
7615           enddo
7616         endif
7617       enddo
7618       return
7619       end subroutine add_hb_contact_eello
7620 !-----------------------------------------------------------------------------
7621       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7622 !      implicit real*8 (a-h,o-z)
7623 !      include 'DIMENSIONS'
7624 !      include 'COMMON.IOUNITS'
7625 !      include 'COMMON.DERIV'
7626 !      include 'COMMON.INTERACT'
7627 !      include 'COMMON.CONTACTS'
7628       real(kind=8),dimension(3) :: gx,gx1
7629       logical :: lprn
7630 !el local variables
7631       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7632       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7633                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7634                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7635                    rlocshield
7636
7637       lprn=.false.
7638       eij=facont_hb(jj,i)
7639       ekl=facont_hb(kk,k)
7640       ees0pij=ees0p(jj,i)
7641       ees0pkl=ees0p(kk,k)
7642       ees0mij=ees0m(jj,i)
7643       ees0mkl=ees0m(kk,k)
7644       ekont=eij*ekl
7645       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7646 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7647 ! Following 4 lines for diagnostics.
7648 !d    ees0pkl=0.0D0
7649 !d    ees0pij=1.0D0
7650 !d    ees0mkl=0.0D0
7651 !d    ees0mij=1.0D0
7652 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7653 !     & 'Contacts ',i,j,
7654 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7655 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7656 !     & 'gradcorr_long'
7657 ! Calculate the multi-body contribution to energy.
7658 !      ecorr=ecorr+ekont*ees
7659 ! Calculate multi-body contributions to the gradient.
7660       coeffpees0pij=coeffp*ees0pij
7661       coeffmees0mij=coeffm*ees0mij
7662       coeffpees0pkl=coeffp*ees0pkl
7663       coeffmees0mkl=coeffm*ees0mkl
7664       do ll=1,3
7665 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7666         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7667         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7668         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7669         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7670         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7671         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7672 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7673         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7674         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7675         coeffmees0mij*gacontm_hb1(ll,kk,k))
7676         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7677         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7678         coeffmees0mij*gacontm_hb2(ll,kk,k))
7679         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7680            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7681            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7682         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7683         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7684         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7685            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7686            coeffmees0mij*gacontm_hb3(ll,kk,k))
7687         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7688         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7689 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7690       enddo
7691 !      write (iout,*)
7692 !grad      do m=i+1,j-1
7693 !grad        do ll=1,3
7694 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7695 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7696 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7697 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7698 !grad        enddo
7699 !grad      enddo
7700 !grad      do m=k+1,l-1
7701 !grad        do ll=1,3
7702 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7703 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7704 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7705 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7706 !grad        enddo
7707 !grad      enddo
7708 !      write (iout,*) "ehbcorr",ekont*ees
7709       ehbcorr=ekont*ees
7710       if (shield_mode.gt.0) then
7711        j=ees0plist(jj,i)
7712        l=ees0plist(kk,k)
7713 !C        print *,i,j,fac_shield(i),fac_shield(j),
7714 !C     &fac_shield(k),fac_shield(l)
7715         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
7716            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7717           do ilist=1,ishield_list(i)
7718            iresshield=shield_list(ilist,i)
7719            do m=1,3
7720            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7721            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7722                    rlocshield  &
7723             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7724             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7725             +rlocshield
7726            enddo
7727           enddo
7728           do ilist=1,ishield_list(j)
7729            iresshield=shield_list(ilist,j)
7730            do m=1,3
7731            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7732            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7733                    rlocshield &
7734             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7735            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7736             +rlocshield
7737            enddo
7738           enddo
7739
7740           do ilist=1,ishield_list(k)
7741            iresshield=shield_list(ilist,k)
7742            do m=1,3
7743            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7744            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7745                    rlocshield &
7746             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7747            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7748             +rlocshield
7749            enddo
7750           enddo
7751           do ilist=1,ishield_list(l)
7752            iresshield=shield_list(ilist,l)
7753            do m=1,3
7754            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7755            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7756                    rlocshield &
7757             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7758            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7759             +rlocshield
7760            enddo
7761           enddo
7762           do m=1,3
7763             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
7764                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7765             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
7766                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7767             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
7768                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7769             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
7770                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7771
7772             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
7773                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7774             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
7775                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7776             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
7777                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7778             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
7779                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7780
7781            enddo
7782       endif
7783       endif
7784       return
7785       end function ehbcorr
7786 #ifdef MOMENT
7787 !-----------------------------------------------------------------------------
7788       subroutine dipole(i,j,jj)
7789 !      implicit real*8 (a-h,o-z)
7790 !      include 'DIMENSIONS'
7791 !      include 'COMMON.IOUNITS'
7792 !      include 'COMMON.CHAIN'
7793 !      include 'COMMON.FFIELD'
7794 !      include 'COMMON.DERIV'
7795 !      include 'COMMON.INTERACT'
7796 !      include 'COMMON.CONTACTS'
7797 !      include 'COMMON.TORSION'
7798 !      include 'COMMON.VAR'
7799 !      include 'COMMON.GEO'
7800       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7801       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7802       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7803
7804       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7805       allocate(dipderx(3,5,4,maxconts,nres))
7806 !
7807
7808       iti1 = itortyp(itype(i+1))
7809       if (j.lt.nres-1) then
7810         itj1 = itortyp(itype(j+1))
7811       else
7812         itj1=ntortyp+1
7813       endif
7814       do iii=1,2
7815         dipi(iii,1)=Ub2(iii,i)
7816         dipderi(iii)=Ub2der(iii,i)
7817         dipi(iii,2)=b1(iii,iti1)
7818         dipj(iii,1)=Ub2(iii,j)
7819         dipderj(iii)=Ub2der(iii,j)
7820         dipj(iii,2)=b1(iii,itj1)
7821       enddo
7822       kkk=0
7823       do iii=1,2
7824         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7825         do jjj=1,2
7826           kkk=kkk+1
7827           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7828         enddo
7829       enddo
7830       do kkk=1,5
7831         do lll=1,3
7832           mmm=0
7833           do iii=1,2
7834             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
7835               auxvec(1))
7836             do jjj=1,2
7837               mmm=mmm+1
7838               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7839             enddo
7840           enddo
7841         enddo
7842       enddo
7843       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7844       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7845       do iii=1,2
7846         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7847       enddo
7848       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7849       do iii=1,2
7850         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7851       enddo
7852       return
7853       end subroutine dipole
7854 #endif
7855 !-----------------------------------------------------------------------------
7856       subroutine calc_eello(i,j,k,l,jj,kk)
7857 !
7858 ! This subroutine computes matrices and vectors needed to calculate
7859 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7860 !
7861       use comm_kut
7862 !      implicit real*8 (a-h,o-z)
7863 !      include 'DIMENSIONS'
7864 !      include 'COMMON.IOUNITS'
7865 !      include 'COMMON.CHAIN'
7866 !      include 'COMMON.DERIV'
7867 !      include 'COMMON.INTERACT'
7868 !      include 'COMMON.CONTACTS'
7869 !      include 'COMMON.TORSION'
7870 !      include 'COMMON.VAR'
7871 !      include 'COMMON.GEO'
7872 !      include 'COMMON.FFIELD'
7873       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
7874       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
7875       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
7876               itj1
7877 !el      logical :: lprn
7878 !el      common /kutas/ lprn
7879 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7880 !d     & ' jj=',jj,' kk=',kk
7881 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7882 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7883 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7884       do iii=1,2
7885         do jjj=1,2
7886           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7887           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7888         enddo
7889       enddo
7890       call transpose2(aa1(1,1),aa1t(1,1))
7891       call transpose2(aa2(1,1),aa2t(1,1))
7892       do kkk=1,5
7893         do lll=1,3
7894           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
7895             aa1tder(1,1,lll,kkk))
7896           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
7897             aa2tder(1,1,lll,kkk))
7898         enddo
7899       enddo
7900       if (l.eq.j+1) then
7901 ! parallel orientation of the two CA-CA-CA frames.
7902         if (i.gt.1) then
7903           iti=itortyp(itype(i))
7904         else
7905           iti=ntortyp+1
7906         endif
7907         itk1=itortyp(itype(k+1))
7908         itj=itortyp(itype(j))
7909         if (l.lt.nres-1) then
7910           itl1=itortyp(itype(l+1))
7911         else
7912           itl1=ntortyp+1
7913         endif
7914 ! A1 kernel(j+1) A2T
7915 !d        do iii=1,2
7916 !d          write (iout,'(3f10.5,5x,3f10.5)')
7917 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7918 !d        enddo
7919         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7920          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7921          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7922 ! Following matrices are needed only for 6-th order cumulants
7923         IF (wcorr6.gt.0.0d0) THEN
7924         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7925          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7926          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7927         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7928          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7929          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7930          ADtEAderx(1,1,1,1,1,1))
7931         lprn=.false.
7932         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7933          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7934          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7935          ADtEA1derx(1,1,1,1,1,1))
7936         ENDIF
7937 ! End 6-th order cumulants
7938 !d        lprn=.false.
7939 !d        if (lprn) then
7940 !d        write (2,*) 'In calc_eello6'
7941 !d        do iii=1,2
7942 !d          write (2,*) 'iii=',iii
7943 !d          do kkk=1,5
7944 !d            write (2,*) 'kkk=',kkk
7945 !d            do jjj=1,2
7946 !d              write (2,'(3(2f10.5),5x)')
7947 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7948 !d            enddo
7949 !d          enddo
7950 !d        enddo
7951 !d        endif
7952         call transpose2(EUgder(1,1,k),auxmat(1,1))
7953         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7954         call transpose2(EUg(1,1,k),auxmat(1,1))
7955         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7956         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7957         do iii=1,2
7958           do kkk=1,5
7959             do lll=1,3
7960               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7961                 EAEAderx(1,1,lll,kkk,iii,1))
7962             enddo
7963           enddo
7964         enddo
7965 ! A1T kernel(i+1) A2
7966         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7967          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7968          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7969 ! Following matrices are needed only for 6-th order cumulants
7970         IF (wcorr6.gt.0.0d0) THEN
7971         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7972          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7973          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7974         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7975          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7976          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7977          ADtEAderx(1,1,1,1,1,2))
7978         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7979          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7980          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7981          ADtEA1derx(1,1,1,1,1,2))
7982         ENDIF
7983 ! End 6-th order cumulants
7984         call transpose2(EUgder(1,1,l),auxmat(1,1))
7985         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7986         call transpose2(EUg(1,1,l),auxmat(1,1))
7987         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7988         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7989         do iii=1,2
7990           do kkk=1,5
7991             do lll=1,3
7992               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7993                 EAEAderx(1,1,lll,kkk,iii,2))
7994             enddo
7995           enddo
7996         enddo
7997 ! AEAb1 and AEAb2
7998 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7999 ! They are needed only when the fifth- or the sixth-order cumulants are
8000 ! indluded.
8001         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8002         call transpose2(AEA(1,1,1),auxmat(1,1))
8003         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8004         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8005         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8006         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8007         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8008         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8009         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8010         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8011         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8012         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8013         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8014         call transpose2(AEA(1,1,2),auxmat(1,1))
8015         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8016         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8017         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8018         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8019         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8020         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8021         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8022         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8023         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8024         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8025         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8026 ! Calculate the Cartesian derivatives of the vectors.
8027         do iii=1,2
8028           do kkk=1,5
8029             do lll=1,3
8030               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8031               call matvec2(auxmat(1,1),b1(1,iti),&
8032                 AEAb1derx(1,lll,kkk,iii,1,1))
8033               call matvec2(auxmat(1,1),Ub2(1,i),&
8034                 AEAb2derx(1,lll,kkk,iii,1,1))
8035               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8036                 AEAb1derx(1,lll,kkk,iii,2,1))
8037               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8038                 AEAb2derx(1,lll,kkk,iii,2,1))
8039               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8040               call matvec2(auxmat(1,1),b1(1,itj),&
8041                 AEAb1derx(1,lll,kkk,iii,1,2))
8042               call matvec2(auxmat(1,1),Ub2(1,j),&
8043                 AEAb2derx(1,lll,kkk,iii,1,2))
8044               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8045                 AEAb1derx(1,lll,kkk,iii,2,2))
8046               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8047                 AEAb2derx(1,lll,kkk,iii,2,2))
8048             enddo
8049           enddo
8050         enddo
8051         ENDIF
8052 ! End vectors
8053       else
8054 ! Antiparallel orientation of the two CA-CA-CA frames.
8055         if (i.gt.1) then
8056           iti=itortyp(itype(i))
8057         else
8058           iti=ntortyp+1
8059         endif
8060         itk1=itortyp(itype(k+1))
8061         itl=itortyp(itype(l))
8062         itj=itortyp(itype(j))
8063         if (j.lt.nres-1) then
8064           itj1=itortyp(itype(j+1))
8065         else
8066           itj1=ntortyp+1
8067         endif
8068 ! A2 kernel(j-1)T A1T
8069         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8070          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8071          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8072 ! Following matrices are needed only for 6-th order cumulants
8073         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8074            j.eq.i+4 .and. l.eq.i+3)) THEN
8075         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8076          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8077          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8078         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8079          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8080          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8081          ADtEAderx(1,1,1,1,1,1))
8082         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8083          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8084          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8085          ADtEA1derx(1,1,1,1,1,1))
8086         ENDIF
8087 ! End 6-th order cumulants
8088         call transpose2(EUgder(1,1,k),auxmat(1,1))
8089         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8090         call transpose2(EUg(1,1,k),auxmat(1,1))
8091         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8092         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8093         do iii=1,2
8094           do kkk=1,5
8095             do lll=1,3
8096               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8097                 EAEAderx(1,1,lll,kkk,iii,1))
8098             enddo
8099           enddo
8100         enddo
8101 ! A2T kernel(i+1)T A1
8102         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8103          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8104          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8105 ! Following matrices are needed only for 6-th order cumulants
8106         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8107            j.eq.i+4 .and. l.eq.i+3)) THEN
8108         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8109          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8110          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8111         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8112          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8113          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8114          ADtEAderx(1,1,1,1,1,2))
8115         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8116          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8117          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8118          ADtEA1derx(1,1,1,1,1,2))
8119         ENDIF
8120 ! End 6-th order cumulants
8121         call transpose2(EUgder(1,1,j),auxmat(1,1))
8122         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8123         call transpose2(EUg(1,1,j),auxmat(1,1))
8124         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8125         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8126         do iii=1,2
8127           do kkk=1,5
8128             do lll=1,3
8129               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8130                 EAEAderx(1,1,lll,kkk,iii,2))
8131             enddo
8132           enddo
8133         enddo
8134 ! AEAb1 and AEAb2
8135 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8136 ! They are needed only when the fifth- or the sixth-order cumulants are
8137 ! indluded.
8138         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8139           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8140         call transpose2(AEA(1,1,1),auxmat(1,1))
8141         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8142         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8143         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8144         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8145         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8146         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8147         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8148         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8149         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8150         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8151         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8152         call transpose2(AEA(1,1,2),auxmat(1,1))
8153         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8154         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8155         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8156         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8157         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8158         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8159         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8160         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8161         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8162         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8163         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8164 ! Calculate the Cartesian derivatives of the vectors.
8165         do iii=1,2
8166           do kkk=1,5
8167             do lll=1,3
8168               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8169               call matvec2(auxmat(1,1),b1(1,iti),&
8170                 AEAb1derx(1,lll,kkk,iii,1,1))
8171               call matvec2(auxmat(1,1),Ub2(1,i),&
8172                 AEAb2derx(1,lll,kkk,iii,1,1))
8173               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8174                 AEAb1derx(1,lll,kkk,iii,2,1))
8175               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8176                 AEAb2derx(1,lll,kkk,iii,2,1))
8177               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8178               call matvec2(auxmat(1,1),b1(1,itl),&
8179                 AEAb1derx(1,lll,kkk,iii,1,2))
8180               call matvec2(auxmat(1,1),Ub2(1,l),&
8181                 AEAb2derx(1,lll,kkk,iii,1,2))
8182               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8183                 AEAb1derx(1,lll,kkk,iii,2,2))
8184               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8185                 AEAb2derx(1,lll,kkk,iii,2,2))
8186             enddo
8187           enddo
8188         enddo
8189         ENDIF
8190 ! End vectors
8191       endif
8192       return
8193       end subroutine calc_eello
8194 !-----------------------------------------------------------------------------
8195       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8196       use comm_kut
8197       implicit none
8198       integer :: nderg
8199       logical :: transp
8200       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8201       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8202       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8203       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8204       integer :: iii,kkk,lll
8205       integer :: jjj,mmm
8206 !el      logical :: lprn
8207 !el      common /kutas/ lprn
8208       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8209       do iii=1,nderg
8210         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8211           AKAderg(1,1,iii))
8212       enddo
8213 !d      if (lprn) write (2,*) 'In kernel'
8214       do kkk=1,5
8215 !d        if (lprn) write (2,*) 'kkk=',kkk
8216         do lll=1,3
8217           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8218             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8219 !d          if (lprn) then
8220 !d            write (2,*) 'lll=',lll
8221 !d            write (2,*) 'iii=1'
8222 !d            do jjj=1,2
8223 !d              write (2,'(3(2f10.5),5x)')
8224 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8225 !d            enddo
8226 !d          endif
8227           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8228             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8229 !d          if (lprn) then
8230 !d            write (2,*) 'lll=',lll
8231 !d            write (2,*) 'iii=2'
8232 !d            do jjj=1,2
8233 !d              write (2,'(3(2f10.5),5x)')
8234 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8235 !d            enddo
8236 !d          endif
8237         enddo
8238       enddo
8239       return
8240       end subroutine kernel
8241 !-----------------------------------------------------------------------------
8242       real(kind=8) function eello4(i,j,k,l,jj,kk)
8243 !      implicit real*8 (a-h,o-z)
8244 !      include 'DIMENSIONS'
8245 !      include 'COMMON.IOUNITS'
8246 !      include 'COMMON.CHAIN'
8247 !      include 'COMMON.DERIV'
8248 !      include 'COMMON.INTERACT'
8249 !      include 'COMMON.CONTACTS'
8250 !      include 'COMMON.TORSION'
8251 !      include 'COMMON.VAR'
8252 !      include 'COMMON.GEO'
8253       real(kind=8),dimension(2,2) :: pizda
8254       real(kind=8),dimension(3) :: ggg1,ggg2
8255       real(kind=8) ::  eel4,glongij,glongkl
8256       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8257 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8258 !d        eello4=0.0d0
8259 !d        return
8260 !d      endif
8261 !d      print *,'eello4:',i,j,k,l,jj,kk
8262 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8263 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8264 !old      eij=facont_hb(jj,i)
8265 !old      ekl=facont_hb(kk,k)
8266 !old      ekont=eij*ekl
8267       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8268 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8269       gcorr_loc(k-1)=gcorr_loc(k-1) &
8270          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8271       if (l.eq.j+1) then
8272         gcorr_loc(l-1)=gcorr_loc(l-1) &
8273            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8274       else
8275         gcorr_loc(j-1)=gcorr_loc(j-1) &
8276            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8277       endif
8278       do iii=1,2
8279         do kkk=1,5
8280           do lll=1,3
8281             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8282                               -EAEAderx(2,2,lll,kkk,iii,1)
8283 !d            derx(lll,kkk,iii)=0.0d0
8284           enddo
8285         enddo
8286       enddo
8287 !d      gcorr_loc(l-1)=0.0d0
8288 !d      gcorr_loc(j-1)=0.0d0
8289 !d      gcorr_loc(k-1)=0.0d0
8290 !d      eel4=1.0d0
8291 !d      write (iout,*)'Contacts have occurred for peptide groups',
8292 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8293 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8294       if (j.lt.nres-1) then
8295         j1=j+1
8296         j2=j-1
8297       else
8298         j1=j-1
8299         j2=j-2
8300       endif
8301       if (l.lt.nres-1) then
8302         l1=l+1
8303         l2=l-1
8304       else
8305         l1=l-1
8306         l2=l-2
8307       endif
8308       do ll=1,3
8309 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8310 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8311         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8312         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8313 !grad        ghalf=0.5d0*ggg1(ll)
8314         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8315         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8316         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8317         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8318         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8319         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8320 !grad        ghalf=0.5d0*ggg2(ll)
8321         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8322         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8323         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8324         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8325         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8326         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8327       enddo
8328 !grad      do m=i+1,j-1
8329 !grad        do ll=1,3
8330 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8331 !grad        enddo
8332 !grad      enddo
8333 !grad      do m=k+1,l-1
8334 !grad        do ll=1,3
8335 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8336 !grad        enddo
8337 !grad      enddo
8338 !grad      do m=i+2,j2
8339 !grad        do ll=1,3
8340 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8341 !grad        enddo
8342 !grad      enddo
8343 !grad      do m=k+2,l2
8344 !grad        do ll=1,3
8345 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8346 !grad        enddo
8347 !grad      enddo
8348 !d      do iii=1,nres-3
8349 !d        write (2,*) iii,gcorr_loc(iii)
8350 !d      enddo
8351       eello4=ekont*eel4
8352 !d      write (2,*) 'ekont',ekont
8353 !d      write (iout,*) 'eello4',ekont*eel4
8354       return
8355       end function eello4
8356 !-----------------------------------------------------------------------------
8357       real(kind=8) function eello5(i,j,k,l,jj,kk)
8358 !      implicit real*8 (a-h,o-z)
8359 !      include 'DIMENSIONS'
8360 !      include 'COMMON.IOUNITS'
8361 !      include 'COMMON.CHAIN'
8362 !      include 'COMMON.DERIV'
8363 !      include 'COMMON.INTERACT'
8364 !      include 'COMMON.CONTACTS'
8365 !      include 'COMMON.TORSION'
8366 !      include 'COMMON.VAR'
8367 !      include 'COMMON.GEO'
8368       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8369       real(kind=8),dimension(2) :: vv
8370       real(kind=8),dimension(3) :: ggg1,ggg2
8371       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8372       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8373       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8374 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8375 !                                                                              C
8376 !                            Parallel chains                                   C
8377 !                                                                              C
8378 !          o             o                   o             o                   C
8379 !         /l\           / \             \   / \           / \   /              C
8380 !        /   \         /   \             \ /   \         /   \ /               C
8381 !       j| o |l1       | o |              o| o |         | o |o                C
8382 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8383 !      \i/   \         /   \ /             /   \         /   \                 C
8384 !       o    k1             o                                                  C
8385 !         (I)          (II)                (III)          (IV)                 C
8386 !                                                                              C
8387 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8388 !                                                                              C
8389 !                            Antiparallel chains                               C
8390 !                                                                              C
8391 !          o             o                   o             o                   C
8392 !         /j\           / \             \   / \           / \   /              C
8393 !        /   \         /   \             \ /   \         /   \ /               C
8394 !      j1| o |l        | o |              o| o |         | o |o                C
8395 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8396 !      \i/   \         /   \ /             /   \         /   \                 C
8397 !       o     k1            o                                                  C
8398 !         (I)          (II)                (III)          (IV)                 C
8399 !                                                                              C
8400 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8401 !                                                                              C
8402 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8403 !                                                                              C
8404 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8405 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8406 !d        eello5=0.0d0
8407 !d        return
8408 !d      endif
8409 !d      write (iout,*)
8410 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8411 !d     &   ' and',k,l
8412       itk=itortyp(itype(k))
8413       itl=itortyp(itype(l))
8414       itj=itortyp(itype(j))
8415       eello5_1=0.0d0
8416       eello5_2=0.0d0
8417       eello5_3=0.0d0
8418       eello5_4=0.0d0
8419 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8420 !d     &   eel5_3_num,eel5_4_num)
8421       do iii=1,2
8422         do kkk=1,5
8423           do lll=1,3
8424             derx(lll,kkk,iii)=0.0d0
8425           enddo
8426         enddo
8427       enddo
8428 !d      eij=facont_hb(jj,i)
8429 !d      ekl=facont_hb(kk,k)
8430 !d      ekont=eij*ekl
8431 !d      write (iout,*)'Contacts have occurred for peptide groups',
8432 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8433 !d      goto 1111
8434 ! Contribution from the graph I.
8435 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8436 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8437       call transpose2(EUg(1,1,k),auxmat(1,1))
8438       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8439       vv(1)=pizda(1,1)-pizda(2,2)
8440       vv(2)=pizda(1,2)+pizda(2,1)
8441       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8442        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8443 ! Explicit gradient in virtual-dihedral angles.
8444       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8445        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8446        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8447       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8448       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8449       vv(1)=pizda(1,1)-pizda(2,2)
8450       vv(2)=pizda(1,2)+pizda(2,1)
8451       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8452        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8453        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8454       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8455       vv(1)=pizda(1,1)-pizda(2,2)
8456       vv(2)=pizda(1,2)+pizda(2,1)
8457       if (l.eq.j+1) then
8458         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8459          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8460          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8461       else
8462         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8463          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8464          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8465       endif
8466 ! Cartesian gradient
8467       do iii=1,2
8468         do kkk=1,5
8469           do lll=1,3
8470             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8471               pizda(1,1))
8472             vv(1)=pizda(1,1)-pizda(2,2)
8473             vv(2)=pizda(1,2)+pizda(2,1)
8474             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8475              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8476              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8477           enddo
8478         enddo
8479       enddo
8480 !      goto 1112
8481 !1111  continue
8482 ! Contribution from graph II
8483       call transpose2(EE(1,1,itk),auxmat(1,1))
8484       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8485       vv(1)=pizda(1,1)+pizda(2,2)
8486       vv(2)=pizda(2,1)-pizda(1,2)
8487       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8488        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8489 ! Explicit gradient in virtual-dihedral angles.
8490       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8491        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8492       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8493       vv(1)=pizda(1,1)+pizda(2,2)
8494       vv(2)=pizda(2,1)-pizda(1,2)
8495       if (l.eq.j+1) then
8496         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8497          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8498          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8499       else
8500         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8501          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8502          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8503       endif
8504 ! Cartesian gradient
8505       do iii=1,2
8506         do kkk=1,5
8507           do lll=1,3
8508             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8509               pizda(1,1))
8510             vv(1)=pizda(1,1)+pizda(2,2)
8511             vv(2)=pizda(2,1)-pizda(1,2)
8512             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8513              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8514              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8515           enddo
8516         enddo
8517       enddo
8518 !d      goto 1112
8519 !d1111  continue
8520       if (l.eq.j+1) then
8521 !d        goto 1110
8522 ! Parallel orientation
8523 ! Contribution from graph III
8524         call transpose2(EUg(1,1,l),auxmat(1,1))
8525         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8526         vv(1)=pizda(1,1)-pizda(2,2)
8527         vv(2)=pizda(1,2)+pizda(2,1)
8528         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8529          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8530 ! Explicit gradient in virtual-dihedral angles.
8531         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8532          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8533          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8534         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8535         vv(1)=pizda(1,1)-pizda(2,2)
8536         vv(2)=pizda(1,2)+pizda(2,1)
8537         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8538          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8539          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8540         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8541         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8542         vv(1)=pizda(1,1)-pizda(2,2)
8543         vv(2)=pizda(1,2)+pizda(2,1)
8544         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8545          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8546          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8547 ! Cartesian gradient
8548         do iii=1,2
8549           do kkk=1,5
8550             do lll=1,3
8551               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8552                 pizda(1,1))
8553               vv(1)=pizda(1,1)-pizda(2,2)
8554               vv(2)=pizda(1,2)+pizda(2,1)
8555               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8556                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8557                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8558             enddo
8559           enddo
8560         enddo
8561 !d        goto 1112
8562 ! Contribution from graph IV
8563 !d1110    continue
8564         call transpose2(EE(1,1,itl),auxmat(1,1))
8565         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8566         vv(1)=pizda(1,1)+pizda(2,2)
8567         vv(2)=pizda(2,1)-pizda(1,2)
8568         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8569          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8570 ! Explicit gradient in virtual-dihedral angles.
8571         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8572          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8573         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8574         vv(1)=pizda(1,1)+pizda(2,2)
8575         vv(2)=pizda(2,1)-pizda(1,2)
8576         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8577          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8578          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8579 ! Cartesian gradient
8580         do iii=1,2
8581           do kkk=1,5
8582             do lll=1,3
8583               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8584                 pizda(1,1))
8585               vv(1)=pizda(1,1)+pizda(2,2)
8586               vv(2)=pizda(2,1)-pizda(1,2)
8587               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8588                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8589                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8590             enddo
8591           enddo
8592         enddo
8593       else
8594 ! Antiparallel orientation
8595 ! Contribution from graph III
8596 !        goto 1110
8597         call transpose2(EUg(1,1,j),auxmat(1,1))
8598         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8599         vv(1)=pizda(1,1)-pizda(2,2)
8600         vv(2)=pizda(1,2)+pizda(2,1)
8601         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8602          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8603 ! Explicit gradient in virtual-dihedral angles.
8604         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8605          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8606          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8607         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8608         vv(1)=pizda(1,1)-pizda(2,2)
8609         vv(2)=pizda(1,2)+pizda(2,1)
8610         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8611          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8612          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8613         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8614         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8615         vv(1)=pizda(1,1)-pizda(2,2)
8616         vv(2)=pizda(1,2)+pizda(2,1)
8617         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8618          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8619          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8620 ! Cartesian gradient
8621         do iii=1,2
8622           do kkk=1,5
8623             do lll=1,3
8624               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8625                 pizda(1,1))
8626               vv(1)=pizda(1,1)-pizda(2,2)
8627               vv(2)=pizda(1,2)+pizda(2,1)
8628               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8629                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8630                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8631             enddo
8632           enddo
8633         enddo
8634 !d        goto 1112
8635 ! Contribution from graph IV
8636 1110    continue
8637         call transpose2(EE(1,1,itj),auxmat(1,1))
8638         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8639         vv(1)=pizda(1,1)+pizda(2,2)
8640         vv(2)=pizda(2,1)-pizda(1,2)
8641         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8642          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8643 ! Explicit gradient in virtual-dihedral angles.
8644         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8645          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8646         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8647         vv(1)=pizda(1,1)+pizda(2,2)
8648         vv(2)=pizda(2,1)-pizda(1,2)
8649         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8650          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8651          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8652 ! Cartesian gradient
8653         do iii=1,2
8654           do kkk=1,5
8655             do lll=1,3
8656               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8657                 pizda(1,1))
8658               vv(1)=pizda(1,1)+pizda(2,2)
8659               vv(2)=pizda(2,1)-pizda(1,2)
8660               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8661                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8662                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8663             enddo
8664           enddo
8665         enddo
8666       endif
8667 1112  continue
8668       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8669 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8670 !d        write (2,*) 'ijkl',i,j,k,l
8671 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8672 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8673 !d      endif
8674 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8675 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8676 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8677 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8678       if (j.lt.nres-1) then
8679         j1=j+1
8680         j2=j-1
8681       else
8682         j1=j-1
8683         j2=j-2
8684       endif
8685       if (l.lt.nres-1) then
8686         l1=l+1
8687         l2=l-1
8688       else
8689         l1=l-1
8690         l2=l-2
8691       endif
8692 !d      eij=1.0d0
8693 !d      ekl=1.0d0
8694 !d      ekont=1.0d0
8695 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8696 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8697 !        summed up outside the subrouine as for the other subroutines
8698 !        handling long-range interactions. The old code is commented out
8699 !        with "cgrad" to keep track of changes.
8700       do ll=1,3
8701 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8702 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8703         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8704         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8705 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8706 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8707 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8708 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8709 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8710 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8711 !     &   gradcorr5ij,
8712 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8713 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8714 !grad        ghalf=0.5d0*ggg1(ll)
8715 !d        ghalf=0.0d0
8716         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8717         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8718         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8719         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8720         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8721         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8722 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8723 !grad        ghalf=0.5d0*ggg2(ll)
8724         ghalf=0.0d0
8725         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8726         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8727         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8728         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8729         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8730         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8731       enddo
8732 !d      goto 1112
8733 !grad      do m=i+1,j-1
8734 !grad        do ll=1,3
8735 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8736 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8737 !grad        enddo
8738 !grad      enddo
8739 !grad      do m=k+1,l-1
8740 !grad        do ll=1,3
8741 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8742 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8743 !grad        enddo
8744 !grad      enddo
8745 !1112  continue
8746 !grad      do m=i+2,j2
8747 !grad        do ll=1,3
8748 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8749 !grad        enddo
8750 !grad      enddo
8751 !grad      do m=k+2,l2
8752 !grad        do ll=1,3
8753 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8754 !grad        enddo
8755 !grad      enddo
8756 !d      do iii=1,nres-3
8757 !d        write (2,*) iii,g_corr5_loc(iii)
8758 !d      enddo
8759       eello5=ekont*eel5
8760 !d      write (2,*) 'ekont',ekont
8761 !d      write (iout,*) 'eello5',ekont*eel5
8762       return
8763       end function eello5
8764 !-----------------------------------------------------------------------------
8765       real(kind=8) function eello6(i,j,k,l,jj,kk)
8766 !      implicit real*8 (a-h,o-z)
8767 !      include 'DIMENSIONS'
8768 !      include 'COMMON.IOUNITS'
8769 !      include 'COMMON.CHAIN'
8770 !      include 'COMMON.DERIV'
8771 !      include 'COMMON.INTERACT'
8772 !      include 'COMMON.CONTACTS'
8773 !      include 'COMMON.TORSION'
8774 !      include 'COMMON.VAR'
8775 !      include 'COMMON.GEO'
8776 !      include 'COMMON.FFIELD'
8777       real(kind=8),dimension(3) :: ggg1,ggg2
8778       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
8779                    eello6_6,eel6
8780       real(kind=8) :: gradcorr6ij,gradcorr6kl
8781       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8782 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8783 !d        eello6=0.0d0
8784 !d        return
8785 !d      endif
8786 !d      write (iout,*)
8787 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8788 !d     &   ' and',k,l
8789       eello6_1=0.0d0
8790       eello6_2=0.0d0
8791       eello6_3=0.0d0
8792       eello6_4=0.0d0
8793       eello6_5=0.0d0
8794       eello6_6=0.0d0
8795 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8796 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8797       do iii=1,2
8798         do kkk=1,5
8799           do lll=1,3
8800             derx(lll,kkk,iii)=0.0d0
8801           enddo
8802         enddo
8803       enddo
8804 !d      eij=facont_hb(jj,i)
8805 !d      ekl=facont_hb(kk,k)
8806 !d      ekont=eij*ekl
8807 !d      eij=1.0d0
8808 !d      ekl=1.0d0
8809 !d      ekont=1.0d0
8810       if (l.eq.j+1) then
8811         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8812         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8813         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8814         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8815         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8816         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8817       else
8818         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8819         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8820         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8821         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8822         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8823           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8824         else
8825           eello6_5=0.0d0
8826         endif
8827         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8828       endif
8829 ! If turn contributions are considered, they will be handled separately.
8830       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8831 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8832 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8833 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8834 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8835 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8836 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8837 !d      goto 1112
8838       if (j.lt.nres-1) then
8839         j1=j+1
8840         j2=j-1
8841       else
8842         j1=j-1
8843         j2=j-2
8844       endif
8845       if (l.lt.nres-1) then
8846         l1=l+1
8847         l2=l-1
8848       else
8849         l1=l-1
8850         l2=l-2
8851       endif
8852       do ll=1,3
8853 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8854 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8855 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8856 !grad        ghalf=0.5d0*ggg1(ll)
8857 !d        ghalf=0.0d0
8858         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8859         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8860         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8861         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8862         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8863         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8864         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8865         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8866 !grad        ghalf=0.5d0*ggg2(ll)
8867 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8868 !d        ghalf=0.0d0
8869         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8870         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8871         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8872         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8873         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8874         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8875       enddo
8876 !d      goto 1112
8877 !grad      do m=i+1,j-1
8878 !grad        do ll=1,3
8879 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8880 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8881 !grad        enddo
8882 !grad      enddo
8883 !grad      do m=k+1,l-1
8884 !grad        do ll=1,3
8885 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8886 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8887 !grad        enddo
8888 !grad      enddo
8889 !grad1112  continue
8890 !grad      do m=i+2,j2
8891 !grad        do ll=1,3
8892 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8893 !grad        enddo
8894 !grad      enddo
8895 !grad      do m=k+2,l2
8896 !grad        do ll=1,3
8897 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8898 !grad        enddo
8899 !grad      enddo
8900 !d      do iii=1,nres-3
8901 !d        write (2,*) iii,g_corr6_loc(iii)
8902 !d      enddo
8903       eello6=ekont*eel6
8904 !d      write (2,*) 'ekont',ekont
8905 !d      write (iout,*) 'eello6',ekont*eel6
8906       return
8907       end function eello6
8908 !-----------------------------------------------------------------------------
8909       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
8910       use comm_kut
8911 !      implicit real*8 (a-h,o-z)
8912 !      include 'DIMENSIONS'
8913 !      include 'COMMON.IOUNITS'
8914 !      include 'COMMON.CHAIN'
8915 !      include 'COMMON.DERIV'
8916 !      include 'COMMON.INTERACT'
8917 !      include 'COMMON.CONTACTS'
8918 !      include 'COMMON.TORSION'
8919 !      include 'COMMON.VAR'
8920 !      include 'COMMON.GEO'
8921       real(kind=8),dimension(2) :: vv,vv1
8922       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8923       logical :: swap
8924 !el      logical :: lprn
8925 !el      common /kutas/ lprn
8926       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8927       real(kind=8) :: s1,s2,s3,s4,s5
8928 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8929 !                                                                              C
8930 !      Parallel       Antiparallel                                             C
8931 !                                                                              C
8932 !          o             o                                                     C
8933 !         /l\           /j\                                                    C
8934 !        /   \         /   \                                                   C
8935 !       /| o |         | o |\                                                  C
8936 !     \ j|/k\|  /   \  |/k\|l /                                                C
8937 !      \ /   \ /     \ /   \ /                                                 C
8938 !       o     o       o     o                                                  C
8939 !       i             i                                                        C
8940 !                                                                              C
8941 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8942       itk=itortyp(itype(k))
8943       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8944       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8945       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8946       call transpose2(EUgC(1,1,k),auxmat(1,1))
8947       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8948       vv1(1)=pizda1(1,1)-pizda1(2,2)
8949       vv1(2)=pizda1(1,2)+pizda1(2,1)
8950       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8951       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8952       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8953       s5=scalar2(vv(1),Dtobr2(1,i))
8954 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8955       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8956       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8957        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8958        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8959        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8960        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8961        +scalar2(vv(1),Dtobr2der(1,i)))
8962       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8963       vv1(1)=pizda1(1,1)-pizda1(2,2)
8964       vv1(2)=pizda1(1,2)+pizda1(2,1)
8965       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8966       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8967       if (l.eq.j+1) then
8968         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8969        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8970        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8971        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8972        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8973       else
8974         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8975        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8976        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8977        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8978        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8979       endif
8980       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8981       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8982       vv1(1)=pizda1(1,1)-pizda1(2,2)
8983       vv1(2)=pizda1(1,2)+pizda1(2,1)
8984       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8985        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8986        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8987        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8988       do iii=1,2
8989         if (swap) then
8990           ind=3-iii
8991         else
8992           ind=iii
8993         endif
8994         do kkk=1,5
8995           do lll=1,3
8996             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8997             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8998             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8999             call transpose2(EUgC(1,1,k),auxmat(1,1))
9000             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9001               pizda1(1,1))
9002             vv1(1)=pizda1(1,1)-pizda1(2,2)
9003             vv1(2)=pizda1(1,2)+pizda1(2,1)
9004             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9005             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9006              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9007             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9008              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9009             s5=scalar2(vv(1),Dtobr2(1,i))
9010             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9011           enddo
9012         enddo
9013       enddo
9014       return
9015       end function eello6_graph1
9016 !-----------------------------------------------------------------------------
9017       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9018       use comm_kut
9019 !      implicit real*8 (a-h,o-z)
9020 !      include 'DIMENSIONS'
9021 !      include 'COMMON.IOUNITS'
9022 !      include 'COMMON.CHAIN'
9023 !      include 'COMMON.DERIV'
9024 !      include 'COMMON.INTERACT'
9025 !      include 'COMMON.CONTACTS'
9026 !      include 'COMMON.TORSION'
9027 !      include 'COMMON.VAR'
9028 !      include 'COMMON.GEO'
9029       logical :: swap
9030       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9031       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9032 !el      logical :: lprn
9033 !el      common /kutas/ lprn
9034       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9035       real(kind=8) :: s2,s3,s4
9036 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9037 !                                                                              C
9038 !      Parallel       Antiparallel                                             C
9039 !                                                                              C
9040 !          o             o                                                     C
9041 !     \   /l\           /j\   /                                                C
9042 !      \ /   \         /   \ /                                                 C
9043 !       o| o |         | o |o                                                  C
9044 !     \ j|/k\|      \  |/k\|l                                                  C
9045 !      \ /   \       \ /   \                                                   C
9046 !       o             o                                                        C
9047 !       i             i                                                        C
9048 !                                                                              C
9049 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9050 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9051 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9052 !           but not in a cluster cumulant
9053 #ifdef MOMENT
9054       s1=dip(1,jj,i)*dip(1,kk,k)
9055 #endif
9056       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9057       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9058       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9059       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9060       call transpose2(EUg(1,1,k),auxmat(1,1))
9061       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9062       vv(1)=pizda(1,1)-pizda(2,2)
9063       vv(2)=pizda(1,2)+pizda(2,1)
9064       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9065 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9066 #ifdef MOMENT
9067       eello6_graph2=-(s1+s2+s3+s4)
9068 #else
9069       eello6_graph2=-(s2+s3+s4)
9070 #endif
9071 !      eello6_graph2=-s3
9072 ! Derivatives in gamma(i-1)
9073       if (i.gt.1) then
9074 #ifdef MOMENT
9075         s1=dipderg(1,jj,i)*dip(1,kk,k)
9076 #endif
9077         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9078         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9079         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9080         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9081 #ifdef MOMENT
9082         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9083 #else
9084         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9085 #endif
9086 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9087       endif
9088 ! Derivatives in gamma(k-1)
9089 #ifdef MOMENT
9090       s1=dip(1,jj,i)*dipderg(1,kk,k)
9091 #endif
9092       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9093       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9094       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9095       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9096       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9097       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9098       vv(1)=pizda(1,1)-pizda(2,2)
9099       vv(2)=pizda(1,2)+pizda(2,1)
9100       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9101 #ifdef MOMENT
9102       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9103 #else
9104       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9105 #endif
9106 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9107 ! Derivatives in gamma(j-1) or gamma(l-1)
9108       if (j.gt.1) then
9109 #ifdef MOMENT
9110         s1=dipderg(3,jj,i)*dip(1,kk,k)
9111 #endif
9112         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9113         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9114         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9115         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9116         vv(1)=pizda(1,1)-pizda(2,2)
9117         vv(2)=pizda(1,2)+pizda(2,1)
9118         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9119 #ifdef MOMENT
9120         if (swap) then
9121           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9122         else
9123           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9124         endif
9125 #endif
9126         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9127 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9128       endif
9129 ! Derivatives in gamma(l-1) or gamma(j-1)
9130       if (l.gt.1) then
9131 #ifdef MOMENT
9132         s1=dip(1,jj,i)*dipderg(3,kk,k)
9133 #endif
9134         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9135         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9136         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9137         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9138         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9139         vv(1)=pizda(1,1)-pizda(2,2)
9140         vv(2)=pizda(1,2)+pizda(2,1)
9141         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9142 #ifdef MOMENT
9143         if (swap) then
9144           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9145         else
9146           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9147         endif
9148 #endif
9149         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9150 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9151       endif
9152 ! Cartesian derivatives.
9153       if (lprn) then
9154         write (2,*) 'In eello6_graph2'
9155         do iii=1,2
9156           write (2,*) 'iii=',iii
9157           do kkk=1,5
9158             write (2,*) 'kkk=',kkk
9159             do jjj=1,2
9160               write (2,'(3(2f10.5),5x)') &
9161               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9162             enddo
9163           enddo
9164         enddo
9165       endif
9166       do iii=1,2
9167         do kkk=1,5
9168           do lll=1,3
9169 #ifdef MOMENT
9170             if (iii.eq.1) then
9171               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9172             else
9173               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9174             endif
9175 #endif
9176             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9177               auxvec(1))
9178             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9179             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9180               auxvec(1))
9181             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9182             call transpose2(EUg(1,1,k),auxmat(1,1))
9183             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9184               pizda(1,1))
9185             vv(1)=pizda(1,1)-pizda(2,2)
9186             vv(2)=pizda(1,2)+pizda(2,1)
9187             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9188 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9189 #ifdef MOMENT
9190             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9191 #else
9192             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9193 #endif
9194             if (swap) then
9195               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9196             else
9197               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9198             endif
9199           enddo
9200         enddo
9201       enddo
9202       return
9203       end function eello6_graph2
9204 !-----------------------------------------------------------------------------
9205       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9206 !      implicit real*8 (a-h,o-z)
9207 !      include 'DIMENSIONS'
9208 !      include 'COMMON.IOUNITS'
9209 !      include 'COMMON.CHAIN'
9210 !      include 'COMMON.DERIV'
9211 !      include 'COMMON.INTERACT'
9212 !      include 'COMMON.CONTACTS'
9213 !      include 'COMMON.TORSION'
9214 !      include 'COMMON.VAR'
9215 !      include 'COMMON.GEO'
9216       real(kind=8),dimension(2) :: vv,auxvec
9217       real(kind=8),dimension(2,2) :: pizda,auxmat
9218       logical :: swap
9219       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9220       real(kind=8) :: s1,s2,s3,s4
9221 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9222 !                                                                              C
9223 !      Parallel       Antiparallel                                             C
9224 !                                                                              C
9225 !          o             o                                                     C
9226 !         /l\   /   \   /j\                                                    C
9227 !        /   \ /     \ /   \                                                   C
9228 !       /| o |o       o| o |\                                                  C
9229 !       j|/k\|  /      |/k\|l /                                                C
9230 !        /   \ /       /   \ /                                                 C
9231 !       /     o       /     o                                                  C
9232 !       i             i                                                        C
9233 !                                                                              C
9234 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9235 !
9236 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9237 !           energy moment and not to the cluster cumulant.
9238       iti=itortyp(itype(i))
9239       if (j.lt.nres-1) then
9240         itj1=itortyp(itype(j+1))
9241       else
9242         itj1=ntortyp+1
9243       endif
9244       itk=itortyp(itype(k))
9245       itk1=itortyp(itype(k+1))
9246       if (l.lt.nres-1) then
9247         itl1=itortyp(itype(l+1))
9248       else
9249         itl1=ntortyp+1
9250       endif
9251 #ifdef MOMENT
9252       s1=dip(4,jj,i)*dip(4,kk,k)
9253 #endif
9254       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9255       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9256       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9257       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9258       call transpose2(EE(1,1,itk),auxmat(1,1))
9259       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9260       vv(1)=pizda(1,1)+pizda(2,2)
9261       vv(2)=pizda(2,1)-pizda(1,2)
9262       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9263 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9264 !d     & "sum",-(s2+s3+s4)
9265 #ifdef MOMENT
9266       eello6_graph3=-(s1+s2+s3+s4)
9267 #else
9268       eello6_graph3=-(s2+s3+s4)
9269 #endif
9270 !      eello6_graph3=-s4
9271 ! Derivatives in gamma(k-1)
9272       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9273       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9274       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9275       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9276 ! Derivatives in gamma(l-1)
9277       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9278       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9279       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9280       vv(1)=pizda(1,1)+pizda(2,2)
9281       vv(2)=pizda(2,1)-pizda(1,2)
9282       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9283       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9284 ! Cartesian derivatives.
9285       do iii=1,2
9286         do kkk=1,5
9287           do lll=1,3
9288 #ifdef MOMENT
9289             if (iii.eq.1) then
9290               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9291             else
9292               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9293             endif
9294 #endif
9295             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9296               auxvec(1))
9297             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9298             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9299               auxvec(1))
9300             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9301             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9302               pizda(1,1))
9303             vv(1)=pizda(1,1)+pizda(2,2)
9304             vv(2)=pizda(2,1)-pizda(1,2)
9305             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9306 #ifdef MOMENT
9307             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9308 #else
9309             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9310 #endif
9311             if (swap) then
9312               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9313             else
9314               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9315             endif
9316 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9317           enddo
9318         enddo
9319       enddo
9320       return
9321       end function eello6_graph3
9322 !-----------------------------------------------------------------------------
9323       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9324 !      implicit real*8 (a-h,o-z)
9325 !      include 'DIMENSIONS'
9326 !      include 'COMMON.IOUNITS'
9327 !      include 'COMMON.CHAIN'
9328 !      include 'COMMON.DERIV'
9329 !      include 'COMMON.INTERACT'
9330 !      include 'COMMON.CONTACTS'
9331 !      include 'COMMON.TORSION'
9332 !      include 'COMMON.VAR'
9333 !      include 'COMMON.GEO'
9334 !      include 'COMMON.FFIELD'
9335       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9336       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9337       logical :: swap
9338       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9339               iii,kkk,lll
9340       real(kind=8) :: s1,s2,s3,s4
9341 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9342 !                                                                              C
9343 !      Parallel       Antiparallel                                             C
9344 !                                                                              C
9345 !          o             o                                                     C
9346 !         /l\   /   \   /j\                                                    C
9347 !        /   \ /     \ /   \                                                   C
9348 !       /| o |o       o| o |\                                                  C
9349 !     \ j|/k\|      \  |/k\|l                                                  C
9350 !      \ /   \       \ /   \                                                   C
9351 !       o     \       o     \                                                  C
9352 !       i             i                                                        C
9353 !                                                                              C
9354 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9355 !
9356 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9357 !           energy moment and not to the cluster cumulant.
9358 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9359       iti=itortyp(itype(i))
9360       itj=itortyp(itype(j))
9361       if (j.lt.nres-1) then
9362         itj1=itortyp(itype(j+1))
9363       else
9364         itj1=ntortyp+1
9365       endif
9366       itk=itortyp(itype(k))
9367       if (k.lt.nres-1) then
9368         itk1=itortyp(itype(k+1))
9369       else
9370         itk1=ntortyp+1
9371       endif
9372       itl=itortyp(itype(l))
9373       if (l.lt.nres-1) then
9374         itl1=itortyp(itype(l+1))
9375       else
9376         itl1=ntortyp+1
9377       endif
9378 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9379 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9380 !d     & ' itl',itl,' itl1',itl1
9381 #ifdef MOMENT
9382       if (imat.eq.1) then
9383         s1=dip(3,jj,i)*dip(3,kk,k)
9384       else
9385         s1=dip(2,jj,j)*dip(2,kk,l)
9386       endif
9387 #endif
9388       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9389       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9390       if (j.eq.l+1) then
9391         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9392         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9393       else
9394         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9395         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9396       endif
9397       call transpose2(EUg(1,1,k),auxmat(1,1))
9398       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9399       vv(1)=pizda(1,1)-pizda(2,2)
9400       vv(2)=pizda(2,1)+pizda(1,2)
9401       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9402 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9403 #ifdef MOMENT
9404       eello6_graph4=-(s1+s2+s3+s4)
9405 #else
9406       eello6_graph4=-(s2+s3+s4)
9407 #endif
9408 ! Derivatives in gamma(i-1)
9409       if (i.gt.1) then
9410 #ifdef MOMENT
9411         if (imat.eq.1) then
9412           s1=dipderg(2,jj,i)*dip(3,kk,k)
9413         else
9414           s1=dipderg(4,jj,j)*dip(2,kk,l)
9415         endif
9416 #endif
9417         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9418         if (j.eq.l+1) then
9419           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9420           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9421         else
9422           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9423           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9424         endif
9425         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9426         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9427 !d          write (2,*) 'turn6 derivatives'
9428 #ifdef MOMENT
9429           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9430 #else
9431           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9432 #endif
9433         else
9434 #ifdef MOMENT
9435           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9436 #else
9437           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9438 #endif
9439         endif
9440       endif
9441 ! Derivatives in gamma(k-1)
9442 #ifdef MOMENT
9443       if (imat.eq.1) then
9444         s1=dip(3,jj,i)*dipderg(2,kk,k)
9445       else
9446         s1=dip(2,jj,j)*dipderg(4,kk,l)
9447       endif
9448 #endif
9449       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9450       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9451       if (j.eq.l+1) then
9452         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9453         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9454       else
9455         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9456         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9457       endif
9458       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9459       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9460       vv(1)=pizda(1,1)-pizda(2,2)
9461       vv(2)=pizda(2,1)+pizda(1,2)
9462       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9463       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9464 #ifdef MOMENT
9465         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9466 #else
9467         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9468 #endif
9469       else
9470 #ifdef MOMENT
9471         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9472 #else
9473         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9474 #endif
9475       endif
9476 ! Derivatives in gamma(j-1) or gamma(l-1)
9477       if (l.eq.j+1 .and. l.gt.1) then
9478         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9479         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9480         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9481         vv(1)=pizda(1,1)-pizda(2,2)
9482         vv(2)=pizda(2,1)+pizda(1,2)
9483         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9484         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9485       else if (j.gt.1) then
9486         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9487         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9488         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9489         vv(1)=pizda(1,1)-pizda(2,2)
9490         vv(2)=pizda(2,1)+pizda(1,2)
9491         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9492         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9493           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9494         else
9495           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9496         endif
9497       endif
9498 ! Cartesian derivatives.
9499       do iii=1,2
9500         do kkk=1,5
9501           do lll=1,3
9502 #ifdef MOMENT
9503             if (iii.eq.1) then
9504               if (imat.eq.1) then
9505                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9506               else
9507                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9508               endif
9509             else
9510               if (imat.eq.1) then
9511                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9512               else
9513                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9514               endif
9515             endif
9516 #endif
9517             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9518               auxvec(1))
9519             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9520             if (j.eq.l+1) then
9521               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9522                 b1(1,itj1),auxvec(1))
9523               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9524             else
9525               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9526                 b1(1,itl1),auxvec(1))
9527               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9528             endif
9529             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9530               pizda(1,1))
9531             vv(1)=pizda(1,1)-pizda(2,2)
9532             vv(2)=pizda(2,1)+pizda(1,2)
9533             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9534             if (swap) then
9535               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9536 #ifdef MOMENT
9537                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9538                    -(s1+s2+s4)
9539 #else
9540                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9541                    -(s2+s4)
9542 #endif
9543                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9544               else
9545 #ifdef MOMENT
9546                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9547 #else
9548                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9549 #endif
9550                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9551               endif
9552             else
9553 #ifdef MOMENT
9554               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9555 #else
9556               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9557 #endif
9558               if (l.eq.j+1) then
9559                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9560               else
9561                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9562               endif
9563             endif
9564           enddo
9565         enddo
9566       enddo
9567       return
9568       end function eello6_graph4
9569 !-----------------------------------------------------------------------------
9570       real(kind=8) function eello_turn6(i,jj,kk)
9571 !      implicit real*8 (a-h,o-z)
9572 !      include 'DIMENSIONS'
9573 !      include 'COMMON.IOUNITS'
9574 !      include 'COMMON.CHAIN'
9575 !      include 'COMMON.DERIV'
9576 !      include 'COMMON.INTERACT'
9577 !      include 'COMMON.CONTACTS'
9578 !      include 'COMMON.TORSION'
9579 !      include 'COMMON.VAR'
9580 !      include 'COMMON.GEO'
9581       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9582       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9583       real(kind=8),dimension(3) :: ggg1,ggg2
9584       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9585       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9586 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9587 !           the respective energy moment and not to the cluster cumulant.
9588 !el local variables
9589       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9590       integer :: j1,j2,l1,l2,ll
9591       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9592       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9593       s1=0.0d0
9594       s8=0.0d0
9595       s13=0.0d0
9596 !
9597       eello_turn6=0.0d0
9598       j=i+4
9599       k=i+1
9600       l=i+3
9601       iti=itortyp(itype(i))
9602       itk=itortyp(itype(k))
9603       itk1=itortyp(itype(k+1))
9604       itl=itortyp(itype(l))
9605       itj=itortyp(itype(j))
9606 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9607 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9608 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9609 !d        eello6=0.0d0
9610 !d        return
9611 !d      endif
9612 !d      write (iout,*)
9613 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9614 !d     &   ' and',k,l
9615 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9616       do iii=1,2
9617         do kkk=1,5
9618           do lll=1,3
9619             derx_turn(lll,kkk,iii)=0.0d0
9620           enddo
9621         enddo
9622       enddo
9623 !d      eij=1.0d0
9624 !d      ekl=1.0d0
9625 !d      ekont=1.0d0
9626       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9627 !d      eello6_5=0.0d0
9628 !d      write (2,*) 'eello6_5',eello6_5
9629 #ifdef MOMENT
9630       call transpose2(AEA(1,1,1),auxmat(1,1))
9631       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9632       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9633       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9634 #endif
9635       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9636       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9637       s2 = scalar2(b1(1,itk),vtemp1(1))
9638 #ifdef MOMENT
9639       call transpose2(AEA(1,1,2),atemp(1,1))
9640       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9641       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9642       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9643 #endif
9644       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9645       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9646       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9647 #ifdef MOMENT
9648       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9649       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9650       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9651       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9652       ss13 = scalar2(b1(1,itk),vtemp4(1))
9653       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9654 #endif
9655 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9656 !      s1=0.0d0
9657 !      s2=0.0d0
9658 !      s8=0.0d0
9659 !      s12=0.0d0
9660 !      s13=0.0d0
9661       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9662 ! Derivatives in gamma(i+2)
9663       s1d =0.0d0
9664       s8d =0.0d0
9665 #ifdef MOMENT
9666       call transpose2(AEA(1,1,1),auxmatd(1,1))
9667       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9668       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9669       call transpose2(AEAderg(1,1,2),atempd(1,1))
9670       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9671       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9672 #endif
9673       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9674       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9675       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9676 !      s1d=0.0d0
9677 !      s2d=0.0d0
9678 !      s8d=0.0d0
9679 !      s12d=0.0d0
9680 !      s13d=0.0d0
9681       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9682 ! Derivatives in gamma(i+3)
9683 #ifdef MOMENT
9684       call transpose2(AEA(1,1,1),auxmatd(1,1))
9685       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9686       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9687       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9688 #endif
9689       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9690       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9691       s2d = scalar2(b1(1,itk),vtemp1d(1))
9692 #ifdef MOMENT
9693       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9694       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9695 #endif
9696       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9697 #ifdef MOMENT
9698       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9699       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9700       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9701 #endif
9702 !      s1d=0.0d0
9703 !      s2d=0.0d0
9704 !      s8d=0.0d0
9705 !      s12d=0.0d0
9706 !      s13d=0.0d0
9707 #ifdef MOMENT
9708       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9709                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9710 #else
9711       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9712                     -0.5d0*ekont*(s2d+s12d)
9713 #endif
9714 ! Derivatives in gamma(i+4)
9715       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9716       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9717       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9718 #ifdef MOMENT
9719       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9720       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9721       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9722 #endif
9723 !      s1d=0.0d0
9724 !      s2d=0.0d0
9725 !      s8d=0.0d0
9726 !      s12d=0.0d0
9727 !      s13d=0.0d0
9728 #ifdef MOMENT
9729       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9730 #else
9731       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9732 #endif
9733 ! Derivatives in gamma(i+5)
9734 #ifdef MOMENT
9735       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9736       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9737       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9738 #endif
9739       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9740       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9741       s2d = scalar2(b1(1,itk),vtemp1d(1))
9742 #ifdef MOMENT
9743       call transpose2(AEA(1,1,2),atempd(1,1))
9744       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9745       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9746 #endif
9747       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9748       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9749 #ifdef MOMENT
9750       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9751       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9752       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9753 #endif
9754 !      s1d=0.0d0
9755 !      s2d=0.0d0
9756 !      s8d=0.0d0
9757 !      s12d=0.0d0
9758 !      s13d=0.0d0
9759 #ifdef MOMENT
9760       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9761                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9762 #else
9763       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9764                     -0.5d0*ekont*(s2d+s12d)
9765 #endif
9766 ! Cartesian derivatives
9767       do iii=1,2
9768         do kkk=1,5
9769           do lll=1,3
9770 #ifdef MOMENT
9771             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9772             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9773             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9774 #endif
9775             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9776             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
9777                 vtemp1d(1))
9778             s2d = scalar2(b1(1,itk),vtemp1d(1))
9779 #ifdef MOMENT
9780             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9781             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9782             s8d = -(atempd(1,1)+atempd(2,2))* &
9783                  scalar2(cc(1,1,itl),vtemp2(1))
9784 #endif
9785             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
9786                  auxmatd(1,1))
9787             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9788             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9789 !      s1d=0.0d0
9790 !      s2d=0.0d0
9791 !      s8d=0.0d0
9792 !      s12d=0.0d0
9793 !      s13d=0.0d0
9794 #ifdef MOMENT
9795             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9796               - 0.5d0*(s1d+s2d)
9797 #else
9798             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9799               - 0.5d0*s2d
9800 #endif
9801 #ifdef MOMENT
9802             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9803               - 0.5d0*(s8d+s12d)
9804 #else
9805             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9806               - 0.5d0*s12d
9807 #endif
9808           enddo
9809         enddo
9810       enddo
9811 #ifdef MOMENT
9812       do kkk=1,5
9813         do lll=1,3
9814           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
9815             achuj_tempd(1,1))
9816           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9817           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9818           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9819           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9820           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
9821             vtemp4d(1))
9822           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9823           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9824           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9825         enddo
9826       enddo
9827 #endif
9828 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9829 !d     &  16*eel_turn6_num
9830 !d      goto 1112
9831       if (j.lt.nres-1) then
9832         j1=j+1
9833         j2=j-1
9834       else
9835         j1=j-1
9836         j2=j-2
9837       endif
9838       if (l.lt.nres-1) then
9839         l1=l+1
9840         l2=l-1
9841       else
9842         l1=l-1
9843         l2=l-2
9844       endif
9845       do ll=1,3
9846 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9847 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9848 !grad        ghalf=0.5d0*ggg1(ll)
9849 !d        ghalf=0.0d0
9850         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9851         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9852         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9853           +ekont*derx_turn(ll,2,1)
9854         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9855         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9856           +ekont*derx_turn(ll,4,1)
9857         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9858         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9859         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9860 !grad        ghalf=0.5d0*ggg2(ll)
9861 !d        ghalf=0.0d0
9862         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9863           +ekont*derx_turn(ll,2,2)
9864         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9865         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
9866           +ekont*derx_turn(ll,4,2)
9867         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9868         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9869         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9870       enddo
9871 !d      goto 1112
9872 !grad      do m=i+1,j-1
9873 !grad        do ll=1,3
9874 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9875 !grad        enddo
9876 !grad      enddo
9877 !grad      do m=k+1,l-1
9878 !grad        do ll=1,3
9879 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9880 !grad        enddo
9881 !grad      enddo
9882 !grad1112  continue
9883 !grad      do m=i+2,j2
9884 !grad        do ll=1,3
9885 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9886 !grad        enddo
9887 !grad      enddo
9888 !grad      do m=k+2,l2
9889 !grad        do ll=1,3
9890 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9891 !grad        enddo
9892 !grad      enddo
9893 !d      do iii=1,nres-3
9894 !d        write (2,*) iii,g_corr6_loc(iii)
9895 !d      enddo
9896       eello_turn6=ekont*eel_turn6
9897 !d      write (2,*) 'ekont',ekont
9898 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
9899       return
9900       end function eello_turn6
9901 !-----------------------------------------------------------------------------
9902       subroutine MATVEC2(A1,V1,V2)
9903 !DIR$ INLINEALWAYS MATVEC2
9904 #ifndef OSF
9905 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9906 #endif
9907 !      implicit real*8 (a-h,o-z)
9908 !      include 'DIMENSIONS'
9909       real(kind=8),dimension(2) :: V1,V2
9910       real(kind=8),dimension(2,2) :: A1
9911       real(kind=8) :: vaux1,vaux2
9912 !      DO 1 I=1,2
9913 !        VI=0.0
9914 !        DO 3 K=1,2
9915 !    3     VI=VI+A1(I,K)*V1(K)
9916 !        Vaux(I)=VI
9917 !    1 CONTINUE
9918
9919       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9920       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9921
9922       v2(1)=vaux1
9923       v2(2)=vaux2
9924       end subroutine MATVEC2
9925 !-----------------------------------------------------------------------------
9926       subroutine MATMAT2(A1,A2,A3)
9927 #ifndef OSF
9928 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9929 #endif
9930 !      implicit real*8 (a-h,o-z)
9931 !      include 'DIMENSIONS'
9932       real(kind=8),dimension(2,2) :: A1,A2,A3
9933       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9934 !      DIMENSION AI3(2,2)
9935 !        DO  J=1,2
9936 !          A3IJ=0.0
9937 !          DO K=1,2
9938 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9939 !          enddo
9940 !          A3(I,J)=A3IJ
9941 !       enddo
9942 !      enddo
9943
9944       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9945       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9946       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9947       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9948
9949       A3(1,1)=AI3_11
9950       A3(2,1)=AI3_21
9951       A3(1,2)=AI3_12
9952       A3(2,2)=AI3_22
9953       end subroutine MATMAT2
9954 !-----------------------------------------------------------------------------
9955       real(kind=8) function scalar2(u,v)
9956 !DIR$ INLINEALWAYS scalar2
9957       implicit none
9958       real(kind=8),dimension(2) :: u,v
9959       real(kind=8) :: sc
9960       integer :: i
9961       scalar2=u(1)*v(1)+u(2)*v(2)
9962       return
9963       end function scalar2
9964 !-----------------------------------------------------------------------------
9965       subroutine transpose2(a,at)
9966 !DIR$ INLINEALWAYS transpose2
9967 #ifndef OSF
9968 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9969 #endif
9970       implicit none
9971       real(kind=8),dimension(2,2) :: a,at
9972       at(1,1)=a(1,1)
9973       at(1,2)=a(2,1)
9974       at(2,1)=a(1,2)
9975       at(2,2)=a(2,2)
9976       return
9977       end subroutine transpose2
9978 !-----------------------------------------------------------------------------
9979       subroutine transpose(n,a,at)
9980       implicit none
9981       integer :: n,i,j
9982       real(kind=8),dimension(n,n) :: a,at
9983       do i=1,n
9984         do j=1,n
9985           at(j,i)=a(i,j)
9986         enddo
9987       enddo
9988       return
9989       end subroutine transpose
9990 !-----------------------------------------------------------------------------
9991       subroutine prodmat3(a1,a2,kk,transp,prod)
9992 !DIR$ INLINEALWAYS prodmat3
9993 #ifndef OSF
9994 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9995 #endif
9996       implicit none
9997       integer :: i,j
9998       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9999       logical :: transp
10000 !rc      double precision auxmat(2,2),prod_(2,2)
10001
10002       if (transp) then
10003 !rc        call transpose2(kk(1,1),auxmat(1,1))
10004 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10005 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10006
10007            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10008        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10009            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10010        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10011            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10012        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10013            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10014        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10015
10016       else
10017 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10018 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10019
10020            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10021         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10022            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10023         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10024            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10025         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10026            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10027         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10028
10029       endif
10030 !      call transpose2(a2(1,1),a2t(1,1))
10031
10032 !rc      print *,transp
10033 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10034 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10035
10036       return
10037       end subroutine prodmat3
10038 !-----------------------------------------------------------------------------
10039 ! energy_p_new_barrier.F
10040 !-----------------------------------------------------------------------------
10041       subroutine sum_gradient
10042 !      implicit real*8 (a-h,o-z)
10043       use io_base, only: pdbout
10044 !      include 'DIMENSIONS'
10045 #ifndef ISNAN
10046       external proc_proc
10047 #ifdef WINPGI
10048 !MS$ATTRIBUTES C ::  proc_proc
10049 #endif
10050 #endif
10051 #ifdef MPI
10052       include 'mpif.h'
10053 #endif
10054       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10055                    gloc_scbuf !(3,maxres)
10056
10057       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10058 !#endif
10059 !el local variables
10060       integer :: i,j,k,ierror,ierr
10061       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10062                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10063                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10064                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10065                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10066                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10067                    gsccorr_max,gsccorrx_max,time00
10068
10069 !      include 'COMMON.SETUP'
10070 !      include 'COMMON.IOUNITS'
10071 !      include 'COMMON.FFIELD'
10072 !      include 'COMMON.DERIV'
10073 !      include 'COMMON.INTERACT'
10074 !      include 'COMMON.SBRIDGE'
10075 !      include 'COMMON.CHAIN'
10076 !      include 'COMMON.VAR'
10077 !      include 'COMMON.CONTROL'
10078 !      include 'COMMON.TIME1'
10079 !      include 'COMMON.MAXGRAD'
10080 !      include 'COMMON.SCCOR'
10081 #ifdef TIMING
10082       time01=MPI_Wtime()
10083 #endif
10084 #ifdef DEBUG
10085       write (iout,*) "sum_gradient gvdwc, gvdwx"
10086       do i=1,nres
10087         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10088          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10089       enddo
10090       call flush(iout)
10091 #endif
10092 #ifdef MPI
10093         gradbufc=0.0d0
10094         gradbufx=0.0d0
10095         gradbufc_sum=0.0d0
10096         gloc_scbuf=0.0d0
10097         glocbuf=0.0d0
10098 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10099         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10100           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10101 #endif
10102 !
10103 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10104 !            in virtual-bond-vector coordinates
10105 !
10106 #ifdef DEBUG
10107 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10108 !      do i=1,nres-1
10109 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10110 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10111 !      enddo
10112 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10113 !      do i=1,nres-1
10114 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10115 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10116 !      enddo
10117       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10118       do i=1,nres
10119         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10120          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10121          (gvdwc_scpp(j,i),j=1,3)
10122       enddo
10123       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10124       do i=1,nres
10125         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10126          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10127          (gelc_loc_long(j,i),j=1,3)
10128       enddo
10129       call flush(iout)
10130 #endif
10131 #ifdef SPLITELE
10132       do i=0,nct
10133         do j=1,3
10134           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10135                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10136                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10137                       wel_loc*gel_loc_long(j,i)+ &
10138                       wcorr*gradcorr_long(j,i)+ &
10139                       wcorr5*gradcorr5_long(j,i)+ &
10140                       wcorr6*gradcorr6_long(j,i)+ &
10141                       wturn6*gcorr6_turn_long(j,i)+ &
10142                       wstrain*ghpbc(j,i) &
10143                      +wliptran*gliptranc(j,i) &
10144                      +welec*gshieldc(j,i) &
10145                      +wcorr*gshieldc_ec(j,i) &
10146                      +wturn3*gshieldc_t3(j,i)&
10147                      +wturn4*gshieldc_t4(j,i)&
10148                      +wel_loc*gshieldc_ll(j,i)&
10149                      +wtube*gg_tube(j,i)
10150
10151
10152
10153         enddo
10154       enddo
10155 #else
10156       do i=0,nct
10157         do j=1,3
10158           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10159                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10160                       welec*gelc_long(j,i)+ &
10161                       wbond*gradb(j,i)+ &
10162                       wel_loc*gel_loc_long(j,i)+ &
10163                       wcorr*gradcorr_long(j,i)+ &
10164                       wcorr5*gradcorr5_long(j,i)+ &
10165                       wcorr6*gradcorr6_long(j,i)+ &
10166                       wturn6*gcorr6_turn_long(j,i)+ &
10167                       wstrain*ghpbc(j,i) &
10168                      +wliptran*gliptranc(j,i) &
10169                      +welec*gshieldc(j,i)&
10170                      +wcorr*gshieldc_ec(j,i) &
10171                      +wturn4*gshieldc_t4(j,i) &
10172                      +wel_loc*gshieldc_ll(j,i)&
10173                      +wtube*gg_tube(j,i)
10174
10175
10176
10177         enddo
10178       enddo
10179 #endif
10180 #ifdef MPI
10181       if (nfgtasks.gt.1) then
10182       time00=MPI_Wtime()
10183 #ifdef DEBUG
10184       write (iout,*) "gradbufc before allreduce"
10185       do i=1,nres
10186         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10187       enddo
10188       call flush(iout)
10189 #endif
10190       do i=0,nres
10191         do j=1,3
10192           gradbufc_sum(j,i)=gradbufc(j,i)
10193         enddo
10194       enddo
10195 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10196 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10197 !      time_reduce=time_reduce+MPI_Wtime()-time00
10198 #ifdef DEBUG
10199 !      write (iout,*) "gradbufc_sum after allreduce"
10200 !      do i=1,nres
10201 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10202 !      enddo
10203 !      call flush(iout)
10204 #endif
10205 #ifdef TIMING
10206 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10207 #endif
10208       do i=0,nres
10209         do k=1,3
10210           gradbufc(k,i)=0.0d0
10211         enddo
10212       enddo
10213 #ifdef DEBUG
10214       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10215       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10216                         " jgrad_end  ",jgrad_end(i),&
10217                         i=igrad_start,igrad_end)
10218 #endif
10219 !
10220 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10221 ! do not parallelize this part.
10222 !
10223 !      do i=igrad_start,igrad_end
10224 !        do j=jgrad_start(i),jgrad_end(i)
10225 !          do k=1,3
10226 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10227 !          enddo
10228 !        enddo
10229 !      enddo
10230       do j=1,3
10231         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10232       enddo
10233       do i=nres-2,-1,-1
10234         do j=1,3
10235           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10236         enddo
10237       enddo
10238 #ifdef DEBUG
10239       write (iout,*) "gradbufc after summing"
10240       do i=1,nres
10241         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10242       enddo
10243       call flush(iout)
10244 #endif
10245       else
10246 #endif
10247 !el#define DEBUG
10248 #ifdef DEBUG
10249       write (iout,*) "gradbufc"
10250       do i=1,nres
10251         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10252       enddo
10253       call flush(iout)
10254 #endif
10255 !el#undef DEBUG
10256       do i=-1,nres
10257         do j=1,3
10258           gradbufc_sum(j,i)=gradbufc(j,i)
10259           gradbufc(j,i)=0.0d0
10260         enddo
10261       enddo
10262       do j=1,3
10263         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10264       enddo
10265       do i=nres-2,-1,-1
10266         do j=1,3
10267           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10268         enddo
10269       enddo
10270 !      do i=nnt,nres-1
10271 !        do k=1,3
10272 !          gradbufc(k,i)=0.0d0
10273 !        enddo
10274 !        do j=i+1,nres
10275 !          do k=1,3
10276 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10277 !          enddo
10278 !        enddo
10279 !      enddo
10280 !el#define DEBUG
10281 #ifdef DEBUG
10282       write (iout,*) "gradbufc after summing"
10283       do i=1,nres
10284         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10285       enddo
10286       call flush(iout)
10287 #endif
10288 !el#undef DEBUG
10289 #ifdef MPI
10290       endif
10291 #endif
10292       do k=1,3
10293         gradbufc(k,nres)=0.0d0
10294       enddo
10295 !el----------------
10296 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10297 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10298 !el-----------------
10299       do i=-1,nct
10300         do j=1,3
10301 #ifdef SPLITELE
10302           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10303                       wel_loc*gel_loc(j,i)+ &
10304                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10305                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10306                       wel_loc*gel_loc_long(j,i)+ &
10307                       wcorr*gradcorr_long(j,i)+ &
10308                       wcorr5*gradcorr5_long(j,i)+ &
10309                       wcorr6*gradcorr6_long(j,i)+ &
10310                       wturn6*gcorr6_turn_long(j,i))+ &
10311                       wbond*gradb(j,i)+ &
10312                       wcorr*gradcorr(j,i)+ &
10313                       wturn3*gcorr3_turn(j,i)+ &
10314                       wturn4*gcorr4_turn(j,i)+ &
10315                       wcorr5*gradcorr5(j,i)+ &
10316                       wcorr6*gradcorr6(j,i)+ &
10317                       wturn6*gcorr6_turn(j,i)+ &
10318                       wsccor*gsccorc(j,i) &
10319                      +wscloc*gscloc(j,i)  &
10320                      +wliptran*gliptranc(j,i) &
10321                      +welec*gshieldc(j,i) &
10322                      +welec*gshieldc_loc(j,i) &
10323                      +wcorr*gshieldc_ec(j,i) &
10324                      +wcorr*gshieldc_loc_ec(j,i) &
10325                      +wturn3*gshieldc_t3(j,i) &
10326                      +wturn3*gshieldc_loc_t3(j,i) &
10327                      +wturn4*gshieldc_t4(j,i) &
10328                      +wturn4*gshieldc_loc_t4(j,i) &
10329                      +wel_loc*gshieldc_ll(j,i) &
10330                      +wel_loc*gshieldc_loc_ll(j,i) &
10331                      +wtube*gg_tube(j,i)
10332
10333
10334 #else
10335           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10336                       wel_loc*gel_loc(j,i)+ &
10337                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10338                       welec*gelc_long(j,i)+ &
10339                       wel_loc*gel_loc_long(j,i)+ &
10340 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10341                       wcorr5*gradcorr5_long(j,i)+ &
10342                       wcorr6*gradcorr6_long(j,i)+ &
10343                       wturn6*gcorr6_turn_long(j,i))+ &
10344                       wbond*gradb(j,i)+ &
10345                       wcorr*gradcorr(j,i)+ &
10346                       wturn3*gcorr3_turn(j,i)+ &
10347                       wturn4*gcorr4_turn(j,i)+ &
10348                       wcorr5*gradcorr5(j,i)+ &
10349                       wcorr6*gradcorr6(j,i)+ &
10350                       wturn6*gcorr6_turn(j,i)+ &
10351                       wsccor*gsccorc(j,i) &
10352                      +wscloc*gscloc(j,i) &
10353                      +wliptran*gliptranc(j,i) &
10354                      +welec*gshieldc(j,i) &
10355                      +welec*gshieldc_loc(j,) &
10356                      +wcorr*gshieldc_ec(j,i) &
10357                      +wcorr*gshieldc_loc_ec(j,i) &
10358                      +wturn3*gshieldc_t3(j,i) &
10359                      +wturn3*gshieldc_loc_t3(j,i) &
10360                      +wturn4*gshieldc_t4(j,i) &
10361                      +wturn4*gshieldc_loc_t4(j,i) &
10362                      +wel_loc*gshieldc_ll(j,i) &
10363                      +wel_loc*gshieldc_loc_ll(j,i) &
10364                      +wtube*gg_tube(j,i)
10365
10366
10367
10368 #endif
10369           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10370                         wbond*gradbx(j,i)+ &
10371                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10372                         wsccor*gsccorx(j,i) &
10373                        +wscloc*gsclocx(j,i) &
10374                        +wliptran*gliptranx(j,i) &
10375                        +welec*gshieldx(j,i)     &
10376                        +wcorr*gshieldx_ec(j,i)  &
10377                        +wturn3*gshieldx_t3(j,i) &
10378                        +wturn4*gshieldx_t4(j,i) &
10379                        +wel_loc*gshieldx_ll(j,i)&
10380                        +wtube*gg_tube_sc(j,i)
10381
10382
10383         enddo
10384       enddo
10385 #ifdef DEBUG
10386       write (iout,*) "gloc before adding corr"
10387       do i=1,4*nres
10388         write (iout,*) i,gloc(i,icg)
10389       enddo
10390 #endif
10391       do i=1,nres-3
10392         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10393          +wcorr5*g_corr5_loc(i) &
10394          +wcorr6*g_corr6_loc(i) &
10395          +wturn4*gel_loc_turn4(i) &
10396          +wturn3*gel_loc_turn3(i) &
10397          +wturn6*gel_loc_turn6(i) &
10398          +wel_loc*gel_loc_loc(i)
10399       enddo
10400 #ifdef DEBUG
10401       write (iout,*) "gloc after adding corr"
10402       do i=1,4*nres
10403         write (iout,*) i,gloc(i,icg)
10404       enddo
10405 #endif
10406 #ifdef MPI
10407       if (nfgtasks.gt.1) then
10408         do j=1,3
10409           do i=1,nres
10410             gradbufc(j,i)=gradc(j,i,icg)
10411             gradbufx(j,i)=gradx(j,i,icg)
10412           enddo
10413         enddo
10414         do i=1,4*nres
10415           glocbuf(i)=gloc(i,icg)
10416         enddo
10417 !#define DEBUG
10418 #ifdef DEBUG
10419       write (iout,*) "gloc_sc before reduce"
10420       do i=1,nres
10421        do j=1,1
10422         write (iout,*) i,j,gloc_sc(j,i,icg)
10423        enddo
10424       enddo
10425 #endif
10426 !#undef DEBUG
10427         do i=1,nres
10428          do j=1,3
10429           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10430          enddo
10431         enddo
10432         time00=MPI_Wtime()
10433         call MPI_Barrier(FG_COMM,IERR)
10434         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10435         time00=MPI_Wtime()
10436         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10437           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10438         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
10439           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10440         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10441           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10442         time_reduce=time_reduce+MPI_Wtime()-time00
10443         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10444           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10445         time_reduce=time_reduce+MPI_Wtime()-time00
10446 !#define DEBUG
10447 #ifdef DEBUG
10448       write (iout,*) "gloc_sc after reduce"
10449       do i=1,nres
10450        do j=1,1
10451         write (iout,*) i,j,gloc_sc(j,i,icg)
10452        enddo
10453       enddo
10454 #endif
10455 !#undef DEBUG
10456 #ifdef DEBUG
10457       write (iout,*) "gloc after reduce"
10458       do i=1,4*nres
10459         write (iout,*) i,gloc(i,icg)
10460       enddo
10461 #endif
10462       endif
10463 #endif
10464       if (gnorm_check) then
10465 !
10466 ! Compute the maximum elements of the gradient
10467 !
10468       gvdwc_max=0.0d0
10469       gvdwc_scp_max=0.0d0
10470       gelc_max=0.0d0
10471       gvdwpp_max=0.0d0
10472       gradb_max=0.0d0
10473       ghpbc_max=0.0d0
10474       gradcorr_max=0.0d0
10475       gel_loc_max=0.0d0
10476       gcorr3_turn_max=0.0d0
10477       gcorr4_turn_max=0.0d0
10478       gradcorr5_max=0.0d0
10479       gradcorr6_max=0.0d0
10480       gcorr6_turn_max=0.0d0
10481       gsccorc_max=0.0d0
10482       gscloc_max=0.0d0
10483       gvdwx_max=0.0d0
10484       gradx_scp_max=0.0d0
10485       ghpbx_max=0.0d0
10486       gradxorr_max=0.0d0
10487       gsccorx_max=0.0d0
10488       gsclocx_max=0.0d0
10489       do i=1,nct
10490         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10491         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10492         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10493         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10494          gvdwc_scp_max=gvdwc_scp_norm
10495         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10496         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10497         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10498         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10499         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10500         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10501         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10502         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10503         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10504         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10505         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10506         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10507         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10508           gcorr3_turn(1,i)))
10509         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10510           gcorr3_turn_max=gcorr3_turn_norm
10511         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10512           gcorr4_turn(1,i)))
10513         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10514           gcorr4_turn_max=gcorr4_turn_norm
10515         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10516         if (gradcorr5_norm.gt.gradcorr5_max) &
10517           gradcorr5_max=gradcorr5_norm
10518         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10519         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10520         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10521           gcorr6_turn(1,i)))
10522         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10523           gcorr6_turn_max=gcorr6_turn_norm
10524         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10525         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10526         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10527         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10528         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10529         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10530         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10531         if (gradx_scp_norm.gt.gradx_scp_max) &
10532           gradx_scp_max=gradx_scp_norm
10533         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10534         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10535         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10536         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10537         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10538         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10539         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10540         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10541       enddo
10542       if (gradout) then
10543 #ifdef AIX
10544         open(istat,file=statname,position="append")
10545 #else
10546         open(istat,file=statname,access="append")
10547 #endif
10548         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10549            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10550            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10551            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10552            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10553            gsccorx_max,gsclocx_max
10554         close(istat)
10555         if (gvdwc_max.gt.1.0d4) then
10556           write (iout,*) "gvdwc gvdwx gradb gradbx"
10557           do i=nnt,nct
10558             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10559               gradb(j,i),gradbx(j,i),j=1,3)
10560           enddo
10561           call pdbout(0.0d0,'cipiszcze',iout)
10562           call flush(iout)
10563         endif
10564       endif
10565       endif
10566 !el#define DEBUG
10567 #ifdef DEBUG
10568       write (iout,*) "gradc gradx gloc"
10569       do i=1,nres
10570         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10571          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10572       enddo
10573 #endif
10574 !el#undef DEBUG
10575 #ifdef TIMING
10576       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10577 #endif
10578       return
10579       end subroutine sum_gradient
10580 !-----------------------------------------------------------------------------
10581       subroutine sc_grad
10582 !      implicit real*8 (a-h,o-z)
10583       use calc_data
10584 !      include 'DIMENSIONS'
10585 !      include 'COMMON.CHAIN'
10586 !      include 'COMMON.DERIV'
10587 !      include 'COMMON.CALC'
10588 !      include 'COMMON.IOUNITS'
10589       real(kind=8), dimension(3) :: dcosom1,dcosom2
10590
10591       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10592       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10593       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10594            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10595 ! diagnostics only
10596 !      eom1=0.0d0
10597 !      eom2=0.0d0
10598 !      eom12=evdwij*eps1_om12
10599 ! end diagnostics
10600 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10601 !       " sigder",sigder
10602 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10603 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10604 !C      print *,sss_ele_cut,'in sc_grad'
10605       do k=1,3
10606         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10607         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10608       enddo
10609       do k=1,3
10610         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10611 !C      print *,'gg',k,gg(k)
10612        enddo
10613 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10614 !      write (iout,*) "gg",(gg(k),k=1,3)
10615       do k=1,3
10616         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10617                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10618                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10619                   *sss_ele_cut
10620
10621         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10622                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10623                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10624                   *sss_ele_cut
10625
10626 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10627 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10628 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10629 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10630       enddo
10631 !
10632 ! Calculate the components of the gradient in DC and X
10633 !
10634 !grad      do k=i,j-1
10635 !grad        do l=1,3
10636 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10637 !grad        enddo
10638 !grad      enddo
10639       do l=1,3
10640         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10641         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10642       enddo
10643       return
10644       end subroutine sc_grad
10645 #ifdef CRYST_THETA
10646 !-----------------------------------------------------------------------------
10647       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
10648
10649       use comm_calcthet
10650 !      implicit real*8 (a-h,o-z)
10651 !      include 'DIMENSIONS'
10652 !      include 'COMMON.LOCAL'
10653 !      include 'COMMON.IOUNITS'
10654 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
10655 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10656 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
10657       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
10658       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
10659 !el      integer :: it
10660 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
10661 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10662 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
10663 !el local variables
10664
10665       delthec=thetai-thet_pred_mean
10666       delthe0=thetai-theta0i
10667 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
10668       t3 = thetai-thet_pred_mean
10669       t6 = t3**2
10670       t9 = term1
10671       t12 = t3*sigcsq
10672       t14 = t12+t6*sigsqtc
10673       t16 = 1.0d0
10674       t21 = thetai-theta0i
10675       t23 = t21**2
10676       t26 = term2
10677       t27 = t21*t26
10678       t32 = termexp
10679       t40 = t32**2
10680       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
10681        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
10682        *(-t12*t9-ak*sig0inv*t27)
10683       return
10684       end subroutine mixder
10685 #endif
10686 !-----------------------------------------------------------------------------
10687 ! cartder.F
10688 !-----------------------------------------------------------------------------
10689       subroutine cartder
10690 !-----------------------------------------------------------------------------
10691 ! This subroutine calculates the derivatives of the consecutive virtual
10692 ! bond vectors and the SC vectors in the virtual-bond angles theta and
10693 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
10694 ! in the angles alpha and omega, describing the location of a side chain
10695 ! in its local coordinate system.
10696 !
10697 ! The derivatives are stored in the following arrays:
10698 !
10699 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
10700 ! The structure is as follows:
10701 !
10702 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
10703 ! 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)
10704 !         . . . . . . . . . . . .  . . . . . .
10705 ! 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)
10706 !                          .
10707 !                          .
10708 !                          .
10709 ! 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)
10710 !
10711 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
10712 ! The structure is same as above.
10713 !
10714 ! DCDS - the derivatives of the side chain vectors in the local spherical
10715 ! andgles alph and omega:
10716 !
10717 ! 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)
10718 ! 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)
10719 !                          .
10720 !                          .
10721 !                          .
10722 ! 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)
10723 !
10724 ! Version of March '95, based on an early version of November '91.
10725 !
10726 !**********************************************************************
10727 !      implicit real*8 (a-h,o-z)
10728 !      include 'DIMENSIONS'
10729 !      include 'COMMON.VAR'
10730 !      include 'COMMON.CHAIN'
10731 !      include 'COMMON.DERIV'
10732 !      include 'COMMON.GEO'
10733 !      include 'COMMON.LOCAL'
10734 !      include 'COMMON.INTERACT'
10735       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
10736       real(kind=8),dimension(3,3) :: dp,temp
10737 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
10738       real(kind=8),dimension(3) :: xx,xx1
10739 !el local variables
10740       integer :: i,k,l,j,m,ind,ind1,jjj
10741       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
10742                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
10743                  sint2,xp,yp,xxp,yyp,zzp,dj
10744
10745 !      common /przechowalnia/ fromto
10746       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
10747 ! get the position of the jth ijth fragment of the chain coordinate system
10748 ! in the fromto array.
10749 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10750 !
10751 !      maxdim=(nres-1)*(nres-2)/2
10752 !      allocate(dcdv(6,maxdim),dxds(6,nres))
10753 ! calculate the derivatives of transformation matrix elements in theta
10754 !
10755
10756 !el      call flush(iout) !el
10757       do i=1,nres-2
10758         rdt(1,1,i)=-rt(1,2,i)
10759         rdt(1,2,i)= rt(1,1,i)
10760         rdt(1,3,i)= 0.0d0
10761         rdt(2,1,i)=-rt(2,2,i)
10762         rdt(2,2,i)= rt(2,1,i)
10763         rdt(2,3,i)= 0.0d0
10764         rdt(3,1,i)=-rt(3,2,i)
10765         rdt(3,2,i)= rt(3,1,i)
10766         rdt(3,3,i)= 0.0d0
10767       enddo
10768 !
10769 ! derivatives in phi
10770 !
10771       do i=2,nres-2
10772         drt(1,1,i)= 0.0d0
10773         drt(1,2,i)= 0.0d0
10774         drt(1,3,i)= 0.0d0
10775         drt(2,1,i)= rt(3,1,i)
10776         drt(2,2,i)= rt(3,2,i)
10777         drt(2,3,i)= rt(3,3,i)
10778         drt(3,1,i)=-rt(2,1,i)
10779         drt(3,2,i)=-rt(2,2,i)
10780         drt(3,3,i)=-rt(2,3,i)
10781       enddo
10782 !
10783 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
10784 !
10785       do i=2,nres-2
10786         ind=indmat(i,i+1)
10787         do k=1,3
10788           do l=1,3
10789             temp(k,l)=rt(k,l,i)
10790           enddo
10791         enddo
10792         do k=1,3
10793           do l=1,3
10794             fromto(k,l,ind)=temp(k,l)
10795           enddo
10796         enddo
10797         do j=i+1,nres-2
10798           ind=indmat(i,j+1)
10799           do k=1,3
10800             do l=1,3
10801               dpkl=0.0d0
10802               do m=1,3
10803                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
10804               enddo
10805               dp(k,l)=dpkl
10806               fromto(k,l,ind)=dpkl
10807             enddo
10808           enddo
10809           do k=1,3
10810             do l=1,3
10811               temp(k,l)=dp(k,l)
10812             enddo
10813           enddo
10814         enddo
10815       enddo
10816 !
10817 ! Calculate derivatives.
10818 !
10819       ind1=0
10820       do i=1,nres-2
10821         ind1=ind1+1
10822 !
10823 ! Derivatives of DC(i+1) in theta(i+2)
10824 !
10825         do j=1,3
10826           do k=1,2
10827             dpjk=0.0D0
10828             do l=1,3
10829               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
10830             enddo
10831             dp(j,k)=dpjk
10832             prordt(j,k,i)=dp(j,k)
10833           enddo
10834           dp(j,3)=0.0D0
10835           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
10836         enddo
10837 !
10838 ! Derivatives of SC(i+1) in theta(i+2)
10839 !
10840         xx1(1)=-0.5D0*xloc(2,i+1)
10841         xx1(2)= 0.5D0*xloc(1,i+1)
10842         do j=1,3
10843           xj=0.0D0
10844           do k=1,2
10845             xj=xj+r(j,k,i)*xx1(k)
10846           enddo
10847           xx(j)=xj
10848         enddo
10849         do j=1,3
10850           rj=0.0D0
10851           do k=1,3
10852             rj=rj+prod(j,k,i)*xx(k)
10853           enddo
10854           dxdv(j,ind1)=rj
10855         enddo
10856 !
10857 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
10858 ! than the other off-diagonal derivatives.
10859 !
10860         do j=1,3
10861           dxoiij=0.0D0
10862           do k=1,3
10863             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10864           enddo
10865           dxdv(j,ind1+1)=dxoiij
10866         enddo
10867 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
10868 !
10869 ! Derivatives of DC(i+1) in phi(i+2)
10870 !
10871         do j=1,3
10872           do k=1,3
10873             dpjk=0.0
10874             do l=2,3
10875               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
10876             enddo
10877             dp(j,k)=dpjk
10878             prodrt(j,k,i)=dp(j,k)
10879           enddo
10880           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
10881         enddo
10882 !
10883 ! Derivatives of SC(i+1) in phi(i+2)
10884 !
10885         xx(1)= 0.0D0
10886         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
10887         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
10888         do j=1,3
10889           rj=0.0D0
10890           do k=2,3
10891             rj=rj+prod(j,k,i)*xx(k)
10892           enddo
10893           dxdv(j+3,ind1)=-rj
10894         enddo
10895 !
10896 ! Derivatives of SC(i+1) in phi(i+3).
10897 !
10898         do j=1,3
10899           dxoiij=0.0D0
10900           do k=1,3
10901             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10902           enddo
10903           dxdv(j+3,ind1+1)=dxoiij
10904         enddo
10905 !
10906 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
10907 ! theta(nres) and phi(i+3) thru phi(nres).
10908 !
10909         do j=i+1,nres-2
10910           ind1=ind1+1
10911           ind=indmat(i+1,j+1)
10912 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
10913           do k=1,3
10914             do l=1,3
10915               tempkl=0.0D0
10916               do m=1,2
10917                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
10918               enddo
10919               temp(k,l)=tempkl
10920             enddo
10921           enddo
10922 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
10923 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
10924 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
10925 ! Derivatives of virtual-bond vectors in theta
10926           do k=1,3
10927             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
10928           enddo
10929 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
10930 ! Derivatives of SC vectors in theta
10931           do k=1,3
10932             dxoijk=0.0D0
10933             do l=1,3
10934               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10935             enddo
10936             dxdv(k,ind1+1)=dxoijk
10937           enddo
10938 !
10939 !--- Calculate the derivatives in phi
10940 !
10941           do k=1,3
10942             do l=1,3
10943               tempkl=0.0D0
10944               do m=1,3
10945                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
10946               enddo
10947               temp(k,l)=tempkl
10948             enddo
10949           enddo
10950           do k=1,3
10951             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
10952           enddo
10953           do k=1,3
10954             dxoijk=0.0D0
10955             do l=1,3
10956               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10957             enddo
10958             dxdv(k+3,ind1+1)=dxoijk
10959           enddo
10960         enddo
10961       enddo
10962 !
10963 ! Derivatives in alpha and omega:
10964 !
10965       do i=2,nres-1
10966 !       dsci=dsc(itype(i))
10967         dsci=vbld(i+nres)
10968 #ifdef OSF
10969         alphi=alph(i)
10970         omegi=omeg(i)
10971         if(alphi.ne.alphi) alphi=100.0
10972         if(omegi.ne.omegi) omegi=-100.0
10973 #else
10974         alphi=alph(i)
10975         omegi=omeg(i)
10976 #endif
10977 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10978         cosalphi=dcos(alphi)
10979         sinalphi=dsin(alphi)
10980         cosomegi=dcos(omegi)
10981         sinomegi=dsin(omegi)
10982         temp(1,1)=-dsci*sinalphi
10983         temp(2,1)= dsci*cosalphi*cosomegi
10984         temp(3,1)=-dsci*cosalphi*sinomegi
10985         temp(1,2)=0.0D0
10986         temp(2,2)=-dsci*sinalphi*sinomegi
10987         temp(3,2)=-dsci*sinalphi*cosomegi
10988         theta2=pi-0.5D0*theta(i+1)
10989         cost2=dcos(theta2)
10990         sint2=dsin(theta2)
10991         jjj=0
10992 !d      print *,((temp(l,k),l=1,3),k=1,2)
10993         do j=1,2
10994           xp=temp(1,j)
10995           yp=temp(2,j)
10996           xxp= xp*cost2+yp*sint2
10997           yyp=-xp*sint2+yp*cost2
10998           zzp=temp(3,j)
10999           xx(1)=xxp
11000           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11001           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11002           do k=1,3
11003             dj=0.0D0
11004             do l=1,3
11005               dj=dj+prod(k,l,i-1)*xx(l)
11006             enddo
11007             dxds(jjj+k,i)=dj
11008           enddo
11009           jjj=jjj+3
11010         enddo
11011       enddo
11012       return
11013       end subroutine cartder
11014 !-----------------------------------------------------------------------------
11015 ! checkder_p.F
11016 !-----------------------------------------------------------------------------
11017       subroutine check_cartgrad
11018 ! Check the gradient of Cartesian coordinates in internal coordinates.
11019 !      implicit real*8 (a-h,o-z)
11020 !      include 'DIMENSIONS'
11021 !      include 'COMMON.IOUNITS'
11022 !      include 'COMMON.VAR'
11023 !      include 'COMMON.CHAIN'
11024 !      include 'COMMON.GEO'
11025 !      include 'COMMON.LOCAL'
11026 !      include 'COMMON.DERIV'
11027       real(kind=8),dimension(6,nres) :: temp
11028       real(kind=8),dimension(3) :: xx,gg
11029       integer :: i,k,j,ii
11030       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11031 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11032 !
11033 ! Check the gradient of the virtual-bond and SC vectors in the internal
11034 ! coordinates.
11035 !
11036       aincr=1.0d-6
11037       aincr2=5.0d-7
11038       call cartder
11039       write (iout,'(a)') '**************** dx/dalpha'
11040       write (iout,'(a)')
11041       do i=2,nres-1
11042         alphi=alph(i)
11043         alph(i)=alph(i)+aincr
11044         do k=1,3
11045           temp(k,i)=dc(k,nres+i)
11046         enddo
11047         call chainbuild
11048         do k=1,3
11049           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11050           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11051         enddo
11052         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11053         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11054         write (iout,'(a)')
11055         alph(i)=alphi
11056         call chainbuild
11057       enddo
11058       write (iout,'(a)')
11059       write (iout,'(a)') '**************** dx/domega'
11060       write (iout,'(a)')
11061       do i=2,nres-1
11062         omegi=omeg(i)
11063         omeg(i)=omeg(i)+aincr
11064         do k=1,3
11065           temp(k,i)=dc(k,nres+i)
11066         enddo
11067         call chainbuild
11068         do k=1,3
11069           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11070           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11071                 (aincr*dabs(dxds(k+3,i))+aincr))
11072         enddo
11073         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11074             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11075         write (iout,'(a)')
11076         omeg(i)=omegi
11077         call chainbuild
11078       enddo
11079       write (iout,'(a)')
11080       write (iout,'(a)') '**************** dx/dtheta'
11081       write (iout,'(a)')
11082       do i=3,nres
11083         theti=theta(i)
11084         theta(i)=theta(i)+aincr
11085         do j=i-1,nres-1
11086           do k=1,3
11087             temp(k,j)=dc(k,nres+j)
11088           enddo
11089         enddo
11090         call chainbuild
11091         do j=i-1,nres-1
11092           ii = indmat(i-2,j)
11093 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11094           do k=1,3
11095             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11096             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11097                   (aincr*dabs(dxdv(k,ii))+aincr))
11098           enddo
11099           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11100               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11101           write(iout,'(a)')
11102         enddo
11103         write (iout,'(a)')
11104         theta(i)=theti
11105         call chainbuild
11106       enddo
11107       write (iout,'(a)') '***************** dx/dphi'
11108       write (iout,'(a)')
11109       do i=4,nres
11110         phi(i)=phi(i)+aincr
11111         do j=i-1,nres-1
11112           do k=1,3
11113             temp(k,j)=dc(k,nres+j)
11114           enddo
11115         enddo
11116         call chainbuild
11117         do j=i-1,nres-1
11118           ii = indmat(i-2,j)
11119 !         print *,'ii=',ii
11120           do k=1,3
11121             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11122             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11123                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11124           enddo
11125           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11126               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11127           write(iout,'(a)')
11128         enddo
11129         phi(i)=phi(i)-aincr
11130         call chainbuild
11131       enddo
11132       write (iout,'(a)') '****************** ddc/dtheta'
11133       do i=1,nres-2
11134         thet=theta(i+2)
11135         theta(i+2)=thet+aincr
11136         do j=i,nres
11137           do k=1,3
11138             temp(k,j)=dc(k,j)
11139           enddo
11140         enddo
11141         call chainbuild
11142         do j=i+1,nres-1
11143           ii = indmat(i,j)
11144 !         print *,'ii=',ii
11145           do k=1,3
11146             gg(k)=(dc(k,j)-temp(k,j))/aincr
11147             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11148                  (aincr*dabs(dcdv(k,ii))+aincr))
11149           enddo
11150           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11151                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11152           write (iout,'(a)')
11153         enddo
11154         do j=1,nres
11155           do k=1,3
11156             dc(k,j)=temp(k,j)
11157           enddo
11158         enddo
11159         theta(i+2)=thet
11160       enddo
11161       write (iout,'(a)') '******************* ddc/dphi'
11162       do i=1,nres-3
11163         phii=phi(i+3)
11164         phi(i+3)=phii+aincr
11165         do j=1,nres
11166           do k=1,3
11167             temp(k,j)=dc(k,j)
11168           enddo
11169         enddo
11170         call chainbuild
11171         do j=i+2,nres-1
11172           ii = indmat(i+1,j)
11173 !         print *,'ii=',ii
11174           do k=1,3
11175             gg(k)=(dc(k,j)-temp(k,j))/aincr
11176             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11177                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11178           enddo
11179           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11180                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11181           write (iout,'(a)')
11182         enddo
11183         do j=1,nres
11184           do k=1,3
11185             dc(k,j)=temp(k,j)
11186           enddo
11187         enddo
11188         phi(i+3)=phii
11189       enddo
11190       return
11191       end subroutine check_cartgrad
11192 !-----------------------------------------------------------------------------
11193       subroutine check_ecart
11194 ! Check the gradient of the energy in Cartesian coordinates.
11195 !     implicit real*8 (a-h,o-z)
11196 !     include 'DIMENSIONS'
11197 !     include 'COMMON.CHAIN'
11198 !     include 'COMMON.DERIV'
11199 !     include 'COMMON.IOUNITS'
11200 !     include 'COMMON.VAR'
11201 !     include 'COMMON.CONTACTS'
11202       use comm_srutu
11203 !el      integer :: icall
11204 !el      common /srutu/ icall
11205       real(kind=8),dimension(6) :: ggg
11206       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11207       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11208       real(kind=8),dimension(6,nres) :: grad_s
11209       real(kind=8),dimension(0:n_ene) :: energia,energia1
11210       integer :: uiparm(1)
11211       real(kind=8) :: urparm(1)
11212 !EL      external fdum
11213       integer :: nf,i,j,k
11214       real(kind=8) :: aincr,etot,etot1
11215       icg=1
11216       nf=0
11217       nfl=0
11218       call zerograd
11219       aincr=1.0D-5
11220       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11221       nf=0
11222       icall=0
11223       call geom_to_var(nvar,x)
11224       call etotal(energia)
11225       etot=energia(0)
11226 !el      call enerprint(energia)
11227       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11228       icall =1
11229       do i=1,nres
11230         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11231       enddo
11232       do i=1,nres
11233         do j=1,3
11234           grad_s(j,i)=gradc(j,i,icg)
11235           grad_s(j+3,i)=gradx(j,i,icg)
11236         enddo
11237       enddo
11238       call flush(iout)
11239       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11240       do i=1,nres
11241         do j=1,3
11242           xx(j)=c(j,i+nres)
11243           ddc(j)=dc(j,i)
11244           ddx(j)=dc(j,i+nres)
11245         enddo
11246         do j=1,3
11247           dc(j,i)=dc(j,i)+aincr
11248           do k=i+1,nres
11249             c(j,k)=c(j,k)+aincr
11250             c(j,k+nres)=c(j,k+nres)+aincr
11251           enddo
11252           call etotal(energia1)
11253           etot1=energia1(0)
11254           ggg(j)=(etot1-etot)/aincr
11255           dc(j,i)=ddc(j)
11256           do k=i+1,nres
11257             c(j,k)=c(j,k)-aincr
11258             c(j,k+nres)=c(j,k+nres)-aincr
11259           enddo
11260         enddo
11261         do j=1,3
11262           c(j,i+nres)=c(j,i+nres)+aincr
11263           dc(j,i+nres)=dc(j,i+nres)+aincr
11264           call etotal(energia1)
11265           etot1=energia1(0)
11266           ggg(j+3)=(etot1-etot)/aincr
11267           c(j,i+nres)=xx(j)
11268           dc(j,i+nres)=ddx(j)
11269         enddo
11270         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11271          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11272       enddo
11273       return
11274       end subroutine check_ecart
11275 #ifdef CARGRAD
11276 !-----------------------------------------------------------------------------
11277       subroutine check_ecartint
11278 ! Check the gradient of the energy in Cartesian coordinates.
11279       use io_base, only: intout
11280 !      implicit real*8 (a-h,o-z)
11281 !      include 'DIMENSIONS'
11282 !      include 'COMMON.CONTROL'
11283 !      include 'COMMON.CHAIN'
11284 !      include 'COMMON.DERIV'
11285 !      include 'COMMON.IOUNITS'
11286 !      include 'COMMON.VAR'
11287 !      include 'COMMON.CONTACTS'
11288 !      include 'COMMON.MD'
11289 !      include 'COMMON.LOCAL'
11290 !      include 'COMMON.SPLITELE'
11291       use comm_srutu
11292 !el      integer :: icall
11293 !el      common /srutu/ icall
11294       real(kind=8),dimension(6) :: ggg,ggg1
11295       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11296       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11297       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11298       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11299       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11300       real(kind=8),dimension(0:n_ene) :: energia,energia1
11301       integer :: uiparm(1)
11302       real(kind=8) :: urparm(1)
11303 !EL      external fdum
11304       integer :: i,j,k,nf
11305       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11306                    etot21,etot22
11307       r_cut=2.0d0
11308       rlambd=0.3d0
11309       icg=1
11310       nf=0
11311       nfl=0
11312       call intout
11313 !      call intcartderiv
11314 !      call checkintcartgrad
11315       call zerograd
11316       aincr=1.0D-5
11317       write(iout,*) 'Calling CHECK_ECARTINT.'
11318       nf=0
11319       icall=0
11320       write (iout,*) "Before geom_to_var"
11321       call geom_to_var(nvar,x)
11322       write (iout,*) "after geom_to_var"
11323       write (iout,*) "split_ene ",split_ene
11324       call flush(iout)
11325       if (.not.split_ene) then
11326         write(iout,*) 'Calling CHECK_ECARTINT if'
11327         call etotal(energia)
11328 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11329         etot=energia(0)
11330         write (iout,*) "etot",etot
11331         call flush(iout)
11332 !el        call enerprint(energia)
11333 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11334         call flush(iout)
11335         write (iout,*) "enter cartgrad"
11336         call flush(iout)
11337         call cartgrad
11338 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11339         write (iout,*) "exit cartgrad"
11340         call flush(iout)
11341         icall =1
11342         do i=1,nres
11343           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11344         enddo
11345         do j=1,3
11346           grad_s(j,0)=gcart(j,0)
11347         enddo
11348 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11349         do i=1,nres
11350           do j=1,3
11351             grad_s(j,i)=gcart(j,i)
11352             grad_s(j+3,i)=gxcart(j,i)
11353           enddo
11354         enddo
11355       else
11356 write(iout,*) 'Calling CHECK_ECARTIN else.'
11357 !- split gradient check
11358         call zerograd
11359         call etotal_long(energia)
11360 !el        call enerprint(energia)
11361         call flush(iout)
11362         write (iout,*) "enter cartgrad"
11363         call flush(iout)
11364         call cartgrad
11365         write (iout,*) "exit cartgrad"
11366         call flush(iout)
11367         icall =1
11368         write (iout,*) "longrange grad"
11369         do i=1,nres
11370           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11371           (gxcart(j,i),j=1,3)
11372         enddo
11373         do j=1,3
11374           grad_s(j,0)=gcart(j,0)
11375         enddo
11376         do i=1,nres
11377           do j=1,3
11378             grad_s(j,i)=gcart(j,i)
11379             grad_s(j+3,i)=gxcart(j,i)
11380           enddo
11381         enddo
11382         call zerograd
11383         call etotal_short(energia)
11384 !el        call enerprint(energia)
11385         call flush(iout)
11386         write (iout,*) "enter cartgrad"
11387         call flush(iout)
11388         call cartgrad
11389         write (iout,*) "exit cartgrad"
11390         call flush(iout)
11391         icall =1
11392         write (iout,*) "shortrange grad"
11393         do i=1,nres
11394           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11395           (gxcart(j,i),j=1,3)
11396         enddo
11397         do j=1,3
11398           grad_s1(j,0)=gcart(j,0)
11399         enddo
11400         do i=1,nres
11401           do j=1,3
11402             grad_s1(j,i)=gcart(j,i)
11403             grad_s1(j+3,i)=gxcart(j,i)
11404           enddo
11405         enddo
11406       endif
11407       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11408 !      do i=1,nres
11409       do i=nnt,nct
11410         do j=1,3
11411           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11412           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11413           ddc(j)=c(j,i)
11414           ddx(j)=c(j,i+nres)
11415           dcnorm_safe1(j)=dc_norm(j,i-1)
11416           dcnorm_safe2(j)=dc_norm(j,i)
11417           dxnorm_safe(j)=dc_norm(j,i+nres)
11418         enddo
11419         do j=1,3
11420           c(j,i)=ddc(j)+aincr
11421           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11422           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11423           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11424           dc(j,i)=c(j,i+1)-c(j,i)
11425           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11426           call int_from_cart1(.false.)
11427           if (.not.split_ene) then
11428             call etotal(energia1)
11429             etot1=energia1(0)
11430             write (iout,*) "ij",i,j," etot1",etot1
11431           else
11432 !- split gradient
11433             call etotal_long(energia1)
11434             etot11=energia1(0)
11435             call etotal_short(energia1)
11436             etot12=energia1(0)
11437           endif
11438 !- end split gradient
11439 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11440           c(j,i)=ddc(j)-aincr
11441           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11442           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11443           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11444           dc(j,i)=c(j,i+1)-c(j,i)
11445           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11446           call int_from_cart1(.false.)
11447           if (.not.split_ene) then
11448             call etotal(energia1)
11449             etot2=energia1(0)
11450             write (iout,*) "ij",i,j," etot2",etot2
11451             ggg(j)=(etot1-etot2)/(2*aincr)
11452           else
11453 !- split gradient
11454             call etotal_long(energia1)
11455             etot21=energia1(0)
11456             ggg(j)=(etot11-etot21)/(2*aincr)
11457             call etotal_short(energia1)
11458             etot22=energia1(0)
11459             ggg1(j)=(etot12-etot22)/(2*aincr)
11460 !- end split gradient
11461 !            write (iout,*) "etot21",etot21," etot22",etot22
11462           endif
11463 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11464           c(j,i)=ddc(j)
11465           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11466           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11467           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11468           dc(j,i)=c(j,i+1)-c(j,i)
11469           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11470           dc_norm(j,i-1)=dcnorm_safe1(j)
11471           dc_norm(j,i)=dcnorm_safe2(j)
11472           dc_norm(j,i+nres)=dxnorm_safe(j)
11473         enddo
11474         do j=1,3
11475           c(j,i+nres)=ddx(j)+aincr
11476           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11477           call int_from_cart1(.false.)
11478           if (.not.split_ene) then
11479             call etotal(energia1)
11480             etot1=energia1(0)
11481           else
11482 !- split gradient
11483             call etotal_long(energia1)
11484             etot11=energia1(0)
11485             call etotal_short(energia1)
11486             etot12=energia1(0)
11487           endif
11488 !- end split gradient
11489           c(j,i+nres)=ddx(j)-aincr
11490           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11491           call int_from_cart1(.false.)
11492           if (.not.split_ene) then
11493             call etotal(energia1)
11494             etot2=energia1(0)
11495             ggg(j+3)=(etot1-etot2)/(2*aincr)
11496           else
11497 !- split gradient
11498             call etotal_long(energia1)
11499             etot21=energia1(0)
11500             ggg(j+3)=(etot11-etot21)/(2*aincr)
11501             call etotal_short(energia1)
11502             etot22=energia1(0)
11503             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11504 !- end split gradient
11505           endif
11506 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11507           c(j,i+nres)=ddx(j)
11508           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11509           dc_norm(j,i+nres)=dxnorm_safe(j)
11510           call int_from_cart1(.false.)
11511         enddo
11512         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11513          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11514         if (split_ene) then
11515           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11516          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11517          k=1,6)
11518          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11519          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11520          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11521         endif
11522       enddo
11523       return
11524       end subroutine check_ecartint
11525 #else
11526 !-----------------------------------------------------------------------------
11527       subroutine check_ecartint
11528 ! Check the gradient of the energy in Cartesian coordinates.
11529       use io_base, only: intout
11530 !      implicit real*8 (a-h,o-z)
11531 !      include 'DIMENSIONS'
11532 !      include 'COMMON.CONTROL'
11533 !      include 'COMMON.CHAIN'
11534 !      include 'COMMON.DERIV'
11535 !      include 'COMMON.IOUNITS'
11536 !      include 'COMMON.VAR'
11537 !      include 'COMMON.CONTACTS'
11538 !      include 'COMMON.MD'
11539 !      include 'COMMON.LOCAL'
11540 !      include 'COMMON.SPLITELE'
11541       use comm_srutu
11542 !el      integer :: icall
11543 !el      common /srutu/ icall
11544       real(kind=8),dimension(6) :: ggg,ggg1
11545       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11546       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11547       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11548       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11549       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11550       real(kind=8),dimension(0:n_ene) :: energia,energia1
11551       integer :: uiparm(1)
11552       real(kind=8) :: urparm(1)
11553 !EL      external fdum
11554       integer :: i,j,k,nf
11555       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11556                    etot21,etot22
11557       r_cut=2.0d0
11558       rlambd=0.3d0
11559       icg=1
11560       nf=0
11561       nfl=0
11562       call intout
11563 !      call intcartderiv
11564 !      call checkintcartgrad
11565       call zerograd
11566       aincr=2.0D-5
11567       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11568       nf=0
11569       icall=0
11570       call geom_to_var(nvar,x)
11571       if (.not.split_ene) then
11572         call etotal(energia)
11573         etot=energia(0)
11574 !el        call enerprint(energia)
11575         call flush(iout)
11576         write (iout,*) "enter cartgrad"
11577         call flush(iout)
11578         call cartgrad
11579         write (iout,*) "exit cartgrad"
11580         call flush(iout)
11581         icall =1
11582         do i=1,nres
11583           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11584         enddo
11585         do j=1,3
11586           grad_s(j,0)=gcart(j,0)
11587         enddo
11588         do i=1,nres
11589           do j=1,3
11590             grad_s(j,i)=gcart(j,i)
11591             grad_s(j+3,i)=gxcart(j,i)
11592           enddo
11593         enddo
11594       else
11595 !- split gradient check
11596         call zerograd
11597         call etotal_long(energia)
11598 !el        call enerprint(energia)
11599         call flush(iout)
11600         write (iout,*) "enter cartgrad"
11601         call flush(iout)
11602         call cartgrad
11603         write (iout,*) "exit cartgrad"
11604         call flush(iout)
11605         icall =1
11606         write (iout,*) "longrange grad"
11607         do i=1,nres
11608           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11609           (gxcart(j,i),j=1,3)
11610         enddo
11611         do j=1,3
11612           grad_s(j,0)=gcart(j,0)
11613         enddo
11614         do i=1,nres
11615           do j=1,3
11616             grad_s(j,i)=gcart(j,i)
11617             grad_s(j+3,i)=gxcart(j,i)
11618           enddo
11619         enddo
11620         call zerograd
11621         call etotal_short(energia)
11622 !el        call enerprint(energia)
11623         call flush(iout)
11624         write (iout,*) "enter cartgrad"
11625         call flush(iout)
11626         call cartgrad
11627         write (iout,*) "exit cartgrad"
11628         call flush(iout)
11629         icall =1
11630         write (iout,*) "shortrange grad"
11631         do i=1,nres
11632           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11633           (gxcart(j,i),j=1,3)
11634         enddo
11635         do j=1,3
11636           grad_s1(j,0)=gcart(j,0)
11637         enddo
11638         do i=1,nres
11639           do j=1,3
11640             grad_s1(j,i)=gcart(j,i)
11641             grad_s1(j+3,i)=gxcart(j,i)
11642           enddo
11643         enddo
11644       endif
11645       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11646       do i=0,nres
11647         do j=1,3
11648           xx(j)=c(j,i+nres)
11649           ddc(j)=dc(j,i)
11650           ddx(j)=dc(j,i+nres)
11651           do k=1,3
11652             dcnorm_safe(k)=dc_norm(k,i)
11653             dxnorm_safe(k)=dc_norm(k,i+nres)
11654           enddo
11655         enddo
11656         do j=1,3
11657           dc(j,i)=ddc(j)+aincr
11658           call chainbuild_cart
11659 #ifdef MPI
11660 ! Broadcast the order to compute internal coordinates to the slaves.
11661 !          if (nfgtasks.gt.1)
11662 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
11663 #endif
11664 !          call int_from_cart1(.false.)
11665           if (.not.split_ene) then
11666             call etotal(energia1)
11667             etot1=energia1(0)
11668           else
11669 !- split gradient
11670             call etotal_long(energia1)
11671             etot11=energia1(0)
11672             call etotal_short(energia1)
11673             etot12=energia1(0)
11674 !            write (iout,*) "etot11",etot11," etot12",etot12
11675           endif
11676 !- end split gradient
11677 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11678           dc(j,i)=ddc(j)-aincr
11679           call chainbuild_cart
11680 !          call int_from_cart1(.false.)
11681           if (.not.split_ene) then
11682             call etotal(energia1)
11683             etot2=energia1(0)
11684             ggg(j)=(etot1-etot2)/(2*aincr)
11685           else
11686 !- split gradient
11687             call etotal_long(energia1)
11688             etot21=energia1(0)
11689             ggg(j)=(etot11-etot21)/(2*aincr)
11690             call etotal_short(energia1)
11691             etot22=energia1(0)
11692             ggg1(j)=(etot12-etot22)/(2*aincr)
11693 !- end split gradient
11694 !            write (iout,*) "etot21",etot21," etot22",etot22
11695           endif
11696 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11697           dc(j,i)=ddc(j)
11698           call chainbuild_cart
11699         enddo
11700         do j=1,3
11701           dc(j,i+nres)=ddx(j)+aincr
11702           call chainbuild_cart
11703 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
11704 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11705 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11706 !          write (iout,*) "dxnormnorm",dsqrt(
11707 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11708 !          write (iout,*) "dxnormnormsafe",dsqrt(
11709 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11710 !          write (iout,*)
11711           if (.not.split_ene) then
11712             call etotal(energia1)
11713             etot1=energia1(0)
11714           else
11715 !- split gradient
11716             call etotal_long(energia1)
11717             etot11=energia1(0)
11718             call etotal_short(energia1)
11719             etot12=energia1(0)
11720           endif
11721 !- end split gradient
11722 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11723           dc(j,i+nres)=ddx(j)-aincr
11724           call chainbuild_cart
11725 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
11726 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11727 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11728 !          write (iout,*)
11729 !          write (iout,*) "dxnormnorm",dsqrt(
11730 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11731 !          write (iout,*) "dxnormnormsafe",dsqrt(
11732 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11733           if (.not.split_ene) then
11734             call etotal(energia1)
11735             etot2=energia1(0)
11736             ggg(j+3)=(etot1-etot2)/(2*aincr)
11737           else
11738 !- split gradient
11739             call etotal_long(energia1)
11740             etot21=energia1(0)
11741             ggg(j+3)=(etot11-etot21)/(2*aincr)
11742             call etotal_short(energia1)
11743             etot22=energia1(0)
11744             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11745 !- end split gradient
11746           endif
11747 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11748           dc(j,i+nres)=ddx(j)
11749           call chainbuild_cart
11750         enddo
11751         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11752          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11753         if (split_ene) then
11754           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11755          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11756          k=1,6)
11757          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11758          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11759          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11760         endif
11761       enddo
11762       return
11763       end subroutine check_ecartint
11764 #endif
11765 !-----------------------------------------------------------------------------
11766       subroutine check_eint
11767 ! Check the gradient of energy in internal coordinates.
11768 !      implicit real*8 (a-h,o-z)
11769 !      include 'DIMENSIONS'
11770 !      include 'COMMON.CHAIN'
11771 !      include 'COMMON.DERIV'
11772 !      include 'COMMON.IOUNITS'
11773 !      include 'COMMON.VAR'
11774 !      include 'COMMON.GEO'
11775       use comm_srutu
11776 !el      integer :: icall
11777 !el      common /srutu/ icall
11778       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
11779       integer :: uiparm(1)
11780       real(kind=8) :: urparm(1)
11781       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
11782       character(len=6) :: key
11783 !EL      external fdum
11784       integer :: i,ii,nf
11785       real(kind=8) :: xi,aincr,etot,etot1,etot2
11786       call zerograd
11787       aincr=1.0D-7
11788       print '(a)','Calling CHECK_INT.'
11789       nf=0
11790       nfl=0
11791       icg=1
11792       call geom_to_var(nvar,x)
11793       call var_to_geom(nvar,x)
11794       call chainbuild
11795       icall=1
11796       print *,'ICG=',ICG
11797       call etotal(energia)
11798       etot = energia(0)
11799 !el      call enerprint(energia)
11800       print *,'ICG=',ICG
11801 #ifdef MPL
11802       if (MyID.ne.BossID) then
11803         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
11804         nf=x(nvar+1)
11805         nfl=x(nvar+2)
11806         icg=x(nvar+3)
11807       endif
11808 #endif
11809       nf=1
11810       nfl=3
11811 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
11812       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
11813 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
11814       icall=1
11815       do i=1,nvar
11816         xi=x(i)
11817         x(i)=xi-0.5D0*aincr
11818         call var_to_geom(nvar,x)
11819         call chainbuild
11820         call etotal(energia1)
11821         etot1=energia1(0)
11822         x(i)=xi+0.5D0*aincr
11823         call var_to_geom(nvar,x)
11824         call chainbuild
11825         call etotal(energia2)
11826         etot2=energia2(0)
11827         gg(i)=(etot2-etot1)/aincr
11828         write (iout,*) i,etot1,etot2
11829         x(i)=xi
11830       enddo
11831       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
11832           '     RelDiff*100% '
11833       do i=1,nvar
11834         if (i.le.nphi) then
11835           ii=i
11836           key = ' phi'
11837         else if (i.le.nphi+ntheta) then
11838           ii=i-nphi
11839           key=' theta'
11840         else if (i.le.nphi+ntheta+nside) then
11841            ii=i-(nphi+ntheta)
11842            key=' alpha'
11843         else
11844            ii=i-(nphi+ntheta+nside)
11845            key=' omega'
11846         endif
11847         write (iout,'(i3,a,i3,3(1pd16.6))') &
11848        i,key,ii,gg(i),gana(i),&
11849        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
11850       enddo
11851       return
11852       end subroutine check_eint
11853 !-----------------------------------------------------------------------------
11854 ! econstr_local.F
11855 !-----------------------------------------------------------------------------
11856       subroutine Econstr_back
11857 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
11858 !      implicit real*8 (a-h,o-z)
11859 !      include 'DIMENSIONS'
11860 !      include 'COMMON.CONTROL'
11861 !      include 'COMMON.VAR'
11862 !      include 'COMMON.MD'
11863       use MD_data
11864 !#ifndef LANG0
11865 !      include 'COMMON.LANGEVIN'
11866 !#else
11867 !      include 'COMMON.LANGEVIN.lang0'
11868 !#endif
11869 !      include 'COMMON.CHAIN'
11870 !      include 'COMMON.DERIV'
11871 !      include 'COMMON.GEO'
11872 !      include 'COMMON.LOCAL'
11873 !      include 'COMMON.INTERACT'
11874 !      include 'COMMON.IOUNITS'
11875 !      include 'COMMON.NAMES'
11876 !      include 'COMMON.TIME1'
11877       integer :: i,j,ii,k
11878       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
11879
11880       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
11881       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
11882       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
11883
11884       Uconst_back=0.0d0
11885       do i=1,nres
11886         dutheta(i)=0.0d0
11887         dugamma(i)=0.0d0
11888         do j=1,3
11889           duscdiff(j,i)=0.0d0
11890           duscdiffx(j,i)=0.0d0
11891         enddo
11892       enddo
11893       do i=1,nfrag_back
11894         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
11895 !
11896 ! Deviations from theta angles
11897 !
11898         utheta_i=0.0d0
11899         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
11900           dtheta_i=theta(j)-thetaref(j)
11901           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
11902           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
11903         enddo
11904         utheta(i)=utheta_i/(ii-1)
11905 !
11906 ! Deviations from gamma angles
11907 !
11908         ugamma_i=0.0d0
11909         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
11910           dgamma_i=pinorm(phi(j)-phiref(j))
11911 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
11912           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
11913           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
11914 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
11915         enddo
11916         ugamma(i)=ugamma_i/(ii-2)
11917 !
11918 ! Deviations from local SC geometry
11919 !
11920         uscdiff(i)=0.0d0
11921         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
11922           dxx=xxtab(j)-xxref(j)
11923           dyy=yytab(j)-yyref(j)
11924           dzz=zztab(j)-zzref(j)
11925           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
11926           do k=1,3
11927             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
11928              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
11929              (ii-1)
11930             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
11931              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
11932              (ii-1)
11933             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
11934            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
11935             /(ii-1)
11936           enddo
11937 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
11938 !     &      xxref(j),yyref(j),zzref(j)
11939         enddo
11940         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
11941 !        write (iout,*) i," uscdiff",uscdiff(i)
11942 !
11943 ! Put together deviations from local geometry
11944 !
11945         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
11946           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
11947 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
11948 !     &   " uconst_back",uconst_back
11949         utheta(i)=dsqrt(utheta(i))
11950         ugamma(i)=dsqrt(ugamma(i))
11951         uscdiff(i)=dsqrt(uscdiff(i))
11952       enddo
11953       return
11954       end subroutine Econstr_back
11955 !-----------------------------------------------------------------------------
11956 ! energy_p_new-sep_barrier.F
11957 !-----------------------------------------------------------------------------
11958       real(kind=8) function sscale(r)
11959 !      include "COMMON.SPLITELE"
11960       real(kind=8) :: r,gamm
11961       if(r.lt.r_cut-rlamb) then
11962         sscale=1.0d0
11963       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11964         gamm=(r-(r_cut-rlamb))/rlamb
11965         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11966       else
11967         sscale=0d0
11968       endif
11969       return
11970       end function sscale
11971       real(kind=8) function sscale_grad(r)
11972 !      include "COMMON.SPLITELE"
11973       real(kind=8) :: r,gamm
11974       if(r.lt.r_cut-rlamb) then
11975         sscale_grad=0.0d0
11976       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11977         gamm=(r-(r_cut-rlamb))/rlamb
11978         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
11979       else
11980         sscale_grad=0d0
11981       endif
11982       return
11983       end function sscale_grad
11984
11985 !!!!!!!!!! PBCSCALE
11986       real(kind=8) function sscale_ele(r)
11987 !      include "COMMON.SPLITELE"
11988       real(kind=8) :: r,gamm
11989       if(r.lt.r_cut_ele-rlamb_ele) then
11990         sscale_ele=1.0d0
11991       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11992         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11993         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11994       else
11995         sscale_ele=0d0
11996       endif
11997       return
11998       end function sscale_ele
11999
12000       real(kind=8)  function sscagrad_ele(r)
12001       real(kind=8) :: r,gamm
12002 !      include "COMMON.SPLITELE"
12003       if(r.lt.r_cut_ele-rlamb_ele) then
12004         sscagrad_ele=0.0d0
12005       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12006         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12007         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12008       else
12009         sscagrad_ele=0.0d0
12010       endif
12011       return
12012       end function sscagrad_ele
12013       real(kind=8) function sscalelip(r)
12014       real(kind=8) r,gamm
12015         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12016       return
12017       end function sscalelip
12018 !C-----------------------------------------------------------------------
12019       real(kind=8) function sscagradlip(r)
12020       real(kind=8) r,gamm
12021         sscagradlip=r*(6.0d0*r-6.0d0)
12022       return
12023       end function sscagradlip
12024
12025 !!!!!!!!!!!!!!!
12026 !-----------------------------------------------------------------------------
12027       subroutine elj_long(evdw)
12028 !
12029 ! This subroutine calculates the interaction energy of nonbonded side chains
12030 ! assuming the LJ potential of interaction.
12031 !
12032 !      implicit real*8 (a-h,o-z)
12033 !      include 'DIMENSIONS'
12034 !      include 'COMMON.GEO'
12035 !      include 'COMMON.VAR'
12036 !      include 'COMMON.LOCAL'
12037 !      include 'COMMON.CHAIN'
12038 !      include 'COMMON.DERIV'
12039 !      include 'COMMON.INTERACT'
12040 !      include 'COMMON.TORSION'
12041 !      include 'COMMON.SBRIDGE'
12042 !      include 'COMMON.NAMES'
12043 !      include 'COMMON.IOUNITS'
12044 !      include 'COMMON.CONTACTS'
12045       real(kind=8),parameter :: accur=1.0d-10
12046       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12047 !el local variables
12048       integer :: i,iint,j,k,itypi,itypi1,itypj
12049       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12050       real(kind=8) :: e1,e2,evdwij,evdw
12051 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12052       evdw=0.0D0
12053       do i=iatsc_s,iatsc_e
12054         itypi=itype(i)
12055         if (itypi.eq.ntyp1) cycle
12056         itypi1=itype(i+1)
12057         xi=c(1,nres+i)
12058         yi=c(2,nres+i)
12059         zi=c(3,nres+i)
12060 !
12061 ! Calculate SC interaction energy.
12062 !
12063         do iint=1,nint_gr(i)
12064 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12065 !d   &                  'iend=',iend(i,iint)
12066           do j=istart(i,iint),iend(i,iint)
12067             itypj=itype(j)
12068             if (itypj.eq.ntyp1) cycle
12069             xj=c(1,nres+j)-xi
12070             yj=c(2,nres+j)-yi
12071             zj=c(3,nres+j)-zi
12072             rij=xj*xj+yj*yj+zj*zj
12073             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12074             if (sss.lt.1.0d0) then
12075               rrij=1.0D0/rij
12076               eps0ij=eps(itypi,itypj)
12077               fac=rrij**expon2
12078               e1=fac*fac*aa_aq(itypi,itypj)
12079               e2=fac*bb_aq(itypi,itypj)
12080               evdwij=e1+e2
12081               evdw=evdw+(1.0d0-sss)*evdwij
12082 !
12083 ! Calculate the components of the gradient in DC and X
12084 !
12085               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12086               gg(1)=xj*fac
12087               gg(2)=yj*fac
12088               gg(3)=zj*fac
12089               do k=1,3
12090                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12091                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12092                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12093                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12094               enddo
12095             endif
12096           enddo      ! j
12097         enddo        ! iint
12098       enddo          ! i
12099       do i=1,nct
12100         do j=1,3
12101           gvdwc(j,i)=expon*gvdwc(j,i)
12102           gvdwx(j,i)=expon*gvdwx(j,i)
12103         enddo
12104       enddo
12105 !******************************************************************************
12106 !
12107 !                              N O T E !!!
12108 !
12109 ! To save time, the factor of EXPON has been extracted from ALL components
12110 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12111 ! use!
12112 !
12113 !******************************************************************************
12114       return
12115       end subroutine elj_long
12116 !-----------------------------------------------------------------------------
12117       subroutine elj_short(evdw)
12118 !
12119 ! This subroutine calculates the interaction energy of nonbonded side chains
12120 ! assuming the LJ potential of interaction.
12121 !
12122 !      implicit real*8 (a-h,o-z)
12123 !      include 'DIMENSIONS'
12124 !      include 'COMMON.GEO'
12125 !      include 'COMMON.VAR'
12126 !      include 'COMMON.LOCAL'
12127 !      include 'COMMON.CHAIN'
12128 !      include 'COMMON.DERIV'
12129 !      include 'COMMON.INTERACT'
12130 !      include 'COMMON.TORSION'
12131 !      include 'COMMON.SBRIDGE'
12132 !      include 'COMMON.NAMES'
12133 !      include 'COMMON.IOUNITS'
12134 !      include 'COMMON.CONTACTS'
12135       real(kind=8),parameter :: accur=1.0d-10
12136       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12137 !el local variables
12138       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12139       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12140       real(kind=8) :: e1,e2,evdwij,evdw
12141 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12142       evdw=0.0D0
12143       do i=iatsc_s,iatsc_e
12144         itypi=itype(i)
12145         if (itypi.eq.ntyp1) cycle
12146         itypi1=itype(i+1)
12147         xi=c(1,nres+i)
12148         yi=c(2,nres+i)
12149         zi=c(3,nres+i)
12150 ! Change 12/1/95
12151         num_conti=0
12152 !
12153 ! Calculate SC interaction energy.
12154 !
12155         do iint=1,nint_gr(i)
12156 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12157 !d   &                  'iend=',iend(i,iint)
12158           do j=istart(i,iint),iend(i,iint)
12159             itypj=itype(j)
12160             if (itypj.eq.ntyp1) cycle
12161             xj=c(1,nres+j)-xi
12162             yj=c(2,nres+j)-yi
12163             zj=c(3,nres+j)-zi
12164 ! Change 12/1/95 to calculate four-body interactions
12165             rij=xj*xj+yj*yj+zj*zj
12166             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12167             if (sss.gt.0.0d0) then
12168               rrij=1.0D0/rij
12169               eps0ij=eps(itypi,itypj)
12170               fac=rrij**expon2
12171               e1=fac*fac*aa_aq(itypi,itypj)
12172               e2=fac*bb_aq(itypi,itypj)
12173               evdwij=e1+e2
12174               evdw=evdw+sss*evdwij
12175 !
12176 ! Calculate the components of the gradient in DC and X
12177 !
12178               fac=-rrij*(e1+evdwij)*sss
12179               gg(1)=xj*fac
12180               gg(2)=yj*fac
12181               gg(3)=zj*fac
12182               do k=1,3
12183                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12184                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12185                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12186                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12187               enddo
12188             endif
12189           enddo      ! j
12190         enddo        ! iint
12191       enddo          ! i
12192       do i=1,nct
12193         do j=1,3
12194           gvdwc(j,i)=expon*gvdwc(j,i)
12195           gvdwx(j,i)=expon*gvdwx(j,i)
12196         enddo
12197       enddo
12198 !******************************************************************************
12199 !
12200 !                              N O T E !!!
12201 !
12202 ! To save time, the factor of EXPON has been extracted from ALL components
12203 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12204 ! use!
12205 !
12206 !******************************************************************************
12207       return
12208       end subroutine elj_short
12209 !-----------------------------------------------------------------------------
12210       subroutine eljk_long(evdw)
12211 !
12212 ! This subroutine calculates the interaction energy of nonbonded side chains
12213 ! assuming the LJK potential of interaction.
12214 !
12215 !      implicit real*8 (a-h,o-z)
12216 !      include 'DIMENSIONS'
12217 !      include 'COMMON.GEO'
12218 !      include 'COMMON.VAR'
12219 !      include 'COMMON.LOCAL'
12220 !      include 'COMMON.CHAIN'
12221 !      include 'COMMON.DERIV'
12222 !      include 'COMMON.INTERACT'
12223 !      include 'COMMON.IOUNITS'
12224 !      include 'COMMON.NAMES'
12225       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12226       logical :: scheck
12227 !el local variables
12228       integer :: i,iint,j,k,itypi,itypi1,itypj
12229       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12230                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12231 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12232       evdw=0.0D0
12233       do i=iatsc_s,iatsc_e
12234         itypi=itype(i)
12235         if (itypi.eq.ntyp1) cycle
12236         itypi1=itype(i+1)
12237         xi=c(1,nres+i)
12238         yi=c(2,nres+i)
12239         zi=c(3,nres+i)
12240 !
12241 ! Calculate SC interaction energy.
12242 !
12243         do iint=1,nint_gr(i)
12244           do j=istart(i,iint),iend(i,iint)
12245             itypj=itype(j)
12246             if (itypj.eq.ntyp1) cycle
12247             xj=c(1,nres+j)-xi
12248             yj=c(2,nres+j)-yi
12249             zj=c(3,nres+j)-zi
12250             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12251             fac_augm=rrij**expon
12252             e_augm=augm(itypi,itypj)*fac_augm
12253             r_inv_ij=dsqrt(rrij)
12254             rij=1.0D0/r_inv_ij
12255             sss=sscale(rij/sigma(itypi,itypj))
12256             if (sss.lt.1.0d0) then
12257               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12258               fac=r_shift_inv**expon
12259               e1=fac*fac*aa_aq(itypi,itypj)
12260               e2=fac*bb_aq(itypi,itypj)
12261               evdwij=e_augm+e1+e2
12262 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12263 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12264 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12265 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
12266 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12267 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12268 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12269               evdw=evdw+(1.0d0-sss)*evdwij
12270 !
12271 ! Calculate the components of the gradient in DC and X
12272 !
12273               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12274               fac=fac*(1.0d0-sss)
12275               gg(1)=xj*fac
12276               gg(2)=yj*fac
12277               gg(3)=zj*fac
12278               do k=1,3
12279                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12280                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12281                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12282                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12283               enddo
12284             endif
12285           enddo      ! j
12286         enddo        ! iint
12287       enddo          ! i
12288       do i=1,nct
12289         do j=1,3
12290           gvdwc(j,i)=expon*gvdwc(j,i)
12291           gvdwx(j,i)=expon*gvdwx(j,i)
12292         enddo
12293       enddo
12294       return
12295       end subroutine eljk_long
12296 !-----------------------------------------------------------------------------
12297       subroutine eljk_short(evdw)
12298 !
12299 ! This subroutine calculates the interaction energy of nonbonded side chains
12300 ! assuming the LJK potential of interaction.
12301 !
12302 !      implicit real*8 (a-h,o-z)
12303 !      include 'DIMENSIONS'
12304 !      include 'COMMON.GEO'
12305 !      include 'COMMON.VAR'
12306 !      include 'COMMON.LOCAL'
12307 !      include 'COMMON.CHAIN'
12308 !      include 'COMMON.DERIV'
12309 !      include 'COMMON.INTERACT'
12310 !      include 'COMMON.IOUNITS'
12311 !      include 'COMMON.NAMES'
12312       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12313       logical :: scheck
12314 !el local variables
12315       integer :: i,iint,j,k,itypi,itypi1,itypj
12316       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12317                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12318 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12319       evdw=0.0D0
12320       do i=iatsc_s,iatsc_e
12321         itypi=itype(i)
12322         if (itypi.eq.ntyp1) cycle
12323         itypi1=itype(i+1)
12324         xi=c(1,nres+i)
12325         yi=c(2,nres+i)
12326         zi=c(3,nres+i)
12327 !
12328 ! Calculate SC interaction energy.
12329 !
12330         do iint=1,nint_gr(i)
12331           do j=istart(i,iint),iend(i,iint)
12332             itypj=itype(j)
12333             if (itypj.eq.ntyp1) cycle
12334             xj=c(1,nres+j)-xi
12335             yj=c(2,nres+j)-yi
12336             zj=c(3,nres+j)-zi
12337             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12338             fac_augm=rrij**expon
12339             e_augm=augm(itypi,itypj)*fac_augm
12340             r_inv_ij=dsqrt(rrij)
12341             rij=1.0D0/r_inv_ij
12342             sss=sscale(rij/sigma(itypi,itypj))
12343             if (sss.gt.0.0d0) then
12344               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12345               fac=r_shift_inv**expon
12346               e1=fac*fac*aa_aq(itypi,itypj)
12347               e2=fac*bb_aq(itypi,itypj)
12348               evdwij=e_augm+e1+e2
12349 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12350 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12351 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12352 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
12353 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12354 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12355 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12356               evdw=evdw+sss*evdwij
12357 !
12358 ! Calculate the components of the gradient in DC and X
12359 !
12360               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12361               fac=fac*sss
12362               gg(1)=xj*fac
12363               gg(2)=yj*fac
12364               gg(3)=zj*fac
12365               do k=1,3
12366                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12367                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12368                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12369                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12370               enddo
12371             endif
12372           enddo      ! j
12373         enddo        ! iint
12374       enddo          ! i
12375       do i=1,nct
12376         do j=1,3
12377           gvdwc(j,i)=expon*gvdwc(j,i)
12378           gvdwx(j,i)=expon*gvdwx(j,i)
12379         enddo
12380       enddo
12381       return
12382       end subroutine eljk_short
12383 !-----------------------------------------------------------------------------
12384       subroutine ebp_long(evdw)
12385 !
12386 ! This subroutine calculates the interaction energy of nonbonded side chains
12387 ! assuming the Berne-Pechukas potential of interaction.
12388 !
12389       use calc_data
12390 !      implicit real*8 (a-h,o-z)
12391 !      include 'DIMENSIONS'
12392 !      include 'COMMON.GEO'
12393 !      include 'COMMON.VAR'
12394 !      include 'COMMON.LOCAL'
12395 !      include 'COMMON.CHAIN'
12396 !      include 'COMMON.DERIV'
12397 !      include 'COMMON.NAMES'
12398 !      include 'COMMON.INTERACT'
12399 !      include 'COMMON.IOUNITS'
12400 !      include 'COMMON.CALC'
12401       use comm_srutu
12402 !el      integer :: icall
12403 !el      common /srutu/ icall
12404 !     double precision rrsave(maxdim)
12405       logical :: lprn
12406 !el local variables
12407       integer :: iint,itypi,itypi1,itypj
12408       real(kind=8) :: rrij,xi,yi,zi,fac
12409       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12410       evdw=0.0D0
12411 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12412       evdw=0.0D0
12413 !     if (icall.eq.0) then
12414 !       lprn=.true.
12415 !     else
12416         lprn=.false.
12417 !     endif
12418 !el      ind=0
12419       do i=iatsc_s,iatsc_e
12420         itypi=itype(i)
12421         if (itypi.eq.ntyp1) cycle
12422         itypi1=itype(i+1)
12423         xi=c(1,nres+i)
12424         yi=c(2,nres+i)
12425         zi=c(3,nres+i)
12426         dxi=dc_norm(1,nres+i)
12427         dyi=dc_norm(2,nres+i)
12428         dzi=dc_norm(3,nres+i)
12429 !        dsci_inv=dsc_inv(itypi)
12430         dsci_inv=vbld_inv(i+nres)
12431 !
12432 ! Calculate SC interaction energy.
12433 !
12434         do iint=1,nint_gr(i)
12435           do j=istart(i,iint),iend(i,iint)
12436 !el            ind=ind+1
12437             itypj=itype(j)
12438             if (itypj.eq.ntyp1) cycle
12439 !            dscj_inv=dsc_inv(itypj)
12440             dscj_inv=vbld_inv(j+nres)
12441             chi1=chi(itypi,itypj)
12442             chi2=chi(itypj,itypi)
12443             chi12=chi1*chi2
12444             chip1=chip(itypi)
12445             chip2=chip(itypj)
12446             chip12=chip1*chip2
12447             alf1=alp(itypi)
12448             alf2=alp(itypj)
12449             alf12=0.5D0*(alf1+alf2)
12450             xj=c(1,nres+j)-xi
12451             yj=c(2,nres+j)-yi
12452             zj=c(3,nres+j)-zi
12453             dxj=dc_norm(1,nres+j)
12454             dyj=dc_norm(2,nres+j)
12455             dzj=dc_norm(3,nres+j)
12456             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12457             rij=dsqrt(rrij)
12458             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12459
12460             if (sss.lt.1.0d0) then
12461
12462 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12463               call sc_angular
12464 ! Calculate whole angle-dependent part of epsilon and contributions
12465 ! to its derivatives
12466               fac=(rrij*sigsq)**expon2
12467               e1=fac*fac*aa_aq(itypi,itypj)
12468               e2=fac*bb_aq(itypi,itypj)
12469               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12470               eps2der=evdwij*eps3rt
12471               eps3der=evdwij*eps2rt
12472               evdwij=evdwij*eps2rt*eps3rt
12473               evdw=evdw+evdwij*(1.0d0-sss)
12474               if (lprn) then
12475               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12476               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12477 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12478 !d     &          restyp(itypi),i,restyp(itypj),j,
12479 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12480 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12481 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12482 !d     &          evdwij
12483               endif
12484 ! Calculate gradient components.
12485               e1=e1*eps1*eps2rt**2*eps3rt**2
12486               fac=-expon*(e1+evdwij)
12487               sigder=fac/sigsq
12488               fac=rrij*fac
12489 ! Calculate radial part of the gradient
12490               gg(1)=xj*fac
12491               gg(2)=yj*fac
12492               gg(3)=zj*fac
12493 ! Calculate the angular part of the gradient and sum add the contributions
12494 ! to the appropriate components of the Cartesian gradient.
12495               call sc_grad_scale(1.0d0-sss)
12496             endif
12497           enddo      ! j
12498         enddo        ! iint
12499       enddo          ! i
12500 !     stop
12501       return
12502       end subroutine ebp_long
12503 !-----------------------------------------------------------------------------
12504       subroutine ebp_short(evdw)
12505 !
12506 ! This subroutine calculates the interaction energy of nonbonded side chains
12507 ! assuming the Berne-Pechukas potential of interaction.
12508 !
12509       use calc_data
12510 !      implicit real*8 (a-h,o-z)
12511 !      include 'DIMENSIONS'
12512 !      include 'COMMON.GEO'
12513 !      include 'COMMON.VAR'
12514 !      include 'COMMON.LOCAL'
12515 !      include 'COMMON.CHAIN'
12516 !      include 'COMMON.DERIV'
12517 !      include 'COMMON.NAMES'
12518 !      include 'COMMON.INTERACT'
12519 !      include 'COMMON.IOUNITS'
12520 !      include 'COMMON.CALC'
12521       use comm_srutu
12522 !el      integer :: icall
12523 !el      common /srutu/ icall
12524 !     double precision rrsave(maxdim)
12525       logical :: lprn
12526 !el local variables
12527       integer :: iint,itypi,itypi1,itypj
12528       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12529       real(kind=8) :: sss,e1,e2,evdw
12530       evdw=0.0D0
12531 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12532       evdw=0.0D0
12533 !     if (icall.eq.0) then
12534 !       lprn=.true.
12535 !     else
12536         lprn=.false.
12537 !     endif
12538 !el      ind=0
12539       do i=iatsc_s,iatsc_e
12540         itypi=itype(i)
12541         if (itypi.eq.ntyp1) cycle
12542         itypi1=itype(i+1)
12543         xi=c(1,nres+i)
12544         yi=c(2,nres+i)
12545         zi=c(3,nres+i)
12546         dxi=dc_norm(1,nres+i)
12547         dyi=dc_norm(2,nres+i)
12548         dzi=dc_norm(3,nres+i)
12549 !        dsci_inv=dsc_inv(itypi)
12550         dsci_inv=vbld_inv(i+nres)
12551 !
12552 ! Calculate SC interaction energy.
12553 !
12554         do iint=1,nint_gr(i)
12555           do j=istart(i,iint),iend(i,iint)
12556 !el            ind=ind+1
12557             itypj=itype(j)
12558             if (itypj.eq.ntyp1) cycle
12559 !            dscj_inv=dsc_inv(itypj)
12560             dscj_inv=vbld_inv(j+nres)
12561             chi1=chi(itypi,itypj)
12562             chi2=chi(itypj,itypi)
12563             chi12=chi1*chi2
12564             chip1=chip(itypi)
12565             chip2=chip(itypj)
12566             chip12=chip1*chip2
12567             alf1=alp(itypi)
12568             alf2=alp(itypj)
12569             alf12=0.5D0*(alf1+alf2)
12570             xj=c(1,nres+j)-xi
12571             yj=c(2,nres+j)-yi
12572             zj=c(3,nres+j)-zi
12573             dxj=dc_norm(1,nres+j)
12574             dyj=dc_norm(2,nres+j)
12575             dzj=dc_norm(3,nres+j)
12576             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12577             rij=dsqrt(rrij)
12578             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12579
12580             if (sss.gt.0.0d0) then
12581
12582 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12583               call sc_angular
12584 ! Calculate whole angle-dependent part of epsilon and contributions
12585 ! to its derivatives
12586               fac=(rrij*sigsq)**expon2
12587               e1=fac*fac*aa_aq(itypi,itypj)
12588               e2=fac*bb_aq(itypi,itypj)
12589               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12590               eps2der=evdwij*eps3rt
12591               eps3der=evdwij*eps2rt
12592               evdwij=evdwij*eps2rt*eps3rt
12593               evdw=evdw+evdwij*sss
12594               if (lprn) then
12595               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12596               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12597 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12598 !d     &          restyp(itypi),i,restyp(itypj),j,
12599 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12600 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12601 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12602 !d     &          evdwij
12603               endif
12604 ! Calculate gradient components.
12605               e1=e1*eps1*eps2rt**2*eps3rt**2
12606               fac=-expon*(e1+evdwij)
12607               sigder=fac/sigsq
12608               fac=rrij*fac
12609 ! Calculate radial part of the gradient
12610               gg(1)=xj*fac
12611               gg(2)=yj*fac
12612               gg(3)=zj*fac
12613 ! Calculate the angular part of the gradient and sum add the contributions
12614 ! to the appropriate components of the Cartesian gradient.
12615               call sc_grad_scale(sss)
12616             endif
12617           enddo      ! j
12618         enddo        ! iint
12619       enddo          ! i
12620 !     stop
12621       return
12622       end subroutine ebp_short
12623 !-----------------------------------------------------------------------------
12624       subroutine egb_long(evdw)
12625 !
12626 ! This subroutine calculates the interaction energy of nonbonded side chains
12627 ! assuming the Gay-Berne potential of interaction.
12628 !
12629       use calc_data
12630 !      implicit real*8 (a-h,o-z)
12631 !      include 'DIMENSIONS'
12632 !      include 'COMMON.GEO'
12633 !      include 'COMMON.VAR'
12634 !      include 'COMMON.LOCAL'
12635 !      include 'COMMON.CHAIN'
12636 !      include 'COMMON.DERIV'
12637 !      include 'COMMON.NAMES'
12638 !      include 'COMMON.INTERACT'
12639 !      include 'COMMON.IOUNITS'
12640 !      include 'COMMON.CALC'
12641 !      include 'COMMON.CONTROL'
12642       logical :: lprn
12643 !el local variables
12644       integer :: iint,itypi,itypi1,itypj,subchap
12645       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
12646       real(kind=8) :: sss,e1,e2,evdw,sss_grad
12647       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12648                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12649                     ssgradlipi,ssgradlipj
12650
12651
12652       evdw=0.0D0
12653 !cccc      energy_dec=.false.
12654 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12655       evdw=0.0D0
12656       lprn=.false.
12657 !     if (icall.eq.0) lprn=.false.
12658 !el      ind=0
12659       do i=iatsc_s,iatsc_e
12660         itypi=itype(i)
12661         if (itypi.eq.ntyp1) cycle
12662         itypi1=itype(i+1)
12663         xi=c(1,nres+i)
12664         yi=c(2,nres+i)
12665         zi=c(3,nres+i)
12666           xi=mod(xi,boxxsize)
12667           if (xi.lt.0) xi=xi+boxxsize
12668           yi=mod(yi,boxysize)
12669           if (yi.lt.0) yi=yi+boxysize
12670           zi=mod(zi,boxzsize)
12671           if (zi.lt.0) zi=zi+boxzsize
12672        if ((zi.gt.bordlipbot)    &
12673         .and.(zi.lt.bordliptop)) then
12674 !C the energy transfer exist
12675         if (zi.lt.buflipbot) then
12676 !C what fraction I am in
12677          fracinbuf=1.0d0-    &
12678              ((zi-bordlipbot)/lipbufthick)
12679 !C lipbufthick is thickenes of lipid buffore
12680          sslipi=sscalelip(fracinbuf)
12681          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12682         elseif (zi.gt.bufliptop) then
12683          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12684          sslipi=sscalelip(fracinbuf)
12685          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12686         else
12687          sslipi=1.0d0
12688          ssgradlipi=0.0
12689         endif
12690        else
12691          sslipi=0.0d0
12692          ssgradlipi=0.0
12693        endif
12694
12695         dxi=dc_norm(1,nres+i)
12696         dyi=dc_norm(2,nres+i)
12697         dzi=dc_norm(3,nres+i)
12698 !        dsci_inv=dsc_inv(itypi)
12699         dsci_inv=vbld_inv(i+nres)
12700 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12701 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12702 !
12703 ! Calculate SC interaction energy.
12704 !
12705         do iint=1,nint_gr(i)
12706           do j=istart(i,iint),iend(i,iint)
12707             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12708               call dyn_ssbond_ene(i,j,evdwij)
12709               evdw=evdw+evdwij
12710               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12711                               'evdw',i,j,evdwij,' ss'
12712 !              if (energy_dec) write (iout,*) &
12713 !                              'evdw',i,j,evdwij,' ss'
12714             ELSE
12715 !el            ind=ind+1
12716             itypj=itype(j)
12717             if (itypj.eq.ntyp1) cycle
12718 !            dscj_inv=dsc_inv(itypj)
12719             dscj_inv=vbld_inv(j+nres)
12720 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12721 !     &       1.0d0/vbld(j+nres)
12722 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12723             sig0ij=sigma(itypi,itypj)
12724             chi1=chi(itypi,itypj)
12725             chi2=chi(itypj,itypi)
12726             chi12=chi1*chi2
12727             chip1=chip(itypi)
12728             chip2=chip(itypj)
12729             chip12=chip1*chip2
12730             alf1=alp(itypi)
12731             alf2=alp(itypj)
12732             alf12=0.5D0*(alf1+alf2)
12733             xj=c(1,nres+j)
12734             yj=c(2,nres+j)
12735             zj=c(3,nres+j)
12736 ! Searching for nearest neighbour
12737           xj=mod(xj,boxxsize)
12738           if (xj.lt.0) xj=xj+boxxsize
12739           yj=mod(yj,boxysize)
12740           if (yj.lt.0) yj=yj+boxysize
12741           zj=mod(zj,boxzsize)
12742           if (zj.lt.0) zj=zj+boxzsize
12743        if ((zj.gt.bordlipbot)   &
12744       .and.(zj.lt.bordliptop)) then
12745 !C the energy transfer exist
12746         if (zj.lt.buflipbot) then
12747 !C what fraction I am in
12748          fracinbuf=1.0d0-  &
12749              ((zj-bordlipbot)/lipbufthick)
12750 !C lipbufthick is thickenes of lipid buffore
12751          sslipj=sscalelip(fracinbuf)
12752          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
12753         elseif (zj.gt.bufliptop) then
12754          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
12755          sslipj=sscalelip(fracinbuf)
12756          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
12757         else
12758          sslipj=1.0d0
12759          ssgradlipj=0.0
12760         endif
12761        else
12762          sslipj=0.0d0
12763          ssgradlipj=0.0
12764        endif
12765       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12766        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12767       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12768        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12769
12770           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12771           xj_safe=xj
12772           yj_safe=yj
12773           zj_safe=zj
12774           subchap=0
12775           do xshift=-1,1
12776           do yshift=-1,1
12777           do zshift=-1,1
12778           xj=xj_safe+xshift*boxxsize
12779           yj=yj_safe+yshift*boxysize
12780           zj=zj_safe+zshift*boxzsize
12781           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12782           if(dist_temp.lt.dist_init) then
12783             dist_init=dist_temp
12784             xj_temp=xj
12785             yj_temp=yj
12786             zj_temp=zj
12787             subchap=1
12788           endif
12789           enddo
12790           enddo
12791           enddo
12792           if (subchap.eq.1) then
12793           xj=xj_temp-xi
12794           yj=yj_temp-yi
12795           zj=zj_temp-zi
12796           else
12797           xj=xj_safe-xi
12798           yj=yj_safe-yi
12799           zj=zj_safe-zi
12800           endif
12801
12802             dxj=dc_norm(1,nres+j)
12803             dyj=dc_norm(2,nres+j)
12804             dzj=dc_norm(3,nres+j)
12805             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12806             rij=dsqrt(rrij)
12807             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12808             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12809             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12810             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12811             if (sss_ele_cut.le.0.0) cycle
12812             if (sss.lt.1.0d0) then
12813
12814 ! Calculate angle-dependent terms of energy and contributions to their
12815 ! derivatives.
12816               call sc_angular
12817               sigsq=1.0D0/sigsq
12818               sig=sig0ij*dsqrt(sigsq)
12819               rij_shift=1.0D0/rij-sig+sig0ij
12820 ! for diagnostics; uncomment
12821 !              rij_shift=1.2*sig0ij
12822 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12823               if (rij_shift.le.0.0D0) then
12824                 evdw=1.0D20
12825 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12826 !d     &          restyp(itypi),i,restyp(itypj),j,
12827 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12828                 return
12829               endif
12830               sigder=-sig*sigsq
12831 !---------------------------------------------------------------
12832               rij_shift=1.0D0/rij_shift
12833               fac=rij_shift**expon
12834               e1=fac*fac*aa
12835               e2=fac*bb
12836               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12837               eps2der=evdwij*eps3rt
12838               eps3der=evdwij*eps2rt
12839 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12840 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
12841               evdwij=evdwij*eps2rt*eps3rt
12842               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
12843               if (lprn) then
12844               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12845               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12846               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12847                 restyp(itypi),i,restyp(itypj),j,&
12848                 epsi,sigm,chi1,chi2,chip1,chip2,&
12849                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12850                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12851                 evdwij
12852               endif
12853
12854               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12855                               'evdw',i,j,evdwij
12856 !              if (energy_dec) write (iout,*) &
12857 !                              'evdw',i,j,evdwij,"egb_long"
12858
12859 ! Calculate gradient components.
12860               e1=e1*eps1*eps2rt**2*eps3rt**2
12861               fac=-expon*(e1+evdwij)*rij_shift
12862               sigder=fac*sigder
12863               fac=rij*fac
12864               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12865             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
12866             /sigmaii(itypi,itypj))
12867 !              fac=0.0d0
12868 ! Calculate the radial part of the gradient
12869               gg(1)=xj*fac
12870               gg(2)=yj*fac
12871               gg(3)=zj*fac
12872 ! Calculate angular part of the gradient.
12873               call sc_grad_scale(1.0d0-sss)
12874             ENDIF    !mask_dyn_ss
12875             endif
12876           enddo      ! j
12877         enddo        ! iint
12878       enddo          ! i
12879 !      write (iout,*) "Number of loop steps in EGB:",ind
12880 !ccc      energy_dec=.false.
12881       return
12882       end subroutine egb_long
12883 !-----------------------------------------------------------------------------
12884       subroutine egb_short(evdw)
12885 !
12886 ! This subroutine calculates the interaction energy of nonbonded side chains
12887 ! assuming the Gay-Berne potential of interaction.
12888 !
12889       use calc_data
12890 !      implicit real*8 (a-h,o-z)
12891 !      include 'DIMENSIONS'
12892 !      include 'COMMON.GEO'
12893 !      include 'COMMON.VAR'
12894 !      include 'COMMON.LOCAL'
12895 !      include 'COMMON.CHAIN'
12896 !      include 'COMMON.DERIV'
12897 !      include 'COMMON.NAMES'
12898 !      include 'COMMON.INTERACT'
12899 !      include 'COMMON.IOUNITS'
12900 !      include 'COMMON.CALC'
12901 !      include 'COMMON.CONTROL'
12902       logical :: lprn
12903 !el local variables
12904       integer :: iint,itypi,itypi1,itypj,subchap
12905       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
12906       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
12907       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12908                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12909                     ssgradlipi,ssgradlipj
12910       evdw=0.0D0
12911 !cccc      energy_dec=.false.
12912 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12913       evdw=0.0D0
12914       lprn=.false.
12915 !     if (icall.eq.0) lprn=.false.
12916 !el      ind=0
12917       do i=iatsc_s,iatsc_e
12918         itypi=itype(i)
12919         if (itypi.eq.ntyp1) cycle
12920         itypi1=itype(i+1)
12921         xi=c(1,nres+i)
12922         yi=c(2,nres+i)
12923         zi=c(3,nres+i)
12924           xi=mod(xi,boxxsize)
12925           if (xi.lt.0) xi=xi+boxxsize
12926           yi=mod(yi,boxysize)
12927           if (yi.lt.0) yi=yi+boxysize
12928           zi=mod(zi,boxzsize)
12929           if (zi.lt.0) zi=zi+boxzsize
12930        if ((zi.gt.bordlipbot)    &
12931         .and.(zi.lt.bordliptop)) then
12932 !C the energy transfer exist
12933         if (zi.lt.buflipbot) then
12934 !C what fraction I am in
12935          fracinbuf=1.0d0-    &
12936              ((zi-bordlipbot)/lipbufthick)
12937 !C lipbufthick is thickenes of lipid buffore
12938          sslipi=sscalelip(fracinbuf)
12939          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12940         elseif (zi.gt.bufliptop) then
12941          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12942          sslipi=sscalelip(fracinbuf)
12943          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12944         else
12945          sslipi=1.0d0
12946          ssgradlipi=0.0
12947         endif
12948        else
12949          sslipi=0.0d0
12950          ssgradlipi=0.0
12951        endif
12952
12953         dxi=dc_norm(1,nres+i)
12954         dyi=dc_norm(2,nres+i)
12955         dzi=dc_norm(3,nres+i)
12956 !        dsci_inv=dsc_inv(itypi)
12957         dsci_inv=vbld_inv(i+nres)
12958
12959         dxi=dc_norm(1,nres+i)
12960         dyi=dc_norm(2,nres+i)
12961         dzi=dc_norm(3,nres+i)
12962 !        dsci_inv=dsc_inv(itypi)
12963         dsci_inv=vbld_inv(i+nres)
12964 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12965 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12966 !
12967 ! Calculate SC interaction energy.
12968 !
12969         do iint=1,nint_gr(i)
12970           do j=istart(i,iint),iend(i,iint)
12971             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12972               call dyn_ssbond_ene(i,j,evdwij)
12973               evdw=evdw+evdwij
12974               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12975                               'evdw',i,j,evdwij,' ss'
12976 !              if (energy_dec) write (iout,*) &
12977 !                              'evdw',i,j,evdwij,' ss'
12978             ELSE
12979 !el            ind=ind+1
12980             itypj=itype(j)
12981             if (itypj.eq.ntyp1) cycle
12982 !            dscj_inv=dsc_inv(itypj)
12983             dscj_inv=vbld_inv(j+nres)
12984 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12985 !     &       1.0d0/vbld(j+nres)
12986 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12987             sig0ij=sigma(itypi,itypj)
12988             chi1=chi(itypi,itypj)
12989             chi2=chi(itypj,itypi)
12990             chi12=chi1*chi2
12991             chip1=chip(itypi)
12992             chip2=chip(itypj)
12993             chip12=chip1*chip2
12994             alf1=alp(itypi)
12995             alf2=alp(itypj)
12996             alf12=0.5D0*(alf1+alf2)
12997 !            xj=c(1,nres+j)-xi
12998 !            yj=c(2,nres+j)-yi
12999 !            zj=c(3,nres+j)-zi
13000             xj=c(1,nres+j)
13001             yj=c(2,nres+j)
13002             zj=c(3,nres+j)
13003 ! Searching for nearest neighbour
13004           xj=mod(xj,boxxsize)
13005           if (xj.lt.0) xj=xj+boxxsize
13006           yj=mod(yj,boxysize)
13007           if (yj.lt.0) yj=yj+boxysize
13008           zj=mod(zj,boxzsize)
13009           if (zj.lt.0) zj=zj+boxzsize
13010        if ((zj.gt.bordlipbot)   &
13011       .and.(zj.lt.bordliptop)) then
13012 !C the energy transfer exist
13013         if (zj.lt.buflipbot) then
13014 !C what fraction I am in
13015          fracinbuf=1.0d0-  &
13016              ((zj-bordlipbot)/lipbufthick)
13017 !C lipbufthick is thickenes of lipid buffore
13018          sslipj=sscalelip(fracinbuf)
13019          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13020         elseif (zj.gt.bufliptop) then
13021          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13022          sslipj=sscalelip(fracinbuf)
13023          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13024         else
13025          sslipj=1.0d0
13026          ssgradlipj=0.0
13027         endif
13028        else
13029          sslipj=0.0d0
13030          ssgradlipj=0.0
13031        endif
13032       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13033        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13034       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13035        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13036
13037           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13038           xj_safe=xj
13039           yj_safe=yj
13040           zj_safe=zj
13041           subchap=0
13042
13043           do xshift=-1,1
13044           do yshift=-1,1
13045           do zshift=-1,1
13046           xj=xj_safe+xshift*boxxsize
13047           yj=yj_safe+yshift*boxysize
13048           zj=zj_safe+zshift*boxzsize
13049           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13050           if(dist_temp.lt.dist_init) then
13051             dist_init=dist_temp
13052             xj_temp=xj
13053             yj_temp=yj
13054             zj_temp=zj
13055             subchap=1
13056           endif
13057           enddo
13058           enddo
13059           enddo
13060           if (subchap.eq.1) then
13061           xj=xj_temp-xi
13062           yj=yj_temp-yi
13063           zj=zj_temp-zi
13064           else
13065           xj=xj_safe-xi
13066           yj=yj_safe-yi
13067           zj=zj_safe-zi
13068           endif
13069
13070             dxj=dc_norm(1,nres+j)
13071             dyj=dc_norm(2,nres+j)
13072             dzj=dc_norm(3,nres+j)
13073             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13074             rij=dsqrt(rrij)
13075             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13076             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13077             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13078             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13079             if (sss_ele_cut.le.0.0) cycle
13080
13081             if (sss.gt.0.0d0) then
13082
13083 ! Calculate angle-dependent terms of energy and contributions to their
13084 ! derivatives.
13085               call sc_angular
13086               sigsq=1.0D0/sigsq
13087               sig=sig0ij*dsqrt(sigsq)
13088               rij_shift=1.0D0/rij-sig+sig0ij
13089 ! for diagnostics; uncomment
13090 !              rij_shift=1.2*sig0ij
13091 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13092               if (rij_shift.le.0.0D0) then
13093                 evdw=1.0D20
13094 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13095 !d     &          restyp(itypi),i,restyp(itypj),j,
13096 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13097                 return
13098               endif
13099               sigder=-sig*sigsq
13100 !---------------------------------------------------------------
13101               rij_shift=1.0D0/rij_shift
13102               fac=rij_shift**expon
13103               e1=fac*fac*aa
13104               e2=fac*bb
13105               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13106               eps2der=evdwij*eps3rt
13107               eps3der=evdwij*eps2rt
13108 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13109 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13110               evdwij=evdwij*eps2rt*eps3rt
13111               evdw=evdw+evdwij*sss*sss_ele_cut
13112               if (lprn) then
13113               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13114               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13115               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13116                 restyp(itypi),i,restyp(itypj),j,&
13117                 epsi,sigm,chi1,chi2,chip1,chip2,&
13118                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13119                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13120                 evdwij
13121               endif
13122
13123               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13124                               'evdw',i,j,evdwij
13125 !              if (energy_dec) write (iout,*) &
13126 !                              'evdw',i,j,evdwij,"egb_short"
13127
13128 ! Calculate gradient components.
13129               e1=e1*eps1*eps2rt**2*eps3rt**2
13130               fac=-expon*(e1+evdwij)*rij_shift
13131               sigder=fac*sigder
13132               fac=rij*fac
13133               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13134             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13135             /sigmaii(itypi,itypj))
13136
13137 !              fac=0.0d0
13138 ! Calculate the radial part of the gradient
13139               gg(1)=xj*fac
13140               gg(2)=yj*fac
13141               gg(3)=zj*fac
13142 ! Calculate angular part of the gradient.
13143               call sc_grad_scale(sss)
13144             endif
13145           ENDIF !mask_dyn_ss
13146           enddo      ! j
13147         enddo        ! iint
13148       enddo          ! i
13149 !      write (iout,*) "Number of loop steps in EGB:",ind
13150 !ccc      energy_dec=.false.
13151       return
13152       end subroutine egb_short
13153 !-----------------------------------------------------------------------------
13154       subroutine egbv_long(evdw)
13155 !
13156 ! This subroutine calculates the interaction energy of nonbonded side chains
13157 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13158 !
13159       use calc_data
13160 !      implicit real*8 (a-h,o-z)
13161 !      include 'DIMENSIONS'
13162 !      include 'COMMON.GEO'
13163 !      include 'COMMON.VAR'
13164 !      include 'COMMON.LOCAL'
13165 !      include 'COMMON.CHAIN'
13166 !      include 'COMMON.DERIV'
13167 !      include 'COMMON.NAMES'
13168 !      include 'COMMON.INTERACT'
13169 !      include 'COMMON.IOUNITS'
13170 !      include 'COMMON.CALC'
13171       use comm_srutu
13172 !el      integer :: icall
13173 !el      common /srutu/ icall
13174       logical :: lprn
13175 !el local variables
13176       integer :: iint,itypi,itypi1,itypj
13177       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13178       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13179       evdw=0.0D0
13180 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13181       evdw=0.0D0
13182       lprn=.false.
13183 !     if (icall.eq.0) lprn=.true.
13184 !el      ind=0
13185       do i=iatsc_s,iatsc_e
13186         itypi=itype(i)
13187         if (itypi.eq.ntyp1) cycle
13188         itypi1=itype(i+1)
13189         xi=c(1,nres+i)
13190         yi=c(2,nres+i)
13191         zi=c(3,nres+i)
13192         dxi=dc_norm(1,nres+i)
13193         dyi=dc_norm(2,nres+i)
13194         dzi=dc_norm(3,nres+i)
13195 !        dsci_inv=dsc_inv(itypi)
13196         dsci_inv=vbld_inv(i+nres)
13197 !
13198 ! Calculate SC interaction energy.
13199 !
13200         do iint=1,nint_gr(i)
13201           do j=istart(i,iint),iend(i,iint)
13202 !el            ind=ind+1
13203             itypj=itype(j)
13204             if (itypj.eq.ntyp1) cycle
13205 !            dscj_inv=dsc_inv(itypj)
13206             dscj_inv=vbld_inv(j+nres)
13207             sig0ij=sigma(itypi,itypj)
13208             r0ij=r0(itypi,itypj)
13209             chi1=chi(itypi,itypj)
13210             chi2=chi(itypj,itypi)
13211             chi12=chi1*chi2
13212             chip1=chip(itypi)
13213             chip2=chip(itypj)
13214             chip12=chip1*chip2
13215             alf1=alp(itypi)
13216             alf2=alp(itypj)
13217             alf12=0.5D0*(alf1+alf2)
13218             xj=c(1,nres+j)-xi
13219             yj=c(2,nres+j)-yi
13220             zj=c(3,nres+j)-zi
13221             dxj=dc_norm(1,nres+j)
13222             dyj=dc_norm(2,nres+j)
13223             dzj=dc_norm(3,nres+j)
13224             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13225             rij=dsqrt(rrij)
13226
13227             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13228
13229             if (sss.lt.1.0d0) then
13230
13231 ! Calculate angle-dependent terms of energy and contributions to their
13232 ! derivatives.
13233               call sc_angular
13234               sigsq=1.0D0/sigsq
13235               sig=sig0ij*dsqrt(sigsq)
13236               rij_shift=1.0D0/rij-sig+r0ij
13237 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13238               if (rij_shift.le.0.0D0) then
13239                 evdw=1.0D20
13240                 return
13241               endif
13242               sigder=-sig*sigsq
13243 !---------------------------------------------------------------
13244               rij_shift=1.0D0/rij_shift
13245               fac=rij_shift**expon
13246               e1=fac*fac*aa_aq(itypi,itypj)
13247               e2=fac*bb_aq(itypi,itypj)
13248               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13249               eps2der=evdwij*eps3rt
13250               eps3der=evdwij*eps2rt
13251               fac_augm=rrij**expon
13252               e_augm=augm(itypi,itypj)*fac_augm
13253               evdwij=evdwij*eps2rt*eps3rt
13254               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13255               if (lprn) then
13256               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13257               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13258               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13259                 restyp(itypi),i,restyp(itypj),j,&
13260                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13261                 chi1,chi2,chip1,chip2,&
13262                 eps1,eps2rt**2,eps3rt**2,&
13263                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13264                 evdwij+e_augm
13265               endif
13266 ! Calculate gradient components.
13267               e1=e1*eps1*eps2rt**2*eps3rt**2
13268               fac=-expon*(e1+evdwij)*rij_shift
13269               sigder=fac*sigder
13270               fac=rij*fac-2*expon*rrij*e_augm
13271 ! Calculate the radial part of the gradient
13272               gg(1)=xj*fac
13273               gg(2)=yj*fac
13274               gg(3)=zj*fac
13275 ! Calculate angular part of the gradient.
13276               call sc_grad_scale(1.0d0-sss)
13277             endif
13278           enddo      ! j
13279         enddo        ! iint
13280       enddo          ! i
13281       end subroutine egbv_long
13282 !-----------------------------------------------------------------------------
13283       subroutine egbv_short(evdw)
13284 !
13285 ! This subroutine calculates the interaction energy of nonbonded side chains
13286 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13287 !
13288       use calc_data
13289 !      implicit real*8 (a-h,o-z)
13290 !      include 'DIMENSIONS'
13291 !      include 'COMMON.GEO'
13292 !      include 'COMMON.VAR'
13293 !      include 'COMMON.LOCAL'
13294 !      include 'COMMON.CHAIN'
13295 !      include 'COMMON.DERIV'
13296 !      include 'COMMON.NAMES'
13297 !      include 'COMMON.INTERACT'
13298 !      include 'COMMON.IOUNITS'
13299 !      include 'COMMON.CALC'
13300       use comm_srutu
13301 !el      integer :: icall
13302 !el      common /srutu/ icall
13303       logical :: lprn
13304 !el local variables
13305       integer :: iint,itypi,itypi1,itypj
13306       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13307       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13308       evdw=0.0D0
13309 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13310       evdw=0.0D0
13311       lprn=.false.
13312 !     if (icall.eq.0) lprn=.true.
13313 !el      ind=0
13314       do i=iatsc_s,iatsc_e
13315         itypi=itype(i)
13316         if (itypi.eq.ntyp1) cycle
13317         itypi1=itype(i+1)
13318         xi=c(1,nres+i)
13319         yi=c(2,nres+i)
13320         zi=c(3,nres+i)
13321         dxi=dc_norm(1,nres+i)
13322         dyi=dc_norm(2,nres+i)
13323         dzi=dc_norm(3,nres+i)
13324 !        dsci_inv=dsc_inv(itypi)
13325         dsci_inv=vbld_inv(i+nres)
13326 !
13327 ! Calculate SC interaction energy.
13328 !
13329         do iint=1,nint_gr(i)
13330           do j=istart(i,iint),iend(i,iint)
13331 !el            ind=ind+1
13332             itypj=itype(j)
13333             if (itypj.eq.ntyp1) cycle
13334 !            dscj_inv=dsc_inv(itypj)
13335             dscj_inv=vbld_inv(j+nres)
13336             sig0ij=sigma(itypi,itypj)
13337             r0ij=r0(itypi,itypj)
13338             chi1=chi(itypi,itypj)
13339             chi2=chi(itypj,itypi)
13340             chi12=chi1*chi2
13341             chip1=chip(itypi)
13342             chip2=chip(itypj)
13343             chip12=chip1*chip2
13344             alf1=alp(itypi)
13345             alf2=alp(itypj)
13346             alf12=0.5D0*(alf1+alf2)
13347             xj=c(1,nres+j)-xi
13348             yj=c(2,nres+j)-yi
13349             zj=c(3,nres+j)-zi
13350             dxj=dc_norm(1,nres+j)
13351             dyj=dc_norm(2,nres+j)
13352             dzj=dc_norm(3,nres+j)
13353             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13354             rij=dsqrt(rrij)
13355
13356             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13357
13358             if (sss.gt.0.0d0) then
13359
13360 ! Calculate angle-dependent terms of energy and contributions to their
13361 ! derivatives.
13362               call sc_angular
13363               sigsq=1.0D0/sigsq
13364               sig=sig0ij*dsqrt(sigsq)
13365               rij_shift=1.0D0/rij-sig+r0ij
13366 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13367               if (rij_shift.le.0.0D0) then
13368                 evdw=1.0D20
13369                 return
13370               endif
13371               sigder=-sig*sigsq
13372 !---------------------------------------------------------------
13373               rij_shift=1.0D0/rij_shift
13374               fac=rij_shift**expon
13375               e1=fac*fac*aa_aq(itypi,itypj)
13376               e2=fac*bb_aq(itypi,itypj)
13377               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13378               eps2der=evdwij*eps3rt
13379               eps3der=evdwij*eps2rt
13380               fac_augm=rrij**expon
13381               e_augm=augm(itypi,itypj)*fac_augm
13382               evdwij=evdwij*eps2rt*eps3rt
13383               evdw=evdw+(evdwij+e_augm)*sss
13384               if (lprn) then
13385               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13386               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13387               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13388                 restyp(itypi),i,restyp(itypj),j,&
13389                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13390                 chi1,chi2,chip1,chip2,&
13391                 eps1,eps2rt**2,eps3rt**2,&
13392                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13393                 evdwij+e_augm
13394               endif
13395 ! Calculate gradient components.
13396               e1=e1*eps1*eps2rt**2*eps3rt**2
13397               fac=-expon*(e1+evdwij)*rij_shift
13398               sigder=fac*sigder
13399               fac=rij*fac-2*expon*rrij*e_augm
13400 ! Calculate the radial part of the gradient
13401               gg(1)=xj*fac
13402               gg(2)=yj*fac
13403               gg(3)=zj*fac
13404 ! Calculate angular part of the gradient.
13405               call sc_grad_scale(sss)
13406             endif
13407           enddo      ! j
13408         enddo        ! iint
13409       enddo          ! i
13410       end subroutine egbv_short
13411 !-----------------------------------------------------------------------------
13412       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13413 !
13414 ! This subroutine calculates the average interaction energy and its gradient
13415 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13416 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13417 ! The potential depends both on the distance of peptide-group centers and on
13418 ! the orientation of the CA-CA virtual bonds.
13419 !
13420 !      implicit real*8 (a-h,o-z)
13421
13422       use comm_locel
13423 #ifdef MPI
13424       include 'mpif.h'
13425 #endif
13426 !      include 'DIMENSIONS'
13427 !      include 'COMMON.CONTROL'
13428 !      include 'COMMON.SETUP'
13429 !      include 'COMMON.IOUNITS'
13430 !      include 'COMMON.GEO'
13431 !      include 'COMMON.VAR'
13432 !      include 'COMMON.LOCAL'
13433 !      include 'COMMON.CHAIN'
13434 !      include 'COMMON.DERIV'
13435 !      include 'COMMON.INTERACT'
13436 !      include 'COMMON.CONTACTS'
13437 !      include 'COMMON.TORSION'
13438 !      include 'COMMON.VECTORS'
13439 !      include 'COMMON.FFIELD'
13440 !      include 'COMMON.TIME1'
13441       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13442       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13443       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13444 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13445       real(kind=8),dimension(4) :: muij
13446 !el      integer :: num_conti,j1,j2
13447 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13448 !el                   dz_normi,xmedi,ymedi,zmedi
13449 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13450 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13451 !el          num_conti,j1,j2
13452 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13453 #ifdef MOMENT
13454       real(kind=8) :: scal_el=1.0d0
13455 #else
13456       real(kind=8) :: scal_el=0.5d0
13457 #endif
13458 ! 12/13/98
13459 ! 13-go grudnia roku pamietnego...
13460       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13461                                              0.0d0,1.0d0,0.0d0,&
13462                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13463 !el local variables
13464       integer :: i,j,k
13465       real(kind=8) :: fac
13466       real(kind=8) :: dxj,dyj,dzj
13467       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13468
13469 !      allocate(num_cont_hb(nres)) !(maxres)
13470 !d      write(iout,*) 'In EELEC'
13471 !d      do i=1,nloctyp
13472 !d        write(iout,*) 'Type',i
13473 !d        write(iout,*) 'B1',B1(:,i)
13474 !d        write(iout,*) 'B2',B2(:,i)
13475 !d        write(iout,*) 'CC',CC(:,:,i)
13476 !d        write(iout,*) 'DD',DD(:,:,i)
13477 !d        write(iout,*) 'EE',EE(:,:,i)
13478 !d      enddo
13479 !d      call check_vecgrad
13480 !d      stop
13481       if (icheckgrad.eq.1) then
13482         do i=1,nres-1
13483           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13484           do k=1,3
13485             dc_norm(k,i)=dc(k,i)*fac
13486           enddo
13487 !          write (iout,*) 'i',i,' fac',fac
13488         enddo
13489       endif
13490       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13491           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13492           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13493 !        call vec_and_deriv
13494 #ifdef TIMING
13495         time01=MPI_Wtime()
13496 #endif
13497 !        print *, "before set matrices"
13498         call set_matrices
13499 !        print *,"after set martices"
13500 #ifdef TIMING
13501         time_mat=time_mat+MPI_Wtime()-time01
13502 #endif
13503       endif
13504 !d      do i=1,nres-1
13505 !d        write (iout,*) 'i=',i
13506 !d        do k=1,3
13507 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13508 !d        enddo
13509 !d        do k=1,3
13510 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13511 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13512 !d        enddo
13513 !d      enddo
13514       t_eelecij=0.0d0
13515       ees=0.0D0
13516       evdw1=0.0D0
13517       eel_loc=0.0d0
13518       eello_turn3=0.0d0
13519       eello_turn4=0.0d0
13520 !el      ind=0
13521       do i=1,nres
13522         num_cont_hb(i)=0
13523       enddo
13524 !d      print '(a)','Enter EELEC'
13525 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13526 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13527 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13528       do i=1,nres
13529         gel_loc_loc(i)=0.0d0
13530         gcorr_loc(i)=0.0d0
13531       enddo
13532 !
13533 !
13534 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13535 !
13536 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13537 !
13538       do i=iturn3_start,iturn3_end
13539         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
13540         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
13541         dxi=dc(1,i)
13542         dyi=dc(2,i)
13543         dzi=dc(3,i)
13544         dx_normi=dc_norm(1,i)
13545         dy_normi=dc_norm(2,i)
13546         dz_normi=dc_norm(3,i)
13547         xmedi=c(1,i)+0.5d0*dxi
13548         ymedi=c(2,i)+0.5d0*dyi
13549         zmedi=c(3,i)+0.5d0*dzi
13550           xmedi=dmod(xmedi,boxxsize)
13551           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13552           ymedi=dmod(ymedi,boxysize)
13553           if (ymedi.lt.0) ymedi=ymedi+boxysize
13554           zmedi=dmod(zmedi,boxzsize)
13555           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13556         num_conti=0
13557         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13558         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13559         num_cont_hb(i)=num_conti
13560       enddo
13561       do i=iturn4_start,iturn4_end
13562         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
13563           .or. itype(i+3).eq.ntyp1 &
13564           .or. itype(i+4).eq.ntyp1) cycle
13565         dxi=dc(1,i)
13566         dyi=dc(2,i)
13567         dzi=dc(3,i)
13568         dx_normi=dc_norm(1,i)
13569         dy_normi=dc_norm(2,i)
13570         dz_normi=dc_norm(3,i)
13571         xmedi=c(1,i)+0.5d0*dxi
13572         ymedi=c(2,i)+0.5d0*dyi
13573         zmedi=c(3,i)+0.5d0*dzi
13574           xmedi=dmod(xmedi,boxxsize)
13575           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13576           ymedi=dmod(ymedi,boxysize)
13577           if (ymedi.lt.0) ymedi=ymedi+boxysize
13578           zmedi=dmod(zmedi,boxzsize)
13579           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13580         num_conti=num_cont_hb(i)
13581         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13582         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
13583           call eturn4(i,eello_turn4)
13584         num_cont_hb(i)=num_conti
13585       enddo   ! i
13586 !
13587 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13588 !
13589       do i=iatel_s,iatel_e
13590         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13591         dxi=dc(1,i)
13592         dyi=dc(2,i)
13593         dzi=dc(3,i)
13594         dx_normi=dc_norm(1,i)
13595         dy_normi=dc_norm(2,i)
13596         dz_normi=dc_norm(3,i)
13597         xmedi=c(1,i)+0.5d0*dxi
13598         ymedi=c(2,i)+0.5d0*dyi
13599         zmedi=c(3,i)+0.5d0*dzi
13600           xmedi=dmod(xmedi,boxxsize)
13601           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13602           ymedi=dmod(ymedi,boxysize)
13603           if (ymedi.lt.0) ymedi=ymedi+boxysize
13604           zmedi=dmod(zmedi,boxzsize)
13605           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13606 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
13607         num_conti=num_cont_hb(i)
13608         do j=ielstart(i),ielend(i)
13609           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13610           call eelecij_scale(i,j,ees,evdw1,eel_loc)
13611         enddo ! j
13612         num_cont_hb(i)=num_conti
13613       enddo   ! i
13614 !      write (iout,*) "Number of loop steps in EELEC:",ind
13615 !d      do i=1,nres
13616 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
13617 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
13618 !d      enddo
13619 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
13620 !cc      eel_loc=eel_loc+eello_turn3
13621 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
13622       return
13623       end subroutine eelec_scale
13624 !-----------------------------------------------------------------------------
13625       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
13626 !      implicit real*8 (a-h,o-z)
13627
13628       use comm_locel
13629 !      include 'DIMENSIONS'
13630 #ifdef MPI
13631       include "mpif.h"
13632 #endif
13633 !      include 'COMMON.CONTROL'
13634 !      include 'COMMON.IOUNITS'
13635 !      include 'COMMON.GEO'
13636 !      include 'COMMON.VAR'
13637 !      include 'COMMON.LOCAL'
13638 !      include 'COMMON.CHAIN'
13639 !      include 'COMMON.DERIV'
13640 !      include 'COMMON.INTERACT'
13641 !      include 'COMMON.CONTACTS'
13642 !      include 'COMMON.TORSION'
13643 !      include 'COMMON.VECTORS'
13644 !      include 'COMMON.FFIELD'
13645 !      include 'COMMON.TIME1'
13646       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
13647       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
13648       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13649 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13650       real(kind=8),dimension(4) :: muij
13651       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13652                     dist_temp, dist_init,sss_grad
13653       integer xshift,yshift,zshift
13654
13655 !el      integer :: num_conti,j1,j2
13656 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13657 !el                   dz_normi,xmedi,ymedi,zmedi
13658 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13659 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13660 !el          num_conti,j1,j2
13661 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13662 #ifdef MOMENT
13663       real(kind=8) :: scal_el=1.0d0
13664 #else
13665       real(kind=8) :: scal_el=0.5d0
13666 #endif
13667 ! 12/13/98
13668 ! 13-go grudnia roku pamietnego...
13669       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13670                                              0.0d0,1.0d0,0.0d0,&
13671                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13672 !el local variables
13673       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
13674       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
13675       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
13676       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
13677       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
13678       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
13679       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
13680                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
13681                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
13682                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
13683                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
13684                   ecosam,ecosbm,ecosgm,ghalf,time00
13685 !      integer :: maxconts
13686 !      maxconts = nres/4
13687 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13688 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13689 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13690 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13691 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13692 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13693 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13694 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13695 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
13696 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
13697 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
13698 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
13699 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
13700
13701 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
13702 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
13703
13704 #ifdef MPI
13705           time00=MPI_Wtime()
13706 #endif
13707 !d      write (iout,*) "eelecij",i,j
13708 !el          ind=ind+1
13709           iteli=itel(i)
13710           itelj=itel(j)
13711           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13712           aaa=app(iteli,itelj)
13713           bbb=bpp(iteli,itelj)
13714           ael6i=ael6(iteli,itelj)
13715           ael3i=ael3(iteli,itelj)
13716           dxj=dc(1,j)
13717           dyj=dc(2,j)
13718           dzj=dc(3,j)
13719           dx_normj=dc_norm(1,j)
13720           dy_normj=dc_norm(2,j)
13721           dz_normj=dc_norm(3,j)
13722 !          xj=c(1,j)+0.5D0*dxj-xmedi
13723 !          yj=c(2,j)+0.5D0*dyj-ymedi
13724 !          zj=c(3,j)+0.5D0*dzj-zmedi
13725           xj=c(1,j)+0.5D0*dxj
13726           yj=c(2,j)+0.5D0*dyj
13727           zj=c(3,j)+0.5D0*dzj
13728           xj=mod(xj,boxxsize)
13729           if (xj.lt.0) xj=xj+boxxsize
13730           yj=mod(yj,boxysize)
13731           if (yj.lt.0) yj=yj+boxysize
13732           zj=mod(zj,boxzsize)
13733           if (zj.lt.0) zj=zj+boxzsize
13734       isubchap=0
13735       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13736       xj_safe=xj
13737       yj_safe=yj
13738       zj_safe=zj
13739       do xshift=-1,1
13740       do yshift=-1,1
13741       do zshift=-1,1
13742           xj=xj_safe+xshift*boxxsize
13743           yj=yj_safe+yshift*boxysize
13744           zj=zj_safe+zshift*boxzsize
13745           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13746           if(dist_temp.lt.dist_init) then
13747             dist_init=dist_temp
13748             xj_temp=xj
13749             yj_temp=yj
13750             zj_temp=zj
13751             isubchap=1
13752           endif
13753        enddo
13754        enddo
13755        enddo
13756        if (isubchap.eq.1) then
13757 !C          print *,i,j
13758           xj=xj_temp-xmedi
13759           yj=yj_temp-ymedi
13760           zj=zj_temp-zmedi
13761        else
13762           xj=xj_safe-xmedi
13763           yj=yj_safe-ymedi
13764           zj=zj_safe-zmedi
13765        endif
13766
13767           rij=xj*xj+yj*yj+zj*zj
13768           rrmij=1.0D0/rij
13769           rij=dsqrt(rij)
13770           rmij=1.0D0/rij
13771 ! For extracting the short-range part of Evdwpp
13772           sss=sscale(rij/rpp(iteli,itelj))
13773             sss_ele_cut=sscale_ele(rij)
13774             sss_ele_grad=sscagrad_ele(rij)
13775             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
13776 !             sss_ele_cut=1.0d0
13777 !             sss_ele_grad=0.0d0
13778             if (sss_ele_cut.le.0.0) go to 128
13779
13780           r3ij=rrmij*rmij
13781           r6ij=r3ij*r3ij
13782           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
13783           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
13784           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
13785           fac=cosa-3.0D0*cosb*cosg
13786           ev1=aaa*r6ij*r6ij
13787 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13788           if (j.eq.i+2) ev1=scal_el*ev1
13789           ev2=bbb*r6ij
13790           fac3=ael6i*r6ij
13791           fac4=ael3i*r3ij
13792           evdwij=ev1+ev2
13793           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
13794           el2=fac4*fac
13795           eesij=el1+el2
13796 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
13797           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
13798           ees=ees+eesij*sss_ele_cut
13799           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
13800 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
13801 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
13802 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
13803 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
13804
13805           if (energy_dec) then
13806               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13807               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
13808           endif
13809
13810 !
13811 ! Calculate contributions to the Cartesian gradient.
13812 !
13813 #ifdef SPLITELE
13814           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
13815           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
13816           fac1=fac
13817           erij(1)=xj*rmij
13818           erij(2)=yj*rmij
13819           erij(3)=zj*rmij
13820 !
13821 ! Radial derivatives. First process both termini of the fragment (i,j)
13822 !
13823           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
13824           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
13825           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
13826 !          do k=1,3
13827 !            ghalf=0.5D0*ggg(k)
13828 !            gelc(k,i)=gelc(k,i)+ghalf
13829 !            gelc(k,j)=gelc(k,j)+ghalf
13830 !          enddo
13831 ! 9/28/08 AL Gradient compotents will be summed only at the end
13832           do k=1,3
13833             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
13834             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
13835           enddo
13836 !
13837 ! Loop over residues i+1 thru j-1.
13838 !
13839 !grad          do k=i+1,j-1
13840 !grad            do l=1,3
13841 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13842 !grad            enddo
13843 !grad          enddo
13844           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
13845           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
13846           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
13847           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
13848           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
13849           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
13850 !          do k=1,3
13851 !            ghalf=0.5D0*ggg(k)
13852 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
13853 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
13854 !          enddo
13855 ! 9/28/08 AL Gradient compotents will be summed only at the end
13856           do k=1,3
13857             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13858             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13859           enddo
13860 !
13861 ! Loop over residues i+1 thru j-1.
13862 !
13863 !grad          do k=i+1,j-1
13864 !grad            do l=1,3
13865 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
13866 !grad            enddo
13867 !grad          enddo
13868 #else
13869           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
13870           facel=(el1+eesij)*sss_ele_cut
13871           fac1=fac
13872           fac=-3*rrmij*(facvdw+facvdw+facel)
13873           erij(1)=xj*rmij
13874           erij(2)=yj*rmij
13875           erij(3)=zj*rmij
13876 !
13877 ! Radial derivatives. First process both termini of the fragment (i,j)
13878 !
13879           ggg(1)=fac*xj
13880           ggg(2)=fac*yj
13881           ggg(3)=fac*zj
13882 !          do k=1,3
13883 !            ghalf=0.5D0*ggg(k)
13884 !            gelc(k,i)=gelc(k,i)+ghalf
13885 !            gelc(k,j)=gelc(k,j)+ghalf
13886 !          enddo
13887 ! 9/28/08 AL Gradient compotents will be summed only at the end
13888           do k=1,3
13889             gelc_long(k,j)=gelc(k,j)+ggg(k)
13890             gelc_long(k,i)=gelc(k,i)-ggg(k)
13891           enddo
13892 !
13893 ! Loop over residues i+1 thru j-1.
13894 !
13895 !grad          do k=i+1,j-1
13896 !grad            do l=1,3
13897 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13898 !grad            enddo
13899 !grad          enddo
13900 ! 9/28/08 AL Gradient compotents will be summed only at the end
13901           ggg(1)=facvdw*xj
13902           ggg(2)=facvdw*yj
13903           ggg(3)=facvdw*zj
13904           do k=1,3
13905             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13906             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13907           enddo
13908 #endif
13909 !
13910 ! Angular part
13911 !
13912           ecosa=2.0D0*fac3*fac1+fac4
13913           fac4=-3.0D0*fac4
13914           fac3=-6.0D0*fac3
13915           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
13916           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
13917           do k=1,3
13918             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13919             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13920           enddo
13921 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
13922 !d   &          (dcosg(k),k=1,3)
13923           do k=1,3
13924             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
13925           enddo
13926 !          do k=1,3
13927 !            ghalf=0.5D0*ggg(k)
13928 !            gelc(k,i)=gelc(k,i)+ghalf
13929 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
13930 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13931 !            gelc(k,j)=gelc(k,j)+ghalf
13932 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
13933 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13934 !          enddo
13935 !grad          do k=i+1,j-1
13936 !grad            do l=1,3
13937 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13938 !grad            enddo
13939 !grad          enddo
13940           do k=1,3
13941             gelc(k,i)=gelc(k,i) &
13942                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13943                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
13944                      *sss_ele_cut
13945             gelc(k,j)=gelc(k,j) &
13946                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13947                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
13948                      *sss_ele_cut
13949             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
13950             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
13951           enddo
13952           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13953               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
13954               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13955 !
13956 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
13957 !   energy of a peptide unit is assumed in the form of a second-order
13958 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
13959 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
13960 !   are computed for EVERY pair of non-contiguous peptide groups.
13961 !
13962           if (j.lt.nres-1) then
13963             j1=j+1
13964             j2=j-1
13965           else
13966             j1=j-1
13967             j2=j-2
13968           endif
13969           kkk=0
13970           do k=1,2
13971             do l=1,2
13972               kkk=kkk+1
13973               muij(kkk)=mu(k,i)*mu(l,j)
13974             enddo
13975           enddo
13976 !d         write (iout,*) 'EELEC: i',i,' j',j
13977 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
13978 !d          write(iout,*) 'muij',muij
13979           ury=scalar(uy(1,i),erij)
13980           urz=scalar(uz(1,i),erij)
13981           vry=scalar(uy(1,j),erij)
13982           vrz=scalar(uz(1,j),erij)
13983           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
13984           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
13985           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
13986           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
13987           fac=dsqrt(-ael6i)*r3ij
13988           a22=a22*fac
13989           a23=a23*fac
13990           a32=a32*fac
13991           a33=a33*fac
13992 !d          write (iout,'(4i5,4f10.5)')
13993 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
13994 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
13995 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
13996 !d     &      uy(:,j),uz(:,j)
13997 !d          write (iout,'(4f10.5)')
13998 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
13999 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14000 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14001 !d           write (iout,'(9f10.5/)')
14002 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14003 ! Derivatives of the elements of A in virtual-bond vectors
14004           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14005           do k=1,3
14006             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14007             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14008             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14009             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14010             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14011             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14012             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14013             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14014             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14015             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14016             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14017             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14018           enddo
14019 ! Compute radial contributions to the gradient
14020           facr=-3.0d0*rrmij
14021           a22der=a22*facr
14022           a23der=a23*facr
14023           a32der=a32*facr
14024           a33der=a33*facr
14025           agg(1,1)=a22der*xj
14026           agg(2,1)=a22der*yj
14027           agg(3,1)=a22der*zj
14028           agg(1,2)=a23der*xj
14029           agg(2,2)=a23der*yj
14030           agg(3,2)=a23der*zj
14031           agg(1,3)=a32der*xj
14032           agg(2,3)=a32der*yj
14033           agg(3,3)=a32der*zj
14034           agg(1,4)=a33der*xj
14035           agg(2,4)=a33der*yj
14036           agg(3,4)=a33der*zj
14037 ! Add the contributions coming from er
14038           fac3=-3.0d0*fac
14039           do k=1,3
14040             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14041             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14042             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14043             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14044           enddo
14045           do k=1,3
14046 ! Derivatives in DC(i)
14047 !grad            ghalf1=0.5d0*agg(k,1)
14048 !grad            ghalf2=0.5d0*agg(k,2)
14049 !grad            ghalf3=0.5d0*agg(k,3)
14050 !grad            ghalf4=0.5d0*agg(k,4)
14051             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14052             -3.0d0*uryg(k,2)*vry)!+ghalf1
14053             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14054             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14055             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14056             -3.0d0*urzg(k,2)*vry)!+ghalf3
14057             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14058             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14059 ! Derivatives in DC(i+1)
14060             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14061             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14062             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14063             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14064             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14065             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14066             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14067             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14068 ! Derivatives in DC(j)
14069             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14070             -3.0d0*vryg(k,2)*ury)!+ghalf1
14071             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14072             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14073             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14074             -3.0d0*vryg(k,2)*urz)!+ghalf3
14075             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14076             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14077 ! Derivatives in DC(j+1) or DC(nres-1)
14078             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14079             -3.0d0*vryg(k,3)*ury)
14080             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14081             -3.0d0*vrzg(k,3)*ury)
14082             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14083             -3.0d0*vryg(k,3)*urz)
14084             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14085             -3.0d0*vrzg(k,3)*urz)
14086 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14087 !grad              do l=1,4
14088 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14089 !grad              enddo
14090 !grad            endif
14091           enddo
14092           acipa(1,1)=a22
14093           acipa(1,2)=a23
14094           acipa(2,1)=a32
14095           acipa(2,2)=a33
14096           a22=-a22
14097           a23=-a23
14098           do l=1,2
14099             do k=1,3
14100               agg(k,l)=-agg(k,l)
14101               aggi(k,l)=-aggi(k,l)
14102               aggi1(k,l)=-aggi1(k,l)
14103               aggj(k,l)=-aggj(k,l)
14104               aggj1(k,l)=-aggj1(k,l)
14105             enddo
14106           enddo
14107           if (j.lt.nres-1) then
14108             a22=-a22
14109             a32=-a32
14110             do l=1,3,2
14111               do k=1,3
14112                 agg(k,l)=-agg(k,l)
14113                 aggi(k,l)=-aggi(k,l)
14114                 aggi1(k,l)=-aggi1(k,l)
14115                 aggj(k,l)=-aggj(k,l)
14116                 aggj1(k,l)=-aggj1(k,l)
14117               enddo
14118             enddo
14119           else
14120             a22=-a22
14121             a23=-a23
14122             a32=-a32
14123             a33=-a33
14124             do l=1,4
14125               do k=1,3
14126                 agg(k,l)=-agg(k,l)
14127                 aggi(k,l)=-aggi(k,l)
14128                 aggi1(k,l)=-aggi1(k,l)
14129                 aggj(k,l)=-aggj(k,l)
14130                 aggj1(k,l)=-aggj1(k,l)
14131               enddo
14132             enddo
14133           endif
14134           ENDIF ! WCORR
14135           IF (wel_loc.gt.0.0d0) THEN
14136 ! Contribution to the local-electrostatic energy coming from the i-j pair
14137           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14138            +a33*muij(4)
14139 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14140
14141           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14142                   'eelloc',i,j,eel_loc_ij
14143 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14144
14145           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14146 ! Partial derivatives in virtual-bond dihedral angles gamma
14147           if (i.gt.1) &
14148           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14149                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14150                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14151                  *sss_ele_cut
14152           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14153                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14154                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14155                  *sss_ele_cut
14156            xtemp(1)=xj
14157            xtemp(2)=yj
14158            xtemp(3)=zj
14159
14160 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14161           do l=1,3
14162             ggg(l)=(agg(l,1)*muij(1)+ &
14163                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14164             *sss_ele_cut &
14165              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14166
14167             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14168             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14169 !grad            ghalf=0.5d0*ggg(l)
14170 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14171 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14172           enddo
14173 !grad          do k=i+1,j2
14174 !grad            do l=1,3
14175 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14176 !grad            enddo
14177 !grad          enddo
14178 ! Remaining derivatives of eello
14179           do l=1,3
14180             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14181                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14182             *sss_ele_cut
14183
14184             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14185                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14186             *sss_ele_cut
14187
14188             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14189                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14190             *sss_ele_cut
14191
14192             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14193                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14194             *sss_ele_cut
14195
14196           enddo
14197           ENDIF
14198 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14199 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14200           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14201              .and. num_conti.le.maxconts) then
14202 !            write (iout,*) i,j," entered corr"
14203 !
14204 ! Calculate the contact function. The ith column of the array JCONT will
14205 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14206 ! greater than I). The arrays FACONT and GACONT will contain the values of
14207 ! the contact function and its derivative.
14208 !           r0ij=1.02D0*rpp(iteli,itelj)
14209 !           r0ij=1.11D0*rpp(iteli,itelj)
14210             r0ij=2.20D0*rpp(iteli,itelj)
14211 !           r0ij=1.55D0*rpp(iteli,itelj)
14212             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14213 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14214             if (fcont.gt.0.0D0) then
14215               num_conti=num_conti+1
14216               if (num_conti.gt.maxconts) then
14217 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14218                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14219                                ' will skip next contacts for this conf.',num_conti
14220               else
14221                 jcont_hb(num_conti,i)=j
14222 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14223 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14224                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14225                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14226 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14227 !  terms.
14228                 d_cont(num_conti,i)=rij
14229 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14230 !     --- Electrostatic-interaction matrix ---
14231                 a_chuj(1,1,num_conti,i)=a22
14232                 a_chuj(1,2,num_conti,i)=a23
14233                 a_chuj(2,1,num_conti,i)=a32
14234                 a_chuj(2,2,num_conti,i)=a33
14235 !     --- Gradient of rij
14236                 do kkk=1,3
14237                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14238                 enddo
14239                 kkll=0
14240                 do k=1,2
14241                   do l=1,2
14242                     kkll=kkll+1
14243                     do m=1,3
14244                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14245                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14246                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14247                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14248                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14249                     enddo
14250                   enddo
14251                 enddo
14252                 ENDIF
14253                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14254 ! Calculate contact energies
14255                 cosa4=4.0D0*cosa
14256                 wij=cosa-3.0D0*cosb*cosg
14257                 cosbg1=cosb+cosg
14258                 cosbg2=cosb-cosg
14259 !               fac3=dsqrt(-ael6i)/r0ij**3
14260                 fac3=dsqrt(-ael6i)*r3ij
14261 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14262                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14263                 if (ees0tmp.gt.0) then
14264                   ees0pij=dsqrt(ees0tmp)
14265                 else
14266                   ees0pij=0
14267                 endif
14268 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14269                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14270                 if (ees0tmp.gt.0) then
14271                   ees0mij=dsqrt(ees0tmp)
14272                 else
14273                   ees0mij=0
14274                 endif
14275 !               ees0mij=0.0D0
14276                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14277                      *sss_ele_cut
14278
14279                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14280                      *sss_ele_cut
14281
14282 ! Diagnostics. Comment out or remove after debugging!
14283 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14284 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14285 !               ees0m(num_conti,i)=0.0D0
14286 ! End diagnostics.
14287 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14288 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14289 ! Angular derivatives of the contact function
14290                 ees0pij1=fac3/ees0pij
14291                 ees0mij1=fac3/ees0mij
14292                 fac3p=-3.0D0*fac3*rrmij
14293                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14294                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14295 !               ees0mij1=0.0D0
14296                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14297                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14298                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14299                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14300                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14301                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14302                 ecosap=ecosa1+ecosa2
14303                 ecosbp=ecosb1+ecosb2
14304                 ecosgp=ecosg1+ecosg2
14305                 ecosam=ecosa1-ecosa2
14306                 ecosbm=ecosb1-ecosb2
14307                 ecosgm=ecosg1-ecosg2
14308 ! Diagnostics
14309 !               ecosap=ecosa1
14310 !               ecosbp=ecosb1
14311 !               ecosgp=ecosg1
14312 !               ecosam=0.0D0
14313 !               ecosbm=0.0D0
14314 !               ecosgm=0.0D0
14315 ! End diagnostics
14316                 facont_hb(num_conti,i)=fcont
14317                 fprimcont=fprimcont/rij
14318 !d              facont_hb(num_conti,i)=1.0D0
14319 ! Following line is for diagnostics.
14320 !d              fprimcont=0.0D0
14321                 do k=1,3
14322                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14323                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14324                 enddo
14325                 do k=1,3
14326                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14327                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14328                 enddo
14329 !                gggp(1)=gggp(1)+ees0pijp*xj
14330 !                gggp(2)=gggp(2)+ees0pijp*yj
14331 !                gggp(3)=gggp(3)+ees0pijp*zj
14332 !                gggm(1)=gggm(1)+ees0mijp*xj
14333 !                gggm(2)=gggm(2)+ees0mijp*yj
14334 !                gggm(3)=gggm(3)+ees0mijp*zj
14335                 gggp(1)=gggp(1)+ees0pijp*xj &
14336                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14337                 gggp(2)=gggp(2)+ees0pijp*yj &
14338                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14339                 gggp(3)=gggp(3)+ees0pijp*zj &
14340                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14341
14342                 gggm(1)=gggm(1)+ees0mijp*xj &
14343                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14344
14345                 gggm(2)=gggm(2)+ees0mijp*yj &
14346                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14347
14348                 gggm(3)=gggm(3)+ees0mijp*zj &
14349                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14350
14351 ! Derivatives due to the contact function
14352                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14353                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14354                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14355                 do k=1,3
14356 !
14357 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14358 !          following the change of gradient-summation algorithm.
14359 !
14360 !grad                  ghalfp=0.5D0*gggp(k)
14361 !grad                  ghalfm=0.5D0*gggm(k)
14362 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14363 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14364 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14365 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14366 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14367 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14368 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14369 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14370 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14371 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14372 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14373 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14374 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14375 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14376                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14377                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14378                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14379                      *sss_ele_cut
14380
14381                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14382                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14383                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14384                      *sss_ele_cut
14385
14386                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14387                      *sss_ele_cut
14388
14389                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14390                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14391                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14392                      *sss_ele_cut
14393
14394                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14395                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14396                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14397                      *sss_ele_cut
14398
14399                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14400                      *sss_ele_cut
14401
14402                 enddo
14403               ENDIF ! wcorr
14404               endif  ! num_conti.le.maxconts
14405             endif  ! fcont.gt.0
14406           endif    ! j.gt.i+1
14407           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14408             do k=1,4
14409               do l=1,3
14410                 ghalf=0.5d0*agg(l,k)
14411                 aggi(l,k)=aggi(l,k)+ghalf
14412                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14413                 aggj(l,k)=aggj(l,k)+ghalf
14414               enddo
14415             enddo
14416             if (j.eq.nres-1 .and. i.lt.j-2) then
14417               do k=1,4
14418                 do l=1,3
14419                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14420                 enddo
14421               enddo
14422             endif
14423           endif
14424  128      continue
14425 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14426       return
14427       end subroutine eelecij_scale
14428 !-----------------------------------------------------------------------------
14429       subroutine evdwpp_short(evdw1)
14430 !
14431 ! Compute Evdwpp
14432 !
14433 !      implicit real*8 (a-h,o-z)
14434 !      include 'DIMENSIONS'
14435 !      include 'COMMON.CONTROL'
14436 !      include 'COMMON.IOUNITS'
14437 !      include 'COMMON.GEO'
14438 !      include 'COMMON.VAR'
14439 !      include 'COMMON.LOCAL'
14440 !      include 'COMMON.CHAIN'
14441 !      include 'COMMON.DERIV'
14442 !      include 'COMMON.INTERACT'
14443 !      include 'COMMON.CONTACTS'
14444 !      include 'COMMON.TORSION'
14445 !      include 'COMMON.VECTORS'
14446 !      include 'COMMON.FFIELD'
14447       real(kind=8),dimension(3) :: ggg
14448 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14449 #ifdef MOMENT
14450       real(kind=8) :: scal_el=1.0d0
14451 #else
14452       real(kind=8) :: scal_el=0.5d0
14453 #endif
14454 !el local variables
14455       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14456       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14457       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14458                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14459                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14460       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14461                     dist_temp, dist_init,sss_grad
14462       integer xshift,yshift,zshift
14463
14464
14465       evdw1=0.0D0
14466 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14467 !     & " iatel_e_vdw",iatel_e_vdw
14468       call flush(iout)
14469       do i=iatel_s_vdw,iatel_e_vdw
14470         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
14471         dxi=dc(1,i)
14472         dyi=dc(2,i)
14473         dzi=dc(3,i)
14474         dx_normi=dc_norm(1,i)
14475         dy_normi=dc_norm(2,i)
14476         dz_normi=dc_norm(3,i)
14477         xmedi=c(1,i)+0.5d0*dxi
14478         ymedi=c(2,i)+0.5d0*dyi
14479         zmedi=c(3,i)+0.5d0*dzi
14480           xmedi=dmod(xmedi,boxxsize)
14481           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14482           ymedi=dmod(ymedi,boxysize)
14483           if (ymedi.lt.0) ymedi=ymedi+boxysize
14484           zmedi=dmod(zmedi,boxzsize)
14485           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14486         num_conti=0
14487 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14488 !     &   ' ielend',ielend_vdw(i)
14489         call flush(iout)
14490         do j=ielstart_vdw(i),ielend_vdw(i)
14491           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
14492 !el          ind=ind+1
14493           iteli=itel(i)
14494           itelj=itel(j)
14495           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14496           aaa=app(iteli,itelj)
14497           bbb=bpp(iteli,itelj)
14498           dxj=dc(1,j)
14499           dyj=dc(2,j)
14500           dzj=dc(3,j)
14501           dx_normj=dc_norm(1,j)
14502           dy_normj=dc_norm(2,j)
14503           dz_normj=dc_norm(3,j)
14504 !          xj=c(1,j)+0.5D0*dxj-xmedi
14505 !          yj=c(2,j)+0.5D0*dyj-ymedi
14506 !          zj=c(3,j)+0.5D0*dzj-zmedi
14507           xj=c(1,j)+0.5D0*dxj
14508           yj=c(2,j)+0.5D0*dyj
14509           zj=c(3,j)+0.5D0*dzj
14510           xj=mod(xj,boxxsize)
14511           if (xj.lt.0) xj=xj+boxxsize
14512           yj=mod(yj,boxysize)
14513           if (yj.lt.0) yj=yj+boxysize
14514           zj=mod(zj,boxzsize)
14515           if (zj.lt.0) zj=zj+boxzsize
14516       isubchap=0
14517       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14518       xj_safe=xj
14519       yj_safe=yj
14520       zj_safe=zj
14521       do xshift=-1,1
14522       do yshift=-1,1
14523       do zshift=-1,1
14524           xj=xj_safe+xshift*boxxsize
14525           yj=yj_safe+yshift*boxysize
14526           zj=zj_safe+zshift*boxzsize
14527           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14528           if(dist_temp.lt.dist_init) then
14529             dist_init=dist_temp
14530             xj_temp=xj
14531             yj_temp=yj
14532             zj_temp=zj
14533             isubchap=1
14534           endif
14535        enddo
14536        enddo
14537        enddo
14538        if (isubchap.eq.1) then
14539 !C          print *,i,j
14540           xj=xj_temp-xmedi
14541           yj=yj_temp-ymedi
14542           zj=zj_temp-zmedi
14543        else
14544           xj=xj_safe-xmedi
14545           yj=yj_safe-ymedi
14546           zj=zj_safe-zmedi
14547        endif
14548
14549           rij=xj*xj+yj*yj+zj*zj
14550           rrmij=1.0D0/rij
14551           rij=dsqrt(rij)
14552           sss=sscale(rij/rpp(iteli,itelj))
14553             sss_ele_cut=sscale_ele(rij)
14554             sss_ele_grad=sscagrad_ele(rij)
14555             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14556             if (sss_ele_cut.le.0.0) cycle
14557           if (sss.gt.0.0d0) then
14558             rmij=1.0D0/rij
14559             r3ij=rrmij*rmij
14560             r6ij=r3ij*r3ij
14561             ev1=aaa*r6ij*r6ij
14562 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14563             if (j.eq.i+2) ev1=scal_el*ev1
14564             ev2=bbb*r6ij
14565             evdwij=ev1+ev2
14566             if (energy_dec) then
14567               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14568             endif
14569             evdw1=evdw1+evdwij*sss*sss_ele_cut
14570 !
14571 ! Calculate contributions to the Cartesian gradient.
14572 !
14573             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14574 !            ggg(1)=facvdw*xj
14575 !            ggg(2)=facvdw*yj
14576 !            ggg(3)=facvdw*zj
14577           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14578           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14579           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14580           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14581           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14582           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14583
14584             do k=1,3
14585               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14586               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14587             enddo
14588           endif
14589         enddo ! j
14590       enddo   ! i
14591       return
14592       end subroutine evdwpp_short
14593 !-----------------------------------------------------------------------------
14594       subroutine escp_long(evdw2,evdw2_14)
14595 !
14596 ! This subroutine calculates the excluded-volume interaction energy between
14597 ! peptide-group centers and side chains and its gradient in virtual-bond and
14598 ! side-chain vectors.
14599 !
14600 !      implicit real*8 (a-h,o-z)
14601 !      include 'DIMENSIONS'
14602 !      include 'COMMON.GEO'
14603 !      include 'COMMON.VAR'
14604 !      include 'COMMON.LOCAL'
14605 !      include 'COMMON.CHAIN'
14606 !      include 'COMMON.DERIV'
14607 !      include 'COMMON.INTERACT'
14608 !      include 'COMMON.FFIELD'
14609 !      include 'COMMON.IOUNITS'
14610 !      include 'COMMON.CONTROL'
14611       real(kind=8),dimension(3) :: ggg
14612 !el local variables
14613       integer :: i,iint,j,k,iteli,itypj,subchap
14614       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14615       real(kind=8) :: evdw2,evdw2_14,evdwij
14616       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14617                     dist_temp, dist_init
14618
14619       evdw2=0.0D0
14620       evdw2_14=0.0d0
14621 !d    print '(a)','Enter ESCP'
14622 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14623       do i=iatscp_s,iatscp_e
14624         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
14625         iteli=itel(i)
14626         xi=0.5D0*(c(1,i)+c(1,i+1))
14627         yi=0.5D0*(c(2,i)+c(2,i+1))
14628         zi=0.5D0*(c(3,i)+c(3,i+1))
14629           xi=mod(xi,boxxsize)
14630           if (xi.lt.0) xi=xi+boxxsize
14631           yi=mod(yi,boxysize)
14632           if (yi.lt.0) yi=yi+boxysize
14633           zi=mod(zi,boxzsize)
14634           if (zi.lt.0) zi=zi+boxzsize
14635
14636         do iint=1,nscp_gr(i)
14637
14638         do j=iscpstart(i,iint),iscpend(i,iint)
14639           itypj=itype(j)
14640           if (itypj.eq.ntyp1) cycle
14641 ! Uncomment following three lines for SC-p interactions
14642 !         xj=c(1,nres+j)-xi
14643 !         yj=c(2,nres+j)-yi
14644 !         zj=c(3,nres+j)-zi
14645 ! Uncomment following three lines for Ca-p interactions
14646           xj=c(1,j)
14647           yj=c(2,j)
14648           zj=c(3,j)
14649           xj=mod(xj,boxxsize)
14650           if (xj.lt.0) xj=xj+boxxsize
14651           yj=mod(yj,boxysize)
14652           if (yj.lt.0) yj=yj+boxysize
14653           zj=mod(zj,boxzsize)
14654           if (zj.lt.0) zj=zj+boxzsize
14655       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14656       xj_safe=xj
14657       yj_safe=yj
14658       zj_safe=zj
14659       subchap=0
14660       do xshift=-1,1
14661       do yshift=-1,1
14662       do zshift=-1,1
14663           xj=xj_safe+xshift*boxxsize
14664           yj=yj_safe+yshift*boxysize
14665           zj=zj_safe+zshift*boxzsize
14666           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14667           if(dist_temp.lt.dist_init) then
14668             dist_init=dist_temp
14669             xj_temp=xj
14670             yj_temp=yj
14671             zj_temp=zj
14672             subchap=1
14673           endif
14674        enddo
14675        enddo
14676        enddo
14677        if (subchap.eq.1) then
14678           xj=xj_temp-xi
14679           yj=yj_temp-yi
14680           zj=zj_temp-zi
14681        else
14682           xj=xj_safe-xi
14683           yj=yj_safe-yi
14684           zj=zj_safe-zi
14685        endif
14686           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14687
14688           rij=dsqrt(1.0d0/rrij)
14689             sss_ele_cut=sscale_ele(rij)
14690             sss_ele_grad=sscagrad_ele(rij)
14691 !            print *,sss_ele_cut,sss_ele_grad,&
14692 !            (rij),r_cut_ele,rlamb_ele
14693             if (sss_ele_cut.le.0.0) cycle
14694           sss=sscale((rij/rscp(itypj,iteli)))
14695           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14696           if (sss.lt.1.0d0) then
14697
14698             fac=rrij**expon2
14699             e1=fac*fac*aad(itypj,iteli)
14700             e2=fac*bad(itypj,iteli)
14701             if (iabs(j-i) .le. 2) then
14702               e1=scal14*e1
14703               e2=scal14*e2
14704               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
14705             endif
14706             evdwij=e1+e2
14707             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
14708             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14709                 'evdw2',i,j,sss,evdwij
14710 !
14711 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14712 !
14713             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
14714             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
14715             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14716             ggg(1)=xj*fac
14717             ggg(2)=yj*fac
14718             ggg(3)=zj*fac
14719 ! Uncomment following three lines for SC-p interactions
14720 !           do k=1,3
14721 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14722 !           enddo
14723 ! Uncomment following line for SC-p interactions
14724 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14725             do k=1,3
14726               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14727               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14728             enddo
14729           endif
14730         enddo
14731
14732         enddo ! iint
14733       enddo ! i
14734       do i=1,nct
14735         do j=1,3
14736           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14737           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14738           gradx_scp(j,i)=expon*gradx_scp(j,i)
14739         enddo
14740       enddo
14741 !******************************************************************************
14742 !
14743 !                              N O T E !!!
14744 !
14745 ! To save time the factor EXPON has been extracted from ALL components
14746 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14747 ! use!
14748 !
14749 !******************************************************************************
14750       return
14751       end subroutine escp_long
14752 !-----------------------------------------------------------------------------
14753       subroutine escp_short(evdw2,evdw2_14)
14754 !
14755 ! This subroutine calculates the excluded-volume interaction energy between
14756 ! peptide-group centers and side chains and its gradient in virtual-bond and
14757 ! side-chain vectors.
14758 !
14759 !      implicit real*8 (a-h,o-z)
14760 !      include 'DIMENSIONS'
14761 !      include 'COMMON.GEO'
14762 !      include 'COMMON.VAR'
14763 !      include 'COMMON.LOCAL'
14764 !      include 'COMMON.CHAIN'
14765 !      include 'COMMON.DERIV'
14766 !      include 'COMMON.INTERACT'
14767 !      include 'COMMON.FFIELD'
14768 !      include 'COMMON.IOUNITS'
14769 !      include 'COMMON.CONTROL'
14770       real(kind=8),dimension(3) :: ggg
14771 !el local variables
14772       integer :: i,iint,j,k,iteli,itypj,subchap
14773       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14774       real(kind=8) :: evdw2,evdw2_14,evdwij
14775       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14776                     dist_temp, dist_init
14777
14778       evdw2=0.0D0
14779       evdw2_14=0.0d0
14780 !d    print '(a)','Enter ESCP'
14781 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14782       do i=iatscp_s,iatscp_e
14783         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
14784         iteli=itel(i)
14785         xi=0.5D0*(c(1,i)+c(1,i+1))
14786         yi=0.5D0*(c(2,i)+c(2,i+1))
14787         zi=0.5D0*(c(3,i)+c(3,i+1))
14788           xi=mod(xi,boxxsize)
14789           if (xi.lt.0) xi=xi+boxxsize
14790           yi=mod(yi,boxysize)
14791           if (yi.lt.0) yi=yi+boxysize
14792           zi=mod(zi,boxzsize)
14793           if (zi.lt.0) zi=zi+boxzsize
14794
14795         do iint=1,nscp_gr(i)
14796
14797         do j=iscpstart(i,iint),iscpend(i,iint)
14798           itypj=itype(j)
14799           if (itypj.eq.ntyp1) cycle
14800 ! Uncomment following three lines for SC-p interactions
14801 !         xj=c(1,nres+j)-xi
14802 !         yj=c(2,nres+j)-yi
14803 !         zj=c(3,nres+j)-zi
14804 ! Uncomment following three lines for Ca-p interactions
14805 !          xj=c(1,j)-xi
14806 !          yj=c(2,j)-yi
14807 !          zj=c(3,j)-zi
14808           xj=c(1,j)
14809           yj=c(2,j)
14810           zj=c(3,j)
14811           xj=mod(xj,boxxsize)
14812           if (xj.lt.0) xj=xj+boxxsize
14813           yj=mod(yj,boxysize)
14814           if (yj.lt.0) yj=yj+boxysize
14815           zj=mod(zj,boxzsize)
14816           if (zj.lt.0) zj=zj+boxzsize
14817       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14818       xj_safe=xj
14819       yj_safe=yj
14820       zj_safe=zj
14821       subchap=0
14822       do xshift=-1,1
14823       do yshift=-1,1
14824       do zshift=-1,1
14825           xj=xj_safe+xshift*boxxsize
14826           yj=yj_safe+yshift*boxysize
14827           zj=zj_safe+zshift*boxzsize
14828           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14829           if(dist_temp.lt.dist_init) then
14830             dist_init=dist_temp
14831             xj_temp=xj
14832             yj_temp=yj
14833             zj_temp=zj
14834             subchap=1
14835           endif
14836        enddo
14837        enddo
14838        enddo
14839        if (subchap.eq.1) then
14840           xj=xj_temp-xi
14841           yj=yj_temp-yi
14842           zj=zj_temp-zi
14843        else
14844           xj=xj_safe-xi
14845           yj=yj_safe-yi
14846           zj=zj_safe-zi
14847        endif
14848
14849           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14850           rij=dsqrt(1.0d0/rrij)
14851             sss_ele_cut=sscale_ele(rij)
14852             sss_ele_grad=sscagrad_ele(rij)
14853 !            print *,sss_ele_cut,sss_ele_grad,&
14854 !            (rij),r_cut_ele,rlamb_ele
14855             if (sss_ele_cut.le.0.0) cycle
14856           sss=sscale(rij/rscp(itypj,iteli))
14857           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14858           if (sss.gt.0.0d0) then
14859
14860             fac=rrij**expon2
14861             e1=fac*fac*aad(itypj,iteli)
14862             e2=fac*bad(itypj,iteli)
14863             if (iabs(j-i) .le. 2) then
14864               e1=scal14*e1
14865               e2=scal14*e2
14866               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
14867             endif
14868             evdwij=e1+e2
14869             evdw2=evdw2+evdwij*sss*sss_ele_cut
14870             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14871                 'evdw2',i,j,sss,evdwij
14872 !
14873 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14874 !
14875             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
14876             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
14877             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14878
14879             ggg(1)=xj*fac
14880             ggg(2)=yj*fac
14881             ggg(3)=zj*fac
14882 ! Uncomment following three lines for SC-p interactions
14883 !           do k=1,3
14884 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14885 !           enddo
14886 ! Uncomment following line for SC-p interactions
14887 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14888             do k=1,3
14889               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14890               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14891             enddo
14892           endif
14893         enddo
14894
14895         enddo ! iint
14896       enddo ! i
14897       do i=1,nct
14898         do j=1,3
14899           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14900           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14901           gradx_scp(j,i)=expon*gradx_scp(j,i)
14902         enddo
14903       enddo
14904 !******************************************************************************
14905 !
14906 !                              N O T E !!!
14907 !
14908 ! To save time the factor EXPON has been extracted from ALL components
14909 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14910 ! use!
14911 !
14912 !******************************************************************************
14913       return
14914       end subroutine escp_short
14915 !-----------------------------------------------------------------------------
14916 ! energy_p_new-sep_barrier.F
14917 !-----------------------------------------------------------------------------
14918       subroutine sc_grad_scale(scalfac)
14919 !      implicit real*8 (a-h,o-z)
14920       use calc_data
14921 !      include 'DIMENSIONS'
14922 !      include 'COMMON.CHAIN'
14923 !      include 'COMMON.DERIV'
14924 !      include 'COMMON.CALC'
14925 !      include 'COMMON.IOUNITS'
14926       real(kind=8),dimension(3) :: dcosom1,dcosom2
14927       real(kind=8) :: scalfac
14928 !el local variables
14929 !      integer :: i,j,k,l
14930
14931       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
14932       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
14933       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
14934            -2.0D0*alf12*eps3der+sigder*sigsq_om12
14935 ! diagnostics only
14936 !      eom1=0.0d0
14937 !      eom2=0.0d0
14938 !      eom12=evdwij*eps1_om12
14939 ! end diagnostics
14940 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
14941 !     &  " sigder",sigder
14942 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
14943 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
14944       do k=1,3
14945         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
14946         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
14947       enddo
14948       do k=1,3
14949         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
14950          *sss_ele_cut
14951       enddo
14952 !      write (iout,*) "gg",(gg(k),k=1,3)
14953       do k=1,3
14954         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
14955                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
14956                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
14957                  *sss_ele_cut
14958         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
14959                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
14960                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
14961          *sss_ele_cut
14962 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
14963 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
14964 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
14965 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
14966       enddo
14967 !
14968 ! Calculate the components of the gradient in DC and X
14969 !
14970       do l=1,3
14971         gvdwc(l,i)=gvdwc(l,i)-gg(l)
14972         gvdwc(l,j)=gvdwc(l,j)+gg(l)
14973       enddo
14974       return
14975       end subroutine sc_grad_scale
14976 !-----------------------------------------------------------------------------
14977 ! energy_split-sep.F
14978 !-----------------------------------------------------------------------------
14979       subroutine etotal_long(energia)
14980 !
14981 ! Compute the long-range slow-varying contributions to the energy
14982 !
14983 !      implicit real*8 (a-h,o-z)
14984 !      include 'DIMENSIONS'
14985       use MD_data, only: totT,usampl,eq_time
14986 #ifndef ISNAN
14987       external proc_proc
14988 #ifdef WINPGI
14989 !MS$ATTRIBUTES C ::  proc_proc
14990 #endif
14991 #endif
14992 #ifdef MPI
14993       include "mpif.h"
14994       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
14995 #endif
14996 !      include 'COMMON.SETUP'
14997 !      include 'COMMON.IOUNITS'
14998 !      include 'COMMON.FFIELD'
14999 !      include 'COMMON.DERIV'
15000 !      include 'COMMON.INTERACT'
15001 !      include 'COMMON.SBRIDGE'
15002 !      include 'COMMON.CHAIN'
15003 !      include 'COMMON.VAR'
15004 !      include 'COMMON.LOCAL'
15005 !      include 'COMMON.MD'
15006       real(kind=8),dimension(0:n_ene) :: energia
15007 !el local variables
15008       integer :: i,n_corr,n_corr1,ierror,ierr
15009       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15010                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15011                   ecorr,ecorr5,ecorr6,eturn6,time00
15012 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15013 !elwrite(iout,*)"in etotal long"
15014
15015       if (modecalc.eq.12.or.modecalc.eq.14) then
15016 #ifdef MPI
15017 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15018 #else
15019         call int_from_cart1(.false.)
15020 #endif
15021       endif
15022 !elwrite(iout,*)"in etotal long"
15023
15024 #ifdef MPI
15025 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15026 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15027       call flush(iout)
15028       if (nfgtasks.gt.1) then
15029         time00=MPI_Wtime()
15030 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15031         if (fg_rank.eq.0) then
15032           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15033 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15034 !          call flush(iout)
15035 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15036 ! FG slaves as WEIGHTS array.
15037           weights_(1)=wsc
15038           weights_(2)=wscp
15039           weights_(3)=welec
15040           weights_(4)=wcorr
15041           weights_(5)=wcorr5
15042           weights_(6)=wcorr6
15043           weights_(7)=wel_loc
15044           weights_(8)=wturn3
15045           weights_(9)=wturn4
15046           weights_(10)=wturn6
15047           weights_(11)=wang
15048           weights_(12)=wscloc
15049           weights_(13)=wtor
15050           weights_(14)=wtor_d
15051           weights_(15)=wstrain
15052           weights_(16)=wvdwpp
15053           weights_(17)=wbond
15054           weights_(18)=scal14
15055           weights_(21)=wsccor
15056 ! FG Master broadcasts the WEIGHTS_ array
15057           call MPI_Bcast(weights_(1),n_ene,&
15058               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15059         else
15060 ! FG slaves receive the WEIGHTS array
15061           call MPI_Bcast(weights(1),n_ene,&
15062               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15063           wsc=weights(1)
15064           wscp=weights(2)
15065           welec=weights(3)
15066           wcorr=weights(4)
15067           wcorr5=weights(5)
15068           wcorr6=weights(6)
15069           wel_loc=weights(7)
15070           wturn3=weights(8)
15071           wturn4=weights(9)
15072           wturn6=weights(10)
15073           wang=weights(11)
15074           wscloc=weights(12)
15075           wtor=weights(13)
15076           wtor_d=weights(14)
15077           wstrain=weights(15)
15078           wvdwpp=weights(16)
15079           wbond=weights(17)
15080           scal14=weights(18)
15081           wsccor=weights(21)
15082         endif
15083         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15084           king,FG_COMM,IERR)
15085          time_Bcast=time_Bcast+MPI_Wtime()-time00
15086          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15087 !        call chainbuild_cart
15088 !        call int_from_cart1(.false.)
15089       endif
15090 !      write (iout,*) 'Processor',myrank,
15091 !     &  ' calling etotal_short ipot=',ipot
15092 !      call flush(iout)
15093 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15094 #endif
15095 !d    print *,'nnt=',nnt,' nct=',nct
15096 !
15097 !elwrite(iout,*)"in etotal long"
15098 ! Compute the side-chain and electrostatic interaction energy
15099 !
15100       goto (101,102,103,104,105,106) ipot
15101 ! Lennard-Jones potential.
15102   101 call elj_long(evdw)
15103 !d    print '(a)','Exit ELJ'
15104       goto 107
15105 ! Lennard-Jones-Kihara potential (shifted).
15106   102 call eljk_long(evdw)
15107       goto 107
15108 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15109   103 call ebp_long(evdw)
15110       goto 107
15111 ! Gay-Berne potential (shifted LJ, angular dependence).
15112   104 call egb_long(evdw)
15113       goto 107
15114 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15115   105 call egbv_long(evdw)
15116       goto 107
15117 ! Soft-sphere potential
15118   106 call e_softsphere(evdw)
15119 !
15120 ! Calculate electrostatic (H-bonding) energy of the main chain.
15121 !
15122   107 continue
15123       call vec_and_deriv
15124       if (ipot.lt.6) then
15125 #ifdef SPLITELE
15126          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15127              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15128              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15129              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15130 #else
15131          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15132              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15133              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15134              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15135 #endif
15136            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15137          else
15138             ees=0
15139             evdw1=0
15140             eel_loc=0
15141             eello_turn3=0
15142             eello_turn4=0
15143          endif
15144       else
15145 !        write (iout,*) "Soft-spheer ELEC potential"
15146         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15147          eello_turn4)
15148       endif
15149 !
15150 ! Calculate excluded-volume interaction energy between peptide groups
15151 ! and side chains.
15152 !
15153       if (ipot.lt.6) then
15154        if(wscp.gt.0d0) then
15155         call escp_long(evdw2,evdw2_14)
15156        else
15157         evdw2=0
15158         evdw2_14=0
15159        endif
15160       else
15161         call escp_soft_sphere(evdw2,evdw2_14)
15162       endif
15163 !
15164 ! 12/1/95 Multi-body terms
15165 !
15166       n_corr=0
15167       n_corr1=0
15168       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15169           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15170          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15171 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15172 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15173       else
15174          ecorr=0.0d0
15175          ecorr5=0.0d0
15176          ecorr6=0.0d0
15177          eturn6=0.0d0
15178       endif
15179       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15180          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15181       endif
15182 !
15183 ! If performing constraint dynamics, call the constraint energy
15184 !  after the equilibration time
15185       if(usampl.and.totT.gt.eq_time) then
15186          call EconstrQ
15187          call Econstr_back
15188       else
15189          Uconst=0.0d0
15190          Uconst_back=0.0d0
15191       endif
15192 !
15193 ! Sum the energies
15194 !
15195       do i=1,n_ene
15196         energia(i)=0.0d0
15197       enddo
15198       energia(1)=evdw
15199 #ifdef SCP14
15200       energia(2)=evdw2-evdw2_14
15201       energia(18)=evdw2_14
15202 #else
15203       energia(2)=evdw2
15204       energia(18)=0.0d0
15205 #endif
15206 #ifdef SPLITELE
15207       energia(3)=ees
15208       energia(16)=evdw1
15209 #else
15210       energia(3)=ees+evdw1
15211       energia(16)=0.0d0
15212 #endif
15213       energia(4)=ecorr
15214       energia(5)=ecorr5
15215       energia(6)=ecorr6
15216       energia(7)=eel_loc
15217       energia(8)=eello_turn3
15218       energia(9)=eello_turn4
15219       energia(10)=eturn6
15220       energia(20)=Uconst+Uconst_back
15221       call sum_energy(energia,.true.)
15222 !      write (iout,*) "Exit ETOTAL_LONG"
15223       call flush(iout)
15224       return
15225       end subroutine etotal_long
15226 !-----------------------------------------------------------------------------
15227       subroutine etotal_short(energia)
15228 !
15229 ! Compute the short-range fast-varying contributions to the energy
15230 !
15231 !      implicit real*8 (a-h,o-z)
15232 !      include 'DIMENSIONS'
15233 #ifndef ISNAN
15234       external proc_proc
15235 #ifdef WINPGI
15236 !MS$ATTRIBUTES C ::  proc_proc
15237 #endif
15238 #endif
15239 #ifdef MPI
15240       include "mpif.h"
15241       integer :: ierror,ierr
15242       real(kind=8),dimension(n_ene) :: weights_
15243       real(kind=8) :: time00
15244 #endif
15245 !      include 'COMMON.SETUP'
15246 !      include 'COMMON.IOUNITS'
15247 !      include 'COMMON.FFIELD'
15248 !      include 'COMMON.DERIV'
15249 !      include 'COMMON.INTERACT'
15250 !      include 'COMMON.SBRIDGE'
15251 !      include 'COMMON.CHAIN'
15252 !      include 'COMMON.VAR'
15253 !      include 'COMMON.LOCAL'
15254       real(kind=8),dimension(0:n_ene) :: energia
15255 !el local variables
15256       integer :: i,nres6
15257       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15258       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
15259       nres6=6*nres
15260
15261 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15262 !      call flush(iout)
15263       if (modecalc.eq.12.or.modecalc.eq.14) then
15264 #ifdef MPI
15265         if (fg_rank.eq.0) call int_from_cart1(.false.)
15266 #else
15267         call int_from_cart1(.false.)
15268 #endif
15269       endif
15270 #ifdef MPI
15271 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15272 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15273 !      call flush(iout)
15274       if (nfgtasks.gt.1) then
15275         time00=MPI_Wtime()
15276 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15277         if (fg_rank.eq.0) then
15278           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15279 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15280 !          call flush(iout)
15281 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15282 ! FG slaves as WEIGHTS array.
15283           weights_(1)=wsc
15284           weights_(2)=wscp
15285           weights_(3)=welec
15286           weights_(4)=wcorr
15287           weights_(5)=wcorr5
15288           weights_(6)=wcorr6
15289           weights_(7)=wel_loc
15290           weights_(8)=wturn3
15291           weights_(9)=wturn4
15292           weights_(10)=wturn6
15293           weights_(11)=wang
15294           weights_(12)=wscloc
15295           weights_(13)=wtor
15296           weights_(14)=wtor_d
15297           weights_(15)=wstrain
15298           weights_(16)=wvdwpp
15299           weights_(17)=wbond
15300           weights_(18)=scal14
15301           weights_(21)=wsccor
15302 ! FG Master broadcasts the WEIGHTS_ array
15303           call MPI_Bcast(weights_(1),n_ene,&
15304               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15305         else
15306 ! FG slaves receive the WEIGHTS array
15307           call MPI_Bcast(weights(1),n_ene,&
15308               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15309           wsc=weights(1)
15310           wscp=weights(2)
15311           welec=weights(3)
15312           wcorr=weights(4)
15313           wcorr5=weights(5)
15314           wcorr6=weights(6)
15315           wel_loc=weights(7)
15316           wturn3=weights(8)
15317           wturn4=weights(9)
15318           wturn6=weights(10)
15319           wang=weights(11)
15320           wscloc=weights(12)
15321           wtor=weights(13)
15322           wtor_d=weights(14)
15323           wstrain=weights(15)
15324           wvdwpp=weights(16)
15325           wbond=weights(17)
15326           scal14=weights(18)
15327           wsccor=weights(21)
15328         endif
15329 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15330         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15331           king,FG_COMM,IERR)
15332 !        write (iout,*) "Processor",myrank," BROADCAST c"
15333         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15334           king,FG_COMM,IERR)
15335 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15336         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15337           king,FG_COMM,IERR)
15338 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15339         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15340           king,FG_COMM,IERR)
15341 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15342         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15343           king,FG_COMM,IERR)
15344 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15345         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15346           king,FG_COMM,IERR)
15347 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15348         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15349           king,FG_COMM,IERR)
15350 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15351         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15352           king,FG_COMM,IERR)
15353 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15354         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15355           king,FG_COMM,IERR)
15356          time_Bcast=time_Bcast+MPI_Wtime()-time00
15357 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15358       endif
15359 !      write (iout,*) 'Processor',myrank,
15360 !     &  ' calling etotal_short ipot=',ipot
15361 !      call flush(iout)
15362 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15363 #endif
15364 !      call int_from_cart1(.false.)
15365 !
15366 ! Compute the side-chain and electrostatic interaction energy
15367 !
15368       goto (101,102,103,104,105,106) ipot
15369 ! Lennard-Jones potential.
15370   101 call elj_short(evdw)
15371 !d    print '(a)','Exit ELJ'
15372       goto 107
15373 ! Lennard-Jones-Kihara potential (shifted).
15374   102 call eljk_short(evdw)
15375       goto 107
15376 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15377   103 call ebp_short(evdw)
15378       goto 107
15379 ! Gay-Berne potential (shifted LJ, angular dependence).
15380   104 call egb_short(evdw)
15381       goto 107
15382 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15383   105 call egbv_short(evdw)
15384       goto 107
15385 ! Soft-sphere potential - already dealt with in the long-range part
15386   106 evdw=0.0d0
15387 !  106 call e_softsphere_short(evdw)
15388 !
15389 ! Calculate electrostatic (H-bonding) energy of the main chain.
15390 !
15391   107 continue
15392 !
15393 ! Calculate the short-range part of Evdwpp
15394 !
15395       call evdwpp_short(evdw1)
15396 !
15397 ! Calculate the short-range part of ESCp
15398 !
15399       if (ipot.lt.6) then
15400         call escp_short(evdw2,evdw2_14)
15401       endif
15402 !
15403 ! Calculate the bond-stretching energy
15404 !
15405       call ebond(estr)
15406 !
15407 ! Calculate the disulfide-bridge and other energy and the contributions
15408 ! from other distance constraints.
15409       call edis(ehpb)
15410 !
15411 ! Calculate the virtual-bond-angle energy.
15412 !
15413       call ebend(ebe)
15414 !
15415 ! Calculate the SC local energy.
15416 !
15417       call vec_and_deriv
15418       call esc(escloc)
15419 !
15420 ! Calculate the virtual-bond torsional energy.
15421 !
15422       call etor(etors,edihcnstr)
15423 !
15424 ! 6/23/01 Calculate double-torsional energy
15425 !
15426       call etor_d(etors_d)
15427 !
15428 ! 21/5/07 Calculate local sicdechain correlation energy
15429 !
15430       if (wsccor.gt.0.0d0) then
15431         call eback_sc_corr(esccor)
15432       else
15433         esccor=0.0d0
15434       endif
15435 !
15436 ! Put energy components into an array
15437 !
15438       do i=1,n_ene
15439         energia(i)=0.0d0
15440       enddo
15441       energia(1)=evdw
15442 #ifdef SCP14
15443       energia(2)=evdw2-evdw2_14
15444       energia(18)=evdw2_14
15445 #else
15446       energia(2)=evdw2
15447       energia(18)=0.0d0
15448 #endif
15449 #ifdef SPLITELE
15450       energia(16)=evdw1
15451 #else
15452       energia(3)=evdw1
15453 #endif
15454       energia(11)=ebe
15455       energia(12)=escloc
15456       energia(13)=etors
15457       energia(14)=etors_d
15458       energia(15)=ehpb
15459       energia(17)=estr
15460       energia(19)=edihcnstr
15461       energia(21)=esccor
15462 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15463       call flush(iout)
15464       call sum_energy(energia,.true.)
15465 !      write (iout,*) "Exit ETOTAL_SHORT"
15466       call flush(iout)
15467       return
15468       end subroutine etotal_short
15469 !-----------------------------------------------------------------------------
15470 ! gnmr1.f
15471 !-----------------------------------------------------------------------------
15472       real(kind=8) function gnmr1(y,ymin,ymax)
15473 !      implicit none
15474       real(kind=8) :: y,ymin,ymax
15475       real(kind=8) :: wykl=4.0d0
15476       if (y.lt.ymin) then
15477         gnmr1=(ymin-y)**wykl/wykl
15478       else if (y.gt.ymax) then
15479         gnmr1=(y-ymax)**wykl/wykl
15480       else
15481         gnmr1=0.0d0
15482       endif
15483       return
15484       end function gnmr1
15485 !-----------------------------------------------------------------------------
15486       real(kind=8) function gnmr1prim(y,ymin,ymax)
15487 !      implicit none
15488       real(kind=8) :: y,ymin,ymax
15489       real(kind=8) :: wykl=4.0d0
15490       if (y.lt.ymin) then
15491         gnmr1prim=-(ymin-y)**(wykl-1)
15492       else if (y.gt.ymax) then
15493         gnmr1prim=(y-ymax)**(wykl-1)
15494       else
15495         gnmr1prim=0.0d0
15496       endif
15497       return
15498       end function gnmr1prim
15499 !-----------------------------------------------------------------------------
15500       real(kind=8) function harmonic(y,ymax)
15501 !      implicit none
15502       real(kind=8) :: y,ymax
15503       real(kind=8) :: wykl=2.0d0
15504       harmonic=(y-ymax)**wykl
15505       return
15506       end function harmonic
15507 !-----------------------------------------------------------------------------
15508       real(kind=8) function harmonicprim(y,ymax)
15509       real(kind=8) :: y,ymin,ymax
15510       real(kind=8) :: wykl=2.0d0
15511       harmonicprim=(y-ymax)*wykl
15512       return
15513       end function harmonicprim
15514 !-----------------------------------------------------------------------------
15515 ! gradient_p.F
15516 !-----------------------------------------------------------------------------
15517       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15518
15519       use io_base, only:intout,briefout
15520 !      implicit real*8 (a-h,o-z)
15521 !      include 'DIMENSIONS'
15522 !      include 'COMMON.CHAIN'
15523 !      include 'COMMON.DERIV'
15524 !      include 'COMMON.VAR'
15525 !      include 'COMMON.INTERACT'
15526 !      include 'COMMON.FFIELD'
15527 !      include 'COMMON.MD'
15528 !      include 'COMMON.IOUNITS'
15529       real(kind=8),external :: ufparm
15530       integer :: uiparm(1)
15531       real(kind=8) :: urparm(1)
15532       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15533       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15534       integer :: n,nf,ind,ind1,i,k,j
15535 !
15536 ! This subroutine calculates total internal coordinate gradient.
15537 ! Depending on the number of function evaluations, either whole energy
15538 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15539 ! internal coordinates are reevaluated or only the cartesian-in-internal
15540 ! coordinate derivatives are evaluated. The subroutine was designed to work
15541 ! with SUMSL.
15542 !
15543 !
15544       icg=mod(nf,2)+1
15545
15546 !d      print *,'grad',nf,icg
15547       if (nf-nfl+1) 20,30,40
15548    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15549 !    write (iout,*) 'grad 20'
15550       if (nf.eq.0) return
15551       goto 40
15552    30 call var_to_geom(n,x)
15553       call chainbuild
15554 !    write (iout,*) 'grad 30'
15555 !
15556 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15557 !
15558    40 call cartder
15559 !     write (iout,*) 'grad 40'
15560 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15561 !
15562 ! Convert the Cartesian gradient into internal-coordinate gradient.
15563 !
15564       ind=0
15565       ind1=0
15566       do i=1,nres-2
15567         gthetai=0.0D0
15568         gphii=0.0D0
15569         do j=i+1,nres-1
15570           ind=ind+1
15571 !         ind=indmat(i,j)
15572 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
15573           do k=1,3
15574             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
15575           enddo
15576           do k=1,3
15577             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
15578           enddo
15579         enddo
15580         do j=i+1,nres-1
15581           ind1=ind1+1
15582 !         ind1=indmat(i,j)
15583 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
15584           do k=1,3
15585             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
15586             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
15587           enddo
15588         enddo
15589         if (i.gt.1) g(i-1)=gphii
15590         if (n.gt.nphi) g(nphi+i)=gthetai
15591       enddo
15592       if (n.le.nphi+ntheta) goto 10
15593       do i=2,nres-1
15594         if (itype(i).ne.10) then
15595           galphai=0.0D0
15596           gomegai=0.0D0
15597           do k=1,3
15598             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
15599           enddo
15600           do k=1,3
15601             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
15602           enddo
15603           g(ialph(i,1))=galphai
15604           g(ialph(i,1)+nside)=gomegai
15605         endif
15606       enddo
15607 !
15608 ! Add the components corresponding to local energy terms.
15609 !
15610    10 continue
15611       do i=1,nvar
15612 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
15613         g(i)=g(i)+gloc(i,icg)
15614       enddo
15615 ! Uncomment following three lines for diagnostics.
15616 !d    call intout
15617 !elwrite(iout,*) "in gradient after calling intout"
15618 !d    call briefout(0,0.0d0)
15619 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
15620       return
15621       end subroutine gradient
15622 !-----------------------------------------------------------------------------
15623       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
15624
15625       use comm_chu
15626 !      implicit real*8 (a-h,o-z)
15627 !      include 'DIMENSIONS'
15628 !      include 'COMMON.DERIV'
15629 !      include 'COMMON.IOUNITS'
15630 !      include 'COMMON.GEO'
15631       integer :: n,nf
15632 !el      integer :: jjj
15633 !el      common /chuju/ jjj
15634       real(kind=8) :: energia(0:n_ene)
15635       integer :: uiparm(1)
15636       real(kind=8) :: urparm(1)
15637       real(kind=8) :: f
15638       real(kind=8),external :: ufparm
15639       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
15640 !     if (jjj.gt.0) then
15641 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15642 !     endif
15643       nfl=nf
15644       icg=mod(nf,2)+1
15645 !d      print *,'func',nf,nfl,icg
15646       call var_to_geom(n,x)
15647       call zerograd
15648       call chainbuild
15649 !d    write (iout,*) 'ETOTAL called from FUNC'
15650       call etotal(energia)
15651       call sum_gradient
15652       f=energia(0)
15653 !     if (jjj.gt.0) then
15654 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15655 !       write (iout,*) 'f=',etot
15656 !       jjj=0
15657 !     endif
15658       return
15659       end subroutine func
15660 !-----------------------------------------------------------------------------
15661       subroutine cartgrad
15662 !      implicit real*8 (a-h,o-z)
15663 !      include 'DIMENSIONS'
15664       use energy_data
15665       use MD_data, only: totT,usampl,eq_time
15666 #ifdef MPI
15667       include 'mpif.h'
15668 #endif
15669 !      include 'COMMON.CHAIN'
15670 !      include 'COMMON.DERIV'
15671 !      include 'COMMON.VAR'
15672 !      include 'COMMON.INTERACT'
15673 !      include 'COMMON.FFIELD'
15674 !      include 'COMMON.MD'
15675 !      include 'COMMON.IOUNITS'
15676 !      include 'COMMON.TIME1'
15677 !
15678       integer :: i,j
15679
15680 ! This subrouting calculates total Cartesian coordinate gradient.
15681 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
15682 !
15683 !el#define DEBUG
15684 #ifdef TIMING
15685       time00=MPI_Wtime()
15686 #endif
15687       icg=1
15688       call sum_gradient
15689 #ifdef TIMING
15690 #endif
15691 !el      write (iout,*) "After sum_gradient"
15692 #ifdef DEBUG
15693 !el      write (iout,*) "After sum_gradient"
15694       do i=1,nres-1
15695         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
15696         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
15697       enddo
15698 #endif
15699 ! If performing constraint dynamics, add the gradients of the constraint energy
15700       if(usampl.and.totT.gt.eq_time) then
15701          do i=1,nct
15702            do j=1,3
15703              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
15704              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
15705            enddo
15706          enddo
15707          do i=1,nres-3
15708            gloc(i,icg)=gloc(i,icg)+dugamma(i)
15709          enddo
15710          do i=1,nres-2
15711            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
15712          enddo
15713       endif
15714 !elwrite (iout,*) "After sum_gradient"
15715 #ifdef TIMING
15716       time01=MPI_Wtime()
15717 #endif
15718       call intcartderiv
15719 !elwrite (iout,*) "After sum_gradient"
15720 #ifdef TIMING
15721       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
15722 #endif
15723 !     call checkintcartgrad
15724 !     write(iout,*) 'calling int_to_cart'
15725 #ifdef DEBUG
15726       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
15727 #endif
15728       do i=0,nct
15729         do j=1,3
15730           gcart(j,i)=gradc(j,i,icg)
15731           gxcart(j,i)=gradx(j,i,icg)
15732         enddo
15733 #ifdef DEBUG
15734         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
15735           (gxcart(j,i),j=1,3),gloc(i,icg)
15736 #endif
15737       enddo
15738 #ifdef TIMING
15739       time01=MPI_Wtime()
15740 #endif
15741       call int_to_cart
15742 #ifdef TIMING
15743       time_inttocart=time_inttocart+MPI_Wtime()-time01
15744 #endif
15745 #ifdef DEBUG
15746       write (iout,*) "gcart and gxcart after int_to_cart"
15747       do i=0,nres-1
15748         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
15749             (gxcart(j,i),j=1,3)
15750       enddo
15751 #endif
15752 #ifdef CARGRAD
15753 #ifdef DEBUG
15754       write (iout,*) "CARGRAD"
15755 #endif
15756       do i=nres,0,-1
15757         do j=1,3
15758           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15759 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15760         enddo
15761 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
15762 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
15763       enddo
15764 ! Correction: dummy residues
15765         if (nnt.gt.1) then
15766           do j=1,3
15767 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
15768             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
15769           enddo
15770         endif
15771         if (nct.lt.nres) then
15772           do j=1,3
15773 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
15774             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
15775           enddo
15776         endif
15777 #endif
15778 #ifdef TIMING
15779       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
15780 #endif
15781 !el#undef DEBUG
15782       return
15783       end subroutine cartgrad
15784 !-----------------------------------------------------------------------------
15785       subroutine zerograd
15786 !      implicit real*8 (a-h,o-z)
15787 !      include 'DIMENSIONS'
15788 !      include 'COMMON.DERIV'
15789 !      include 'COMMON.CHAIN'
15790 !      include 'COMMON.VAR'
15791 !      include 'COMMON.MD'
15792 !      include 'COMMON.SCCOR'
15793 !
15794 !el local variables
15795       integer :: i,j,intertyp,k
15796 ! Initialize Cartesian-coordinate gradient
15797 !
15798 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
15799 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
15800
15801 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
15802 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
15803 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
15804 !      allocate(gradcorr_long(3,nres))
15805 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
15806 !      allocate(gcorr6_turn_long(3,nres))
15807 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
15808
15809 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
15810
15811 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
15812 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
15813
15814 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
15815 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
15816
15817 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
15818 !      allocate(gscloc(3,nres)) !(3,maxres)
15819 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
15820
15821
15822
15823 !      common /deriv_scloc/
15824 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
15825 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
15826 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
15827 !      common /mpgrad/
15828 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
15829
15830
15831
15832 !          gradc(j,i,icg)=0.0d0
15833 !          gradx(j,i,icg)=0.0d0
15834
15835 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
15836 !elwrite(iout,*) "icg",icg
15837       do i=-1,nres
15838         do j=1,3
15839           gvdwx(j,i)=0.0D0
15840           gradx_scp(j,i)=0.0D0
15841           gvdwc(j,i)=0.0D0
15842           gvdwc_scp(j,i)=0.0D0
15843           gvdwc_scpp(j,i)=0.0d0
15844           gelc(j,i)=0.0D0
15845           gelc_long(j,i)=0.0D0
15846           gradb(j,i)=0.0d0
15847           gradbx(j,i)=0.0d0
15848           gvdwpp(j,i)=0.0d0
15849           gel_loc(j,i)=0.0d0
15850           gel_loc_long(j,i)=0.0d0
15851           ghpbc(j,i)=0.0D0
15852           ghpbx(j,i)=0.0D0
15853           gcorr3_turn(j,i)=0.0d0
15854           gcorr4_turn(j,i)=0.0d0
15855           gradcorr(j,i)=0.0d0
15856           gradcorr_long(j,i)=0.0d0
15857           gradcorr5_long(j,i)=0.0d0
15858           gradcorr6_long(j,i)=0.0d0
15859           gcorr6_turn_long(j,i)=0.0d0
15860           gradcorr5(j,i)=0.0d0
15861           gradcorr6(j,i)=0.0d0
15862           gcorr6_turn(j,i)=0.0d0
15863           gsccorc(j,i)=0.0d0
15864           gsccorx(j,i)=0.0d0
15865           gradc(j,i,icg)=0.0d0
15866           gradx(j,i,icg)=0.0d0
15867           gscloc(j,i)=0.0d0
15868           gsclocx(j,i)=0.0d0
15869           gliptran(j,i)=0.0d0
15870           gliptranx(j,i)=0.0d0
15871           gliptranc(j,i)=0.0d0
15872           gshieldx(j,i)=0.0d0
15873           gshieldc(j,i)=0.0d0
15874           gshieldc_loc(j,i)=0.0d0
15875           gshieldx_ec(j,i)=0.0d0
15876           gshieldc_ec(j,i)=0.0d0
15877           gshieldc_loc_ec(j,i)=0.0d0
15878           gshieldx_t3(j,i)=0.0d0
15879           gshieldc_t3(j,i)=0.0d0
15880           gshieldc_loc_t3(j,i)=0.0d0
15881           gshieldx_t4(j,i)=0.0d0
15882           gshieldc_t4(j,i)=0.0d0
15883           gshieldc_loc_t4(j,i)=0.0d0
15884           gshieldx_ll(j,i)=0.0d0
15885           gshieldc_ll(j,i)=0.0d0
15886           gshieldc_loc_ll(j,i)=0.0d0
15887           gg_tube(j,i)=0.0d0
15888           gg_tube_sc(j,i)=0.0d0
15889           do intertyp=1,3
15890            gloc_sc(intertyp,i,icg)=0.0d0
15891           enddo
15892         enddo
15893       enddo
15894       do i=1,nres
15895        do j=1,maxcontsshi
15896        shield_list(j,i)=0
15897         do k=1,3
15898 !C           print *,i,j,k
15899            grad_shield_side(k,j,i)=0.0d0
15900            grad_shield_loc(k,j,i)=0.0d0
15901          enddo
15902        enddo
15903        ishield_list(i)=0
15904       enddo
15905
15906 !
15907 ! Initialize the gradient of local energy terms.
15908 !
15909 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
15910 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
15911 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
15912 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
15913 !      allocate(gel_loc_turn3(nres))
15914 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
15915 !      allocate(gsccor_loc(nres))       !(maxres)
15916
15917       do i=1,4*nres
15918         gloc(i,icg)=0.0D0
15919       enddo
15920       do i=1,nres
15921         gel_loc_loc(i)=0.0d0
15922         gcorr_loc(i)=0.0d0
15923         g_corr5_loc(i)=0.0d0
15924         g_corr6_loc(i)=0.0d0
15925         gel_loc_turn3(i)=0.0d0
15926         gel_loc_turn4(i)=0.0d0
15927         gel_loc_turn6(i)=0.0d0
15928         gsccor_loc(i)=0.0d0
15929       enddo
15930 ! initialize gcart and gxcart
15931 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
15932       do i=0,nres
15933         do j=1,3
15934           gcart(j,i)=0.0d0
15935           gxcart(j,i)=0.0d0
15936         enddo
15937       enddo
15938       return
15939       end subroutine zerograd
15940 !-----------------------------------------------------------------------------
15941       real(kind=8) function fdum()
15942       fdum=0.0D0
15943       return
15944       end function fdum
15945 !-----------------------------------------------------------------------------
15946 ! intcartderiv.F
15947 !-----------------------------------------------------------------------------
15948       subroutine intcartderiv
15949 !      implicit real*8 (a-h,o-z)
15950 !      include 'DIMENSIONS'
15951 #ifdef MPI
15952       include 'mpif.h'
15953 #endif
15954 !      include 'COMMON.SETUP'
15955 !      include 'COMMON.CHAIN'
15956 !      include 'COMMON.VAR'
15957 !      include 'COMMON.GEO'
15958 !      include 'COMMON.INTERACT'
15959 !      include 'COMMON.DERIV'
15960 !      include 'COMMON.IOUNITS'
15961 !      include 'COMMON.LOCAL'
15962 !      include 'COMMON.SCCOR'
15963       real(kind=8) :: pi4,pi34
15964       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
15965       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
15966                     dcosomega,dsinomega !(3,3,maxres)
15967       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
15968
15969       integer :: i,j,k
15970       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
15971                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
15972                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
15973                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
15974       integer :: nres2
15975       nres2=2*nres
15976
15977 !el from module energy-------------
15978 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
15979 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
15980 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
15981
15982 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
15983 !el      allocate(dsintau(3,3,3,0:nres2))
15984 !el      allocate(dtauangle(3,3,3,0:nres2))
15985 !el      allocate(domicron(3,2,2,0:nres2))
15986 !el      allocate(dcosomicron(3,2,2,0:nres2))
15987
15988
15989
15990 #if defined(MPI) && defined(PARINTDER)
15991       if (nfgtasks.gt.1 .and. me.eq.king) &
15992         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
15993 #endif
15994       pi4 = 0.5d0*pipol
15995       pi34 = 3*pi4
15996
15997 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
15998 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
15999
16000 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16001       do i=1,nres
16002         do j=1,3
16003           dtheta(j,1,i)=0.0d0
16004           dtheta(j,2,i)=0.0d0
16005           dphi(j,1,i)=0.0d0
16006           dphi(j,2,i)=0.0d0
16007           dphi(j,3,i)=0.0d0
16008         enddo
16009       enddo
16010 ! Derivatives of theta's
16011 #if defined(MPI) && defined(PARINTDER)
16012 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16013       do i=max0(ithet_start-1,3),ithet_end
16014 #else
16015       do i=3,nres
16016 #endif
16017         cost=dcos(theta(i))
16018         sint=sqrt(1-cost*cost)
16019         do j=1,3
16020           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16021           vbld(i-1)
16022           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16023           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16024           vbld(i)
16025           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16026         enddo
16027       enddo
16028 #if defined(MPI) && defined(PARINTDER)
16029 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16030       do i=max0(ithet_start-1,3),ithet_end
16031 #else
16032       do i=3,nres
16033 #endif
16034       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
16035         cost1=dcos(omicron(1,i))
16036         sint1=sqrt(1-cost1*cost1)
16037         cost2=dcos(omicron(2,i))
16038         sint2=sqrt(1-cost2*cost2)
16039        do j=1,3
16040 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16041           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16042           cost1*dc_norm(j,i-2))/ &
16043           vbld(i-1)
16044           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16045           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16046           +cost1*(dc_norm(j,i-1+nres)))/ &
16047           vbld(i-1+nres)
16048           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16049 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16050 !C Looks messy but better than if in loop
16051           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16052           +cost2*dc_norm(j,i-1))/ &
16053           vbld(i)
16054           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16055           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16056            +cost2*(-dc_norm(j,i-1+nres)))/ &
16057           vbld(i-1+nres)
16058 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
16059           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16060         enddo
16061        endif
16062       enddo
16063 !elwrite(iout,*) "after vbld write"
16064 ! Derivatives of phi:
16065 ! If phi is 0 or 180 degrees, then the formulas
16066 ! have to be derived by power series expansion of the
16067 ! conventional formulas around 0 and 180.
16068 #ifdef PARINTDER
16069       do i=iphi1_start,iphi1_end
16070 #else
16071       do i=4,nres
16072 #endif
16073 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
16074 ! the conventional case
16075         sint=dsin(theta(i))
16076         sint1=dsin(theta(i-1))
16077         sing=dsin(phi(i))
16078         cost=dcos(theta(i))
16079         cost1=dcos(theta(i-1))
16080         cosg=dcos(phi(i))
16081         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16082         fac0=1.0d0/(sint1*sint)
16083         fac1=cost*fac0
16084         fac2=cost1*fac0
16085         fac3=cosg*cost1/(sint1*sint1)
16086         fac4=cosg*cost/(sint*sint)
16087 !    Obtaining the gamma derivatives from sine derivative
16088        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16089            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16090            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16091          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16092          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16093          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16094          do j=1,3
16095             ctgt=cost/sint
16096             ctgt1=cost1/sint1
16097             cosg_inv=1.0d0/cosg
16098             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
16099             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16100               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16101             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16102             dsinphi(j,2,i)= &
16103               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16104               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16105             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16106             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16107               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16108 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16109             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16110             endif
16111 ! Bug fixed 3/24/05 (AL)
16112          enddo
16113 !   Obtaining the gamma derivatives from cosine derivative
16114         else
16115            do j=1,3
16116            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
16117            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16118            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16119            dc_norm(j,i-3))/vbld(i-2)
16120            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16121            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16122            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16123            dcostheta(j,1,i)
16124            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16125            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16126            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16127            dc_norm(j,i-1))/vbld(i)
16128            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16129            endif
16130          enddo
16131         endif
16132       enddo
16133 !alculate derivative of Tauangle
16134 #ifdef PARINTDER
16135       do i=itau_start,itau_end
16136 #else
16137       do i=3,nres
16138 !elwrite(iout,*) " vecpr",i,nres
16139 #endif
16140        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
16141 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
16142 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
16143 !c dtauangle(j,intertyp,dervityp,residue number)
16144 !c INTERTYP=1 SC...Ca...Ca..Ca
16145 ! the conventional case
16146         sint=dsin(theta(i))
16147         sint1=dsin(omicron(2,i-1))
16148         sing=dsin(tauangle(1,i))
16149         cost=dcos(theta(i))
16150         cost1=dcos(omicron(2,i-1))
16151         cosg=dcos(tauangle(1,i))
16152 !elwrite(iout,*) " vecpr5",i,nres
16153         do j=1,3
16154 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16155 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16156         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16157 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16158         enddo
16159         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16160         fac0=1.0d0/(sint1*sint)
16161         fac1=cost*fac0
16162         fac2=cost1*fac0
16163         fac3=cosg*cost1/(sint1*sint1)
16164         fac4=cosg*cost/(sint*sint)
16165 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16166 !    Obtaining the gamma derivatives from sine derivative
16167        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16168            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16169            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16170          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16171          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16172          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16173         do j=1,3
16174             ctgt=cost/sint
16175             ctgt1=cost1/sint1
16176             cosg_inv=1.0d0/cosg
16177             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16178        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16179        *vbld_inv(i-2+nres)
16180             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16181             dsintau(j,1,2,i)= &
16182               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16183               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16184 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16185             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16186 ! Bug fixed 3/24/05 (AL)
16187             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16188               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16189 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16190             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16191          enddo
16192 !   Obtaining the gamma derivatives from cosine derivative
16193         else
16194            do j=1,3
16195            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16196            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16197            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16198            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16199            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16200            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16201            dcostheta(j,1,i)
16202            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16203            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16204            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16205            dc_norm(j,i-1))/vbld(i)
16206            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16207 !         write (iout,*) "else",i
16208          enddo
16209         endif
16210 !        do k=1,3
16211 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16212 !        enddo
16213       enddo
16214 !C Second case Ca...Ca...Ca...SC
16215 #ifdef PARINTDER
16216       do i=itau_start,itau_end
16217 #else
16218       do i=4,nres
16219 #endif
16220        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
16221           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
16222 ! the conventional case
16223         sint=dsin(omicron(1,i))
16224         sint1=dsin(theta(i-1))
16225         sing=dsin(tauangle(2,i))
16226         cost=dcos(omicron(1,i))
16227         cost1=dcos(theta(i-1))
16228         cosg=dcos(tauangle(2,i))
16229 !        do j=1,3
16230 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16231 !        enddo
16232         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16233         fac0=1.0d0/(sint1*sint)
16234         fac1=cost*fac0
16235         fac2=cost1*fac0
16236         fac3=cosg*cost1/(sint1*sint1)
16237         fac4=cosg*cost/(sint*sint)
16238 !    Obtaining the gamma derivatives from sine derivative
16239        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16240            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16241            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16242          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16243          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16244          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16245         do j=1,3
16246             ctgt=cost/sint
16247             ctgt1=cost1/sint1
16248             cosg_inv=1.0d0/cosg
16249             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16250               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16251 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16252 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16253             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16254             dsintau(j,2,2,i)= &
16255               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16256               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16257 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16258 !     & sing*ctgt*domicron(j,1,2,i),
16259 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16260             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16261 ! Bug fixed 3/24/05 (AL)
16262             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16263              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16264 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16265             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16266          enddo
16267 !   Obtaining the gamma derivatives from cosine derivative
16268         else
16269            do j=1,3
16270            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16271            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16272            dc_norm(j,i-3))/vbld(i-2)
16273            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16274            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16275            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16276            dcosomicron(j,1,1,i)
16277            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16278            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16279            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16280            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16281            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16282 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16283          enddo
16284         endif
16285       enddo
16286
16287 !CC third case SC...Ca...Ca...SC
16288 #ifdef PARINTDER
16289
16290       do i=itau_start,itau_end
16291 #else
16292       do i=3,nres
16293 #endif
16294 ! the conventional case
16295       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
16296       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
16297         sint=dsin(omicron(1,i))
16298         sint1=dsin(omicron(2,i-1))
16299         sing=dsin(tauangle(3,i))
16300         cost=dcos(omicron(1,i))
16301         cost1=dcos(omicron(2,i-1))
16302         cosg=dcos(tauangle(3,i))
16303         do j=1,3
16304         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16305 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16306         enddo
16307         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16308         fac0=1.0d0/(sint1*sint)
16309         fac1=cost*fac0
16310         fac2=cost1*fac0
16311         fac3=cosg*cost1/(sint1*sint1)
16312         fac4=cosg*cost/(sint*sint)
16313 !    Obtaining the gamma derivatives from sine derivative
16314        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16315            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16316            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16317          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16318          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16319          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16320         do j=1,3
16321             ctgt=cost/sint
16322             ctgt1=cost1/sint1
16323             cosg_inv=1.0d0/cosg
16324             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16325               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16326               *vbld_inv(i-2+nres)
16327             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16328             dsintau(j,3,2,i)= &
16329               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16330               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16331             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16332 ! Bug fixed 3/24/05 (AL)
16333             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16334               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16335               *vbld_inv(i-1+nres)
16336 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16337             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16338          enddo
16339 !   Obtaining the gamma derivatives from cosine derivative
16340         else
16341            do j=1,3
16342            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16343            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16344            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16345            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16346            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16347            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16348            dcosomicron(j,1,1,i)
16349            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16350            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16351            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16352            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16353            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16354 !          write(iout,*) "else",i
16355          enddo
16356         endif
16357       enddo
16358
16359 #ifdef CRYST_SC
16360 !   Derivatives of side-chain angles alpha and omega
16361 #if defined(MPI) && defined(PARINTDER)
16362         do i=ibond_start,ibond_end
16363 #else
16364         do i=2,nres-1
16365 #endif
16366           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
16367              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16368              fac6=fac5/vbld(i)
16369              fac7=fac5*fac5
16370              fac8=fac5/vbld(i+1)
16371              fac9=fac5/vbld(i+nres)
16372              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16373              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16374              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16375              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16376              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16377              sina=sqrt(1-cosa*cosa)
16378              sino=dsin(omeg(i))
16379 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16380              do j=1,3
16381                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16382                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16383                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16384                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16385                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16386                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16387                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16388                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16389                 vbld(i+nres))
16390                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16391             enddo
16392 ! obtaining the derivatives of omega from sines
16393             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16394                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16395                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16396                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16397                dsin(theta(i+1)))
16398                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16399                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16400                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16401                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16402                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16403                coso_inv=1.0d0/dcos(omeg(i))
16404                do j=1,3
16405                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16406                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16407                  (sino*dc_norm(j,i-1))/vbld(i)
16408                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16409                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16410                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16411                  -sino*dc_norm(j,i)/vbld(i+1)
16412                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16413                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16414                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16415                  vbld(i+nres)
16416                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16417               enddo
16418            else
16419 !   obtaining the derivatives of omega from cosines
16420              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16421              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16422              fac12=fac10*sina
16423              fac13=fac12*fac12
16424              fac14=sina*sina
16425              do j=1,3
16426                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16427                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16428                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16429                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16430                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16431                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16432                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16433                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16434                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16435                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16436                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16437                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16438                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16439                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16440                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16441             enddo
16442           endif
16443          else
16444            do j=1,3
16445              do k=1,3
16446                dalpha(k,j,i)=0.0d0
16447                domega(k,j,i)=0.0d0
16448              enddo
16449            enddo
16450          endif
16451        enddo
16452 #endif
16453 #if defined(MPI) && defined(PARINTDER)
16454       if (nfgtasks.gt.1) then
16455 #ifdef DEBUG
16456 !d      write (iout,*) "Gather dtheta"
16457 !d      call flush(iout)
16458       write (iout,*) "dtheta before gather"
16459       do i=1,nres
16460         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16461       enddo
16462 #endif
16463       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16464         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16465         king,FG_COMM,IERROR)
16466 #ifdef DEBUG
16467 !d      write (iout,*) "Gather dphi"
16468 !d      call flush(iout)
16469       write (iout,*) "dphi before gather"
16470       do i=1,nres
16471         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16472       enddo
16473 #endif
16474       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16475         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16476         king,FG_COMM,IERROR)
16477 !d      write (iout,*) "Gather dalpha"
16478 !d      call flush(iout)
16479 #ifdef CRYST_SC
16480       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16481         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16482         king,FG_COMM,IERROR)
16483 !d      write (iout,*) "Gather domega"
16484 !d      call flush(iout)
16485       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16486         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16487         king,FG_COMM,IERROR)
16488 #endif
16489       endif
16490 #endif
16491 #ifdef DEBUG
16492       write (iout,*) "dtheta after gather"
16493       do i=1,nres
16494         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16495       enddo
16496       write (iout,*) "dphi after gather"
16497       do i=1,nres
16498         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16499       enddo
16500       write (iout,*) "dalpha after gather"
16501       do i=1,nres
16502         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16503       enddo
16504       write (iout,*) "domega after gather"
16505       do i=1,nres
16506         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16507       enddo
16508 #endif
16509       return
16510       end subroutine intcartderiv
16511 !-----------------------------------------------------------------------------
16512       subroutine checkintcartgrad
16513 !      implicit real*8 (a-h,o-z)
16514 !      include 'DIMENSIONS'
16515 #ifdef MPI
16516       include 'mpif.h'
16517 #endif
16518 !      include 'COMMON.CHAIN'
16519 !      include 'COMMON.VAR'
16520 !      include 'COMMON.GEO'
16521 !      include 'COMMON.INTERACT'
16522 !      include 'COMMON.DERIV'
16523 !      include 'COMMON.IOUNITS'
16524 !      include 'COMMON.SETUP'
16525       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16526       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16527       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16528       real(kind=8),dimension(3) :: dc_norm_s
16529       real(kind=8) :: aincr=1.0d-5
16530       integer :: i,j
16531       real(kind=8) :: dcji
16532       do i=1,nres
16533         phi_s(i)=phi(i)
16534         theta_s(i)=theta(i)
16535         alph_s(i)=alph(i)
16536         omeg_s(i)=omeg(i)
16537       enddo
16538 ! Check theta gradient
16539       write (iout,*) &
16540        "Analytical (upper) and numerical (lower) gradient of theta"
16541       write (iout,*)
16542       do i=3,nres
16543         do j=1,3
16544           dcji=dc(j,i-2)
16545           dc(j,i-2)=dcji+aincr
16546           call chainbuild_cart
16547           call int_from_cart1(.false.)
16548           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
16549           dc(j,i-2)=dcji
16550           dcji=dc(j,i-1)
16551           dc(j,i-1)=dc(j,i-1)+aincr
16552           call chainbuild_cart
16553           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
16554           dc(j,i-1)=dcji
16555         enddo
16556 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
16557 !el          (dtheta(j,2,i),j=1,3)
16558 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
16559 !el          (dthetanum(j,2,i),j=1,3)
16560 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
16561 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
16562 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
16563 !el        write (iout,*)
16564       enddo
16565 ! Check gamma gradient
16566       write (iout,*) &
16567        "Analytical (upper) and numerical (lower) gradient of gamma"
16568       do i=4,nres
16569         do j=1,3
16570           dcji=dc(j,i-3)
16571           dc(j,i-3)=dcji+aincr
16572           call chainbuild_cart
16573           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
16574           dc(j,i-3)=dcji
16575           dcji=dc(j,i-2)
16576           dc(j,i-2)=dcji+aincr
16577           call chainbuild_cart
16578           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
16579           dc(j,i-2)=dcji
16580           dcji=dc(j,i-1)
16581           dc(j,i-1)=dc(j,i-1)+aincr
16582           call chainbuild_cart
16583           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
16584           dc(j,i-1)=dcji
16585         enddo
16586 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
16587 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
16588 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
16589 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
16590 !el        write (iout,'(5x,3(3f10.5,5x))') &
16591 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
16592 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
16593 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
16594 !el        write (iout,*)
16595       enddo
16596 ! Check alpha gradient
16597       write (iout,*) &
16598        "Analytical (upper) and numerical (lower) gradient of alpha"
16599       do i=2,nres-1
16600        if(itype(i).ne.10) then
16601             do j=1,3
16602               dcji=dc(j,i-1)
16603               dc(j,i-1)=dcji+aincr
16604               call chainbuild_cart
16605               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
16606               /aincr
16607               dc(j,i-1)=dcji
16608               dcji=dc(j,i)
16609               dc(j,i)=dcji+aincr
16610               call chainbuild_cart
16611               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
16612               /aincr
16613               dc(j,i)=dcji
16614               dcji=dc(j,i+nres)
16615               dc(j,i+nres)=dc(j,i+nres)+aincr
16616               call chainbuild_cart
16617               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
16618               /aincr
16619              dc(j,i+nres)=dcji
16620             enddo
16621           endif
16622 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
16623 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
16624 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
16625 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
16626 !el        write (iout,'(5x,3(3f10.5,5x))') &
16627 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
16628 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
16629 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
16630 !el        write (iout,*)
16631       enddo
16632 !     Check omega gradient
16633       write (iout,*) &
16634        "Analytical (upper) and numerical (lower) gradient of omega"
16635       do i=2,nres-1
16636        if(itype(i).ne.10) then
16637             do j=1,3
16638               dcji=dc(j,i-1)
16639               dc(j,i-1)=dcji+aincr
16640               call chainbuild_cart
16641               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
16642               /aincr
16643               dc(j,i-1)=dcji
16644               dcji=dc(j,i)
16645               dc(j,i)=dcji+aincr
16646               call chainbuild_cart
16647               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
16648               /aincr
16649               dc(j,i)=dcji
16650               dcji=dc(j,i+nres)
16651               dc(j,i+nres)=dc(j,i+nres)+aincr
16652               call chainbuild_cart
16653               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
16654               /aincr
16655              dc(j,i+nres)=dcji
16656             enddo
16657           endif
16658 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
16659 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
16660 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
16661 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
16662 !el        write (iout,'(5x,3(3f10.5,5x))') &
16663 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
16664 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
16665 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
16666 !el        write (iout,*)
16667       enddo
16668       return
16669       end subroutine checkintcartgrad
16670 !-----------------------------------------------------------------------------
16671 ! q_measure.F
16672 !-----------------------------------------------------------------------------
16673       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
16674 !      implicit real*8 (a-h,o-z)
16675 !      include 'DIMENSIONS'
16676 !      include 'COMMON.IOUNITS'
16677 !      include 'COMMON.CHAIN'
16678 !      include 'COMMON.INTERACT'
16679 !      include 'COMMON.VAR'
16680       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
16681       integer :: kkk,nsep=3
16682       real(kind=8) :: qm        !dist,
16683       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
16684       logical :: lprn=.false.
16685       logical :: flag
16686 !      real(kind=8) :: sigm,x
16687
16688 !el      sigm(x)=0.25d0*x     ! local function
16689       qqmax=1.0d10
16690       do kkk=1,nperm
16691       qq = 0.0d0
16692       nl=0
16693        if(flag) then
16694         do il=seg1+nsep,seg2
16695           do jl=seg1,il-nsep
16696             nl=nl+1
16697             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
16698                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
16699                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16700             dij=dist(il,jl)
16701             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16702             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16703               nl=nl+1
16704               d0ijCM=dsqrt( &
16705                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16706                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16707                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16708               dijCM=dist(il+nres,jl+nres)
16709               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16710             endif
16711             qq = qq+qqij+qqijCM
16712           enddo
16713         enddo
16714         qq = qq/nl
16715       else
16716       do il=seg1,seg2
16717         if((seg3-il).lt.3) then
16718              secseg=il+3
16719         else
16720              secseg=seg3
16721         endif
16722           do jl=secseg,seg4
16723             nl=nl+1
16724             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16725                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16726                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16727             dij=dist(il,jl)
16728             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16729             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16730               nl=nl+1
16731               d0ijCM=dsqrt( &
16732                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16733                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16734                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16735               dijCM=dist(il+nres,jl+nres)
16736               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16737             endif
16738             qq = qq+qqij+qqijCM
16739           enddo
16740         enddo
16741       qq = qq/nl
16742       endif
16743       if (qqmax.le.qq) qqmax=qq
16744       enddo
16745       qwolynes=1.0d0-qqmax
16746       return
16747       end function qwolynes
16748 !-----------------------------------------------------------------------------
16749       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
16750 !      implicit real*8 (a-h,o-z)
16751 !      include 'DIMENSIONS'
16752 !      include 'COMMON.IOUNITS'
16753 !      include 'COMMON.CHAIN'
16754 !      include 'COMMON.INTERACT'
16755 !      include 'COMMON.VAR'
16756 !      include 'COMMON.MD'
16757       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
16758       integer :: nsep=3, kkk
16759 !el      real(kind=8) :: dist
16760       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
16761       logical :: lprn=.false.
16762       logical :: flag
16763       real(kind=8) :: sim,dd0,fac,ddqij
16764 !el      sigm(x)=0.25d0*x            ! local function
16765       do kkk=1,nperm
16766       do i=0,nres
16767         do j=1,3
16768           dqwol(j,i)=0.0d0
16769           dxqwol(j,i)=0.0d0
16770         enddo
16771       enddo
16772       nl=0
16773        if(flag) then
16774         do il=seg1+nsep,seg2
16775           do jl=seg1,il-nsep
16776             nl=nl+1
16777             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16778                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16779                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16780             dij=dist(il,jl)
16781             sim = 1.0d0/sigm(d0ij)
16782             sim = sim*sim
16783             dd0 = dij-d0ij
16784             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
16785             do k=1,3
16786               ddqij = (c(k,il)-c(k,jl))*fac
16787               dqwol(k,il)=dqwol(k,il)+ddqij
16788               dqwol(k,jl)=dqwol(k,jl)-ddqij
16789             enddo
16790
16791             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16792               nl=nl+1
16793               d0ijCM=dsqrt( &
16794                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16795                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16796                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16797               dijCM=dist(il+nres,jl+nres)
16798               sim = 1.0d0/sigm(d0ijCM)
16799               sim = sim*sim
16800               dd0=dijCM-d0ijCM
16801               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
16802               do k=1,3
16803                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
16804                 dxqwol(k,il)=dxqwol(k,il)+ddqij
16805                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
16806               enddo
16807             endif
16808           enddo
16809         enddo
16810        else
16811         do il=seg1,seg2
16812         if((seg3-il).lt.3) then
16813              secseg=il+3
16814         else
16815              secseg=seg3
16816         endif
16817           do jl=secseg,seg4
16818             nl=nl+1
16819             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16820                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16821                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16822             dij=dist(il,jl)
16823             sim = 1.0d0/sigm(d0ij)
16824             sim = sim*sim
16825             dd0 = dij-d0ij
16826             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
16827             do k=1,3
16828               ddqij = (c(k,il)-c(k,jl))*fac
16829               dqwol(k,il)=dqwol(k,il)+ddqij
16830               dqwol(k,jl)=dqwol(k,jl)-ddqij
16831             enddo
16832             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16833               nl=nl+1
16834               d0ijCM=dsqrt( &
16835                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16836                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16837                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16838               dijCM=dist(il+nres,jl+nres)
16839               sim = 1.0d0/sigm(d0ijCM)
16840               sim=sim*sim
16841               dd0 = dijCM-d0ijCM
16842               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
16843               do k=1,3
16844                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
16845                dxqwol(k,il)=dxqwol(k,il)+ddqij
16846                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
16847               enddo
16848             endif
16849           enddo
16850         enddo
16851       endif
16852       enddo
16853        do i=0,nres
16854          do j=1,3
16855            dqwol(j,i)=dqwol(j,i)/nl
16856            dxqwol(j,i)=dxqwol(j,i)/nl
16857          enddo
16858        enddo
16859       return
16860       end subroutine qwolynes_prim
16861 !-----------------------------------------------------------------------------
16862       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
16863 !      implicit real*8 (a-h,o-z)
16864 !      include 'DIMENSIONS'
16865 !      include 'COMMON.IOUNITS'
16866 !      include 'COMMON.CHAIN'
16867 !      include 'COMMON.INTERACT'
16868 !      include 'COMMON.VAR'
16869       integer :: seg1,seg2,seg3,seg4
16870       logical :: flag
16871       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
16872       real(kind=8),dimension(3,0:2*nres) :: cdummy
16873       real(kind=8) :: q1,q2
16874       real(kind=8) :: delta=1.0d-10
16875       integer :: i,j
16876
16877       do i=0,nres
16878         do j=1,3
16879           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
16880           cdummy(j,i)=c(j,i)
16881           c(j,i)=c(j,i)+delta
16882           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
16883           qwolan(j,i)=(q2-q1)/delta
16884           c(j,i)=cdummy(j,i)
16885         enddo
16886       enddo
16887       do i=0,nres
16888         do j=1,3
16889           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
16890           cdummy(j,i+nres)=c(j,i+nres)
16891           c(j,i+nres)=c(j,i+nres)+delta
16892           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
16893           qwolxan(j,i)=(q2-q1)/delta
16894           c(j,i+nres)=cdummy(j,i+nres)
16895         enddo
16896       enddo
16897 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
16898 !      do i=0,nct
16899 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
16900 !      enddo
16901 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
16902 !      do i=0,nct
16903 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
16904 !      enddo
16905       return
16906       end subroutine qwol_num
16907 !-----------------------------------------------------------------------------
16908       subroutine EconstrQ
16909 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
16910 !      implicit real*8 (a-h,o-z)
16911 !      include 'DIMENSIONS'
16912 !      include 'COMMON.CONTROL'
16913 !      include 'COMMON.VAR'
16914 !      include 'COMMON.MD'
16915       use MD_data
16916 !#ifndef LANG0
16917 !      include 'COMMON.LANGEVIN'
16918 !#else
16919 !      include 'COMMON.LANGEVIN.lang0'
16920 !#endif
16921 !      include 'COMMON.CHAIN'
16922 !      include 'COMMON.DERIV'
16923 !      include 'COMMON.GEO'
16924 !      include 'COMMON.LOCAL'
16925 !      include 'COMMON.INTERACT'
16926 !      include 'COMMON.IOUNITS'
16927 !      include 'COMMON.NAMES'
16928 !      include 'COMMON.TIME1'
16929       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
16930       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
16931                    duconst,duxconst
16932       integer :: kstart,kend,lstart,lend,idummy
16933       real(kind=8) :: delta=1.0d-7
16934       integer :: i,j,k,ii
16935       do i=0,nres
16936          do j=1,3
16937             duconst(j,i)=0.0d0
16938             dudconst(j,i)=0.0d0
16939             duxconst(j,i)=0.0d0
16940             dudxconst(j,i)=0.0d0
16941          enddo
16942       enddo
16943       Uconst=0.0d0
16944       do i=1,nfrag
16945          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
16946            idummy,idummy)
16947          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
16948 ! Calculating the derivatives of Constraint energy with respect to Q
16949          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
16950            qinfrag(i,iset))
16951 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
16952 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
16953 !         hmnum=(hm2-hm1)/delta
16954 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
16955 !     &   qinfrag(i,iset))
16956 !         write(iout,*) "harmonicnum frag", hmnum
16957 ! Calculating the derivatives of Q with respect to cartesian coordinates
16958          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
16959           idummy,idummy)
16960 !         write(iout,*) "dqwol "
16961 !         do ii=1,nres
16962 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
16963 !         enddo
16964 !         write(iout,*) "dxqwol "
16965 !         do ii=1,nres
16966 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
16967 !         enddo
16968 ! Calculating numerical gradients of dU/dQi and dQi/dxi
16969 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
16970 !     &  ,idummy,idummy)
16971 !  The gradients of Uconst in Cs
16972          do ii=0,nres
16973             do j=1,3
16974                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
16975                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
16976             enddo
16977          enddo
16978       enddo
16979       do i=1,npair
16980          kstart=ifrag(1,ipair(1,i,iset),iset)
16981          kend=ifrag(2,ipair(1,i,iset),iset)
16982          lstart=ifrag(1,ipair(2,i,iset),iset)
16983          lend=ifrag(2,ipair(2,i,iset),iset)
16984          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
16985          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
16986 !  Calculating dU/dQ
16987          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
16988 !         hm1=harmonic(qpair(i),qinpair(i,iset))
16989 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
16990 !         hmnum=(hm2-hm1)/delta
16991 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
16992 !     &   qinpair(i,iset))
16993 !         write(iout,*) "harmonicnum pair ", hmnum
16994 ! Calculating dQ/dXi
16995          call qwolynes_prim(kstart,kend,.false.,&
16996           lstart,lend)
16997 !         write(iout,*) "dqwol "
16998 !         do ii=1,nres
16999 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17000 !         enddo
17001 !         write(iout,*) "dxqwol "
17002 !         do ii=1,nres
17003 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17004 !        enddo
17005 ! Calculating numerical gradients
17006 !        call qwol_num(kstart,kend,.false.
17007 !     &  ,lstart,lend)
17008 ! The gradients of Uconst in Cs
17009          do ii=0,nres
17010             do j=1,3
17011                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17012                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17013             enddo
17014          enddo
17015       enddo
17016 !      write(iout,*) "Uconst inside subroutine ", Uconst
17017 ! Transforming the gradients from Cs to dCs for the backbone
17018       do i=0,nres
17019          do j=i+1,nres
17020            do k=1,3
17021              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17022            enddo
17023          enddo
17024       enddo
17025 !  Transforming the gradients from Cs to dCs for the side chains
17026       do i=1,nres
17027          do j=1,3
17028            dudxconst(j,i)=duxconst(j,i)
17029          enddo
17030       enddo
17031 !      write(iout,*) "dU/ddc backbone "
17032 !       do ii=0,nres
17033 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17034 !      enddo
17035 !      write(iout,*) "dU/ddX side chain "
17036 !      do ii=1,nres
17037 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17038 !      enddo
17039 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17040 !      call dEconstrQ_num
17041       return
17042       end subroutine EconstrQ
17043 !-----------------------------------------------------------------------------
17044       subroutine dEconstrQ_num
17045 ! Calculating numerical dUconst/ddc and dUconst/ddx
17046 !      implicit real*8 (a-h,o-z)
17047 !      include 'DIMENSIONS'
17048 !      include 'COMMON.CONTROL'
17049 !      include 'COMMON.VAR'
17050 !      include 'COMMON.MD'
17051       use MD_data
17052 !#ifndef LANG0
17053 !      include 'COMMON.LANGEVIN'
17054 !#else
17055 !      include 'COMMON.LANGEVIN.lang0'
17056 !#endif
17057 !      include 'COMMON.CHAIN'
17058 !      include 'COMMON.DERIV'
17059 !      include 'COMMON.GEO'
17060 !      include 'COMMON.LOCAL'
17061 !      include 'COMMON.INTERACT'
17062 !      include 'COMMON.IOUNITS'
17063 !      include 'COMMON.NAMES'
17064 !      include 'COMMON.TIME1'
17065       real(kind=8) :: uzap1,uzap2
17066       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17067       integer :: kstart,kend,lstart,lend,idummy
17068       real(kind=8) :: delta=1.0d-7
17069 !el local variables
17070       integer :: i,ii,j
17071 !     real(kind=8) ::
17072 !     For the backbone
17073       do i=0,nres-1
17074          do j=1,3
17075             dUcartan(j,i)=0.0d0
17076             cdummy(j,i)=dc(j,i)
17077             dc(j,i)=dc(j,i)+delta
17078             call chainbuild_cart
17079             uzap2=0.0d0
17080             do ii=1,nfrag
17081              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17082                 idummy,idummy)
17083                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17084                 qinfrag(ii,iset))
17085             enddo
17086             do ii=1,npair
17087                kstart=ifrag(1,ipair(1,ii,iset),iset)
17088                kend=ifrag(2,ipair(1,ii,iset),iset)
17089                lstart=ifrag(1,ipair(2,ii,iset),iset)
17090                lend=ifrag(2,ipair(2,ii,iset),iset)
17091                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17092                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17093                  qinpair(ii,iset))
17094             enddo
17095             dc(j,i)=cdummy(j,i)
17096             call chainbuild_cart
17097             uzap1=0.0d0
17098              do ii=1,nfrag
17099              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17100                 idummy,idummy)
17101                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17102                 qinfrag(ii,iset))
17103             enddo
17104             do ii=1,npair
17105                kstart=ifrag(1,ipair(1,ii,iset),iset)
17106                kend=ifrag(2,ipair(1,ii,iset),iset)
17107                lstart=ifrag(1,ipair(2,ii,iset),iset)
17108                lend=ifrag(2,ipair(2,ii,iset),iset)
17109                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17110                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17111                 qinpair(ii,iset))
17112             enddo
17113             ducartan(j,i)=(uzap2-uzap1)/(delta)
17114          enddo
17115       enddo
17116 ! Calculating numerical gradients for dU/ddx
17117       do i=0,nres-1
17118          duxcartan(j,i)=0.0d0
17119          do j=1,3
17120             cdummy(j,i)=dc(j,i+nres)
17121             dc(j,i+nres)=dc(j,i+nres)+delta
17122             call chainbuild_cart
17123             uzap2=0.0d0
17124             do ii=1,nfrag
17125              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17126                 idummy,idummy)
17127                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17128                 qinfrag(ii,iset))
17129             enddo
17130             do ii=1,npair
17131                kstart=ifrag(1,ipair(1,ii,iset),iset)
17132                kend=ifrag(2,ipair(1,ii,iset),iset)
17133                lstart=ifrag(1,ipair(2,ii,iset),iset)
17134                lend=ifrag(2,ipair(2,ii,iset),iset)
17135                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17136                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17137                 qinpair(ii,iset))
17138             enddo
17139             dc(j,i+nres)=cdummy(j,i)
17140             call chainbuild_cart
17141             uzap1=0.0d0
17142              do ii=1,nfrag
17143                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17144                 ifrag(2,ii,iset),.true.,idummy,idummy)
17145                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17146                 qinfrag(ii,iset))
17147             enddo
17148             do ii=1,npair
17149                kstart=ifrag(1,ipair(1,ii,iset),iset)
17150                kend=ifrag(2,ipair(1,ii,iset),iset)
17151                lstart=ifrag(1,ipair(2,ii,iset),iset)
17152                lend=ifrag(2,ipair(2,ii,iset),iset)
17153                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17154                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17155                 qinpair(ii,iset))
17156             enddo
17157             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17158          enddo
17159       enddo
17160       write(iout,*) "Numerical dUconst/ddc backbone "
17161       do ii=0,nres
17162         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17163       enddo
17164 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17165 !      do ii=1,nres
17166 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17167 !      enddo
17168       return
17169       end subroutine dEconstrQ_num
17170 !-----------------------------------------------------------------------------
17171 ! ssMD.F
17172 !-----------------------------------------------------------------------------
17173       subroutine check_energies
17174
17175 !      use random, only: ran_number
17176
17177 !      implicit none
17178 !     Includes
17179 !      include 'DIMENSIONS'
17180 !      include 'COMMON.CHAIN'
17181 !      include 'COMMON.VAR'
17182 !      include 'COMMON.IOUNITS'
17183 !      include 'COMMON.SBRIDGE'
17184 !      include 'COMMON.LOCAL'
17185 !      include 'COMMON.GEO'
17186
17187 !     External functions
17188 !EL      double precision ran_number
17189 !EL      external ran_number
17190
17191 !     Local variables
17192       integer :: i,j,k,l,lmax,p,pmax
17193       real(kind=8) :: rmin,rmax
17194       real(kind=8) :: eij
17195
17196       real(kind=8) :: d
17197       real(kind=8) :: wi,rij,tj,pj
17198 !      return
17199
17200       i=5
17201       j=14
17202
17203       d=dsc(1)
17204       rmin=2.0D0
17205       rmax=12.0D0
17206
17207       lmax=10000
17208       pmax=1
17209
17210       do k=1,3
17211         c(k,i)=0.0D0
17212         c(k,j)=0.0D0
17213         c(k,nres+i)=0.0D0
17214         c(k,nres+j)=0.0D0
17215       enddo
17216
17217       do l=1,lmax
17218
17219 !t        wi=ran_number(0.0D0,pi)
17220 !        wi=ran_number(0.0D0,pi/6.0D0)
17221 !        wi=0.0D0
17222 !t        tj=ran_number(0.0D0,pi)
17223 !t        pj=ran_number(0.0D0,pi)
17224 !        pj=ran_number(0.0D0,pi/6.0D0)
17225 !        pj=0.0D0
17226
17227         do p=1,pmax
17228 !t           rij=ran_number(rmin,rmax)
17229
17230            c(1,j)=d*sin(pj)*cos(tj)
17231            c(2,j)=d*sin(pj)*sin(tj)
17232            c(3,j)=d*cos(pj)
17233
17234            c(3,nres+i)=-rij
17235
17236            c(1,i)=d*sin(wi)
17237            c(3,i)=-rij-d*cos(wi)
17238
17239            do k=1,3
17240               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17241               dc_norm(k,nres+i)=dc(k,nres+i)/d
17242               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17243               dc_norm(k,nres+j)=dc(k,nres+j)/d
17244            enddo
17245
17246            call dyn_ssbond_ene(i,j,eij)
17247         enddo
17248       enddo
17249       call exit(1)
17250       return
17251       end subroutine check_energies
17252 !-----------------------------------------------------------------------------
17253       subroutine dyn_ssbond_ene(resi,resj,eij)
17254 !      implicit none
17255 !      Includes
17256       use calc_data
17257       use comm_sschecks
17258 !      include 'DIMENSIONS'
17259 !      include 'COMMON.SBRIDGE'
17260 !      include 'COMMON.CHAIN'
17261 !      include 'COMMON.DERIV'
17262 !      include 'COMMON.LOCAL'
17263 !      include 'COMMON.INTERACT'
17264 !      include 'COMMON.VAR'
17265 !      include 'COMMON.IOUNITS'
17266 !      include 'COMMON.CALC'
17267 #ifndef CLUST
17268 #ifndef WHAM
17269        use MD_data
17270 !      include 'COMMON.MD'
17271 !      use MD, only: totT,t_bath
17272 #endif
17273 #endif
17274 !     External functions
17275 !EL      double precision h_base
17276 !EL      external h_base
17277
17278 !     Input arguments
17279       integer :: resi,resj
17280
17281 !     Output arguments
17282       real(kind=8) :: eij
17283
17284 !     Local variables
17285       logical :: havebond
17286       integer itypi,itypj
17287       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17288       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17289       real(kind=8),dimension(3) :: dcosom1,dcosom2
17290       real(kind=8) :: ed
17291       real(kind=8) :: pom1,pom2
17292       real(kind=8) :: ljA,ljB,ljXs
17293       real(kind=8),dimension(1:3) :: d_ljB
17294       real(kind=8) :: ssA,ssB,ssC,ssXs
17295       real(kind=8) :: ssxm,ljxm,ssm,ljm
17296       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17297       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17298       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17299 !-------FIRST METHOD
17300       real(kind=8) :: xm
17301       real(kind=8),dimension(1:3) :: d_xm
17302 !-------END FIRST METHOD
17303 !-------SECOND METHOD
17304 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17305 !-------END SECOND METHOD
17306
17307 !-------TESTING CODE
17308 !el      logical :: checkstop,transgrad
17309 !el      common /sschecks/ checkstop,transgrad
17310
17311       integer :: icheck,nicheck,jcheck,njcheck
17312       real(kind=8),dimension(-1:1) :: echeck
17313       real(kind=8) :: deps,ssx0,ljx0
17314 !-------END TESTING CODE
17315
17316       eij=0.0d0
17317       i=resi
17318       j=resj
17319
17320 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17321 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17322
17323       itypi=itype(i)
17324       dxi=dc_norm(1,nres+i)
17325       dyi=dc_norm(2,nres+i)
17326       dzi=dc_norm(3,nres+i)
17327       dsci_inv=vbld_inv(i+nres)
17328
17329       itypj=itype(j)
17330       xj=c(1,nres+j)-c(1,nres+i)
17331       yj=c(2,nres+j)-c(2,nres+i)
17332       zj=c(3,nres+j)-c(3,nres+i)
17333       dxj=dc_norm(1,nres+j)
17334       dyj=dc_norm(2,nres+j)
17335       dzj=dc_norm(3,nres+j)
17336       dscj_inv=vbld_inv(j+nres)
17337
17338       chi1=chi(itypi,itypj)
17339       chi2=chi(itypj,itypi)
17340       chi12=chi1*chi2
17341       chip1=chip(itypi)
17342       chip2=chip(itypj)
17343       chip12=chip1*chip2
17344       alf1=alp(itypi)
17345       alf2=alp(itypj)
17346       alf12=0.5D0*(alf1+alf2)
17347
17348       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17349       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17350 !     The following are set in sc_angular
17351 !      erij(1)=xj*rij
17352 !      erij(2)=yj*rij
17353 !      erij(3)=zj*rij
17354 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17355 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17356 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17357       call sc_angular
17358       rij=1.0D0/rij  ! Reset this so it makes sense
17359
17360       sig0ij=sigma(itypi,itypj)
17361       sig=sig0ij*dsqrt(1.0D0/sigsq)
17362
17363       ljXs=sig-sig0ij
17364       ljA=eps1*eps2rt**2*eps3rt**2
17365       ljB=ljA*bb_aq(itypi,itypj)
17366       ljA=ljA*aa_aq(itypi,itypj)
17367       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17368
17369       ssXs=d0cm
17370       deltat1=1.0d0-om1
17371       deltat2=1.0d0+om2
17372       deltat12=om2-om1+2.0d0
17373       cosphi=om12-om1*om2
17374       ssA=akcm
17375       ssB=akct*deltat12
17376       ssC=ss_depth &
17377            +akth*(deltat1*deltat1+deltat2*deltat2) &
17378            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17379       ssxm=ssXs-0.5D0*ssB/ssA
17380
17381 !-------TESTING CODE
17382 !$$$c     Some extra output
17383 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17384 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17385 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17386 !$$$      if (ssx0.gt.0.0d0) then
17387 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17388 !$$$      else
17389 !$$$        ssx0=ssxm
17390 !$$$      endif
17391 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17392 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17393 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17394 !$$$      return
17395 !-------END TESTING CODE
17396
17397 !-------TESTING CODE
17398 !     Stop and plot energy and derivative as a function of distance
17399       if (checkstop) then
17400         ssm=ssC-0.25D0*ssB*ssB/ssA
17401         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17402         if (ssm.lt.ljm .and. &
17403              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17404           nicheck=1000
17405           njcheck=1
17406           deps=0.5d-7
17407         else
17408           checkstop=.false.
17409         endif
17410       endif
17411       if (.not.checkstop) then
17412         nicheck=0
17413         njcheck=-1
17414       endif
17415
17416       do icheck=0,nicheck
17417       do jcheck=-1,njcheck
17418       if (checkstop) rij=(ssxm-1.0d0)+ &
17419              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17420 !-------END TESTING CODE
17421
17422       if (rij.gt.ljxm) then
17423         havebond=.false.
17424         ljd=rij-ljXs
17425         fac=(1.0D0/ljd)**expon
17426         e1=fac*fac*aa_aq(itypi,itypj)
17427         e2=fac*bb_aq(itypi,itypj)
17428         eij=eps1*eps2rt*eps3rt*(e1+e2)
17429         eps2der=eij*eps3rt
17430         eps3der=eij*eps2rt
17431         eij=eij*eps2rt*eps3rt
17432
17433         sigder=-sig/sigsq
17434         e1=e1*eps1*eps2rt**2*eps3rt**2
17435         ed=-expon*(e1+eij)/ljd
17436         sigder=ed*sigder
17437         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17438         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17439         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17440              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17441       else if (rij.lt.ssxm) then
17442         havebond=.true.
17443         ssd=rij-ssXs
17444         eij=ssA*ssd*ssd+ssB*ssd+ssC
17445
17446         ed=2*akcm*ssd+akct*deltat12
17447         pom1=akct*ssd
17448         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17449         eom1=-2*akth*deltat1-pom1-om2*pom2
17450         eom2= 2*akth*deltat2+pom1-om1*pom2
17451         eom12=pom2
17452       else
17453         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17454
17455         d_ssxm(1)=0.5D0*akct/ssA
17456         d_ssxm(2)=-d_ssxm(1)
17457         d_ssxm(3)=0.0D0
17458
17459         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17460         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17461         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17462         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17463
17464 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17465         xm=0.5d0*(ssxm+ljxm)
17466         do k=1,3
17467           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17468         enddo
17469         if (rij.lt.xm) then
17470           havebond=.true.
17471           ssm=ssC-0.25D0*ssB*ssB/ssA
17472           d_ssm(1)=0.5D0*akct*ssB/ssA
17473           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17474           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17475           d_ssm(3)=omega
17476           f1=(rij-xm)/(ssxm-xm)
17477           f2=(rij-ssxm)/(xm-ssxm)
17478           h1=h_base(f1,hd1)
17479           h2=h_base(f2,hd2)
17480           eij=ssm*h1+Ht*h2
17481           delta_inv=1.0d0/(xm-ssxm)
17482           deltasq_inv=delta_inv*delta_inv
17483           fac=ssm*hd1-Ht*hd2
17484           fac1=deltasq_inv*fac*(xm-rij)
17485           fac2=deltasq_inv*fac*(rij-ssxm)
17486           ed=delta_inv*(Ht*hd2-ssm*hd1)
17487           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17488           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17489           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17490         else
17491           havebond=.false.
17492           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17493           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17494           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17495           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17496                alf12/eps3rt)
17497           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17498           f1=(rij-ljxm)/(xm-ljxm)
17499           f2=(rij-xm)/(ljxm-xm)
17500           h1=h_base(f1,hd1)
17501           h2=h_base(f2,hd2)
17502           eij=Ht*h1+ljm*h2
17503           delta_inv=1.0d0/(ljxm-xm)
17504           deltasq_inv=delta_inv*delta_inv
17505           fac=Ht*hd1-ljm*hd2
17506           fac1=deltasq_inv*fac*(ljxm-rij)
17507           fac2=deltasq_inv*fac*(rij-xm)
17508           ed=delta_inv*(ljm*hd2-Ht*hd1)
17509           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17510           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17511           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17512         endif
17513 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17514
17515 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17516 !$$$        ssd=rij-ssXs
17517 !$$$        ljd=rij-ljXs
17518 !$$$        fac1=rij-ljxm
17519 !$$$        fac2=rij-ssxm
17520 !$$$
17521 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17522 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17523 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17524 !$$$
17525 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17526 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17527 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17528 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17529 !$$$        d_ssm(3)=omega
17530 !$$$
17531 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17532 !$$$        do k=1,3
17533 !$$$          d_ljm(k)=ljm*d_ljB(k)
17534 !$$$        enddo
17535 !$$$        ljm=ljm*ljB
17536 !$$$
17537 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17538 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17539 !$$$        d_ss(2)=akct*ssd
17540 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17541 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17542 !$$$        d_ss(3)=omega
17543 !$$$
17544 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17545 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17546 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
17547 !$$$        do k=1,3
17548 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
17549 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
17550 !$$$        enddo
17551 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
17552 !$$$
17553 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
17554 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
17555 !$$$        h1=h_base(f1,hd1)
17556 !$$$        h2=h_base(f2,hd2)
17557 !$$$        eij=ss*h1+ljf*h2
17558 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
17559 !$$$        deltasq_inv=delta_inv*delta_inv
17560 !$$$        fac=ljf*hd2-ss*hd1
17561 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
17562 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
17563 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
17564 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
17565 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
17566 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
17567 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
17568 !$$$
17569 !$$$        havebond=.false.
17570 !$$$        if (ed.gt.0.0d0) havebond=.true.
17571 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17572
17573       endif
17574
17575       if (havebond) then
17576 !#ifndef CLUST
17577 !#ifndef WHAM
17578 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
17579 !          write(iout,'(a15,f12.2,f8.1,2i5)')
17580 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
17581 !        endif
17582 !#endif
17583 !#endif
17584         dyn_ssbond_ij(i,j)=eij
17585       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
17586         dyn_ssbond_ij(i,j)=1.0d300
17587 !#ifndef CLUST
17588 !#ifndef WHAM
17589 !        write(iout,'(a15,f12.2,f8.1,2i5)')
17590 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
17591 !#endif
17592 !#endif
17593       endif
17594
17595 !-------TESTING CODE
17596 !el      if (checkstop) then
17597         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
17598              "CHECKSTOP",rij,eij,ed
17599         echeck(jcheck)=eij
17600 !el      endif
17601       enddo
17602       if (checkstop) then
17603         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
17604       endif
17605       enddo
17606       if (checkstop) then
17607         transgrad=.true.
17608         checkstop=.false.
17609       endif
17610 !-------END TESTING CODE
17611
17612       do k=1,3
17613         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
17614         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
17615       enddo
17616       do k=1,3
17617         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
17618       enddo
17619       do k=1,3
17620         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17621              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17622              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17623         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17624              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17625              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17626       enddo
17627 !grad      do k=i,j-1
17628 !grad        do l=1,3
17629 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
17630 !grad        enddo
17631 !grad      enddo
17632
17633       do l=1,3
17634         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17635         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17636       enddo
17637
17638       return
17639       end subroutine dyn_ssbond_ene
17640 !-----------------------------------------------------------------------------
17641       real(kind=8) function h_base(x,deriv)
17642 !     A smooth function going 0->1 in range [0,1]
17643 !     It should NOT be called outside range [0,1], it will not work there.
17644       implicit none
17645
17646 !     Input arguments
17647       real(kind=8) :: x
17648
17649 !     Output arguments
17650       real(kind=8) :: deriv
17651
17652 !     Local variables
17653       real(kind=8) :: xsq
17654
17655
17656 !     Two parabolas put together.  First derivative zero at extrema
17657 !$$$      if (x.lt.0.5D0) then
17658 !$$$        h_base=2.0D0*x*x
17659 !$$$        deriv=4.0D0*x
17660 !$$$      else
17661 !$$$        deriv=1.0D0-x
17662 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
17663 !$$$        deriv=4.0D0*deriv
17664 !$$$      endif
17665
17666 !     Third degree polynomial.  First derivative zero at extrema
17667       h_base=x*x*(3.0d0-2.0d0*x)
17668       deriv=6.0d0*x*(1.0d0-x)
17669
17670 !     Fifth degree polynomial.  First and second derivatives zero at extrema
17671 !$$$      xsq=x*x
17672 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
17673 !$$$      deriv=x-1.0d0
17674 !$$$      deriv=deriv*deriv
17675 !$$$      deriv=30.0d0*xsq*deriv
17676
17677       return
17678       end function h_base
17679 !-----------------------------------------------------------------------------
17680       subroutine dyn_set_nss
17681 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
17682 !      implicit none
17683       use MD_data, only: totT,t_bath
17684 !     Includes
17685 !      include 'DIMENSIONS'
17686 #ifdef MPI
17687       include "mpif.h"
17688 #endif
17689 !      include 'COMMON.SBRIDGE'
17690 !      include 'COMMON.CHAIN'
17691 !      include 'COMMON.IOUNITS'
17692 !      include 'COMMON.SETUP'
17693 !      include 'COMMON.MD'
17694 !     Local variables
17695       real(kind=8) :: emin
17696       integer :: i,j,imin,ierr
17697       integer :: diff,allnss,newnss
17698       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
17699                 newihpb,newjhpb
17700       logical :: found
17701       integer,dimension(0:nfgtasks) :: i_newnss
17702       integer,dimension(0:nfgtasks) :: displ
17703       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
17704       integer :: g_newnss
17705
17706       allnss=0
17707       do i=1,nres-1
17708         do j=i+1,nres
17709           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
17710             allnss=allnss+1
17711             allflag(allnss)=0
17712             allihpb(allnss)=i
17713             alljhpb(allnss)=j
17714           endif
17715         enddo
17716       enddo
17717
17718 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
17719
17720  1    emin=1.0d300
17721       do i=1,allnss
17722         if (allflag(i).eq.0 .and. &
17723              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
17724           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
17725           imin=i
17726         endif
17727       enddo
17728       if (emin.lt.1.0d300) then
17729         allflag(imin)=1
17730         do i=1,allnss
17731           if (allflag(i).eq.0 .and. &
17732                (allihpb(i).eq.allihpb(imin) .or. &
17733                alljhpb(i).eq.allihpb(imin) .or. &
17734                allihpb(i).eq.alljhpb(imin) .or. &
17735                alljhpb(i).eq.alljhpb(imin))) then
17736             allflag(i)=-1
17737           endif
17738         enddo
17739         goto 1
17740       endif
17741
17742 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
17743
17744       newnss=0
17745       do i=1,allnss
17746         if (allflag(i).eq.1) then
17747           newnss=newnss+1
17748           newihpb(newnss)=allihpb(i)
17749           newjhpb(newnss)=alljhpb(i)
17750         endif
17751       enddo
17752
17753 #ifdef MPI
17754       if (nfgtasks.gt.1)then
17755
17756         call MPI_Reduce(newnss,g_newnss,1,&
17757           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
17758         call MPI_Gather(newnss,1,MPI_INTEGER,&
17759                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
17760         displ(0)=0
17761         do i=1,nfgtasks-1,1
17762           displ(i)=i_newnss(i-1)+displ(i-1)
17763         enddo
17764         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
17765                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
17766                          king,FG_COMM,IERR)
17767         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
17768                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
17769                          king,FG_COMM,IERR)
17770         if(fg_rank.eq.0) then
17771 !         print *,'g_newnss',g_newnss
17772 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
17773 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
17774          newnss=g_newnss
17775          do i=1,newnss
17776           newihpb(i)=g_newihpb(i)
17777           newjhpb(i)=g_newjhpb(i)
17778          enddo
17779         endif
17780       endif
17781 #endif
17782
17783       diff=newnss-nss
17784
17785 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
17786
17787       do i=1,nss
17788         found=.false.
17789         do j=1,newnss
17790           if (idssb(i).eq.newihpb(j) .and. &
17791                jdssb(i).eq.newjhpb(j)) found=.true.
17792         enddo
17793 #ifndef CLUST
17794 #ifndef WHAM
17795         if (.not.found.and.fg_rank.eq.0) &
17796             write(iout,'(a15,f12.2,f8.1,2i5)') &
17797              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
17798 #endif
17799 #endif
17800       enddo
17801
17802       do i=1,newnss
17803         found=.false.
17804         do j=1,nss
17805           if (newihpb(i).eq.idssb(j) .and. &
17806                newjhpb(i).eq.jdssb(j)) found=.true.
17807         enddo
17808 #ifndef CLUST
17809 #ifndef WHAM
17810         if (.not.found.and.fg_rank.eq.0) &
17811             write(iout,'(a15,f12.2,f8.1,2i5)') &
17812              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
17813 #endif
17814 #endif
17815       enddo
17816
17817       nss=newnss
17818       do i=1,nss
17819         idssb(i)=newihpb(i)
17820         jdssb(i)=newjhpb(i)
17821       enddo
17822
17823       return
17824       end subroutine dyn_set_nss
17825 ! Lipid transfer energy function
17826       subroutine Eliptransfer(eliptran)
17827 !C this is done by Adasko
17828 !C      print *,"wchodze"
17829 !C structure of box:
17830 !C      water
17831 !C--bordliptop-- buffore starts
17832 !C--bufliptop--- here true lipid starts
17833 !C      lipid
17834 !C--buflipbot--- lipid ends buffore starts
17835 !C--bordlipbot--buffore ends
17836       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
17837       integer :: i
17838       eliptran=0.0
17839       print *, "I am in eliptran"
17840       do i=ilip_start,ilip_end
17841 !C       do i=1,1
17842         if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1).or.(i.eq.nres))&
17843          cycle
17844
17845         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
17846         if (positi.le.0.0) positi=positi+boxzsize
17847 !C        print *,i
17848 !C first for peptide groups
17849 !c for each residue check if it is in lipid or lipid water border area
17850        if ((positi.gt.bordlipbot)  &
17851       .and.(positi.lt.bordliptop)) then
17852 !C the energy transfer exist
17853         if (positi.lt.buflipbot) then
17854 !C what fraction I am in
17855          fracinbuf=1.0d0-      &
17856              ((positi-bordlipbot)/lipbufthick)
17857 !C lipbufthick is thickenes of lipid buffore
17858          sslip=sscalelip(fracinbuf)
17859          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
17860          eliptran=eliptran+sslip*pepliptran
17861          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
17862          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
17863 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
17864
17865 !C        print *,"doing sccale for lower part"
17866 !C         print *,i,sslip,fracinbuf,ssgradlip
17867         elseif (positi.gt.bufliptop) then
17868          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
17869          sslip=sscalelip(fracinbuf)
17870          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
17871          eliptran=eliptran+sslip*pepliptran
17872          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
17873          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
17874 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
17875 !C          print *, "doing sscalefor top part"
17876 !C         print *,i,sslip,fracinbuf,ssgradlip
17877         else
17878          eliptran=eliptran+pepliptran
17879 !C         print *,"I am in true lipid"
17880         endif
17881 !C       else
17882 !C       eliptran=elpitran+0.0 ! I am in water
17883        endif
17884        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
17885        enddo
17886 ! here starts the side chain transfer
17887        do i=ilip_start,ilip_end
17888         if (itype(i).eq.ntyp1) cycle
17889         positi=(mod(c(3,i+nres),boxzsize))
17890         if (positi.le.0) positi=positi+boxzsize
17891 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
17892 !c for each residue check if it is in lipid or lipid water border area
17893 !C       respos=mod(c(3,i+nres),boxzsize)
17894 !C       print *,positi,bordlipbot,buflipbot
17895        if ((positi.gt.bordlipbot) &
17896        .and.(positi.lt.bordliptop)) then
17897 !C the energy transfer exist
17898         if (positi.lt.buflipbot) then
17899          fracinbuf=1.0d0-   &
17900            ((positi-bordlipbot)/lipbufthick)
17901 !C lipbufthick is thickenes of lipid buffore
17902          sslip=sscalelip(fracinbuf)
17903          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
17904          eliptran=eliptran+sslip*liptranene(itype(i))
17905          gliptranx(3,i)=gliptranx(3,i) &
17906       +ssgradlip*liptranene(itype(i))
17907          gliptranc(3,i-1)= gliptranc(3,i-1) &
17908       +ssgradlip*liptranene(itype(i))
17909 !C         print *,"doing sccale for lower part"
17910         elseif (positi.gt.bufliptop) then
17911          fracinbuf=1.0d0-  &
17912       ((bordliptop-positi)/lipbufthick)
17913          sslip=sscalelip(fracinbuf)
17914          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
17915          eliptran=eliptran+sslip*liptranene(itype(i))
17916          gliptranx(3,i)=gliptranx(3,i)  &
17917        +ssgradlip*liptranene(itype(i))
17918          gliptranc(3,i-1)= gliptranc(3,i-1) &
17919       +ssgradlip*liptranene(itype(i))
17920 !C          print *, "doing sscalefor top part",sslip,fracinbuf
17921         else
17922          eliptran=eliptran+liptranene(itype(i))
17923 !C         print *,"I am in true lipid"
17924         endif
17925         endif ! if in lipid or buffor
17926 !C       else
17927 !C       eliptran=elpitran+0.0 ! I am in water
17928         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
17929        enddo
17930        return
17931        end  subroutine Eliptransfer
17932 !----------------------------------NANO FUNCTIONS
17933 !C-----------------------------------------------------------------------
17934 !C-----------------------------------------------------------
17935 !C This subroutine is to mimic the histone like structure but as well can be
17936 !C utilizet to nanostructures (infinit) small modification has to be used to
17937 !C make it finite (z gradient at the ends has to be changes as well as the x,y
17938 !C gradient has to be modified at the ends
17939 !C The energy function is Kihara potential
17940 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
17941 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
17942 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
17943 !C simple Kihara potential
17944       subroutine calctube(Etube)
17945       real(kind=8) :: vectube(3),enetube(nres*2)
17946       real(kind=8) :: Etube,xtemp,xminact,yminact,&
17947        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
17948        sc_aa_tube,sc_bb_tube
17949       integer :: i,j,iti
17950       Etube=0.0d0
17951       do i=itube_start,itube_end
17952         enetube(i)=0.0d0
17953         enetube(i+nres)=0.0d0
17954       enddo
17955 !C first we calculate the distance from tube center
17956 !C for UNRES
17957        do i=itube_start,itube_end
17958 !C lets ommit dummy atoms for now
17959        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
17960 !C now calculate distance from center of tube and direction vectors
17961       xmin=boxxsize
17962       ymin=boxysize
17963 ! Find minimum distance in periodic box
17964         do j=-1,1
17965          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
17966          vectube(1)=vectube(1)+boxxsize*j
17967          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
17968          vectube(2)=vectube(2)+boxysize*j
17969          xminact=abs(vectube(1)-tubecenter(1))
17970          yminact=abs(vectube(2)-tubecenter(2))
17971            if (xmin.gt.xminact) then
17972             xmin=xminact
17973             xtemp=vectube(1)
17974            endif
17975            if (ymin.gt.yminact) then
17976              ymin=yminact
17977              ytemp=vectube(2)
17978             endif
17979          enddo
17980       vectube(1)=xtemp
17981       vectube(2)=ytemp
17982       vectube(1)=vectube(1)-tubecenter(1)
17983       vectube(2)=vectube(2)-tubecenter(2)
17984
17985 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
17986 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
17987
17988 !C as the tube is infinity we do not calculate the Z-vector use of Z
17989 !C as chosen axis
17990       vectube(3)=0.0d0
17991 !C now calculte the distance
17992        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
17993 !C now normalize vector
17994       vectube(1)=vectube(1)/tub_r
17995       vectube(2)=vectube(2)/tub_r
17996 !C calculte rdiffrence between r and r0
17997       rdiff=tub_r-tubeR0
17998 !C and its 6 power
17999       rdiff6=rdiff**6.0d0
18000 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18001        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18002 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18003 !C       print *,rdiff,rdiff6,pep_aa_tube
18004 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18005 !C now we calculate gradient
18006        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18007             6.0d0*pep_bb_tube)/rdiff6/rdiff
18008 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18009 !C     &rdiff,fac
18010 !C now direction of gg_tube vector
18011         do j=1,3
18012         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18013         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18014         enddo
18015         enddo
18016 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18017 !C        print *,gg_tube(1,0),"TU"
18018
18019
18020        do i=itube_start,itube_end
18021 !C Lets not jump over memory as we use many times iti
18022          iti=itype(i)
18023 !C lets ommit dummy atoms for now
18024          if ((iti.eq.ntyp1)  &
18025 !C in UNRES uncomment the line below as GLY has no side-chain...
18026 !C      .or.(iti.eq.10)
18027         ) cycle
18028       xmin=boxxsize
18029       ymin=boxysize
18030         do j=-1,1
18031          vectube(1)=mod((c(1,i+nres)),boxxsize)
18032          vectube(1)=vectube(1)+boxxsize*j
18033          vectube(2)=mod((c(2,i+nres)),boxysize)
18034          vectube(2)=vectube(2)+boxysize*j
18035
18036          xminact=abs(vectube(1)-tubecenter(1))
18037          yminact=abs(vectube(2)-tubecenter(2))
18038            if (xmin.gt.xminact) then
18039             xmin=xminact
18040             xtemp=vectube(1)
18041            endif
18042            if (ymin.gt.yminact) then
18043              ymin=yminact
18044              ytemp=vectube(2)
18045             endif
18046          enddo
18047       vectube(1)=xtemp
18048       vectube(2)=ytemp
18049 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18050 !C     &     tubecenter(2)
18051       vectube(1)=vectube(1)-tubecenter(1)
18052       vectube(2)=vectube(2)-tubecenter(2)
18053
18054 !C as the tube is infinity we do not calculate the Z-vector use of Z
18055 !C as chosen axis
18056       vectube(3)=0.0d0
18057 !C now calculte the distance
18058        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18059 !C now normalize vector
18060       vectube(1)=vectube(1)/tub_r
18061       vectube(2)=vectube(2)/tub_r
18062
18063 !C calculte rdiffrence between r and r0
18064       rdiff=tub_r-tubeR0
18065 !C and its 6 power
18066       rdiff6=rdiff**6.0d0
18067 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18068        sc_aa_tube=sc_aa_tube_par(iti)
18069        sc_bb_tube=sc_bb_tube_par(iti)
18070        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18071        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18072              6.0d0*sc_bb_tube/rdiff6/rdiff
18073 !C now direction of gg_tube vector
18074          do j=1,3
18075           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18076           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18077          enddo
18078         enddo
18079         do i=itube_start,itube_end
18080           Etube=Etube+enetube(i)+enetube(i+nres)
18081         enddo
18082 !C        print *,"ETUBE", etube
18083         return
18084         end subroutine calctube
18085 !C TO DO 1) add to total energy
18086 !C       2) add to gradient summation
18087 !C       3) add reading parameters (AND of course oppening of PARAM file)
18088 !C       4) add reading the center of tube
18089 !C       5) add COMMONs
18090 !C       6) add to zerograd
18091 !C       7) allocate matrices
18092
18093
18094 !C-----------------------------------------------------------------------
18095 !C-----------------------------------------------------------
18096 !C This subroutine is to mimic the histone like structure but as well can be
18097 !C utilizet to nanostructures (infinit) small modification has to be used to
18098 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18099 !C gradient has to be modified at the ends
18100 !C The energy function is Kihara potential
18101 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18102 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18103 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18104 !C simple Kihara potential
18105       subroutine calctube2(Etube)
18106       real(kind=8) :: vectube(3),enetube(nres*2)
18107       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18108        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18109        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18110       integer:: i,j,iti
18111       Etube=0.0d0
18112       do i=itube_start,itube_end
18113         enetube(i)=0.0d0
18114         enetube(i+nres)=0.0d0
18115       enddo
18116 !C first we calculate the distance from tube center
18117 !C first sugare-phosphate group for NARES this would be peptide group
18118 !C for UNRES
18119        do i=itube_start,itube_end
18120 !C lets ommit dummy atoms for now
18121
18122        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
18123 !C now calculate distance from center of tube and direction vectors
18124 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18125 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18126 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18127 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18128       xmin=boxxsize
18129       ymin=boxysize
18130         do j=-1,1
18131          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18132          vectube(1)=vectube(1)+boxxsize*j
18133          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18134          vectube(2)=vectube(2)+boxysize*j
18135
18136          xminact=abs(vectube(1)-tubecenter(1))
18137          yminact=abs(vectube(2)-tubecenter(2))
18138            if (xmin.gt.xminact) then
18139             xmin=xminact
18140             xtemp=vectube(1)
18141            endif
18142            if (ymin.gt.yminact) then
18143              ymin=yminact
18144              ytemp=vectube(2)
18145             endif
18146          enddo
18147       vectube(1)=xtemp
18148       vectube(2)=ytemp
18149       vectube(1)=vectube(1)-tubecenter(1)
18150       vectube(2)=vectube(2)-tubecenter(2)
18151
18152 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18153 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18154
18155 !C as the tube is infinity we do not calculate the Z-vector use of Z
18156 !C as chosen axis
18157       vectube(3)=0.0d0
18158 !C now calculte the distance
18159        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18160 !C now normalize vector
18161       vectube(1)=vectube(1)/tub_r
18162       vectube(2)=vectube(2)/tub_r
18163 !C calculte rdiffrence between r and r0
18164       rdiff=tub_r-tubeR0
18165 !C and its 6 power
18166       rdiff6=rdiff**6.0d0
18167 !C THIS FRAGMENT MAKES TUBE FINITE
18168         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18169         if (positi.le.0) positi=positi+boxzsize
18170 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18171 !c for each residue check if it is in lipid or lipid water border area
18172 !C       respos=mod(c(3,i+nres),boxzsize)
18173 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18174        if ((positi.gt.bordtubebot)  &
18175         .and.(positi.lt.bordtubetop)) then
18176 !C the energy transfer exist
18177         if (positi.lt.buftubebot) then
18178          fracinbuf=1.0d0-  &
18179            ((positi-bordtubebot)/tubebufthick)
18180 !C lipbufthick is thickenes of lipid buffore
18181          sstube=sscalelip(fracinbuf)
18182          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18183 !C         print *,ssgradtube, sstube,tubetranene(itype(i))
18184          enetube(i)=enetube(i)+sstube*tubetranenepep
18185 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18186 !C     &+ssgradtube*tubetranene(itype(i))
18187 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18188 !C     &+ssgradtube*tubetranene(itype(i))
18189 !C         print *,"doing sccale for lower part"
18190         elseif (positi.gt.buftubetop) then
18191          fracinbuf=1.0d0-  &
18192         ((bordtubetop-positi)/tubebufthick)
18193          sstube=sscalelip(fracinbuf)
18194          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18195          enetube(i)=enetube(i)+sstube*tubetranenepep
18196 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18197 !C     &+ssgradtube*tubetranene(itype(i))
18198 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18199 !C     &+ssgradtube*tubetranene(itype(i))
18200 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18201         else
18202          sstube=1.0d0
18203          ssgradtube=0.0d0
18204          enetube(i)=enetube(i)+sstube*tubetranenepep
18205 !C         print *,"I am in true lipid"
18206         endif
18207         else
18208 !C          sstube=0.0d0
18209 !C          ssgradtube=0.0d0
18210         cycle
18211         endif ! if in lipid or buffor
18212
18213 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18214        enetube(i)=enetube(i)+sstube* &
18215         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18216 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18217 !C       print *,rdiff,rdiff6,pep_aa_tube
18218 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18219 !C now we calculate gradient
18220        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18221              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18222 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18223 !C     &rdiff,fac
18224
18225 !C now direction of gg_tube vector
18226        do j=1,3
18227         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18228         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18229         enddo
18230          gg_tube(3,i)=gg_tube(3,i)  &
18231        +ssgradtube*enetube(i)/sstube/2.0d0
18232          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18233        +ssgradtube*enetube(i)/sstube/2.0d0
18234
18235         enddo
18236 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18237 !C        print *,gg_tube(1,0),"TU"
18238         do i=itube_start,itube_end
18239 !C Lets not jump over memory as we use many times iti
18240          iti=itype(i)
18241 !C lets ommit dummy atoms for now
18242          if ((iti.eq.ntyp1) &
18243 !!C in UNRES uncomment the line below as GLY has no side-chain...
18244            .or.(iti.eq.10) &
18245           ) cycle
18246           vectube(1)=c(1,i+nres)
18247           vectube(1)=mod(vectube(1),boxxsize)
18248           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18249           vectube(2)=c(2,i+nres)
18250           vectube(2)=mod(vectube(2),boxysize)
18251           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18252
18253       vectube(1)=vectube(1)-tubecenter(1)
18254       vectube(2)=vectube(2)-tubecenter(2)
18255 !C THIS FRAGMENT MAKES TUBE FINITE
18256         positi=(mod(c(3,i+nres),boxzsize))
18257         if (positi.le.0) positi=positi+boxzsize
18258 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18259 !c for each residue check if it is in lipid or lipid water border area
18260 !C       respos=mod(c(3,i+nres),boxzsize)
18261 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18262
18263        if ((positi.gt.bordtubebot)  &
18264         .and.(positi.lt.bordtubetop)) then
18265 !C the energy transfer exist
18266         if (positi.lt.buftubebot) then
18267          fracinbuf=1.0d0- &
18268             ((positi-bordtubebot)/tubebufthick)
18269 !C lipbufthick is thickenes of lipid buffore
18270          sstube=sscalelip(fracinbuf)
18271          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18272 !C         print *,ssgradtube, sstube,tubetranene(itype(i))
18273          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
18274 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18275 !C     &+ssgradtube*tubetranene(itype(i))
18276 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18277 !C     &+ssgradtube*tubetranene(itype(i))
18278 !C         print *,"doing sccale for lower part"
18279         elseif (positi.gt.buftubetop) then
18280          fracinbuf=1.0d0- &
18281         ((bordtubetop-positi)/tubebufthick)
18282
18283          sstube=sscalelip(fracinbuf)
18284          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18285          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
18286 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18287 !C     &+ssgradtube*tubetranene(itype(i))
18288 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18289 !C     &+ssgradtube*tubetranene(itype(i))
18290 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18291         else
18292          sstube=1.0d0
18293          ssgradtube=0.0d0
18294          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
18295 !C         print *,"I am in true lipid"
18296         endif
18297         else
18298 !C          sstube=0.0d0
18299 !C          ssgradtube=0.0d0
18300         cycle
18301         endif ! if in lipid or buffor
18302 !CEND OF FINITE FRAGMENT
18303 !C as the tube is infinity we do not calculate the Z-vector use of Z
18304 !C as chosen axis
18305       vectube(3)=0.0d0
18306 !C now calculte the distance
18307        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18308 !C now normalize vector
18309       vectube(1)=vectube(1)/tub_r
18310       vectube(2)=vectube(2)/tub_r
18311 !C calculte rdiffrence between r and r0
18312       rdiff=tub_r-tubeR0
18313 !C and its 6 power
18314       rdiff6=rdiff**6.0d0
18315 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18316        sc_aa_tube=sc_aa_tube_par(iti)
18317        sc_bb_tube=sc_bb_tube_par(iti)
18318        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18319                        *sstube+enetube(i+nres)
18320 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18321 !C now we calculate gradient
18322        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18323             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18324 !C now direction of gg_tube vector
18325          do j=1,3
18326           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18327           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18328          enddo
18329          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18330        +ssgradtube*enetube(i+nres)/sstube
18331          gg_tube(3,i-1)= gg_tube(3,i-1) &
18332        +ssgradtube*enetube(i+nres)/sstube
18333
18334         enddo
18335         do i=itube_start,itube_end
18336           Etube=Etube+enetube(i)+enetube(i+nres)
18337         enddo
18338 !C        print *,"ETUBE", etube
18339         return
18340         end subroutine calctube2
18341 !=====================================================================================================================================
18342       subroutine calcnano(Etube)
18343       real(kind=8) :: vectube(3),enetube(nres*2), &
18344       enecavtube(nres*2)
18345       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18346        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
18347        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
18348        integer:: i,j,iti
18349
18350       Etube=0.0d0
18351       print *,itube_start,itube_end,"poczatek"
18352       do i=itube_start,itube_end
18353         enetube(i)=0.0d0
18354         enetube(i+nres)=0.0d0
18355       enddo
18356 !C first we calculate the distance from tube center
18357 !C first sugare-phosphate group for NARES this would be peptide group
18358 !C for UNRES
18359        do i=itube_start,itube_end
18360 !C lets ommit dummy atoms for now
18361        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
18362 !C now calculate distance from center of tube and direction vectors
18363       xmin=boxxsize
18364       ymin=boxysize
18365       zmin=boxzsize
18366
18367         do j=-1,1
18368          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18369          vectube(1)=vectube(1)+boxxsize*j
18370          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18371          vectube(2)=vectube(2)+boxysize*j
18372          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18373          vectube(3)=vectube(3)+boxzsize*j
18374
18375
18376          xminact=dabs(vectube(1)-tubecenter(1))
18377          yminact=dabs(vectube(2)-tubecenter(2))
18378          zminact=dabs(vectube(3)-tubecenter(3))
18379
18380            if (xmin.gt.xminact) then
18381             xmin=xminact
18382             xtemp=vectube(1)
18383            endif
18384            if (ymin.gt.yminact) then
18385              ymin=yminact
18386              ytemp=vectube(2)
18387             endif
18388            if (zmin.gt.zminact) then
18389              zmin=zminact
18390              ztemp=vectube(3)
18391             endif
18392          enddo
18393       vectube(1)=xtemp
18394       vectube(2)=ytemp
18395       vectube(3)=ztemp
18396
18397       vectube(1)=vectube(1)-tubecenter(1)
18398       vectube(2)=vectube(2)-tubecenter(2)
18399       vectube(3)=vectube(3)-tubecenter(3)
18400
18401 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18402 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18403 !C as the tube is infinity we do not calculate the Z-vector use of Z
18404 !C as chosen axis
18405 !C      vectube(3)=0.0d0
18406 !C now calculte the distance
18407        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18408 !C now normalize vector
18409       vectube(1)=vectube(1)/tub_r
18410       vectube(2)=vectube(2)/tub_r
18411       vectube(3)=vectube(3)/tub_r
18412 !C calculte rdiffrence between r and r0
18413       rdiff=tub_r-tubeR0
18414 !C and its 6 power
18415       rdiff6=rdiff**6.0d0
18416 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18417        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18418 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18419 !C       print *,rdiff,rdiff6,pep_aa_tube
18420 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18421 !C now we calculate gradient
18422        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
18423             6.0d0*pep_bb_tube)/rdiff6/rdiff
18424 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18425 !C     &rdiff,fac
18426          if (acavtubpep.eq.0.0d0) then
18427 !C go to 667
18428          enecavtube(i)=0.0
18429          faccav=0.0
18430          else
18431          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
18432          enecavtube(i)=  &
18433         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
18434         /denominator
18435          enecavtube(i)=0.0
18436          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
18437         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
18438         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
18439         /denominator**2.0d0
18440 !C         faccav=0.0
18441 !C         fac=fac+faccav
18442 !C 667     continue
18443          endif
18444
18445         do j=1,3
18446         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18447         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18448         enddo
18449         enddo
18450
18451        do i=itube_start,itube_end
18452         enecavtube(i)=0.0d0
18453 !C Lets not jump over memory as we use many times iti
18454          iti=itype(i)
18455 !C lets ommit dummy atoms for now
18456          if ((iti.eq.ntyp1) &
18457 !C in UNRES uncomment the line below as GLY has no side-chain...
18458 !C      .or.(iti.eq.10)
18459          ) cycle
18460       xmin=boxxsize
18461       ymin=boxysize
18462       zmin=boxzsize
18463         do j=-1,1
18464          vectube(1)=dmod((c(1,i+nres)),boxxsize)
18465          vectube(1)=vectube(1)+boxxsize*j
18466          vectube(2)=dmod((c(2,i+nres)),boxysize)
18467          vectube(2)=vectube(2)+boxysize*j
18468          vectube(3)=dmod((c(3,i+nres)),boxzsize)
18469          vectube(3)=vectube(3)+boxzsize*j
18470
18471
18472          xminact=dabs(vectube(1)-tubecenter(1))
18473          yminact=dabs(vectube(2)-tubecenter(2))
18474          zminact=dabs(vectube(3)-tubecenter(3))
18475
18476            if (xmin.gt.xminact) then
18477             xmin=xminact
18478             xtemp=vectube(1)
18479            endif
18480            if (ymin.gt.yminact) then
18481              ymin=yminact
18482              ytemp=vectube(2)
18483             endif
18484            if (zmin.gt.zminact) then
18485              zmin=zminact
18486              ztemp=vectube(3)
18487             endif
18488          enddo
18489       vectube(1)=xtemp
18490       vectube(2)=ytemp
18491       vectube(3)=ztemp
18492
18493 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18494 !C     &     tubecenter(2)
18495       vectube(1)=vectube(1)-tubecenter(1)
18496       vectube(2)=vectube(2)-tubecenter(2)
18497       vectube(3)=vectube(3)-tubecenter(3)
18498 !C now calculte the distance
18499        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18500 !C now normalize vector
18501       vectube(1)=vectube(1)/tub_r
18502       vectube(2)=vectube(2)/tub_r
18503       vectube(3)=vectube(3)/tub_r
18504
18505 !C calculte rdiffrence between r and r0
18506       rdiff=tub_r-tubeR0
18507 !C and its 6 power
18508       rdiff6=rdiff**6.0d0
18509        sc_aa_tube=sc_aa_tube_par(iti)
18510        sc_bb_tube=sc_bb_tube_par(iti)
18511        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18512 !C       enetube(i+nres)=0.0d0
18513 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18514 !C now we calculate gradient
18515        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
18516             6.0d0*sc_bb_tube/rdiff6/rdiff
18517 !C       fac=0.0
18518 !C now direction of gg_tube vector
18519 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
18520          if (acavtub(iti).eq.0.0d0) then
18521 !C go to 667
18522          enecavtube(i+nres)=0.0d0
18523          faccav=0.0d0
18524          else
18525          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
18526          enecavtube(i+nres)=   &
18527         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
18528         /denominator
18529 !C         enecavtube(i)=0.0
18530          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
18531         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
18532         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
18533         /denominator**2.0d0
18534 !C         faccav=0.0
18535          fac=fac+faccav
18536 !C 667     continue
18537          endif
18538 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
18539 !C     &   enecavtube(i),faccav
18540 !C         print *,"licz=",
18541 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
18542 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
18543          do j=1,3
18544           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18545           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18546          enddo
18547         enddo
18548
18549
18550
18551         do i=itube_start,itube_end
18552           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
18553          +enecavtube(i+nres)
18554         enddo
18555 !C        print *,"ETUBE", etube
18556         return
18557         end subroutine calcnano
18558
18559 !===============================================
18560 !--------------------------------------------------------------------------------
18561 !C first for shielding is setting of function of side-chains
18562
18563        subroutine set_shield_fac2
18564        real(kind=8) :: div77_81=0.974996043d0, &
18565         div4_81=0.2222222222d0
18566        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
18567          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
18568          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
18569          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
18570 !C the vector between center of side_chain and peptide group
18571        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
18572          pept_group,costhet_grad,cosphi_grad_long, &
18573          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
18574          sh_frac_dist_grad,pep_side
18575         integer i,j,k
18576 !C      write(2,*) "ivec",ivec_start,ivec_end
18577       do i=1,nres
18578         fac_shield(i)=0.0d0
18579         do j=1,3
18580         grad_shield(j,i)=0.0d0
18581         enddo
18582       enddo
18583       do i=ivec_start,ivec_end
18584 !C      do i=1,nres-1
18585 !C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
18586       ishield_list(i)=0
18587       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
18588 !Cif there two consequtive dummy atoms there is no peptide group between them
18589 !C the line below has to be changed for FGPROC>1
18590       VolumeTotal=0.0
18591       do k=1,nres
18592        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
18593        dist_pep_side=0.0
18594        dist_side_calf=0.0
18595        do j=1,3
18596 !C first lets set vector conecting the ithe side-chain with kth side-chain
18597       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
18598 !C      pep_side(j)=2.0d0
18599 !C and vector conecting the side-chain with its proper calfa
18600       side_calf(j)=c(j,k+nres)-c(j,k)
18601 !C      side_calf(j)=2.0d0
18602       pept_group(j)=c(j,i)-c(j,i+1)
18603 !C lets have their lenght
18604       dist_pep_side=pep_side(j)**2+dist_pep_side
18605       dist_side_calf=dist_side_calf+side_calf(j)**2
18606       dist_pept_group=dist_pept_group+pept_group(j)**2
18607       enddo
18608        dist_pep_side=sqrt(dist_pep_side)
18609        dist_pept_group=sqrt(dist_pept_group)
18610        dist_side_calf=sqrt(dist_side_calf)
18611       do j=1,3
18612         pep_side_norm(j)=pep_side(j)/dist_pep_side
18613         side_calf_norm(j)=dist_side_calf
18614       enddo
18615 !C now sscale fraction
18616        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
18617 !C       print *,buff_shield,"buff"
18618 !C now sscale
18619         if (sh_frac_dist.le.0.0) cycle
18620 !C        print *,ishield_list(i),i
18621 !C If we reach here it means that this side chain reaches the shielding sphere
18622 !C Lets add him to the list for gradient
18623         ishield_list(i)=ishield_list(i)+1
18624 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
18625 !C this list is essential otherwise problem would be O3
18626         shield_list(ishield_list(i),i)=k
18627 !C Lets have the sscale value
18628         if (sh_frac_dist.gt.1.0) then
18629          scale_fac_dist=1.0d0
18630          do j=1,3
18631          sh_frac_dist_grad(j)=0.0d0
18632          enddo
18633         else
18634          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
18635                         *(2.0d0*sh_frac_dist-3.0d0)
18636          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
18637                        /dist_pep_side/buff_shield*0.5d0
18638          do j=1,3
18639          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
18640 !C         sh_frac_dist_grad(j)=0.0d0
18641 !C         scale_fac_dist=1.0d0
18642 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
18643 !C     &                    sh_frac_dist_grad(j)
18644          enddo
18645         endif
18646 !C this is what is now we have the distance scaling now volume...
18647       short=short_r_sidechain(itype(k))
18648       long=long_r_sidechain(itype(k))
18649       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
18650       sinthet=short/dist_pep_side*costhet
18651 !C now costhet_grad
18652 !C       costhet=0.6d0
18653 !C       sinthet=0.8
18654        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
18655 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
18656 !C     &             -short/dist_pep_side**2/costhet)
18657 !C       costhet_fac=0.0d0
18658        do j=1,3
18659          costhet_grad(j)=costhet_fac*pep_side(j)
18660        enddo
18661 !C remember for the final gradient multiply costhet_grad(j)
18662 !C for side_chain by factor -2 !
18663 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
18664 !C pep_side0pept_group is vector multiplication
18665       pep_side0pept_group=0.0d0
18666       do j=1,3
18667       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
18668       enddo
18669       cosalfa=(pep_side0pept_group/ &
18670       (dist_pep_side*dist_side_calf))
18671       fac_alfa_sin=1.0d0-cosalfa**2
18672       fac_alfa_sin=dsqrt(fac_alfa_sin)
18673       rkprim=fac_alfa_sin*(long-short)+short
18674 !C      rkprim=short
18675
18676 !C now costhet_grad
18677        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
18678 !C       cosphi=0.6
18679        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
18680        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
18681            dist_pep_side**2)
18682 !C       sinphi=0.8
18683        do j=1,3
18684          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
18685       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
18686       *(long-short)/fac_alfa_sin*cosalfa/ &
18687       ((dist_pep_side*dist_side_calf))* &
18688       ((side_calf(j))-cosalfa* &
18689       ((pep_side(j)/dist_pep_side)*dist_side_calf))
18690 !C       cosphi_grad_long(j)=0.0d0
18691         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
18692       *(long-short)/fac_alfa_sin*cosalfa &
18693       /((dist_pep_side*dist_side_calf))* &
18694       (pep_side(j)- &
18695       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
18696 !C       cosphi_grad_loc(j)=0.0d0
18697        enddo
18698 !C      print *,sinphi,sinthet
18699       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
18700      &                    /VSolvSphere_div
18701 !C     &                    *wshield
18702 !C now the gradient...
18703       do j=1,3
18704       grad_shield(j,i)=grad_shield(j,i) &
18705 !C gradient po skalowaniu
18706                      +(sh_frac_dist_grad(j)*VofOverlap &
18707 !C  gradient po costhet
18708             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
18709         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
18710             sinphi/sinthet*costhet*costhet_grad(j) &
18711            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
18712         )*wshield
18713 !C grad_shield_side is Cbeta sidechain gradient
18714       grad_shield_side(j,ishield_list(i),i)=&
18715              (sh_frac_dist_grad(j)*-2.0d0&
18716              *VofOverlap&
18717             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
18718        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
18719             sinphi/sinthet*costhet*costhet_grad(j)&
18720            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
18721             )*wshield
18722
18723        grad_shield_loc(j,ishield_list(i),i)=   &
18724             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
18725       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
18726             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
18727              ))&
18728              *wshield
18729       enddo
18730       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
18731       enddo
18732       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
18733
18734 !C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
18735       enddo
18736       return
18737       end subroutine set_shield_fac2
18738
18739 !-----------------------------------------------------------------------------
18740 #ifdef WHAM
18741       subroutine read_ssHist
18742 !      implicit none
18743 !      Includes
18744 !      include 'DIMENSIONS'
18745 !      include "DIMENSIONS.FREE"
18746 !      include 'COMMON.FREE'
18747 !     Local variables
18748       integer :: i,j
18749       character(len=80) :: controlcard
18750
18751       do i=1,dyn_nssHist
18752         call card_concat(controlcard,.true.)
18753         read(controlcard,*) &
18754              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
18755       enddo
18756
18757       return
18758       end subroutine read_ssHist
18759 #endif
18760 !-----------------------------------------------------------------------------
18761       integer function indmat(i,j)
18762 !el
18763 ! get the position of the jth ijth fragment of the chain coordinate system
18764 ! in the fromto array.
18765         integer :: i,j
18766
18767         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
18768       return
18769       end function indmat
18770 !-----------------------------------------------------------------------------
18771       real(kind=8) function sigm(x)
18772 !el
18773        real(kind=8) :: x
18774         sigm=0.25d0*x
18775       return
18776       end function sigm
18777 !-----------------------------------------------------------------------------
18778 !-----------------------------------------------------------------------------
18779       subroutine alloc_ener_arrays
18780 !EL Allocation of arrays used by module energy
18781       use MD_data, only: mset
18782 !el local variables
18783       integer :: i,j
18784
18785       if(nres.lt.100) then
18786         maxconts=nres
18787       elseif(nres.lt.200) then
18788         maxconts=0.8*nres       ! Max. number of contacts per residue
18789       else
18790         maxconts=0.6*nres ! (maxconts=maxres/4)
18791       endif
18792       maxcont=12*nres   ! Max. number of SC contacts
18793       maxvar=6*nres     ! Max. number of variables
18794 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
18795       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
18796 !----------------------
18797 ! arrays in subroutine init_int_table
18798 !el#ifdef MPI
18799 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
18800 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
18801 !el#endif
18802       allocate(nint_gr(nres))
18803       allocate(nscp_gr(nres))
18804       allocate(ielstart(nres))
18805       allocate(ielend(nres))
18806 !(maxres)
18807       allocate(istart(nres,maxint_gr))
18808       allocate(iend(nres,maxint_gr))
18809 !(maxres,maxint_gr)
18810       allocate(iscpstart(nres,maxint_gr))
18811       allocate(iscpend(nres,maxint_gr))
18812 !(maxres,maxint_gr)
18813       allocate(ielstart_vdw(nres))
18814       allocate(ielend_vdw(nres))
18815 !(maxres)
18816
18817       allocate(lentyp(0:nfgtasks-1))
18818 !(0:maxprocs-1)
18819 !----------------------
18820 ! commom.contacts
18821 !      common /contacts/
18822       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
18823       allocate(icont(2,maxcont))
18824 !(2,maxcont)
18825 !      common /contacts1/
18826       allocate(num_cont(0:nres+4))
18827 !(maxres)
18828       allocate(jcont(maxconts,nres))
18829 !(maxconts,maxres)
18830       allocate(facont(maxconts,nres))
18831 !(maxconts,maxres)
18832       allocate(gacont(3,maxconts,nres))
18833 !(3,maxconts,maxres)
18834 !      common /contacts_hb/
18835       allocate(gacontp_hb1(3,maxconts,nres))
18836       allocate(gacontp_hb2(3,maxconts,nres))
18837       allocate(gacontp_hb3(3,maxconts,nres))
18838       allocate(gacontm_hb1(3,maxconts,nres))
18839       allocate(gacontm_hb2(3,maxconts,nres))
18840       allocate(gacontm_hb3(3,maxconts,nres))
18841       allocate(gacont_hbr(3,maxconts,nres))
18842       allocate(grij_hb_cont(3,maxconts,nres))
18843 !(3,maxconts,maxres)
18844       allocate(facont_hb(maxconts,nres))
18845
18846       allocate(ees0p(maxconts,nres))
18847       allocate(ees0m(maxconts,nres))
18848       allocate(d_cont(maxconts,nres))
18849       allocate(ees0plist(maxconts,nres))
18850
18851 !(maxconts,maxres)
18852       allocate(num_cont_hb(nres))
18853 !(maxres)
18854       allocate(jcont_hb(maxconts,nres))
18855 !(maxconts,maxres)
18856 !      common /rotat/
18857       allocate(Ug(2,2,nres))
18858       allocate(Ugder(2,2,nres))
18859       allocate(Ug2(2,2,nres))
18860       allocate(Ug2der(2,2,nres))
18861 !(2,2,maxres)
18862       allocate(obrot(2,nres))
18863       allocate(obrot2(2,nres))
18864       allocate(obrot_der(2,nres))
18865       allocate(obrot2_der(2,nres))
18866 !(2,maxres)
18867 !      common /precomp1/
18868       allocate(mu(2,nres))
18869       allocate(muder(2,nres))
18870       allocate(Ub2(2,nres))
18871       Ub2(1,:)=0.0d0
18872       Ub2(2,:)=0.0d0
18873       allocate(Ub2der(2,nres))
18874       allocate(Ctobr(2,nres))
18875       allocate(Ctobrder(2,nres))
18876       allocate(Dtobr2(2,nres))
18877       allocate(Dtobr2der(2,nres))
18878 !(2,maxres)
18879       allocate(EUg(2,2,nres))
18880       allocate(EUgder(2,2,nres))
18881       allocate(CUg(2,2,nres))
18882       allocate(CUgder(2,2,nres))
18883       allocate(DUg(2,2,nres))
18884       allocate(Dugder(2,2,nres))
18885       allocate(DtUg2(2,2,nres))
18886       allocate(DtUg2der(2,2,nres))
18887 !(2,2,maxres)
18888 !      common /precomp2/
18889       allocate(Ug2Db1t(2,nres))
18890       allocate(Ug2Db1tder(2,nres))
18891       allocate(CUgb2(2,nres))
18892       allocate(CUgb2der(2,nres))
18893 !(2,maxres)
18894       allocate(EUgC(2,2,nres))
18895       allocate(EUgCder(2,2,nres))
18896       allocate(EUgD(2,2,nres))
18897       allocate(EUgDder(2,2,nres))
18898       allocate(DtUg2EUg(2,2,nres))
18899       allocate(Ug2DtEUg(2,2,nres))
18900 !(2,2,maxres)
18901       allocate(Ug2DtEUgder(2,2,2,nres))
18902       allocate(DtUg2EUgder(2,2,2,nres))
18903 !(2,2,2,maxres)
18904 !      common /rotat_old/
18905       allocate(costab(nres))
18906       allocate(sintab(nres))
18907       allocate(costab2(nres))
18908       allocate(sintab2(nres))
18909 !(maxres)
18910 !      common /dipmat/
18911       allocate(a_chuj(2,2,maxconts,nres))
18912 !(2,2,maxconts,maxres)(maxconts=maxres/4)
18913       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
18914 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
18915 !      common /contdistrib/
18916       allocate(ncont_sent(nres))
18917       allocate(ncont_recv(nres))
18918
18919       allocate(iat_sent(nres))
18920 !(maxres)
18921       allocate(iint_sent(4,nres,nres))
18922       allocate(iint_sent_local(4,nres,nres))
18923 !(4,maxres,maxres)
18924       allocate(iturn3_sent(4,0:nres+4))
18925       allocate(iturn4_sent(4,0:nres+4))
18926       allocate(iturn3_sent_local(4,nres))
18927       allocate(iturn4_sent_local(4,nres))
18928 !(4,maxres)
18929       allocate(itask_cont_from(0:nfgtasks-1))
18930       allocate(itask_cont_to(0:nfgtasks-1))
18931 !(0:max_fg_procs-1)
18932
18933
18934
18935 !----------------------
18936 ! commom.deriv;
18937 !      common /derivat/
18938       allocate(dcdv(6,maxdim))
18939       allocate(dxdv(6,maxdim))
18940 !(6,maxdim)
18941       allocate(dxds(6,nres))
18942 !(6,maxres)
18943       allocate(gradx(3,-1:nres,0:2))
18944       allocate(gradc(3,-1:nres,0:2))
18945 !(3,maxres,2)
18946       allocate(gvdwx(3,-1:nres))
18947       allocate(gvdwc(3,-1:nres))
18948       allocate(gelc(3,-1:nres))
18949       allocate(gelc_long(3,-1:nres))
18950       allocate(gvdwpp(3,-1:nres))
18951       allocate(gvdwc_scpp(3,-1:nres))
18952       allocate(gradx_scp(3,-1:nres))
18953       allocate(gvdwc_scp(3,-1:nres))
18954       allocate(ghpbx(3,-1:nres))
18955       allocate(ghpbc(3,-1:nres))
18956       allocate(gradcorr(3,-1:nres))
18957       allocate(gradcorr_long(3,-1:nres))
18958       allocate(gradcorr5_long(3,-1:nres))
18959       allocate(gradcorr6_long(3,-1:nres))
18960       allocate(gcorr6_turn_long(3,-1:nres))
18961       allocate(gradxorr(3,-1:nres))
18962       allocate(gradcorr5(3,-1:nres))
18963       allocate(gradcorr6(3,-1:nres))
18964       allocate(gliptran(3,-1:nres))
18965       allocate(gliptranc(3,-1:nres))
18966       allocate(gliptranx(3,-1:nres))
18967       allocate(gshieldx(3,-1:nres))
18968       allocate(gshieldc(3,-1:nres))
18969       allocate(gshieldc_loc(3,-1:nres))
18970       allocate(gshieldx_ec(3,-1:nres))
18971       allocate(gshieldc_ec(3,-1:nres))
18972       allocate(gshieldc_loc_ec(3,-1:nres))
18973       allocate(gshieldx_t3(3,-1:nres))
18974       allocate(gshieldc_t3(3,-1:nres))
18975       allocate(gshieldc_loc_t3(3,-1:nres))
18976       allocate(gshieldx_t4(3,-1:nres))
18977       allocate(gshieldc_t4(3,-1:nres))
18978       allocate(gshieldc_loc_t4(3,-1:nres))
18979       allocate(gshieldx_ll(3,-1:nres))
18980       allocate(gshieldc_ll(3,-1:nres))
18981       allocate(gshieldc_loc_ll(3,-1:nres))
18982       allocate(grad_shield(3,-1:nres))
18983       allocate(gg_tube_sc(3,-1:nres))
18984       allocate(gg_tube(3,-1:nres))
18985 !(3,maxres)
18986       allocate(grad_shield_side(3,50,nres))
18987       allocate(grad_shield_loc(3,50,nres))
18988 ! grad for shielding surroing
18989       allocate(gloc(0:maxvar,0:2))
18990       allocate(gloc_x(0:maxvar,2))
18991 !(maxvar,2)
18992       allocate(gel_loc(3,-1:nres))
18993       allocate(gel_loc_long(3,-1:nres))
18994       allocate(gcorr3_turn(3,-1:nres))
18995       allocate(gcorr4_turn(3,-1:nres))
18996       allocate(gcorr6_turn(3,-1:nres))
18997       allocate(gradb(3,-1:nres))
18998       allocate(gradbx(3,-1:nres))
18999 !(3,maxres)
19000       allocate(gel_loc_loc(maxvar))
19001       allocate(gel_loc_turn3(maxvar))
19002       allocate(gel_loc_turn4(maxvar))
19003       allocate(gel_loc_turn6(maxvar))
19004       allocate(gcorr_loc(maxvar))
19005       allocate(g_corr5_loc(maxvar))
19006       allocate(g_corr6_loc(maxvar))
19007 !(maxvar)
19008       allocate(gsccorc(3,-1:nres))
19009       allocate(gsccorx(3,-1:nres))
19010 !(3,maxres)
19011       allocate(gsccor_loc(-1:nres))
19012 !(maxres)
19013       allocate(dtheta(3,2,-1:nres))
19014 !(3,2,maxres)
19015       allocate(gscloc(3,-1:nres))
19016       allocate(gsclocx(3,-1:nres))
19017 !(3,maxres)
19018       allocate(dphi(3,3,-1:nres))
19019       allocate(dalpha(3,3,-1:nres))
19020       allocate(domega(3,3,-1:nres))
19021 !(3,3,maxres)
19022 !      common /deriv_scloc/
19023       allocate(dXX_C1tab(3,nres))
19024       allocate(dYY_C1tab(3,nres))
19025       allocate(dZZ_C1tab(3,nres))
19026       allocate(dXX_Ctab(3,nres))
19027       allocate(dYY_Ctab(3,nres))
19028       allocate(dZZ_Ctab(3,nres))
19029       allocate(dXX_XYZtab(3,nres))
19030       allocate(dYY_XYZtab(3,nres))
19031       allocate(dZZ_XYZtab(3,nres))
19032 !(3,maxres)
19033 !      common /mpgrad/
19034       allocate(jgrad_start(nres))
19035       allocate(jgrad_end(nres))
19036 !(maxres)
19037 !----------------------
19038
19039 !      common /indices/
19040       allocate(ibond_displ(0:nfgtasks-1))
19041       allocate(ibond_count(0:nfgtasks-1))
19042       allocate(ithet_displ(0:nfgtasks-1))
19043       allocate(ithet_count(0:nfgtasks-1))
19044       allocate(iphi_displ(0:nfgtasks-1))
19045       allocate(iphi_count(0:nfgtasks-1))
19046       allocate(iphi1_displ(0:nfgtasks-1))
19047       allocate(iphi1_count(0:nfgtasks-1))
19048       allocate(ivec_displ(0:nfgtasks-1))
19049       allocate(ivec_count(0:nfgtasks-1))
19050       allocate(iset_displ(0:nfgtasks-1))
19051       allocate(iset_count(0:nfgtasks-1))
19052       allocate(iint_count(0:nfgtasks-1))
19053       allocate(iint_displ(0:nfgtasks-1))
19054 !(0:max_fg_procs-1)
19055 !----------------------
19056 ! common.MD
19057 !      common /mdgrad/
19058       allocate(gcart(3,-1:nres))
19059       allocate(gxcart(3,-1:nres))
19060 !(3,0:MAXRES)
19061       allocate(gradcag(3,-1:nres))
19062       allocate(gradxag(3,-1:nres))
19063 !(3,MAXRES)
19064 !      common /back_constr/
19065 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19066       allocate(dutheta(nres))
19067       allocate(dugamma(nres))
19068 !(maxres)
19069       allocate(duscdiff(3,nres))
19070       allocate(duscdiffx(3,nres))
19071 !(3,maxres)
19072 !el i io:read_fragments
19073 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19074 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19075 !      common /qmeas/
19076 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19077 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19078       allocate(mset(0:nprocs))  !(maxprocs/20)
19079       mset(:)=0
19080 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19081 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19082       allocate(dUdconst(3,0:nres))
19083       allocate(dUdxconst(3,0:nres))
19084       allocate(dqwol(3,0:nres))
19085       allocate(dxqwol(3,0:nres))
19086 !(3,0:MAXRES)
19087 !----------------------
19088 ! common.sbridge
19089 !      common /sbridge/ in io_common: read_bridge
19090 !el    allocate((:),allocatable :: iss  !(maxss)
19091 !      common /links/  in io_common: read_bridge
19092 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19093 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19094 !      common /dyn_ssbond/
19095 ! and side-chain vectors in theta or phi.
19096       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19097 !(maxres,maxres)
19098 !      do i=1,nres
19099 !        do j=i+1,nres
19100       dyn_ssbond_ij(:,:)=1.0d300
19101 !        enddo
19102 !      enddo
19103
19104       if (nss.gt.0) then
19105         allocate(idssb(nss),jdssb(nss))
19106 !(maxdim)
19107       endif
19108       allocate(ishield_list(nres))
19109       allocate(shield_list(50,nres))
19110       allocate(dyn_ss_mask(nres))
19111       allocate(fac_shield(nres))
19112 !(maxres)
19113       dyn_ss_mask(:)=.false.
19114 !----------------------
19115 ! common.sccor
19116 ! Parameters of the SCCOR term
19117 !      common/sccor/
19118 !el in io_conf: parmread
19119 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19120 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19121 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19122 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19123 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19124 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19125 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19126 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19127 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
19128 !----------------
19129       allocate(gloc_sc(3,0:2*nres,0:10))
19130 !(3,0:maxres2,10)maxres2=2*maxres
19131       allocate(dcostau(3,3,3,2*nres))
19132       allocate(dsintau(3,3,3,2*nres))
19133       allocate(dtauangle(3,3,3,2*nres))
19134       allocate(dcosomicron(3,3,3,2*nres))
19135       allocate(domicron(3,3,3,2*nres))
19136 !(3,3,3,maxres2)maxres2=2*maxres
19137 !----------------------
19138 ! common.var
19139 !      common /restr/
19140       allocate(varall(maxvar))
19141 !(maxvar)(maxvar=6*maxres)
19142       allocate(mask_theta(nres))
19143       allocate(mask_phi(nres))
19144       allocate(mask_side(nres))
19145 !(maxres)
19146 !----------------------
19147 ! common.vectors
19148 !      common /vectors/
19149       allocate(uy(3,nres))
19150       allocate(uz(3,nres))
19151 !(3,maxres)
19152       allocate(uygrad(3,3,2,nres))
19153       allocate(uzgrad(3,3,2,nres))
19154 !(3,3,2,maxres)
19155
19156       return
19157       end subroutine alloc_ener_arrays
19158 !-----------------------------------------------------------------------------
19159 !-----------------------------------------------------------------------------
19160       end module energy