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,gradafm !(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                       Eafmforce,ethetacnstr
 227       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 228
 229 #ifdef MPI
 230       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 231 ! shielding effect varibles for MPI
 232 !      real(kind=8)   fac_shieldbuf(maxres),
 233 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 234 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 235 !     & grad_shieldbuf(3,-1:maxres)
 236 !       integer ishield_listbuf(maxres),
 237 !     &shield_listbuf(maxcontsshi,maxres)
 238
 239 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 240 !     & " nfgtasks",nfgtasks
 241       if (nfgtasks.gt.1) then
 242         time00=MPI_Wtime()
 243 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 244         if (fg_rank.eq.0) then
 245           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 246 !          print *,"Processor",myrank," BROADCAST iorder"
 247 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 248 ! FG slaves as WEIGHTS array.
 249           weights_(1)=wsc
 250           weights_(2)=wscp
 251           weights_(3)=welec
 252           weights_(4)=wcorr
 253           weights_(5)=wcorr5
 254           weights_(6)=wcorr6
 255           weights_(7)=wel_loc
 256           weights_(8)=wturn3
 257           weights_(9)=wturn4
 258           weights_(10)=wturn6
 259           weights_(11)=wang
 260           weights_(12)=wscloc
 261           weights_(13)=wtor
 262           weights_(14)=wtor_d
 263           weights_(15)=wstrain
 264           weights_(16)=wvdwpp
 265           weights_(17)=wbond
 266           weights_(18)=scal14
 267           weights_(21)=wsccor
 268 ! FG Master broadcasts the WEIGHTS_ array
 269           call MPI_Bcast(weights_(1),n_ene,&
 270              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 271         else
 272 ! FG slaves receive the WEIGHTS array
 273           call MPI_Bcast(weights(1),n_ene,&
 274               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 275           wsc=weights(1)
 276           wscp=weights(2)
 277           welec=weights(3)
 278           wcorr=weights(4)
 279           wcorr5=weights(5)
 280           wcorr6=weights(6)
 281           wel_loc=weights(7)
 282           wturn3=weights(8)
 283           wturn4=weights(9)
 284           wturn6=weights(10)
 285           wang=weights(11)
 286           wscloc=weights(12)
 287           wtor=weights(13)
 288           wtor_d=weights(14)
 289           wstrain=weights(15)
 290           wvdwpp=weights(16)
 291           wbond=weights(17)
 292           scal14=weights(18)
 293           wsccor=weights(21)
 294         endif
 295         time_Bcast=time_Bcast+MPI_Wtime()-time00
 296         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 297 !        call chainbuild_cart
 298       endif
 299 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 300 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 301 #else
 302 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 303 !        call int_from_cart1(.false.)
 304 !      endif
 305 #endif
 306 #ifdef TIMING
 307       time00=MPI_Wtime()
 308 #endif
 309 !
 310 ! Compute the side-chain and electrostatic interaction energy
 311 !        print *, "Before EVDW"
 312 !      goto (101,102,103,104,105,106) ipot
 313       select case(ipot)
 314 ! Lennard-Jones potential.
 315 !  101 call elj(evdw)
 316        case (1)
 317          call elj(evdw)
 318 !d    print '(a)','Exit ELJcall el'
 319 !      goto 107
 320 ! Lennard-Jones-Kihara potential (shifted).
 321 !  102 call eljk(evdw)
 322        case (2)
 323          call eljk(evdw)
 324 !      goto 107
 325 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 326 !  103 call ebp(evdw)
 327        case (3)
 328          call ebp(evdw)
 329 !      goto 107
 330 ! Gay-Berne potential (shifted LJ, angular dependence).
 331 !  104 call egb(evdw)
 332        case (4)
 333          call egb(evdw)
 334 !      goto 107
 335 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 336 !  105 call egbv(evdw)
 337        case (5)
 338          call egbv(evdw)
 339 !      goto 107
 340 ! Soft-sphere potential
 341 !  106 call e_softsphere(evdw)
 342        case (6)
 343          call e_softsphere(evdw)
 344 !
 345 ! Calculate electrostatic (H-bonding) energy of the main chain.
 346 !
 347 !  107 continue
 348        case default
 349          write(iout,*)"Wrong ipot"
 350 !         return
 351 !   50 continue
 352       end select
 353 !      continue
 354 !        print *,"after EGB"
 355 ! shielding effect
 356        if (shield_mode.eq.2) then
 357                  call set_shield_fac2
 358        endif
 359 !mc
 360 !mc Sep-06: egb takes care of dynamic ss bonds too
 361 !mc
 362 !      if (dyn_ss) call dyn_set_nss
 363 !      print *,"Processor",myrank," computed USCSC"
 364 #ifdef TIMING
 365       time01=MPI_Wtime()
 366 #endif
 367       call vec_and_deriv
 368 #ifdef TIMING
 369       time_vec=time_vec+MPI_Wtime()-time01
 370 #endif
 371 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 372       if (ipot.lt.6) then
 373 #ifdef SPLITELE
 374 !         print *,"after ipot if", ipot
 375          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 376              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 377              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 378              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 379 #else
 380          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 381              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 382              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 383              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 384 #endif
 385 !            print *,"just befor eelec call"
 386             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 387 !         write (iout,*) "ELEC calc"
 388          else
 389             ees=0.0d0
 390             evdw1=0.0d0
 391             eel_loc=0.0d0
 392             eello_turn3=0.0d0
 393             eello_turn4=0.0d0
 394          endif
 395       else
 396 !        write (iout,*) "Soft-spheer ELEC potential"
 397         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 398          eello_turn4)
 399       endif
 400 !      print *,"Processor",myrank," computed UELEC"
 401 !
 402 ! Calculate excluded-volume interaction energy between peptide groups
 403 ! and side chains.
 404 !
 405 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 406
 407       if (ipot.lt.6) then
 408        if(wscp.gt.0d0) then
 409         call escp(evdw2,evdw2_14)
 410        else
 411         evdw2=0
 412         evdw2_14=0
 413        endif
 414       else
 415 !        write (iout,*) "Soft-sphere SCP potential"
 416         call escp_soft_sphere(evdw2,evdw2_14)
 417       endif
 418 !       write(iout,*) "in etotal before ebond",ipot
 419
 420 !
 421 ! Calculate the bond-stretching energy
 422 !
 423       call ebond(estr)
 424 !       write(iout,*) "in etotal afer ebond",ipot
 425
 426 !
 427 ! Calculate the disulfide-bridge and other energy and the contributions
 428 ! from other distance constraints.
 429 !      print *,'Calling EHPB'
 430       call edis(ehpb)
 431 !elwrite(iout,*) "in etotal afer edis",ipot
 432 !      print *,'EHPB exitted succesfully.'
 433 !
 434 ! Calculate the virtual-bond-angle energy.
 435 !
 436       if (wang.gt.0d0) then
 437         call ebend(ebe,ethetacnstr)
 438       else
 439         ebe=0
 440       endif
 441 !      print *,"Processor",myrank," computed UB"
 442 !
 443 ! Calculate the SC local energy.
 444 !
 445       call esc(escloc)
 446 !elwrite(iout,*) "in etotal afer esc",ipot
 447 !      print *,"Processor",myrank," computed USC"
 448 !
 449 ! Calculate the virtual-bond torsional energy.
 450 !
 451 !d    print *,'nterm=',nterm
 452       if (wtor.gt.0) then
 453        call etor(etors,edihcnstr)
 454       else
 455        etors=0
 456        edihcnstr=0
 457       endif
 458 !      print *,"Processor",myrank," computed Utor"
 459 !
 460 ! 6/23/01 Calculate double-torsional energy
 461 !
 462 !elwrite(iout,*) "in etotal",ipot
 463       if (wtor_d.gt.0) then
 464        call etor_d(etors_d)
 465       else
 466        etors_d=0
 467       endif
 468 !      print *,"Processor",myrank," computed Utord"
 469 !
 470 ! 21/5/07 Calculate local sicdechain correlation energy
 471 !
 472       if (wsccor.gt.0.0d0) then
 473         call eback_sc_corr(esccor)
 474       else
 475         esccor=0.0d0
 476       endif
 477 !      print *,"Processor",myrank," computed Usccorr"
 478 !
 479 ! 12/1/95 Multi-body terms
 480 !
 481       n_corr=0
 482       n_corr1=0
 483       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 484           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 485          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 486 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 487 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 488       else
 489          ecorr=0.0d0
 490          ecorr5=0.0d0
 491          ecorr6=0.0d0
 492          eturn6=0.0d0
 493       endif
 494 !elwrite(iout,*) "in etotal",ipot
 495       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 496          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 497 !d         write (iout,*) "multibody_hb ecorr",ecorr
 498       endif
 499 !elwrite(iout,*) "afeter  multibody hb"
 500
 501 !      print *,"Processor",myrank," computed Ucorr"
 502 !
 503 ! If performing constraint dynamics, call the constraint energy
 504 !  after the equilibration time
 505       if(usampl.and.totT.gt.eq_time) then
 506 !elwrite(iout,*) "afeter  multibody hb"
 507          call EconstrQ
 508 !elwrite(iout,*) "afeter  multibody hb"
 509          call Econstr_back
 510 !elwrite(iout,*) "afeter  multibody hb"
 511       else
 512          Uconst=0.0d0
 513          Uconst_back=0.0d0
 514       endif
 515       call flush(iout)
 516 !         write(iout,*) "after Econstr"
 517
 518       if (wliptran.gt.0) then
 519 !        print *,"PRZED WYWOLANIEM"
 520         call Eliptransfer(eliptran)
 521       else
 522        eliptran=0.0d0
 523       endif
 524       if (fg_rank.eq.0) then
 525       if (AFMlog.gt.0) then
 526         call AFMforce(Eafmforce)
 527       else if (selfguide.gt.0) then
 528         call AFMvel(Eafmforce)
 529       endif
 530       endif
 531       if (tubemode.eq.1) then
 532        call calctube(etube)
 533       else if (tubemode.eq.2) then
 534        call calctube2(etube)
 535       elseif (tubemode.eq.3) then
 536        call calcnano(etube)
 537       else
 538        etube=0.0d0
 539       endif
 540
 541 #ifdef TIMING
 542       time_enecalc=time_enecalc+MPI_Wtime()-time00
 543 #endif
 544 !      print *,"Processor",myrank," computed Uconstr"
 545 #ifdef TIMING
 546       time00=MPI_Wtime()
 547 #endif
 548 !
 549 ! Sum the energies
 550 !
 551       energia(1)=evdw
 552 #ifdef SCP14
 553       energia(2)=evdw2-evdw2_14
 554       energia(18)=evdw2_14
 555 #else
 556       energia(2)=evdw2
 557       energia(18)=0.0d0
 558 #endif
 559 #ifdef SPLITELE
 560       energia(3)=ees
 561       energia(16)=evdw1
 562 #else
 563       energia(3)=ees+evdw1
 564       energia(16)=0.0d0
 565 #endif
 566       energia(4)=ecorr
 567       energia(5)=ecorr5
 568       energia(6)=ecorr6
 569       energia(7)=eel_loc
 570       energia(8)=eello_turn3
 571       energia(9)=eello_turn4
 572       energia(10)=eturn6
 573       energia(11)=ebe
 574       energia(12)=escloc
 575       energia(13)=etors
 576       energia(14)=etors_d
 577       energia(15)=ehpb
 578       energia(19)=edihcnstr
 579       energia(17)=estr
 580       energia(20)=Uconst+Uconst_back
 581       energia(21)=esccor
 582       energia(22)=eliptran
 583       energia(23)=Eafmforce
 584       energia(24)=ethetacnstr
 585       energia(25)=etube
 586 !    Here are the energies showed per procesor if the are more processors
 587 !    per molecule then we sum it up in sum_energy subroutine
 588 !      print *," Processor",myrank," calls SUM_ENERGY"
 589       call sum_energy(energia,.true.)
 590       if (dyn_ss) call dyn_set_nss
 591 !      print *," Processor",myrank," left SUM_ENERGY"
 592 #ifdef TIMING
 593       time_sumene=time_sumene+MPI_Wtime()-time00
 594 #endif
 595 !el        call enerprint(energia)
 596 !elwrite(iout,*)"finish etotal"
 597       return
 598       end subroutine etotal
 599 !-----------------------------------------------------------------------------
 600       subroutine sum_energy(energia,reduce)
 601 !      implicit real*8 (a-h,o-z)
 602 !      include 'DIMENSIONS'
 603 #ifndef ISNAN
 604       external proc_proc
 605 #ifdef WINPGI
 606 !MS$ATTRIBUTES C ::  proc_proc
 607 #endif
 608 #endif
 609 #ifdef MPI
 610       include "mpif.h"
 611 #endif
 612 !      include 'COMMON.SETUP'
 613 !      include 'COMMON.IOUNITS'
 614       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 615 !      include 'COMMON.FFIELD'
 616 !      include 'COMMON.DERIV'
 617 !      include 'COMMON.INTERACT'
 618 !      include 'COMMON.SBRIDGE'
 619 !      include 'COMMON.CHAIN'
 620 !      include 'COMMON.VAR'
 621 !      include 'COMMON.CONTROL'
 622 !      include 'COMMON.TIME1'
 623       logical :: reduce
 624       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 625       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 626       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 627         eliptran,etube, Eafmforce,ethetacnstr
 628       integer :: i
 629 #ifdef MPI
 630       integer :: ierr
 631       real(kind=8) :: time00
 632       if (nfgtasks.gt.1 .and. reduce) then
 633
 634 #ifdef DEBUG
 635         write (iout,*) "energies before REDUCE"
 636         call enerprint(energia)
 637         call flush(iout)
 638 #endif
 639         do i=0,n_ene
 640           enebuff(i)=energia(i)
 641         enddo
 642         time00=MPI_Wtime()
 643         call MPI_Barrier(FG_COMM,IERR)
 644         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 645         time00=MPI_Wtime()
 646         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 647           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 648 #ifdef DEBUG
 649         write (iout,*) "energies after REDUCE"
 650         call enerprint(energia)
 651         call flush(iout)
 652 #endif
 653         time_Reduce=time_Reduce+MPI_Wtime()-time00
 654       endif
 655       if (fg_rank.eq.0) then
 656 #endif
 657       evdw=energia(1)
 658 #ifdef SCP14
 659       evdw2=energia(2)+energia(18)
 660       evdw2_14=energia(18)
 661 #else
 662       evdw2=energia(2)
 663 #endif
 664 #ifdef SPLITELE
 665       ees=energia(3)
 666       evdw1=energia(16)
 667 #else
 668       ees=energia(3)
 669       evdw1=0.0d0
 670 #endif
 671       ecorr=energia(4)
 672       ecorr5=energia(5)
 673       ecorr6=energia(6)
 674       eel_loc=energia(7)
 675       eello_turn3=energia(8)
 676       eello_turn4=energia(9)
 677       eturn6=energia(10)
 678       ebe=energia(11)
 679       escloc=energia(12)
 680       etors=energia(13)
 681       etors_d=energia(14)
 682       ehpb=energia(15)
 683       edihcnstr=energia(19)
 684       estr=energia(17)
 685       Uconst=energia(20)
 686       esccor=energia(21)
 687       eliptran=energia(22)
 688       Eafmforce=energia(23)
 689       ethetacnstr=energia(24)
 690       etube=energia(25)
 691 #ifdef SPLITELE
 692       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 693        +wang*ebe+wtor*etors+wscloc*escloc &
 694        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 695        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 696        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 697        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 698        +Eafmforce+ethetacnstr
 699 #else
 700       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 701        +wang*ebe+wtor*etors+wscloc*escloc &
 702        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 703        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 704        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 705        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 706        +Eafmforce+ethetacnstr
 707
 708 #endif
 709       energia(0)=etot
 710 ! detecting NaNQ
 711 #ifdef ISNAN
 712 #ifdef AIX
 713       if (isnan(etot).ne.0) energia(0)=1.0d+99
 714 #else
 715       if (isnan(etot)) energia(0)=1.0d+99
 716 #endif
 717 #else
 718       i=0
 719 #ifdef WINPGI
 720       idumm=proc_proc(etot,i)
 721 #else
 722       call proc_proc(etot,i)
 723 #endif
 724       if(i.eq.1)energia(0)=1.0d+99
 725 #endif
 726 #ifdef MPI
 727       endif
 728 #endif
 729 !      call enerprint(energia)
 730       call flush(iout)
 731       return
 732       end subroutine sum_energy
 733 !-----------------------------------------------------------------------------
 734       subroutine rescale_weights(t_bath)
 735 !      implicit real*8 (a-h,o-z)
 736 #ifdef MPI
 737       include 'mpif.h'
 738 #endif
 739 !      include 'DIMENSIONS'
 740 !      include 'COMMON.IOUNITS'
 741 !      include 'COMMON.FFIELD'
 742 !      include 'COMMON.SBRIDGE'
 743       real(kind=8) :: kfac=2.4d0
 744       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 745 !el local variables
 746       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 747       real(kind=8) :: T0=3.0d2
 748       integer :: ierror
 749 !      facT=temp0/t_bath
 750 !      facT=2*temp0/(t_bath+temp0)
 751       if (rescale_mode.eq.0) then
 752         facT(1)=1.0d0
 753         facT(2)=1.0d0
 754         facT(3)=1.0d0
 755         facT(4)=1.0d0
 756         facT(5)=1.0d0
 757         facT(6)=1.0d0
 758       else if (rescale_mode.eq.1) then
 759         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 760         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 761         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 762         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 763         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 764 #ifdef WHAM_RUN
 765 !#if defined(WHAM_RUN) || defined(CLUSTER)
 766 #if defined(FUNCTH)
 767 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 768         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 769 #elif defined(FUNCT)
 770         facT(6)=t_bath/T0
 771 #else
 772         facT(6)=1.0d0
 773 #endif
 774 #endif
 775       else if (rescale_mode.eq.2) then
 776         x=t_bath/temp0
 777         x2=x*x
 778         x3=x2*x
 779         x4=x3*x
 780         x5=x4*x
 781         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 782         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 783         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 784         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 785         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 786 #ifdef WHAM_RUN
 787 !#if defined(WHAM_RUN) || defined(CLUSTER)
 788 #if defined(FUNCTH)
 789         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 790 #elif defined(FUNCT)
 791         facT(6)=t_bath/T0
 792 #else
 793         facT(6)=1.0d0
 794 #endif
 795 #endif
 796       else
 797         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 798         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 799 #ifdef MPI
 800        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 801 #endif
 802        stop 555
 803       endif
 804       welec=weights(3)*fact(1)
 805       wcorr=weights(4)*fact(3)
 806       wcorr5=weights(5)*fact(4)
 807       wcorr6=weights(6)*fact(5)
 808       wel_loc=weights(7)*fact(2)
 809       wturn3=weights(8)*fact(2)
 810       wturn4=weights(9)*fact(3)
 811       wturn6=weights(10)*fact(5)
 812       wtor=weights(13)*fact(1)
 813       wtor_d=weights(14)*fact(2)
 814       wsccor=weights(21)*fact(1)
 815
 816       return
 817       end subroutine rescale_weights
 818 !-----------------------------------------------------------------------------
 819       subroutine enerprint(energia)
 820 !      implicit real*8 (a-h,o-z)
 821 !      include 'DIMENSIONS'
 822 !      include 'COMMON.IOUNITS'
 823 !      include 'COMMON.FFIELD'
 824 !      include 'COMMON.SBRIDGE'
 825 !      include 'COMMON.MD'
 826       real(kind=8) :: energia(0:n_ene)
 827 !el local variables
 828       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 829       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 830       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 831        etube,ethetacnstr,Eafmforce
 832
 833       etot=energia(0)
 834       evdw=energia(1)
 835       evdw2=energia(2)
 836 #ifdef SCP14
 837       evdw2=energia(2)+energia(18)
 838 #else
 839       evdw2=energia(2)
 840 #endif
 841       ees=energia(3)
 842 #ifdef SPLITELE
 843       evdw1=energia(16)
 844 #endif
 845       ecorr=energia(4)
 846       ecorr5=energia(5)
 847       ecorr6=energia(6)
 848       eel_loc=energia(7)
 849       eello_turn3=energia(8)
 850       eello_turn4=energia(9)
 851       eello_turn6=energia(10)
 852       ebe=energia(11)
 853       escloc=energia(12)
 854       etors=energia(13)
 855       etors_d=energia(14)
 856       ehpb=energia(15)
 857       edihcnstr=energia(19)
 858       estr=energia(17)
 859       Uconst=energia(20)
 860       esccor=energia(21)
 861       eliptran=energia(22)
 862       Eafmforce=energia(23)
 863       ethetacnstr=energia(24)
 864       etube=energia(25)
 865 #ifdef SPLITELE
 866       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 867         estr,wbond,ebe,wang,&
 868         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 869         ecorr,wcorr,&
 870         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 871         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 872         edihcnstr,ethetacnstr,ebr*nss,&
 873         Uconst,eliptran,wliptran,Eafmforce,etube,wtube,etot
 874    10 format (/'Virtual-chain energies:'// &
 875        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 876        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 877        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 878        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 879        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 880        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 881        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 882        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 883        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 884        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 885        ' (SS bridges & dist. cnstr.)'/ &
 886        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 887        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 888        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 889        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 890        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 891        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 892        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 893        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 894        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 895        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
 896        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 897        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 898        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
 899        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
 900        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 901        'ETOT=  ',1pE16.6,' (total)')
 902 #else
 903       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 904         estr,wbond,ebe,wang,&
 905         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 906         ecorr,wcorr,&
 907         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 908         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 909         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
 910         etube,wtube,etot
 911    10 format (/'Virtual-chain energies:'// &
 912        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 913        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 914        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 915        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 916        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 917        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 918        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 919        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 920        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 921        ' (SS bridges & dist. cnstr.)'/ &
 922        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 923        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 924        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 925        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 926        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 927        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 928        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 929        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 930        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 931        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
 932        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 933        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 934        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
 935        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
 936        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 937        'ETOT=  ',1pE16.6,' (total)')
 938 #endif
 939       return
 940       end subroutine enerprint
 941 !-----------------------------------------------------------------------------
 942       subroutine elj(evdw)
 943 !
 944 ! This subroutine calculates the interaction energy of nonbonded side chains
 945 ! assuming the LJ potential of interaction.
 946 !
 947 !      implicit real*8 (a-h,o-z)
 948 !      include 'DIMENSIONS'
 949       real(kind=8),parameter :: accur=1.0d-10
 950 !      include 'COMMON.GEO'
 951 !      include 'COMMON.VAR'
 952 !      include 'COMMON.LOCAL'
 953 !      include 'COMMON.CHAIN'
 954 !      include 'COMMON.DERIV'
 955 !      include 'COMMON.INTERACT'
 956 !      include 'COMMON.TORSION'
 957 !      include 'COMMON.SBRIDGE'
 958 !      include 'COMMON.NAMES'
 959 !      include 'COMMON.IOUNITS'
 960 !      include 'COMMON.CONTACTS'
 961       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
 962       integer :: num_conti
 963 !el local variables
 964       integer :: i,itypi,iint,j,itypi1,itypj,k
 965       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 966       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 967       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 968
 969 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 970       evdw=0.0D0
 971 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 972 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 973 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 974 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 975
 976       do i=iatsc_s,iatsc_e
 977         itypi=iabs(itype(i,1))
 978         if (itypi.eq.ntyp1) cycle
 979         itypi1=iabs(itype(i+1,1))
 980         xi=c(1,nres+i)
 981         yi=c(2,nres+i)
 982         zi=c(3,nres+i)
 983 ! Change 12/1/95
 984         num_conti=0
 985 !
 986 ! Calculate SC interaction energy.
 987 !
 988         do iint=1,nint_gr(i)
 989 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 990 !d   &                  'iend=',iend(i,iint)
 991           do j=istart(i,iint),iend(i,iint)
 992             itypj=iabs(itype(j,1))
 993             if (itypj.eq.ntyp1) cycle
 994             xj=c(1,nres+j)-xi
 995             yj=c(2,nres+j)-yi
 996             zj=c(3,nres+j)-zi
 997 ! Change 12/1/95 to calculate four-body interactions
 998             rij=xj*xj+yj*yj+zj*zj
 999             rrij=1.0D0/rij
1000 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1001             eps0ij=eps(itypi,itypj)
1002             fac=rrij**expon2
1003             e1=fac*fac*aa_aq(itypi,itypj)
1004             e2=fac*bb_aq(itypi,itypj)
1005             evdwij=e1+e2
1006 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1007 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1008 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1009 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1010 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1011 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1012             evdw=evdw+evdwij
1013 !
1014 ! Calculate the components of the gradient in DC and X
1015 !
1016             fac=-rrij*(e1+evdwij)
1017             gg(1)=xj*fac
1018             gg(2)=yj*fac
1019             gg(3)=zj*fac
1020             do k=1,3
1021               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1022               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1023               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1024               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1025             enddo
1026 !grad            do k=i,j-1
1027 !grad              do l=1,3
1028 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1029 !grad              enddo
1030 !grad            enddo
1031 !
1032 ! 12/1/95, revised on 5/20/97
1033 !
1034 ! Calculate the contact function. The ith column of the array JCONT will
1035 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1036 ! greater than I). The arrays FACONT and GACONT will contain the values of
1037 ! the contact function and its derivative.
1038 !
1039 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1040 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1041 ! Uncomment next line, if the correlation interactions are contact function only
1042             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1043               rij=dsqrt(rij)
1044               sigij=sigma(itypi,itypj)
1045               r0ij=rs0(itypi,itypj)
1046 !
1047 ! Check whether the SC's are not too far to make a contact.
1048 !
1049               rcut=1.5d0*r0ij
1050               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1051 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1052 !
1053               if (fcont.gt.0.0D0) then
1054 ! If the SC-SC distance if close to sigma, apply spline.
1055 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1056 !Adam &             fcont1,fprimcont1)
1057 !Adam           fcont1=1.0d0-fcont1
1058 !Adam           if (fcont1.gt.0.0d0) then
1059 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1060 !Adam             fcont=fcont*fcont1
1061 !Adam           endif
1062 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1063 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1064 !ga             do k=1,3
1065 !ga               gg(k)=gg(k)*eps0ij
1066 !ga             enddo
1067 !ga             eps0ij=-evdwij*eps0ij
1068 ! Uncomment for AL's type of SC correlation interactions.
1069 !adam           eps0ij=-evdwij
1070                 num_conti=num_conti+1
1071                 jcont(num_conti,i)=j
1072                 facont(num_conti,i)=fcont*eps0ij
1073                 fprimcont=eps0ij*fprimcont/rij
1074                 fcont=expon*fcont
1075 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1076 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1077 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1078 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1079                 gacont(1,num_conti,i)=-fprimcont*xj
1080                 gacont(2,num_conti,i)=-fprimcont*yj
1081                 gacont(3,num_conti,i)=-fprimcont*zj
1082 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1083 !d              write (iout,'(2i3,3f10.5)')
1084 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1085               endif
1086             endif
1087           enddo      ! j
1088         enddo        ! iint
1089 ! Change 12/1/95
1090         num_cont(i)=num_conti
1091       enddo          ! i
1092       do i=1,nct
1093         do j=1,3
1094           gvdwc(j,i)=expon*gvdwc(j,i)
1095           gvdwx(j,i)=expon*gvdwx(j,i)
1096         enddo
1097       enddo
1098 !******************************************************************************
1099 !
1100 !                              N O T E !!!
1101 !
1102 ! To save time, the factor of EXPON has been extracted from ALL components
1103 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1104 ! use!
1105 !
1106 !******************************************************************************
1107       return
1108       end subroutine elj
1109 !-----------------------------------------------------------------------------
1110       subroutine eljk(evdw)
1111 !
1112 ! This subroutine calculates the interaction energy of nonbonded side chains
1113 ! assuming the LJK potential of interaction.
1114 !
1115 !      implicit real*8 (a-h,o-z)
1116 !      include 'DIMENSIONS'
1117 !      include 'COMMON.GEO'
1118 !      include 'COMMON.VAR'
1119 !      include 'COMMON.LOCAL'
1120 !      include 'COMMON.CHAIN'
1121 !      include 'COMMON.DERIV'
1122 !      include 'COMMON.INTERACT'
1123 !      include 'COMMON.IOUNITS'
1124 !      include 'COMMON.NAMES'
1125       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1126       logical :: scheck
1127 !el local variables
1128       integer :: i,iint,j,itypi,itypi1,k,itypj
1129       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1130       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1131
1132 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1133       evdw=0.0D0
1134       do i=iatsc_s,iatsc_e
1135         itypi=iabs(itype(i,1))
1136         if (itypi.eq.ntyp1) cycle
1137         itypi1=iabs(itype(i+1,1))
1138         xi=c(1,nres+i)
1139         yi=c(2,nres+i)
1140         zi=c(3,nres+i)
1141 !
1142 ! Calculate SC interaction energy.
1143 !
1144         do iint=1,nint_gr(i)
1145           do j=istart(i,iint),iend(i,iint)
1146             itypj=iabs(itype(j,1))
1147             if (itypj.eq.ntyp1) cycle
1148             xj=c(1,nres+j)-xi
1149             yj=c(2,nres+j)-yi
1150             zj=c(3,nres+j)-zi
1151             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1152             fac_augm=rrij**expon
1153             e_augm=augm(itypi,itypj)*fac_augm
1154             r_inv_ij=dsqrt(rrij)
1155             rij=1.0D0/r_inv_ij
1156             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1157             fac=r_shift_inv**expon
1158             e1=fac*fac*aa_aq(itypi,itypj)
1159             e2=fac*bb_aq(itypi,itypj)
1160             evdwij=e_augm+e1+e2
1161 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1162 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1163 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1164 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1165 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1166 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1167 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1168             evdw=evdw+evdwij
1169 !
1170 ! Calculate the components of the gradient in DC and X
1171 !
1172             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1173             gg(1)=xj*fac
1174             gg(2)=yj*fac
1175             gg(3)=zj*fac
1176             do k=1,3
1177               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1178               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1179               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1180               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1181             enddo
1182 !grad            do k=i,j-1
1183 !grad              do l=1,3
1184 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1185 !grad              enddo
1186 !grad            enddo
1187           enddo      ! j
1188         enddo        ! iint
1189       enddo          ! i
1190       do i=1,nct
1191         do j=1,3
1192           gvdwc(j,i)=expon*gvdwc(j,i)
1193           gvdwx(j,i)=expon*gvdwx(j,i)
1194         enddo
1195       enddo
1196       return
1197       end subroutine eljk
1198 !-----------------------------------------------------------------------------
1199       subroutine ebp(evdw)
1200 !
1201 ! This subroutine calculates the interaction energy of nonbonded side chains
1202 ! assuming the Berne-Pechukas potential of interaction.
1203 !
1204       use comm_srutu
1205       use calc_data
1206 !      implicit real*8 (a-h,o-z)
1207 !      include 'DIMENSIONS'
1208 !      include 'COMMON.GEO'
1209 !      include 'COMMON.VAR'
1210 !      include 'COMMON.LOCAL'
1211 !      include 'COMMON.CHAIN'
1212 !      include 'COMMON.DERIV'
1213 !      include 'COMMON.NAMES'
1214 !      include 'COMMON.INTERACT'
1215 !      include 'COMMON.IOUNITS'
1216 !      include 'COMMON.CALC'
1217       use comm_srutu
1218 !el      integer :: icall
1219 !el      common /srutu/ icall
1220 !     double precision rrsave(maxdim)
1221       logical :: lprn
1222 !el local variables
1223       integer :: iint,itypi,itypi1,itypj
1224       real(kind=8) :: rrij,xi,yi,zi
1225       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1226
1227 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1228       evdw=0.0D0
1229 !     if (icall.eq.0) then
1230 !       lprn=.true.
1231 !     else
1232         lprn=.false.
1233 !     endif
1234 !el      ind=0
1235       do i=iatsc_s,iatsc_e
1236         itypi=iabs(itype(i,1))
1237         if (itypi.eq.ntyp1) cycle
1238         itypi1=iabs(itype(i+1,1))
1239         xi=c(1,nres+i)
1240         yi=c(2,nres+i)
1241         zi=c(3,nres+i)
1242         dxi=dc_norm(1,nres+i)
1243         dyi=dc_norm(2,nres+i)
1244         dzi=dc_norm(3,nres+i)
1245 !        dsci_inv=dsc_inv(itypi)
1246         dsci_inv=vbld_inv(i+nres)
1247 !
1248 ! Calculate SC interaction energy.
1249 !
1250         do iint=1,nint_gr(i)
1251           do j=istart(i,iint),iend(i,iint)
1252 !el            ind=ind+1
1253             itypj=iabs(itype(j,1))
1254             if (itypj.eq.ntyp1) cycle
1255 !            dscj_inv=dsc_inv(itypj)
1256             dscj_inv=vbld_inv(j+nres)
1257             chi1=chi(itypi,itypj)
1258             chi2=chi(itypj,itypi)
1259             chi12=chi1*chi2
1260             chip1=chip(itypi)
1261             chip2=chip(itypj)
1262             chip12=chip1*chip2
1263             alf1=alp(itypi)
1264             alf2=alp(itypj)
1265             alf12=0.5D0*(alf1+alf2)
1266 ! For diagnostics only!!!
1267 !           chi1=0.0D0
1268 !           chi2=0.0D0
1269 !           chi12=0.0D0
1270 !           chip1=0.0D0
1271 !           chip2=0.0D0
1272 !           chip12=0.0D0
1273 !           alf1=0.0D0
1274 !           alf2=0.0D0
1275 !           alf12=0.0D0
1276             xj=c(1,nres+j)-xi
1277             yj=c(2,nres+j)-yi
1278             zj=c(3,nres+j)-zi
1279             dxj=dc_norm(1,nres+j)
1280             dyj=dc_norm(2,nres+j)
1281             dzj=dc_norm(3,nres+j)
1282             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1283 !d          if (icall.eq.0) then
1284 !d            rrsave(ind)=rrij
1285 !d          else
1286 !d            rrij=rrsave(ind)
1287 !d          endif
1288             rij=dsqrt(rrij)
1289 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1290             call sc_angular
1291 ! Calculate whole angle-dependent part of epsilon and contributions
1292 ! to its derivatives
1293             fac=(rrij*sigsq)**expon2
1294             e1=fac*fac*aa_aq(itypi,itypj)
1295             e2=fac*bb_aq(itypi,itypj)
1296             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1297             eps2der=evdwij*eps3rt
1298             eps3der=evdwij*eps2rt
1299             evdwij=evdwij*eps2rt*eps3rt
1300             evdw=evdw+evdwij
1301             if (lprn) then
1302             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1303             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1304 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1305 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1306 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1307 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1308 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1309 !d     &        evdwij
1310             endif
1311 ! Calculate gradient components.
1312             e1=e1*eps1*eps2rt**2*eps3rt**2
1313             fac=-expon*(e1+evdwij)
1314             sigder=fac/sigsq
1315             fac=rrij*fac
1316 ! Calculate radial part of the gradient
1317             gg(1)=xj*fac
1318             gg(2)=yj*fac
1319             gg(3)=zj*fac
1320 ! Calculate the angular part of the gradient and sum add the contributions
1321 ! to the appropriate components of the Cartesian gradient.
1322             call sc_grad
1323           enddo      ! j
1324         enddo        ! iint
1325       enddo          ! i
1326 !     stop
1327       return
1328       end subroutine ebp
1329 !-----------------------------------------------------------------------------
1330       subroutine egb(evdw)
1331 !
1332 ! This subroutine calculates the interaction energy of nonbonded side chains
1333 ! assuming the Gay-Berne potential of interaction.
1334 !
1335       use calc_data
1336 !      implicit real*8 (a-h,o-z)
1337 !      include 'DIMENSIONS'
1338 !      include 'COMMON.GEO'
1339 !      include 'COMMON.VAR'
1340 !      include 'COMMON.LOCAL'
1341 !      include 'COMMON.CHAIN'
1342 !      include 'COMMON.DERIV'
1343 !      include 'COMMON.NAMES'
1344 !      include 'COMMON.INTERACT'
1345 !      include 'COMMON.IOUNITS'
1346 !      include 'COMMON.CALC'
1347 !      include 'COMMON.CONTROL'
1348 !      include 'COMMON.SBRIDGE'
1349       logical :: lprn
1350 !el local variables
1351       integer :: iint,itypi,itypi1,itypj,subchap
1352       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1353       real(kind=8) :: evdw,sig0ij
1354       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1355                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1356                     sslipi,sslipj,faclip
1357       integer :: ii
1358       real(kind=8) :: fracinbuf
1359
1360 !cccc      energy_dec=.false.
1361 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1362       evdw=0.0D0
1363       lprn=.false.
1364 !     if (icall.eq.0) lprn=.false.
1365 !el      ind=0
1366       do i=iatsc_s,iatsc_e
1367 !C        print *,"I am in EVDW",i
1368         itypi=iabs(itype(i,1))
1369 !        if (i.ne.47) cycle
1370         if (itypi.eq.ntyp1) cycle
1371         itypi1=iabs(itype(i+1,1))
1372         xi=c(1,nres+i)
1373         yi=c(2,nres+i)
1374         zi=c(3,nres+i)
1375           xi=dmod(xi,boxxsize)
1376           if (xi.lt.0) xi=xi+boxxsize
1377           yi=dmod(yi,boxysize)
1378           if (yi.lt.0) yi=yi+boxysize
1379           zi=dmod(zi,boxzsize)
1380           if (zi.lt.0) zi=zi+boxzsize
1381
1382        if ((zi.gt.bordlipbot)  &
1383         .and.(zi.lt.bordliptop)) then
1384 !C the energy transfer exist
1385         if (zi.lt.buflipbot) then
1386 !C what fraction I am in
1387          fracinbuf=1.0d0-  &
1388               ((zi-bordlipbot)/lipbufthick)
1389 !C lipbufthick is thickenes of lipid buffore
1390          sslipi=sscalelip(fracinbuf)
1391          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1392         elseif (zi.gt.bufliptop) then
1393          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1394          sslipi=sscalelip(fracinbuf)
1395          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1396         else
1397          sslipi=1.0d0
1398          ssgradlipi=0.0
1399         endif
1400        else
1401          sslipi=0.0d0
1402          ssgradlipi=0.0
1403        endif
1404 !       print *, sslipi,ssgradlipi
1405         dxi=dc_norm(1,nres+i)
1406         dyi=dc_norm(2,nres+i)
1407         dzi=dc_norm(3,nres+i)
1408 !        dsci_inv=dsc_inv(itypi)
1409         dsci_inv=vbld_inv(i+nres)
1410 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1411 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1412 !
1413 ! Calculate SC interaction energy.
1414 !
1415         do iint=1,nint_gr(i)
1416           do j=istart(i,iint),iend(i,iint)
1417             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1418               call dyn_ssbond_ene(i,j,evdwij)
1419               evdw=evdw+evdwij
1420               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1421                               'evdw',i,j,evdwij,' ss'
1422 !              if (energy_dec) write (iout,*) &
1423 !                              'evdw',i,j,evdwij,' ss'
1424              do k=j+1,iend(i,iint)
1425 !C search over all next residues
1426               if (dyn_ss_mask(k)) then
1427 !C check if they are cysteins
1428 !C              write(iout,*) 'k=',k
1429
1430 !c              write(iout,*) "PRZED TRI", evdwij
1431 !               evdwij_przed_tri=evdwij
1432               call triple_ssbond_ene(i,j,k,evdwij)
1433 !c               if(evdwij_przed_tri.ne.evdwij) then
1434 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1435 !c               endif
1436
1437 !c              write(iout,*) "PO TRI", evdwij
1438 !C call the energy function that removes the artifical triple disulfide
1439 !C bond the soubroutine is located in ssMD.F
1440               evdw=evdw+evdwij
1441               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1442                             'evdw',i,j,evdwij,'tss'
1443               endif!dyn_ss_mask(k)
1444              enddo! k
1445             ELSE
1446 !el            ind=ind+1
1447             itypj=iabs(itype(j,1))
1448             if (itypj.eq.ntyp1) cycle
1449 !             if (j.ne.78) cycle
1450 !            dscj_inv=dsc_inv(itypj)
1451             dscj_inv=vbld_inv(j+nres)
1452 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1453 !              1.0d0/vbld(j+nres) !d
1454 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1455             sig0ij=sigma(itypi,itypj)
1456             chi1=chi(itypi,itypj)
1457             chi2=chi(itypj,itypi)
1458             chi12=chi1*chi2
1459             chip1=chip(itypi)
1460             chip2=chip(itypj)
1461             chip12=chip1*chip2
1462             alf1=alp(itypi)
1463             alf2=alp(itypj)
1464             alf12=0.5D0*(alf1+alf2)
1465 ! For diagnostics only!!!
1466 !           chi1=0.0D0
1467 !           chi2=0.0D0
1468 !           chi12=0.0D0
1469 !           chip1=0.0D0
1470 !           chip2=0.0D0
1471 !           chip12=0.0D0
1472 !           alf1=0.0D0
1473 !           alf2=0.0D0
1474 !           alf12=0.0D0
1475            xj=c(1,nres+j)
1476            yj=c(2,nres+j)
1477            zj=c(3,nres+j)
1478           xj=dmod(xj,boxxsize)
1479           if (xj.lt.0) xj=xj+boxxsize
1480           yj=dmod(yj,boxysize)
1481           if (yj.lt.0) yj=yj+boxysize
1482           zj=dmod(zj,boxzsize)
1483           if (zj.lt.0) zj=zj+boxzsize
1484 !          print *,"tu",xi,yi,zi,xj,yj,zj
1485 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1486 ! this fragment set correct epsilon for lipid phase
1487        if ((zj.gt.bordlipbot)  &
1488        .and.(zj.lt.bordliptop)) then
1489 !C the energy transfer exist
1490         if (zj.lt.buflipbot) then
1491 !C what fraction I am in
1492          fracinbuf=1.0d0-     &
1493              ((zj-bordlipbot)/lipbufthick)
1494 !C lipbufthick is thickenes of lipid buffore
1495          sslipj=sscalelip(fracinbuf)
1496          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1497         elseif (zj.gt.bufliptop) then
1498          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1499          sslipj=sscalelip(fracinbuf)
1500          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1501         else
1502          sslipj=1.0d0
1503          ssgradlipj=0.0
1504         endif
1505        else
1506          sslipj=0.0d0
1507          ssgradlipj=0.0
1508        endif
1509       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1510        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1511       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1512        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1513 !------------------------------------------------
1514       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1515       xj_safe=xj
1516       yj_safe=yj
1517       zj_safe=zj
1518       subchap=0
1519       do xshift=-1,1
1520       do yshift=-1,1
1521       do zshift=-1,1
1522           xj=xj_safe+xshift*boxxsize
1523           yj=yj_safe+yshift*boxysize
1524           zj=zj_safe+zshift*boxzsize
1525           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1526           if(dist_temp.lt.dist_init) then
1527             dist_init=dist_temp
1528             xj_temp=xj
1529             yj_temp=yj
1530             zj_temp=zj
1531             subchap=1
1532           endif
1533        enddo
1534        enddo
1535        enddo
1536        if (subchap.eq.1) then
1537           xj=xj_temp-xi
1538           yj=yj_temp-yi
1539           zj=zj_temp-zi
1540        else
1541           xj=xj_safe-xi
1542           yj=yj_safe-yi
1543           zj=zj_safe-zi
1544        endif
1545             dxj=dc_norm(1,nres+j)
1546             dyj=dc_norm(2,nres+j)
1547             dzj=dc_norm(3,nres+j)
1548 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1549 !            write (iout,*) "j",j," dc_norm",& !d
1550 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1551 !          write(iout,*)"rrij ",rrij
1552 !          write(iout,*)"xj yj zj ", xj, yj, zj
1553 !          write(iout,*)"xi yi zi ", xi, yi, zi
1554 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1555             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1556             rij=dsqrt(rrij)
1557             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1558             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1559 !            print *,sss_ele_cut,sss_ele_grad,&
1560 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1561             if (sss_ele_cut.le.0.0) cycle
1562 ! Calculate angle-dependent terms of energy and contributions to their
1563 ! derivatives.
1564             call sc_angular
1565             sigsq=1.0D0/sigsq
1566             sig=sig0ij*dsqrt(sigsq)
1567             rij_shift=1.0D0/rij-sig+sig0ij
1568 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1569 !            "sig0ij",sig0ij
1570 ! for diagnostics; uncomment
1571 !            rij_shift=1.2*sig0ij
1572 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1573             if (rij_shift.le.0.0D0) then
1574               evdw=1.0D20
1575 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1576 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1577 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1578               return
1579             endif
1580             sigder=-sig*sigsq
1581 !---------------------------------------------------------------
1582             rij_shift=1.0D0/rij_shift
1583             fac=rij_shift**expon
1584             faclip=fac
1585             e1=fac*fac*aa!(itypi,itypj)
1586             e2=fac*bb!(itypi,itypj)
1587             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1588             eps2der=evdwij*eps3rt
1589             eps3der=evdwij*eps2rt
1590 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1591 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1592 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1593             evdwij=evdwij*eps2rt*eps3rt
1594             evdw=evdw+evdwij*sss_ele_cut
1595             if (lprn) then
1596             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1597             epsi=bb**2/aa!(itypi,itypj)
1598             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1599               restyp(itypi,1),i,restyp(itypj,1),j, &
1600               epsi,sigm,chi1,chi2,chip1,chip2, &
1601               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1602               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1603               evdwij
1604             endif
1605
1606             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1607                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1608 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1609 !            if (energy_dec) write (iout,*) &
1610 !                             'evdw',i,j,evdwij
1611
1612 ! Calculate gradient components.
1613             e1=e1*eps1*eps2rt**2*eps3rt**2
1614             fac=-expon*(e1+evdwij)*rij_shift
1615             sigder=fac*sigder
1616             fac=rij*fac
1617 !            print *,'before fac',fac,rij,evdwij
1618             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1619             /sigma(itypi,itypj)*rij
1620 !            print *,'grad part scale',fac,   &
1621 !             evdwij*sss_ele_grad/sss_ele_cut &
1622 !            /sigma(itypi,itypj)*rij
1623 !            fac=0.0d0
1624 ! Calculate the radial part of the gradient
1625             gg(1)=xj*fac
1626             gg(2)=yj*fac
1627             gg(3)=zj*fac
1628 !C Calculate the radial part of the gradient
1629             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1630        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1631         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1632        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1633             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1634             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1635
1636 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1637 ! Calculate angular part of the gradient.
1638             call sc_grad
1639             ENDIF    ! dyn_ss
1640           enddo      ! j
1641         enddo        ! iint
1642       enddo          ! i
1643 !      write (iout,*) "Number of loop steps in EGB:",ind
1644 !ccc      energy_dec=.false.
1645       return
1646       end subroutine egb
1647 !-----------------------------------------------------------------------------
1648       subroutine egbv(evdw)
1649 !
1650 ! This subroutine calculates the interaction energy of nonbonded side chains
1651 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1652 !
1653       use comm_srutu
1654       use calc_data
1655 !      implicit real*8 (a-h,o-z)
1656 !      include 'DIMENSIONS'
1657 !      include 'COMMON.GEO'
1658 !      include 'COMMON.VAR'
1659 !      include 'COMMON.LOCAL'
1660 !      include 'COMMON.CHAIN'
1661 !      include 'COMMON.DERIV'
1662 !      include 'COMMON.NAMES'
1663 !      include 'COMMON.INTERACT'
1664 !      include 'COMMON.IOUNITS'
1665 !      include 'COMMON.CALC'
1666       use comm_srutu
1667 !el      integer :: icall
1668 !el      common /srutu/ icall
1669       logical :: lprn
1670 !el local variables
1671       integer :: iint,itypi,itypi1,itypj
1672       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1673       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1674
1675 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1676       evdw=0.0D0
1677       lprn=.false.
1678 !     if (icall.eq.0) lprn=.true.
1679 !el      ind=0
1680       do i=iatsc_s,iatsc_e
1681         itypi=iabs(itype(i,1))
1682         if (itypi.eq.ntyp1) cycle
1683         itypi1=iabs(itype(i+1,1))
1684         xi=c(1,nres+i)
1685         yi=c(2,nres+i)
1686         zi=c(3,nres+i)
1687         dxi=dc_norm(1,nres+i)
1688         dyi=dc_norm(2,nres+i)
1689         dzi=dc_norm(3,nres+i)
1690 !        dsci_inv=dsc_inv(itypi)
1691         dsci_inv=vbld_inv(i+nres)
1692 !
1693 ! Calculate SC interaction energy.
1694 !
1695         do iint=1,nint_gr(i)
1696           do j=istart(i,iint),iend(i,iint)
1697 !el            ind=ind+1
1698             itypj=iabs(itype(j,1))
1699             if (itypj.eq.ntyp1) cycle
1700 !            dscj_inv=dsc_inv(itypj)
1701             dscj_inv=vbld_inv(j+nres)
1702             sig0ij=sigma(itypi,itypj)
1703             r0ij=r0(itypi,itypj)
1704             chi1=chi(itypi,itypj)
1705             chi2=chi(itypj,itypi)
1706             chi12=chi1*chi2
1707             chip1=chip(itypi)
1708             chip2=chip(itypj)
1709             chip12=chip1*chip2
1710             alf1=alp(itypi)
1711             alf2=alp(itypj)
1712             alf12=0.5D0*(alf1+alf2)
1713 ! For diagnostics only!!!
1714 !           chi1=0.0D0
1715 !           chi2=0.0D0
1716 !           chi12=0.0D0
1717 !           chip1=0.0D0
1718 !           chip2=0.0D0
1719 !           chip12=0.0D0
1720 !           alf1=0.0D0
1721 !           alf2=0.0D0
1722 !           alf12=0.0D0
1723             xj=c(1,nres+j)-xi
1724             yj=c(2,nres+j)-yi
1725             zj=c(3,nres+j)-zi
1726             dxj=dc_norm(1,nres+j)
1727             dyj=dc_norm(2,nres+j)
1728             dzj=dc_norm(3,nres+j)
1729             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1730             rij=dsqrt(rrij)
1731 ! Calculate angle-dependent terms of energy and contributions to their
1732 ! derivatives.
1733             call sc_angular
1734             sigsq=1.0D0/sigsq
1735             sig=sig0ij*dsqrt(sigsq)
1736             rij_shift=1.0D0/rij-sig+r0ij
1737 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1738             if (rij_shift.le.0.0D0) then
1739               evdw=1.0D20
1740               return
1741             endif
1742             sigder=-sig*sigsq
1743 !---------------------------------------------------------------
1744             rij_shift=1.0D0/rij_shift
1745             fac=rij_shift**expon
1746             e1=fac*fac*aa_aq(itypi,itypj)
1747             e2=fac*bb_aq(itypi,itypj)
1748             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1749             eps2der=evdwij*eps3rt
1750             eps3der=evdwij*eps2rt
1751             fac_augm=rrij**expon
1752             e_augm=augm(itypi,itypj)*fac_augm
1753             evdwij=evdwij*eps2rt*eps3rt
1754             evdw=evdw+evdwij+e_augm
1755             if (lprn) then
1756             sigm=dabs(aa_aq(itypi,itypj)/&
1757             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1758             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1759             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1760               restyp(itypi,1),i,restyp(itypj,1),j,&
1761               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1762               chi1,chi2,chip1,chip2,&
1763               eps1,eps2rt**2,eps3rt**2,&
1764               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1765               evdwij+e_augm
1766             endif
1767 ! Calculate gradient components.
1768             e1=e1*eps1*eps2rt**2*eps3rt**2
1769             fac=-expon*(e1+evdwij)*rij_shift
1770             sigder=fac*sigder
1771             fac=rij*fac-2*expon*rrij*e_augm
1772 ! Calculate the radial part of the gradient
1773             gg(1)=xj*fac
1774             gg(2)=yj*fac
1775             gg(3)=zj*fac
1776 ! Calculate angular part of the gradient.
1777             call sc_grad
1778           enddo      ! j
1779         enddo        ! iint
1780       enddo          ! i
1781       end subroutine egbv
1782 !-----------------------------------------------------------------------------
1783 !el      subroutine sc_angular in module geometry
1784 !-----------------------------------------------------------------------------
1785       subroutine e_softsphere(evdw)
1786 !
1787 ! This subroutine calculates the interaction energy of nonbonded side chains
1788 ! assuming the LJ potential of interaction.
1789 !
1790 !      implicit real*8 (a-h,o-z)
1791 !      include 'DIMENSIONS'
1792       real(kind=8),parameter :: accur=1.0d-10
1793 !      include 'COMMON.GEO'
1794 !      include 'COMMON.VAR'
1795 !      include 'COMMON.LOCAL'
1796 !      include 'COMMON.CHAIN'
1797 !      include 'COMMON.DERIV'
1798 !      include 'COMMON.INTERACT'
1799 !      include 'COMMON.TORSION'
1800 !      include 'COMMON.SBRIDGE'
1801 !      include 'COMMON.NAMES'
1802 !      include 'COMMON.IOUNITS'
1803 !      include 'COMMON.CONTACTS'
1804       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1805 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1806 !el local variables
1807       integer :: i,iint,j,itypi,itypi1,itypj,k
1808       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1809       real(kind=8) :: fac
1810
1811       evdw=0.0D0
1812       do i=iatsc_s,iatsc_e
1813         itypi=iabs(itype(i,1))
1814         if (itypi.eq.ntyp1) cycle
1815         itypi1=iabs(itype(i+1,1))
1816         xi=c(1,nres+i)
1817         yi=c(2,nres+i)
1818         zi=c(3,nres+i)
1819 !
1820 ! Calculate SC interaction energy.
1821 !
1822         do iint=1,nint_gr(i)
1823 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1824 !d   &                  'iend=',iend(i,iint)
1825           do j=istart(i,iint),iend(i,iint)
1826             itypj=iabs(itype(j,1))
1827             if (itypj.eq.ntyp1) cycle
1828             xj=c(1,nres+j)-xi
1829             yj=c(2,nres+j)-yi
1830             zj=c(3,nres+j)-zi
1831             rij=xj*xj+yj*yj+zj*zj
1832 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1833             r0ij=r0(itypi,itypj)
1834             r0ijsq=r0ij*r0ij
1835 !            print *,i,j,r0ij,dsqrt(rij)
1836             if (rij.lt.r0ijsq) then
1837               evdwij=0.25d0*(rij-r0ijsq)**2
1838               fac=rij-r0ijsq
1839             else
1840               evdwij=0.0d0
1841               fac=0.0d0
1842             endif
1843             evdw=evdw+evdwij
1844 !
1845 ! Calculate the components of the gradient in DC and X
1846 !
1847             gg(1)=xj*fac
1848             gg(2)=yj*fac
1849             gg(3)=zj*fac
1850             do k=1,3
1851               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1852               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1853               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1854               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1855             enddo
1856 !grad            do k=i,j-1
1857 !grad              do l=1,3
1858 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1859 !grad              enddo
1860 !grad            enddo
1861           enddo ! j
1862         enddo ! iint
1863       enddo ! i
1864       return
1865       end subroutine e_softsphere
1866 !-----------------------------------------------------------------------------
1867       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1868 !
1869 ! Soft-sphere potential of p-p interaction
1870 !
1871 !      implicit real*8 (a-h,o-z)
1872 !      include 'DIMENSIONS'
1873 !      include 'COMMON.CONTROL'
1874 !      include 'COMMON.IOUNITS'
1875 !      include 'COMMON.GEO'
1876 !      include 'COMMON.VAR'
1877 !      include 'COMMON.LOCAL'
1878 !      include 'COMMON.CHAIN'
1879 !      include 'COMMON.DERIV'
1880 !      include 'COMMON.INTERACT'
1881 !      include 'COMMON.CONTACTS'
1882 !      include 'COMMON.TORSION'
1883 !      include 'COMMON.VECTORS'
1884 !      include 'COMMON.FFIELD'
1885       real(kind=8),dimension(3) :: ggg
1886 !d      write(iout,*) 'In EELEC_soft_sphere'
1887 !el local variables
1888       integer :: i,j,k,num_conti,iteli,itelj
1889       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1890       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1891       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1892
1893       ees=0.0D0
1894       evdw1=0.0D0
1895       eel_loc=0.0d0
1896       eello_turn3=0.0d0
1897       eello_turn4=0.0d0
1898 !el      ind=0
1899       do i=iatel_s,iatel_e
1900         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
1901         dxi=dc(1,i)
1902         dyi=dc(2,i)
1903         dzi=dc(3,i)
1904         xmedi=c(1,i)+0.5d0*dxi
1905         ymedi=c(2,i)+0.5d0*dyi
1906         zmedi=c(3,i)+0.5d0*dzi
1907         num_conti=0
1908 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1909         do j=ielstart(i),ielend(i)
1910           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
1911 !el          ind=ind+1
1912           iteli=itel(i)
1913           itelj=itel(j)
1914           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1915           r0ij=rpp(iteli,itelj)
1916           r0ijsq=r0ij*r0ij
1917           dxj=dc(1,j)
1918           dyj=dc(2,j)
1919           dzj=dc(3,j)
1920           xj=c(1,j)+0.5D0*dxj-xmedi
1921           yj=c(2,j)+0.5D0*dyj-ymedi
1922           zj=c(3,j)+0.5D0*dzj-zmedi
1923           rij=xj*xj+yj*yj+zj*zj
1924           if (rij.lt.r0ijsq) then
1925             evdw1ij=0.25d0*(rij-r0ijsq)**2
1926             fac=rij-r0ijsq
1927           else
1928             evdw1ij=0.0d0
1929             fac=0.0d0
1930           endif
1931           evdw1=evdw1+evdw1ij
1932 !
1933 ! Calculate contributions to the Cartesian gradient.
1934 !
1935           ggg(1)=fac*xj
1936           ggg(2)=fac*yj
1937           ggg(3)=fac*zj
1938           do k=1,3
1939             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1940             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1941           enddo
1942 !
1943 ! Loop over residues i+1 thru j-1.
1944 !
1945 !grad          do k=i+1,j-1
1946 !grad            do l=1,3
1947 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1948 !grad            enddo
1949 !grad          enddo
1950         enddo ! j
1951       enddo   ! i
1952 !grad      do i=nnt,nct-1
1953 !grad        do k=1,3
1954 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1955 !grad        enddo
1956 !grad        do j=i+1,nct-1
1957 !grad          do k=1,3
1958 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1959 !grad          enddo
1960 !grad        enddo
1961 !grad      enddo
1962       return
1963       end subroutine eelec_soft_sphere
1964 !-----------------------------------------------------------------------------
1965       subroutine vec_and_deriv
1966 !      implicit real*8 (a-h,o-z)
1967 !      include 'DIMENSIONS'
1968 #ifdef MPI
1969       include 'mpif.h'
1970 #endif
1971 !      include 'COMMON.IOUNITS'
1972 !      include 'COMMON.GEO'
1973 !      include 'COMMON.VAR'
1974 !      include 'COMMON.LOCAL'
1975 !      include 'COMMON.CHAIN'
1976 !      include 'COMMON.VECTORS'
1977 !      include 'COMMON.SETUP'
1978 !      include 'COMMON.TIME1'
1979       real(kind=8),dimension(3,3,2) :: uyder,uzder
1980       real(kind=8),dimension(2) :: vbld_inv_temp
1981 ! Compute the local reference systems. For reference system (i), the
1982 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1983 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1984 !el local variables
1985       integer :: i,j,k,l
1986       real(kind=8) :: facy,fac,costh
1987
1988 #ifdef PARVEC
1989       do i=ivec_start,ivec_end
1990 #else
1991       do i=1,nres-1
1992 #endif
1993           if (i.eq.nres-1) then
1994 ! Case of the last full residue
1995 ! Compute the Z-axis
1996             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1997             costh=dcos(pi-theta(nres))
1998             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1999             do k=1,3
2000               uz(k,i)=fac*uz(k,i)
2001             enddo
2002 ! Compute the derivatives of uz
2003             uzder(1,1,1)= 0.0d0
2004             uzder(2,1,1)=-dc_norm(3,i-1)
2005             uzder(3,1,1)= dc_norm(2,i-1)
2006             uzder(1,2,1)= dc_norm(3,i-1)
2007             uzder(2,2,1)= 0.0d0
2008             uzder(3,2,1)=-dc_norm(1,i-1)
2009             uzder(1,3,1)=-dc_norm(2,i-1)
2010             uzder(2,3,1)= dc_norm(1,i-1)
2011             uzder(3,3,1)= 0.0d0
2012             uzder(1,1,2)= 0.0d0
2013             uzder(2,1,2)= dc_norm(3,i)
2014             uzder(3,1,2)=-dc_norm(2,i)
2015             uzder(1,2,2)=-dc_norm(3,i)
2016             uzder(2,2,2)= 0.0d0
2017             uzder(3,2,2)= dc_norm(1,i)
2018             uzder(1,3,2)= dc_norm(2,i)
2019             uzder(2,3,2)=-dc_norm(1,i)
2020             uzder(3,3,2)= 0.0d0
2021 ! Compute the Y-axis
2022             facy=fac
2023             do k=1,3
2024               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2025             enddo
2026 ! Compute the derivatives of uy
2027             do j=1,3
2028               do k=1,3
2029                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2030                               -dc_norm(k,i)*dc_norm(j,i-1)
2031                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2032               enddo
2033               uyder(j,j,1)=uyder(j,j,1)-costh
2034               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2035             enddo
2036             do j=1,2
2037               do k=1,3
2038                 do l=1,3
2039                   uygrad(l,k,j,i)=uyder(l,k,j)
2040                   uzgrad(l,k,j,i)=uzder(l,k,j)
2041                 enddo
2042               enddo
2043             enddo
2044             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2045             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2046             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2047             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2048           else
2049 ! Other residues
2050 ! Compute the Z-axis
2051             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2052             costh=dcos(pi-theta(i+2))
2053             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2054             do k=1,3
2055               uz(k,i)=fac*uz(k,i)
2056             enddo
2057 ! Compute the derivatives of uz
2058             uzder(1,1,1)= 0.0d0
2059             uzder(2,1,1)=-dc_norm(3,i+1)
2060             uzder(3,1,1)= dc_norm(2,i+1)
2061             uzder(1,2,1)= dc_norm(3,i+1)
2062             uzder(2,2,1)= 0.0d0
2063             uzder(3,2,1)=-dc_norm(1,i+1)
2064             uzder(1,3,1)=-dc_norm(2,i+1)
2065             uzder(2,3,1)= dc_norm(1,i+1)
2066             uzder(3,3,1)= 0.0d0
2067             uzder(1,1,2)= 0.0d0
2068             uzder(2,1,2)= dc_norm(3,i)
2069             uzder(3,1,2)=-dc_norm(2,i)
2070             uzder(1,2,2)=-dc_norm(3,i)
2071             uzder(2,2,2)= 0.0d0
2072             uzder(3,2,2)= dc_norm(1,i)
2073             uzder(1,3,2)= dc_norm(2,i)
2074             uzder(2,3,2)=-dc_norm(1,i)
2075             uzder(3,3,2)= 0.0d0
2076 ! Compute the Y-axis
2077             facy=fac
2078             do k=1,3
2079               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2080             enddo
2081 ! Compute the derivatives of uy
2082             do j=1,3
2083               do k=1,3
2084                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2085                               -dc_norm(k,i)*dc_norm(j,i+1)
2086                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2087               enddo
2088               uyder(j,j,1)=uyder(j,j,1)-costh
2089               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2090             enddo
2091             do j=1,2
2092               do k=1,3
2093                 do l=1,3
2094                   uygrad(l,k,j,i)=uyder(l,k,j)
2095                   uzgrad(l,k,j,i)=uzder(l,k,j)
2096                 enddo
2097               enddo
2098             enddo
2099             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2100             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2101             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2102             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2103           endif
2104       enddo
2105       do i=1,nres-1
2106         vbld_inv_temp(1)=vbld_inv(i+1)
2107         if (i.lt.nres-1) then
2108           vbld_inv_temp(2)=vbld_inv(i+2)
2109           else
2110           vbld_inv_temp(2)=vbld_inv(i)
2111           endif
2112         do j=1,2
2113           do k=1,3
2114             do l=1,3
2115               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2116               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2117             enddo
2118           enddo
2119         enddo
2120       enddo
2121 #if defined(PARVEC) && defined(MPI)
2122       if (nfgtasks1.gt.1) then
2123         time00=MPI_Wtime()
2124 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2125 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2126 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2127         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2128          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2129          FG_COMM1,IERR)
2130         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2131          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2132          FG_COMM1,IERR)
2133         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2134          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2135          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2136         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2137          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2138          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2139         time_gather=time_gather+MPI_Wtime()-time00
2140       endif
2141 !      if (fg_rank.eq.0) then
2142 !        write (iout,*) "Arrays UY and UZ"
2143 !        do i=1,nres-1
2144 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2145 !     &     (uz(k,i),k=1,3)
2146 !        enddo
2147 !      endif
2148 #endif
2149       return
2150       end subroutine vec_and_deriv
2151 !-----------------------------------------------------------------------------
2152       subroutine check_vecgrad
2153 !      implicit real*8 (a-h,o-z)
2154 !      include 'DIMENSIONS'
2155 !      include 'COMMON.IOUNITS'
2156 !      include 'COMMON.GEO'
2157 !      include 'COMMON.VAR'
2158 !      include 'COMMON.LOCAL'
2159 !      include 'COMMON.CHAIN'
2160 !      include 'COMMON.VECTORS'
2161       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2162       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2163       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2164       real(kind=8),dimension(3) :: erij
2165       real(kind=8) :: delta=1.0d-7
2166 !el local variables
2167       integer :: i,j,k,l
2168
2169       call vec_and_deriv
2170 !d      do i=1,nres
2171 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2172 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2173 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2174 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2175 !d     &     (dc_norm(if90,i),if90=1,3)
2176 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2177 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2178 !d          write(iout,'(a)')
2179 !d      enddo
2180       do i=1,nres
2181         do j=1,2
2182           do k=1,3
2183             do l=1,3
2184               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2185               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2186             enddo
2187           enddo
2188         enddo
2189       enddo
2190       call vec_and_deriv
2191       do i=1,nres
2192         do j=1,3
2193           uyt(j,i)=uy(j,i)
2194           uzt(j,i)=uz(j,i)
2195         enddo
2196       enddo
2197       do i=1,nres
2198 !d        write (iout,*) 'i=',i
2199         do k=1,3
2200           erij(k)=dc_norm(k,i)
2201         enddo
2202         do j=1,3
2203           do k=1,3
2204             dc_norm(k,i)=erij(k)
2205           enddo
2206           dc_norm(j,i)=dc_norm(j,i)+delta
2207 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2208 !          do k=1,3
2209 !            dc_norm(k,i)=dc_norm(k,i)/fac
2210 !          enddo
2211 !          write (iout,*) (dc_norm(k,i),k=1,3)
2212 !          write (iout,*) (erij(k),k=1,3)
2213           call vec_and_deriv
2214           do k=1,3
2215             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2216             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2217             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2218             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2219           enddo
2220 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2221 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2222 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2223         enddo
2224         do k=1,3
2225           dc_norm(k,i)=erij(k)
2226         enddo
2227 !d        do k=1,3
2228 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2229 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2230 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2231 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2232 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2233 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2234 !d          write (iout,'(a)')
2235 !d        enddo
2236       enddo
2237       return
2238       end subroutine check_vecgrad
2239 !-----------------------------------------------------------------------------
2240       subroutine set_matrices
2241 !      implicit real*8 (a-h,o-z)
2242 !      include 'DIMENSIONS'
2243 #ifdef MPI
2244       include "mpif.h"
2245 !      include "COMMON.SETUP"
2246       integer :: IERR
2247       integer :: status(MPI_STATUS_SIZE)
2248 #endif
2249 !      include 'COMMON.IOUNITS'
2250 !      include 'COMMON.GEO'
2251 !      include 'COMMON.VAR'
2252 !      include 'COMMON.LOCAL'
2253 !      include 'COMMON.CHAIN'
2254 !      include 'COMMON.DERIV'
2255 !      include 'COMMON.INTERACT'
2256 !      include 'COMMON.CONTACTS'
2257 !      include 'COMMON.TORSION'
2258 !      include 'COMMON.VECTORS'
2259 !      include 'COMMON.FFIELD'
2260       real(kind=8) :: auxvec(2),auxmat(2,2)
2261       integer :: i,iti1,iti,k,l
2262       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2263 !       print *,"in set matrices"
2264 !
2265 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2266 ! to calculate the el-loc multibody terms of various order.
2267 !
2268 !AL el      mu=0.0d0
2269 #ifdef PARMAT
2270       do i=ivec_start+2,ivec_end+2
2271 #else
2272       do i=3,nres+1
2273 #endif
2274 !      print *,i,"i"
2275         if (i .lt. nres+1) then
2276           sin1=dsin(phi(i))
2277           cos1=dcos(phi(i))
2278           sintab(i-2)=sin1
2279           costab(i-2)=cos1
2280           obrot(1,i-2)=cos1
2281           obrot(2,i-2)=sin1
2282           sin2=dsin(2*phi(i))
2283           cos2=dcos(2*phi(i))
2284           sintab2(i-2)=sin2
2285           costab2(i-2)=cos2
2286           obrot2(1,i-2)=cos2
2287           obrot2(2,i-2)=sin2
2288           Ug(1,1,i-2)=-cos1
2289           Ug(1,2,i-2)=-sin1
2290           Ug(2,1,i-2)=-sin1
2291           Ug(2,2,i-2)= cos1
2292           Ug2(1,1,i-2)=-cos2
2293           Ug2(1,2,i-2)=-sin2
2294           Ug2(2,1,i-2)=-sin2
2295           Ug2(2,2,i-2)= cos2
2296         else
2297           costab(i-2)=1.0d0
2298           sintab(i-2)=0.0d0
2299           obrot(1,i-2)=1.0d0
2300           obrot(2,i-2)=0.0d0
2301           obrot2(1,i-2)=0.0d0
2302           obrot2(2,i-2)=0.0d0
2303           Ug(1,1,i-2)=1.0d0
2304           Ug(1,2,i-2)=0.0d0
2305           Ug(2,1,i-2)=0.0d0
2306           Ug(2,2,i-2)=1.0d0
2307           Ug2(1,1,i-2)=0.0d0
2308           Ug2(1,2,i-2)=0.0d0
2309           Ug2(2,1,i-2)=0.0d0
2310           Ug2(2,2,i-2)=0.0d0
2311         endif
2312         if (i .gt. 3 .and. i .lt. nres+1) then
2313           obrot_der(1,i-2)=-sin1
2314           obrot_der(2,i-2)= cos1
2315           Ugder(1,1,i-2)= sin1
2316           Ugder(1,2,i-2)=-cos1
2317           Ugder(2,1,i-2)=-cos1
2318           Ugder(2,2,i-2)=-sin1
2319           dwacos2=cos2+cos2
2320           dwasin2=sin2+sin2
2321           obrot2_der(1,i-2)=-dwasin2
2322           obrot2_der(2,i-2)= dwacos2
2323           Ug2der(1,1,i-2)= dwasin2
2324           Ug2der(1,2,i-2)=-dwacos2
2325           Ug2der(2,1,i-2)=-dwacos2
2326           Ug2der(2,2,i-2)=-dwasin2
2327         else
2328           obrot_der(1,i-2)=0.0d0
2329           obrot_der(2,i-2)=0.0d0
2330           Ugder(1,1,i-2)=0.0d0
2331           Ugder(1,2,i-2)=0.0d0
2332           Ugder(2,1,i-2)=0.0d0
2333           Ugder(2,2,i-2)=0.0d0
2334           obrot2_der(1,i-2)=0.0d0
2335           obrot2_der(2,i-2)=0.0d0
2336           Ug2der(1,1,i-2)=0.0d0
2337           Ug2der(1,2,i-2)=0.0d0
2338           Ug2der(2,1,i-2)=0.0d0
2339           Ug2der(2,2,i-2)=0.0d0
2340         endif
2341 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2342         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2343           iti = itortyp(itype(i-2,1))
2344         else
2345           iti=ntortyp+1
2346         endif
2347 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2348         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2349           iti1 = itortyp(itype(i-1,1))
2350         else
2351           iti1=ntortyp+1
2352         endif
2353 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2354 !d        write (iout,*) '*******i',i,' iti1',iti
2355 !d        write (iout,*) 'b1',b1(:,iti)
2356 !d        write (iout,*) 'b2',b2(:,iti)
2357 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2358 !        if (i .gt. iatel_s+2) then
2359         if (i .gt. nnt+2) then
2360           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2361           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2362           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2363           then
2364           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2365           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2366           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2367           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2368           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2369           endif
2370         else
2371           do k=1,2
2372             Ub2(k,i-2)=0.0d0
2373             Ctobr(k,i-2)=0.0d0
2374             Dtobr2(k,i-2)=0.0d0
2375             do l=1,2
2376               EUg(l,k,i-2)=0.0d0
2377               CUg(l,k,i-2)=0.0d0
2378               DUg(l,k,i-2)=0.0d0
2379               DtUg2(l,k,i-2)=0.0d0
2380             enddo
2381           enddo
2382         endif
2383         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2384         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2385         do k=1,2
2386           muder(k,i-2)=Ub2der(k,i-2)
2387         enddo
2388 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2389         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2390           if (itype(i-1,1).le.ntyp) then
2391             iti1 = itortyp(itype(i-1,1))
2392           else
2393             iti1=ntortyp+1
2394           endif
2395         else
2396           iti1=ntortyp+1
2397         endif
2398         do k=1,2
2399           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2400         enddo
2401 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2402 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2403 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2404 !d        write (iout,*) 'mu1',mu1(:,i-2)
2405 !d        write (iout,*) 'mu2',mu2(:,i-2)
2406         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2407         then
2408         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2409         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2410         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2411         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2412         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2413 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2414         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2415         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2416         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2417         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2418         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2419         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2420         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2421         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2422         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2423         endif
2424       enddo
2425 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2426 ! The order of matrices is from left to right.
2427       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2428       then
2429 !      do i=max0(ivec_start,2),ivec_end
2430       do i=2,nres-1
2431         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2432         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2433         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2434         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2435         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2436         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2437         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2438         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2439       enddo
2440       endif
2441 #if defined(MPI) && defined(PARMAT)
2442 #ifdef DEBUG
2443 !      if (fg_rank.eq.0) then
2444         write (iout,*) "Arrays UG and UGDER before GATHER"
2445         do i=1,nres-1
2446           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2447            ((ug(l,k,i),l=1,2),k=1,2),&
2448            ((ugder(l,k,i),l=1,2),k=1,2)
2449         enddo
2450         write (iout,*) "Arrays UG2 and UG2DER"
2451         do i=1,nres-1
2452           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2453            ((ug2(l,k,i),l=1,2),k=1,2),&
2454            ((ug2der(l,k,i),l=1,2),k=1,2)
2455         enddo
2456         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2457         do i=1,nres-1
2458           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2459            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2460            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2461         enddo
2462         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2463         do i=1,nres-1
2464           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2465            costab(i),sintab(i),costab2(i),sintab2(i)
2466         enddo
2467         write (iout,*) "Array MUDER"
2468         do i=1,nres-1
2469           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2470         enddo
2471 !      endif
2472 #endif
2473       if (nfgtasks.gt.1) then
2474         time00=MPI_Wtime()
2475 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2476 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2477 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2478 #ifdef MATGATHER
2479         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2480          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2481          FG_COMM1,IERR)
2482         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2483          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2484          FG_COMM1,IERR)
2485         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2486          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2487          FG_COMM1,IERR)
2488         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2489          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2490          FG_COMM1,IERR)
2491         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2492          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2493          FG_COMM1,IERR)
2494         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2495          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2496          FG_COMM1,IERR)
2497         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2498          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2499          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2500         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2501          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2502          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2503         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2504          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2505          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2506         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2507          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2508          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2509         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2510         then
2511         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2512          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2513          FG_COMM1,IERR)
2514         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2515          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2516          FG_COMM1,IERR)
2517         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2518          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2519          FG_COMM1,IERR)
2520        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2521          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2522          FG_COMM1,IERR)
2523         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2524          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2525          FG_COMM1,IERR)
2526         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2527          ivec_count(fg_rank1),&
2528          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2529          FG_COMM1,IERR)
2530         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2531          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2532          FG_COMM1,IERR)
2533         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2534          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2535          FG_COMM1,IERR)
2536         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2537          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2538          FG_COMM1,IERR)
2539         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2540          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2541          FG_COMM1,IERR)
2542         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2543          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2544          FG_COMM1,IERR)
2545         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2546          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2547          FG_COMM1,IERR)
2548         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2549          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2550          FG_COMM1,IERR)
2551         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2552          ivec_count(fg_rank1),&
2553          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2554          FG_COMM1,IERR)
2555         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2556          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2557          FG_COMM1,IERR)
2558        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2559          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2560          FG_COMM1,IERR)
2561         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2562          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2563          FG_COMM1,IERR)
2564        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2565          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2566          FG_COMM1,IERR)
2567         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2568          ivec_count(fg_rank1),&
2569          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2570          FG_COMM1,IERR)
2571         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2572          ivec_count(fg_rank1),&
2573          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2574          FG_COMM1,IERR)
2575         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2576          ivec_count(fg_rank1),&
2577          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2578          MPI_MAT2,FG_COMM1,IERR)
2579         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2580          ivec_count(fg_rank1),&
2581          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2582          MPI_MAT2,FG_COMM1,IERR)
2583         endif
2584 #else
2585 ! Passes matrix info through the ring
2586       isend=fg_rank1
2587       irecv=fg_rank1-1
2588       if (irecv.lt.0) irecv=nfgtasks1-1
2589       iprev=irecv
2590       inext=fg_rank1+1
2591       if (inext.ge.nfgtasks1) inext=0
2592       do i=1,nfgtasks1-1
2593 !        write (iout,*) "isend",isend," irecv",irecv
2594 !        call flush(iout)
2595         lensend=lentyp(isend)
2596         lenrecv=lentyp(irecv)
2597 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2598 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2599 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2600 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2601 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2602 !        write (iout,*) "Gather ROTAT1"
2603 !        call flush(iout)
2604 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2605 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2606 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2607 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2608 !        write (iout,*) "Gather ROTAT2"
2609 !        call flush(iout)
2610         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2611          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2612          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2613          iprev,4400+irecv,FG_COMM,status,IERR)
2614 !        write (iout,*) "Gather ROTAT_OLD"
2615 !        call flush(iout)
2616         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2617          MPI_PRECOMP11(lensend),inext,5500+isend,&
2618          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2619          iprev,5500+irecv,FG_COMM,status,IERR)
2620 !        write (iout,*) "Gather PRECOMP11"
2621 !        call flush(iout)
2622         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2623          MPI_PRECOMP12(lensend),inext,6600+isend,&
2624          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2625          iprev,6600+irecv,FG_COMM,status,IERR)
2626 !        write (iout,*) "Gather PRECOMP12"
2627 !        call flush(iout)
2628         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2629         then
2630         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2631          MPI_ROTAT2(lensend),inext,7700+isend,&
2632          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2633          iprev,7700+irecv,FG_COMM,status,IERR)
2634 !        write (iout,*) "Gather PRECOMP21"
2635 !        call flush(iout)
2636         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2637          MPI_PRECOMP22(lensend),inext,8800+isend,&
2638          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2639          iprev,8800+irecv,FG_COMM,status,IERR)
2640 !        write (iout,*) "Gather PRECOMP22"
2641 !        call flush(iout)
2642         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2643          MPI_PRECOMP23(lensend),inext,9900+isend,&
2644          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2645          MPI_PRECOMP23(lenrecv),&
2646          iprev,9900+irecv,FG_COMM,status,IERR)
2647 !        write (iout,*) "Gather PRECOMP23"
2648 !        call flush(iout)
2649         endif
2650         isend=irecv
2651         irecv=irecv-1
2652         if (irecv.lt.0) irecv=nfgtasks1-1
2653       enddo
2654 #endif
2655         time_gather=time_gather+MPI_Wtime()-time00
2656       endif
2657 #ifdef DEBUG
2658 !      if (fg_rank.eq.0) then
2659         write (iout,*) "Arrays UG and UGDER"
2660         do i=1,nres-1
2661           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2662            ((ug(l,k,i),l=1,2),k=1,2),&
2663            ((ugder(l,k,i),l=1,2),k=1,2)
2664         enddo
2665         write (iout,*) "Arrays UG2 and UG2DER"
2666         do i=1,nres-1
2667           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2668            ((ug2(l,k,i),l=1,2),k=1,2),&
2669            ((ug2der(l,k,i),l=1,2),k=1,2)
2670         enddo
2671         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2672         do i=1,nres-1
2673           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2674            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2675            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2676         enddo
2677         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2678         do i=1,nres-1
2679           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2680            costab(i),sintab(i),costab2(i),sintab2(i)
2681         enddo
2682         write (iout,*) "Array MUDER"
2683         do i=1,nres-1
2684           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2685         enddo
2686 !      endif
2687 #endif
2688 #endif
2689 !d      do i=1,nres
2690 !d        iti = itortyp(itype(i,1))
2691 !d        write (iout,*) i
2692 !d        do j=1,2
2693 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2694 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2695 !d        enddo
2696 !d      enddo
2697       return
2698       end subroutine set_matrices
2699 !-----------------------------------------------------------------------------
2700       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2701 !
2702 ! This subroutine calculates the average interaction energy and its gradient
2703 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2704 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2705 ! The potential depends both on the distance of peptide-group centers and on
2706 ! the orientation of the CA-CA virtual bonds.
2707 !
2708       use comm_locel
2709 !      implicit real*8 (a-h,o-z)
2710 #ifdef MPI
2711       include 'mpif.h'
2712 #endif
2713 !      include 'DIMENSIONS'
2714 !      include 'COMMON.CONTROL'
2715 !      include 'COMMON.SETUP'
2716 !      include 'COMMON.IOUNITS'
2717 !      include 'COMMON.GEO'
2718 !      include 'COMMON.VAR'
2719 !      include 'COMMON.LOCAL'
2720 !      include 'COMMON.CHAIN'
2721 !      include 'COMMON.DERIV'
2722 !      include 'COMMON.INTERACT'
2723 !      include 'COMMON.CONTACTS'
2724 !      include 'COMMON.TORSION'
2725 !      include 'COMMON.VECTORS'
2726 !      include 'COMMON.FFIELD'
2727 !      include 'COMMON.TIME1'
2728       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2729       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2730       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2731 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2732       real(kind=8),dimension(4) :: muij
2733 !el      integer :: num_conti,j1,j2
2734 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2735 !el        dz_normi,xmedi,ymedi,zmedi
2736
2737 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2738 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2739 !el          num_conti,j1,j2
2740
2741 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2742 #ifdef MOMENT
2743       real(kind=8) :: scal_el=1.0d0
2744 #else
2745       real(kind=8) :: scal_el=0.5d0
2746 #endif
2747 ! 12/13/98
2748 ! 13-go grudnia roku pamietnego...
2749       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2750                                              0.0d0,1.0d0,0.0d0,&
2751                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2752 !el local variables
2753       integer :: i,k,j
2754       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2755       real(kind=8) :: fac,t_eelecij,fracinbuf
2756
2757
2758 !d      write(iout,*) 'In EELEC'
2759 !        print *,"IN EELEC"
2760 !d      do i=1,nloctyp
2761 !d        write(iout,*) 'Type',i
2762 !d        write(iout,*) 'B1',B1(:,i)
2763 !d        write(iout,*) 'B2',B2(:,i)
2764 !d        write(iout,*) 'CC',CC(:,:,i)
2765 !d        write(iout,*) 'DD',DD(:,:,i)
2766 !d        write(iout,*) 'EE',EE(:,:,i)
2767 !d      enddo
2768 !d      call check_vecgrad
2769 !d      stop
2770 !      ees=0.0d0  !AS
2771 !      evdw1=0.0d0
2772 !      eel_loc=0.0d0
2773 !      eello_turn3=0.0d0
2774 !      eello_turn4=0.0d0
2775       t_eelecij=0.0d0
2776       ees=0.0D0
2777       evdw1=0.0D0
2778       eel_loc=0.0d0
2779       eello_turn3=0.0d0
2780       eello_turn4=0.0d0
2781 !
2782
2783       if (icheckgrad.eq.1) then
2784 !el
2785 !        do i=0,2*nres+2
2786 !          dc_norm(1,i)=0.0d0
2787 !          dc_norm(2,i)=0.0d0
2788 !          dc_norm(3,i)=0.0d0
2789 !        enddo
2790         do i=1,nres-1
2791           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2792           do k=1,3
2793             dc_norm(k,i)=dc(k,i)*fac
2794           enddo
2795 !          write (iout,*) 'i',i,' fac',fac
2796         enddo
2797       endif
2798 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2799 !        wturn6
2800       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2801           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2802           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2803 !        call vec_and_deriv
2804 #ifdef TIMING
2805         time01=MPI_Wtime()
2806 #endif
2807 !        print *, "before set matrices"
2808         call set_matrices
2809 !        print *, "after set matrices"
2810
2811 #ifdef TIMING
2812         time_mat=time_mat+MPI_Wtime()-time01
2813 #endif
2814       endif
2815 !       print *, "after set matrices"
2816 !d      do i=1,nres-1
2817 !d        write (iout,*) 'i=',i
2818 !d        do k=1,3
2819 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2820 !d        enddo
2821 !d        do k=1,3
2822 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2823 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2824 !d        enddo
2825 !d      enddo
2826       t_eelecij=0.0d0
2827       ees=0.0D0
2828       evdw1=0.0D0
2829       eel_loc=0.0d0
2830       eello_turn3=0.0d0
2831       eello_turn4=0.0d0
2832 !el      ind=0
2833       do i=1,nres
2834         num_cont_hb(i)=0
2835       enddo
2836 !d      print '(a)','Enter EELEC'
2837 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2838 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2839 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2840       do i=1,nres
2841         gel_loc_loc(i)=0.0d0
2842         gcorr_loc(i)=0.0d0
2843       enddo
2844 !
2845 !
2846 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2847 !
2848 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2849 !
2850
2851
2852 !        print *,"before iturn3 loop"
2853       do i=iturn3_start,iturn3_end
2854         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
2855         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
2856         dxi=dc(1,i)
2857         dyi=dc(2,i)
2858         dzi=dc(3,i)
2859         dx_normi=dc_norm(1,i)
2860         dy_normi=dc_norm(2,i)
2861         dz_normi=dc_norm(3,i)
2862         xmedi=c(1,i)+0.5d0*dxi
2863         ymedi=c(2,i)+0.5d0*dyi
2864         zmedi=c(3,i)+0.5d0*dzi
2865           xmedi=dmod(xmedi,boxxsize)
2866           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2867           ymedi=dmod(ymedi,boxysize)
2868           if (ymedi.lt.0) ymedi=ymedi+boxysize
2869           zmedi=dmod(zmedi,boxzsize)
2870           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2871         num_conti=0
2872        if ((zmedi.gt.bordlipbot) &
2873         .and.(zmedi.lt.bordliptop)) then
2874 !C the energy transfer exist
2875         if (zmedi.lt.buflipbot) then
2876 !C what fraction I am in
2877          fracinbuf=1.0d0- &
2878                ((zmedi-bordlipbot)/lipbufthick)
2879 !C lipbufthick is thickenes of lipid buffore
2880          sslipi=sscalelip(fracinbuf)
2881          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2882         elseif (zmedi.gt.bufliptop) then
2883          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2884          sslipi=sscalelip(fracinbuf)
2885          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2886         else
2887          sslipi=1.0d0
2888          ssgradlipi=0.0
2889         endif
2890        else
2891          sslipi=0.0d0
2892          ssgradlipi=0.0
2893        endif
2894 !       print *,i,sslipi,ssgradlipi
2895        call eelecij(i,i+2,ees,evdw1,eel_loc)
2896         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2897         num_cont_hb(i)=num_conti
2898       enddo
2899       do i=iturn4_start,iturn4_end
2900         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
2901           .or. itype(i+3,1).eq.ntyp1 &
2902           .or. itype(i+4,1).eq.ntyp1) cycle
2903         dxi=dc(1,i)
2904         dyi=dc(2,i)
2905         dzi=dc(3,i)
2906         dx_normi=dc_norm(1,i)
2907         dy_normi=dc_norm(2,i)
2908         dz_normi=dc_norm(3,i)
2909         xmedi=c(1,i)+0.5d0*dxi
2910         ymedi=c(2,i)+0.5d0*dyi
2911         zmedi=c(3,i)+0.5d0*dzi
2912           xmedi=dmod(xmedi,boxxsize)
2913           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2914           ymedi=dmod(ymedi,boxysize)
2915           if (ymedi.lt.0) ymedi=ymedi+boxysize
2916           zmedi=dmod(zmedi,boxzsize)
2917           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2918        if ((zmedi.gt.bordlipbot)  &
2919        .and.(zmedi.lt.bordliptop)) then
2920 !C the energy transfer exist
2921         if (zmedi.lt.buflipbot) then
2922 !C what fraction I am in
2923          fracinbuf=1.0d0- &
2924              ((zmedi-bordlipbot)/lipbufthick)
2925 !C lipbufthick is thickenes of lipid buffore
2926          sslipi=sscalelip(fracinbuf)
2927          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2928         elseif (zmedi.gt.bufliptop) then
2929          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2930          sslipi=sscalelip(fracinbuf)
2931          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2932         else
2933          sslipi=1.0d0
2934          ssgradlipi=0.0
2935         endif
2936        else
2937          sslipi=0.0d0
2938          ssgradlipi=0.0
2939        endif
2940
2941         num_conti=num_cont_hb(i)
2942         call eelecij(i,i+3,ees,evdw1,eel_loc)
2943         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
2944          call eturn4(i,eello_turn4)
2945         num_cont_hb(i)=num_conti
2946       enddo   ! i
2947 !
2948 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2949 !
2950       do i=iatel_s,iatel_e
2951         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2952         dxi=dc(1,i)
2953         dyi=dc(2,i)
2954         dzi=dc(3,i)
2955         dx_normi=dc_norm(1,i)
2956         dy_normi=dc_norm(2,i)
2957         dz_normi=dc_norm(3,i)
2958         xmedi=c(1,i)+0.5d0*dxi
2959         ymedi=c(2,i)+0.5d0*dyi
2960         zmedi=c(3,i)+0.5d0*dzi
2961           xmedi=dmod(xmedi,boxxsize)
2962           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2963           ymedi=dmod(ymedi,boxysize)
2964           if (ymedi.lt.0) ymedi=ymedi+boxysize
2965           zmedi=dmod(zmedi,boxzsize)
2966           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2967        if ((zmedi.gt.bordlipbot)  &
2968         .and.(zmedi.lt.bordliptop)) then
2969 !C the energy transfer exist
2970         if (zmedi.lt.buflipbot) then
2971 !C what fraction I am in
2972          fracinbuf=1.0d0- &
2973              ((zmedi-bordlipbot)/lipbufthick)
2974 !C lipbufthick is thickenes of lipid buffore
2975          sslipi=sscalelip(fracinbuf)
2976          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2977         elseif (zmedi.gt.bufliptop) then
2978          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2979          sslipi=sscalelip(fracinbuf)
2980          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2981         else
2982          sslipi=1.0d0
2983          ssgradlipi=0.0
2984         endif
2985        else
2986          sslipi=0.0d0
2987          ssgradlipi=0.0
2988        endif
2989
2990 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2991         num_conti=num_cont_hb(i)
2992         do j=ielstart(i),ielend(i)
2993 !          write (iout,*) i,j,itype(i,1),itype(j,1)
2994           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
2995           call eelecij(i,j,ees,evdw1,eel_loc)
2996         enddo ! j
2997         num_cont_hb(i)=num_conti
2998       enddo   ! i
2999 !      write (iout,*) "Number of loop steps in EELEC:",ind
3000 !d      do i=1,nres
3001 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3002 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3003 !d      enddo
3004 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3005 !cc      eel_loc=eel_loc+eello_turn3
3006 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3007       return
3008       end subroutine eelec
3009 !-----------------------------------------------------------------------------
3010       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3011
3012       use comm_locel
3013 !      implicit real*8 (a-h,o-z)
3014 !      include 'DIMENSIONS'
3015 #ifdef MPI
3016       include "mpif.h"
3017 #endif
3018 !      include 'COMMON.CONTROL'
3019 !      include 'COMMON.IOUNITS'
3020 !      include 'COMMON.GEO'
3021 !      include 'COMMON.VAR'
3022 !      include 'COMMON.LOCAL'
3023 !      include 'COMMON.CHAIN'
3024 !      include 'COMMON.DERIV'
3025 !      include 'COMMON.INTERACT'
3026 !      include 'COMMON.CONTACTS'
3027 !      include 'COMMON.TORSION'
3028 !      include 'COMMON.VECTORS'
3029 !      include 'COMMON.FFIELD'
3030 !      include 'COMMON.TIME1'
3031       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3032       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3033       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3034 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3035       real(kind=8),dimension(4) :: muij
3036       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3037                     dist_temp, dist_init,rlocshield,fracinbuf
3038       integer xshift,yshift,zshift,ilist,iresshield
3039 !el      integer :: num_conti,j1,j2
3040 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3041 !el        dz_normi,xmedi,ymedi,zmedi
3042
3043 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3044 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3045 !el          num_conti,j1,j2
3046
3047 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3048 #ifdef MOMENT
3049       real(kind=8) :: scal_el=1.0d0
3050 #else
3051       real(kind=8) :: scal_el=0.5d0
3052 #endif
3053 ! 12/13/98
3054 ! 13-go grudnia roku pamietnego...
3055       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3056                                              0.0d0,1.0d0,0.0d0,&
3057                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3058 !      integer :: maxconts=nres/4
3059 !el local variables
3060       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3061       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3062       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3063       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3064                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3065                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3066                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3067                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3068                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3069                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3070                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3071 !      maxconts=nres/4
3072 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3073 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3074
3075 !          time00=MPI_Wtime()
3076 !d      write (iout,*) "eelecij",i,j
3077 !          ind=ind+1
3078           iteli=itel(i)
3079           itelj=itel(j)
3080           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3081           aaa=app(iteli,itelj)
3082           bbb=bpp(iteli,itelj)
3083           ael6i=ael6(iteli,itelj)
3084           ael3i=ael3(iteli,itelj)
3085           dxj=dc(1,j)
3086           dyj=dc(2,j)
3087           dzj=dc(3,j)
3088           dx_normj=dc_norm(1,j)
3089           dy_normj=dc_norm(2,j)
3090           dz_normj=dc_norm(3,j)
3091 !          xj=c(1,j)+0.5D0*dxj-xmedi
3092 !          yj=c(2,j)+0.5D0*dyj-ymedi
3093 !          zj=c(3,j)+0.5D0*dzj-zmedi
3094           xj=c(1,j)+0.5D0*dxj
3095           yj=c(2,j)+0.5D0*dyj
3096           zj=c(3,j)+0.5D0*dzj
3097           xj=mod(xj,boxxsize)
3098           if (xj.lt.0) xj=xj+boxxsize
3099           yj=mod(yj,boxysize)
3100           if (yj.lt.0) yj=yj+boxysize
3101           zj=mod(zj,boxzsize)
3102           if (zj.lt.0) zj=zj+boxzsize
3103        if ((zj.gt.bordlipbot)  &
3104        .and.(zj.lt.bordliptop)) then
3105 !C the energy transfer exist
3106         if (zj.lt.buflipbot) then
3107 !C what fraction I am in
3108          fracinbuf=1.0d0-     &
3109              ((zj-bordlipbot)/lipbufthick)
3110 !C lipbufthick is thickenes of lipid buffore
3111          sslipj=sscalelip(fracinbuf)
3112          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3113         elseif (zj.gt.bufliptop) then
3114          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3115          sslipj=sscalelip(fracinbuf)
3116          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3117         else
3118          sslipj=1.0d0
3119          ssgradlipj=0.0
3120         endif
3121        else
3122          sslipj=0.0d0
3123          ssgradlipj=0.0
3124        endif
3125
3126       isubchap=0
3127       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3128       xj_safe=xj
3129       yj_safe=yj
3130       zj_safe=zj
3131       do xshift=-1,1
3132       do yshift=-1,1
3133       do zshift=-1,1
3134           xj=xj_safe+xshift*boxxsize
3135           yj=yj_safe+yshift*boxysize
3136           zj=zj_safe+zshift*boxzsize
3137           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3138           if(dist_temp.lt.dist_init) then
3139             dist_init=dist_temp
3140             xj_temp=xj
3141             yj_temp=yj
3142             zj_temp=zj
3143             isubchap=1
3144           endif
3145        enddo
3146        enddo
3147        enddo
3148        if (isubchap.eq.1) then
3149 !C          print *,i,j
3150           xj=xj_temp-xmedi
3151           yj=yj_temp-ymedi
3152           zj=zj_temp-zmedi
3153        else
3154           xj=xj_safe-xmedi
3155           yj=yj_safe-ymedi
3156           zj=zj_safe-zmedi
3157        endif
3158
3159           rij=xj*xj+yj*yj+zj*zj
3160           rrmij=1.0D0/rij
3161           rij=dsqrt(rij)
3162 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3163             sss_ele_cut=sscale_ele(rij)
3164             sss_ele_grad=sscagrad_ele(rij)
3165 !             sss_ele_cut=1.0d0
3166 !             sss_ele_grad=0.0d0
3167 !            print *,sss_ele_cut,sss_ele_grad,&
3168 !            (rij),r_cut_ele,rlamb_ele
3169 !            if (sss_ele_cut.le.0.0) go to 128
3170
3171           rmij=1.0D0/rij
3172           r3ij=rrmij*rmij
3173           r6ij=r3ij*r3ij
3174           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3175           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3176           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3177           fac=cosa-3.0D0*cosb*cosg
3178           ev1=aaa*r6ij*r6ij
3179 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3180           if (j.eq.i+2) ev1=scal_el*ev1
3181           ev2=bbb*r6ij
3182           fac3=ael6i*r6ij
3183           fac4=ael3i*r3ij
3184           evdwij=ev1+ev2
3185           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3186           el2=fac4*fac
3187 !          eesij=el1+el2
3188           if (shield_mode.gt.0) then
3189 !C          fac_shield(i)=0.4
3190 !C          fac_shield(j)=0.6
3191           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3192           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3193           eesij=(el1+el2)
3194           ees=ees+eesij*sss_ele_cut
3195 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3196 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3197           else
3198           fac_shield(i)=1.0
3199           fac_shield(j)=1.0
3200           eesij=(el1+el2)
3201           ees=ees+eesij   &
3202             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3203 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3204           endif
3205
3206 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3207           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3208 !          ees=ees+eesij*sss_ele_cut
3209           evdw1=evdw1+evdwij*sss_ele_cut  &
3210            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3211 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3212 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3213 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3214 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3215
3216           if (energy_dec) then
3217 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3218 !                  'evdw1',i,j,evdwij,&
3219 !                  iteli,itelj,aaa,evdw1
3220               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3221               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3222           endif
3223 !
3224 ! Calculate contributions to the Cartesian gradient.
3225 !
3226 #ifdef SPLITELE
3227           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3228               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3229           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3230              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3231           fac1=fac
3232           erij(1)=xj*rmij
3233           erij(2)=yj*rmij
3234           erij(3)=zj*rmij
3235 !
3236 ! Radial derivatives. First process both termini of the fragment (i,j)
3237 !
3238           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3239           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3240           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3241            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3242           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3243             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3244
3245           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3246           (shield_mode.gt.0)) then
3247 !C          print *,i,j
3248           do ilist=1,ishield_list(i)
3249            iresshield=shield_list(ilist,i)
3250            do k=1,3
3251            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3252            *2.0*sss_ele_cut
3253            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3254                    rlocshield &
3255             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3256             *sss_ele_cut
3257             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3258            enddo
3259           enddo
3260           do ilist=1,ishield_list(j)
3261            iresshield=shield_list(ilist,j)
3262            do k=1,3
3263            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3264           *2.0*sss_ele_cut
3265            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3266                    rlocshield &
3267            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3268            *sss_ele_cut
3269            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3270            enddo
3271           enddo
3272           do k=1,3
3273             gshieldc(k,i)=gshieldc(k,i)+ &
3274                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3275            *sss_ele_cut
3276
3277             gshieldc(k,j)=gshieldc(k,j)+ &
3278                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3279            *sss_ele_cut
3280
3281             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3282                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3283            *sss_ele_cut
3284
3285             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3286                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3287            *sss_ele_cut
3288
3289            enddo
3290            endif
3291
3292
3293 !          do k=1,3
3294 !            ghalf=0.5D0*ggg(k)
3295 !            gelc(k,i)=gelc(k,i)+ghalf
3296 !            gelc(k,j)=gelc(k,j)+ghalf
3297 !          enddo
3298 ! 9/28/08 AL Gradient compotents will be summed only at the end
3299           do k=1,3
3300             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3301             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3302           enddo
3303             gelc_long(3,j)=gelc_long(3,j)+  &
3304           ssgradlipj*eesij/2.0d0*lipscale**2&
3305            *sss_ele_cut
3306
3307             gelc_long(3,i)=gelc_long(3,i)+  &
3308           ssgradlipi*eesij/2.0d0*lipscale**2&
3309            *sss_ele_cut
3310
3311
3312 !
3313 ! Loop over residues i+1 thru j-1.
3314 !
3315 !grad          do k=i+1,j-1
3316 !grad            do l=1,3
3317 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3318 !grad            enddo
3319 !grad          enddo
3320           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3321            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3322           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3323            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3324           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3325            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3326
3327 !          do k=1,3
3328 !            ghalf=0.5D0*ggg(k)
3329 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3330 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3331 !          enddo
3332 ! 9/28/08 AL Gradient compotents will be summed only at the end
3333           do k=1,3
3334             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3335             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3336           enddo
3337
3338 !C Lipidic part for scaling weight
3339            gvdwpp(3,j)=gvdwpp(3,j)+ &
3340           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3341            gvdwpp(3,i)=gvdwpp(3,i)+ &
3342           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3343 !! Loop over residues i+1 thru j-1.
3344 !
3345 !grad          do k=i+1,j-1
3346 !grad            do l=1,3
3347 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3348 !grad            enddo
3349 !grad          enddo
3350 #else
3351           facvdw=(ev1+evdwij)*sss_ele_cut &
3352            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3353
3354           facel=(el1+eesij)*sss_ele_cut
3355           fac1=fac
3356           fac=-3*rrmij*(facvdw+facvdw+facel)
3357           erij(1)=xj*rmij
3358           erij(2)=yj*rmij
3359           erij(3)=zj*rmij
3360 !
3361 ! Radial derivatives. First process both termini of the fragment (i,j)
3362 !
3363           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3364           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3365           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3366 !          do k=1,3
3367 !            ghalf=0.5D0*ggg(k)
3368 !            gelc(k,i)=gelc(k,i)+ghalf
3369 !            gelc(k,j)=gelc(k,j)+ghalf
3370 !          enddo
3371 ! 9/28/08 AL Gradient compotents will be summed only at the end
3372           do k=1,3
3373             gelc_long(k,j)=gelc(k,j)+ggg(k)
3374             gelc_long(k,i)=gelc(k,i)-ggg(k)
3375           enddo
3376 !
3377 ! Loop over residues i+1 thru j-1.
3378 !
3379 !grad          do k=i+1,j-1
3380 !grad            do l=1,3
3381 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3382 !grad            enddo
3383 !grad          enddo
3384 ! 9/28/08 AL Gradient compotents will be summed only at the end
3385           ggg(1)=facvdw*xj &
3386            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3387           ggg(2)=facvdw*yj &
3388            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3389           ggg(3)=facvdw*zj &
3390            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3391
3392           do k=1,3
3393             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3394             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3395           enddo
3396            gvdwpp(3,j)=gvdwpp(3,j)+ &
3397           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3398            gvdwpp(3,i)=gvdwpp(3,i)+ &
3399           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3400
3401 #endif
3402 !
3403 ! Angular part
3404 !
3405           ecosa=2.0D0*fac3*fac1+fac4
3406           fac4=-3.0D0*fac4
3407           fac3=-6.0D0*fac3
3408           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3409           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3410           do k=1,3
3411             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3412             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3413           enddo
3414 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3415 !d   &          (dcosg(k),k=1,3)
3416           do k=1,3
3417             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3418              *fac_shield(i)**2*fac_shield(j)**2 &
3419              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3420
3421           enddo
3422 !          do k=1,3
3423 !            ghalf=0.5D0*ggg(k)
3424 !            gelc(k,i)=gelc(k,i)+ghalf
3425 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3426 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3427 !            gelc(k,j)=gelc(k,j)+ghalf
3428 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3429 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3430 !          enddo
3431 !grad          do k=i+1,j-1
3432 !grad            do l=1,3
3433 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3434 !grad            enddo
3435 !grad          enddo
3436           do k=1,3
3437             gelc(k,i)=gelc(k,i) &
3438                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3439                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3440                      *sss_ele_cut &
3441                      *fac_shield(i)**2*fac_shield(j)**2 &
3442                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3443
3444             gelc(k,j)=gelc(k,j) &
3445                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3446                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3447                      *sss_ele_cut  &
3448                      *fac_shield(i)**2*fac_shield(j)**2  &
3449                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3450
3451             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3452             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3453           enddo
3454
3455           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3456               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3457               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3458 !
3459 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3460 !   energy of a peptide unit is assumed in the form of a second-order
3461 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3462 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3463 !   are computed for EVERY pair of non-contiguous peptide groups.
3464 !
3465           if (j.lt.nres-1) then
3466             j1=j+1
3467             j2=j-1
3468           else
3469             j1=j-1
3470             j2=j-2
3471           endif
3472           kkk=0
3473           do k=1,2
3474             do l=1,2
3475               kkk=kkk+1
3476               muij(kkk)=mu(k,i)*mu(l,j)
3477             enddo
3478           enddo
3479 !d         write (iout,*) 'EELEC: i',i,' j',j
3480 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3481 !d          write(iout,*) 'muij',muij
3482           ury=scalar(uy(1,i),erij)
3483           urz=scalar(uz(1,i),erij)
3484           vry=scalar(uy(1,j),erij)
3485           vrz=scalar(uz(1,j),erij)
3486           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3487           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3488           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3489           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3490           fac=dsqrt(-ael6i)*r3ij
3491           a22=a22*fac
3492           a23=a23*fac
3493           a32=a32*fac
3494           a33=a33*fac
3495 !d          write (iout,'(4i5,4f10.5)')
3496 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3497 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3498 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3499 !d     &      uy(:,j),uz(:,j)
3500 !d          write (iout,'(4f10.5)')
3501 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3502 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3503 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3504 !d           write (iout,'(9f10.5/)')
3505 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3506 ! Derivatives of the elements of A in virtual-bond vectors
3507           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3508           do k=1,3
3509             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3510             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3511             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3512             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3513             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3514             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3515             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3516             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3517             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3518             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3519             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3520             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3521           enddo
3522 ! Compute radial contributions to the gradient
3523           facr=-3.0d0*rrmij
3524           a22der=a22*facr
3525           a23der=a23*facr
3526           a32der=a32*facr
3527           a33der=a33*facr
3528           agg(1,1)=a22der*xj
3529           agg(2,1)=a22der*yj
3530           agg(3,1)=a22der*zj
3531           agg(1,2)=a23der*xj
3532           agg(2,2)=a23der*yj
3533           agg(3,2)=a23der*zj
3534           agg(1,3)=a32der*xj
3535           agg(2,3)=a32der*yj
3536           agg(3,3)=a32der*zj
3537           agg(1,4)=a33der*xj
3538           agg(2,4)=a33der*yj
3539           agg(3,4)=a33der*zj
3540 ! Add the contributions coming from er
3541           fac3=-3.0d0*fac
3542           do k=1,3
3543             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3544             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3545             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3546             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3547           enddo
3548           do k=1,3
3549 ! Derivatives in DC(i)
3550 !grad            ghalf1=0.5d0*agg(k,1)
3551 !grad            ghalf2=0.5d0*agg(k,2)
3552 !grad            ghalf3=0.5d0*agg(k,3)
3553 !grad            ghalf4=0.5d0*agg(k,4)
3554             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3555             -3.0d0*uryg(k,2)*vry)!+ghalf1
3556             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3557             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3558             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3559             -3.0d0*urzg(k,2)*vry)!+ghalf3
3560             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3561             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3562 ! Derivatives in DC(i+1)
3563             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3564             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3565             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3566             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3567             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3568             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3569             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3570             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3571 ! Derivatives in DC(j)
3572             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3573             -3.0d0*vryg(k,2)*ury)!+ghalf1
3574             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3575             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3576             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3577             -3.0d0*vryg(k,2)*urz)!+ghalf3
3578             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3579             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3580 ! Derivatives in DC(j+1) or DC(nres-1)
3581             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3582             -3.0d0*vryg(k,3)*ury)
3583             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3584             -3.0d0*vrzg(k,3)*ury)
3585             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3586             -3.0d0*vryg(k,3)*urz)
3587             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3588             -3.0d0*vrzg(k,3)*urz)
3589 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3590 !grad              do l=1,4
3591 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3592 !grad              enddo
3593 !grad            endif
3594           enddo
3595           acipa(1,1)=a22
3596           acipa(1,2)=a23
3597           acipa(2,1)=a32
3598           acipa(2,2)=a33
3599           a22=-a22
3600           a23=-a23
3601           do l=1,2
3602             do k=1,3
3603               agg(k,l)=-agg(k,l)
3604               aggi(k,l)=-aggi(k,l)
3605               aggi1(k,l)=-aggi1(k,l)
3606               aggj(k,l)=-aggj(k,l)
3607               aggj1(k,l)=-aggj1(k,l)
3608             enddo
3609           enddo
3610           if (j.lt.nres-1) then
3611             a22=-a22
3612             a32=-a32
3613             do l=1,3,2
3614               do k=1,3
3615                 agg(k,l)=-agg(k,l)
3616                 aggi(k,l)=-aggi(k,l)
3617                 aggi1(k,l)=-aggi1(k,l)
3618                 aggj(k,l)=-aggj(k,l)
3619                 aggj1(k,l)=-aggj1(k,l)
3620               enddo
3621             enddo
3622           else
3623             a22=-a22
3624             a23=-a23
3625             a32=-a32
3626             a33=-a33
3627             do l=1,4
3628               do k=1,3
3629                 agg(k,l)=-agg(k,l)
3630                 aggi(k,l)=-aggi(k,l)
3631                 aggi1(k,l)=-aggi1(k,l)
3632                 aggj(k,l)=-aggj(k,l)
3633                 aggj1(k,l)=-aggj1(k,l)
3634               enddo
3635             enddo
3636           endif
3637           ENDIF ! WCORR
3638           IF (wel_loc.gt.0.0d0) THEN
3639 ! Contribution to the local-electrostatic energy coming from the i-j pair
3640           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3641            +a33*muij(4)
3642           if (shield_mode.eq.0) then
3643            fac_shield(i)=1.0
3644            fac_shield(j)=1.0
3645           endif
3646           eel_loc_ij=eel_loc_ij &
3647          *fac_shield(i)*fac_shield(j) &
3648          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3649 !C Now derivative over eel_loc
3650           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3651          (shield_mode.gt.0)) then
3652 !C          print *,i,j
3653
3654           do ilist=1,ishield_list(i)
3655            iresshield=shield_list(ilist,i)
3656            do k=1,3
3657            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3658                                                 /fac_shield(i)&
3659            *sss_ele_cut
3660            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3661                    rlocshield  &
3662           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3663           *sss_ele_cut
3664
3665             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3666            +rlocshield
3667            enddo
3668           enddo
3669           do ilist=1,ishield_list(j)
3670            iresshield=shield_list(ilist,j)
3671            do k=1,3
3672            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3673                                             /fac_shield(j)   &
3674             *sss_ele_cut
3675            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3676                    rlocshield  &
3677       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3678        *sss_ele_cut
3679
3680            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3681                   +rlocshield
3682
3683            enddo
3684           enddo
3685
3686           do k=1,3
3687             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3688                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3689                     *sss_ele_cut
3690             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3691                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3692                     *sss_ele_cut
3693             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3694                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3695                     *sss_ele_cut
3696             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3697                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3698                     *sss_ele_cut
3699
3700            enddo
3701            endif
3702
3703
3704 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3705 !           eel_loc_ij=0.0
3706           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3707                   'eelloc',i,j,eel_loc_ij
3708 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3709 !          if (energy_dec) write (iout,*) "muij",muij
3710 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3711
3712           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3713 ! Partial derivatives in virtual-bond dihedral angles gamma
3714           if (i.gt.1) &
3715           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3716                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3717                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3718                  *sss_ele_cut  &
3719           *fac_shield(i)*fac_shield(j) &
3720           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3721
3722           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3723                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3724                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3725                  *sss_ele_cut &
3726           *fac_shield(i)*fac_shield(j) &
3727           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3728 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3729 !          do l=1,3
3730 !            ggg(1)=(agg(1,1)*muij(1)+ &
3731 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3732 !            *sss_ele_cut &
3733 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3734 !            ggg(2)=(agg(2,1)*muij(1)+ &
3735 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3736 !            *sss_ele_cut &
3737 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3738 !            ggg(3)=(agg(3,1)*muij(1)+ &
3739 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3740 !            *sss_ele_cut &
3741 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3742            xtemp(1)=xj
3743            xtemp(2)=yj
3744            xtemp(3)=zj
3745
3746            do l=1,3
3747             ggg(l)=(agg(l,1)*muij(1)+ &
3748                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3749             *sss_ele_cut &
3750           *fac_shield(i)*fac_shield(j) &
3751           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3752              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3753
3754
3755             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3756             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3757 !grad            ghalf=0.5d0*ggg(l)
3758 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3759 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3760           enddo
3761             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3762           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3763           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3764
3765             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3766           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3767           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3768
3769 !grad          do k=i+1,j2
3770 !grad            do l=1,3
3771 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3772 !grad            enddo
3773 !grad          enddo
3774 ! Remaining derivatives of eello
3775           do l=1,3
3776             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3777                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3778             *sss_ele_cut &
3779           *fac_shield(i)*fac_shield(j) &
3780           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3781
3782 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3783             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3784                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3785             +aggi1(l,4)*muij(4))&
3786             *sss_ele_cut &
3787           *fac_shield(i)*fac_shield(j) &
3788           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3789
3790 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3791             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3792                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3793             *sss_ele_cut &
3794           *fac_shield(i)*fac_shield(j) &
3795           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3796
3797 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3798             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3799                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3800             +aggj1(l,4)*muij(4))&
3801             *sss_ele_cut &
3802           *fac_shield(i)*fac_shield(j) &
3803           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3804
3805 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3806           enddo
3807           ENDIF
3808 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3809 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3810           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3811              .and. num_conti.le.maxconts) then
3812 !            write (iout,*) i,j," entered corr"
3813 !
3814 ! Calculate the contact function. The ith column of the array JCONT will
3815 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3816 ! greater than I). The arrays FACONT and GACONT will contain the values of
3817 ! the contact function and its derivative.
3818 !           r0ij=1.02D0*rpp(iteli,itelj)
3819 !           r0ij=1.11D0*rpp(iteli,itelj)
3820             r0ij=2.20D0*rpp(iteli,itelj)
3821 !           r0ij=1.55D0*rpp(iteli,itelj)
3822             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3823 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3824             if (fcont.gt.0.0D0) then
3825               num_conti=num_conti+1
3826               if (num_conti.gt.maxconts) then
3827 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3828 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3829                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3830                                ' will skip next contacts for this conf.', num_conti
3831               else
3832                 jcont_hb(num_conti,i)=j
3833 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3834 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3835                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3836                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3837 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3838 !  terms.
3839                 d_cont(num_conti,i)=rij
3840 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3841 !     --- Electrostatic-interaction matrix ---
3842                 a_chuj(1,1,num_conti,i)=a22
3843                 a_chuj(1,2,num_conti,i)=a23
3844                 a_chuj(2,1,num_conti,i)=a32
3845                 a_chuj(2,2,num_conti,i)=a33
3846 !     --- Gradient of rij
3847                 do kkk=1,3
3848                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3849                 enddo
3850                 kkll=0
3851                 do k=1,2
3852                   do l=1,2
3853                     kkll=kkll+1
3854                     do m=1,3
3855                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3856                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3857                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3858                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3859                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3860                     enddo
3861                   enddo
3862                 enddo
3863                 ENDIF
3864                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3865 ! Calculate contact energies
3866                 cosa4=4.0D0*cosa
3867                 wij=cosa-3.0D0*cosb*cosg
3868                 cosbg1=cosb+cosg
3869                 cosbg2=cosb-cosg
3870 !               fac3=dsqrt(-ael6i)/r0ij**3
3871                 fac3=dsqrt(-ael6i)*r3ij
3872 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3873                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3874                 if (ees0tmp.gt.0) then
3875                   ees0pij=dsqrt(ees0tmp)
3876                 else
3877                   ees0pij=0
3878                 endif
3879                 if (shield_mode.eq.0) then
3880                 fac_shield(i)=1.0d0
3881                 fac_shield(j)=1.0d0
3882                 else
3883                 ees0plist(num_conti,i)=j
3884                 endif
3885 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3886                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3887                 if (ees0tmp.gt.0) then
3888                   ees0mij=dsqrt(ees0tmp)
3889                 else
3890                   ees0mij=0
3891                 endif
3892 !               ees0mij=0.0D0
3893                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
3894                      *sss_ele_cut &
3895                      *fac_shield(i)*fac_shield(j)
3896
3897                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
3898                      *sss_ele_cut &
3899                      *fac_shield(i)*fac_shield(j)
3900
3901 ! Diagnostics. Comment out or remove after debugging!
3902 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3903 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3904 !               ees0m(num_conti,i)=0.0D0
3905 ! End diagnostics.
3906 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3907 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3908 ! Angular derivatives of the contact function
3909                 ees0pij1=fac3/ees0pij
3910                 ees0mij1=fac3/ees0mij
3911                 fac3p=-3.0D0*fac3*rrmij
3912                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3913                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3914 !               ees0mij1=0.0D0
3915                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3916                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3917                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3918                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3919                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3920                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3921                 ecosap=ecosa1+ecosa2
3922                 ecosbp=ecosb1+ecosb2
3923                 ecosgp=ecosg1+ecosg2
3924                 ecosam=ecosa1-ecosa2
3925                 ecosbm=ecosb1-ecosb2
3926                 ecosgm=ecosg1-ecosg2
3927 ! Diagnostics
3928 !               ecosap=ecosa1
3929 !               ecosbp=ecosb1
3930 !               ecosgp=ecosg1
3931 !               ecosam=0.0D0
3932 !               ecosbm=0.0D0
3933 !               ecosgm=0.0D0
3934 ! End diagnostics
3935                 facont_hb(num_conti,i)=fcont
3936                 fprimcont=fprimcont/rij
3937 !d              facont_hb(num_conti,i)=1.0D0
3938 ! Following line is for diagnostics.
3939 !d              fprimcont=0.0D0
3940                 do k=1,3
3941                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3942                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3943                 enddo
3944                 do k=1,3
3945                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3946                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3947                 enddo
3948                 gggp(1)=gggp(1)+ees0pijp*xj &
3949                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3950                 gggp(2)=gggp(2)+ees0pijp*yj &
3951                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3952                 gggp(3)=gggp(3)+ees0pijp*zj &
3953                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3954
3955                 gggm(1)=gggm(1)+ees0mijp*xj &
3956                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3957
3958                 gggm(2)=gggm(2)+ees0mijp*yj &
3959                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3960
3961                 gggm(3)=gggm(3)+ees0mijp*zj &
3962                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3963
3964 ! Derivatives due to the contact function
3965                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3966                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3967                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3968                 do k=1,3
3969 !
3970 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3971 !          following the change of gradient-summation algorithm.
3972 !
3973 !grad                  ghalfp=0.5D0*gggp(k)
3974 !grad                  ghalfm=0.5D0*gggm(k)
3975                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3976                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3977                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3978                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3979
3980                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3981                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3982                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3983                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3984
3985                   gacontp_hb3(k,num_conti,i)=gggp(k) &
3986                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3987
3988                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3989                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3990                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3991                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3992
3993                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3994                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3995                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
3996                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3997
3998                   gacontm_hb3(k,num_conti,i)=gggm(k) &
3999                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4000
4001                 enddo
4002 ! Diagnostics. Comment out or remove after debugging!
4003 !diag           do k=1,3
4004 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4005 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4006 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4007 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4008 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4009 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4010 !diag           enddo
4011               ENDIF ! wcorr
4012               endif  ! num_conti.le.maxconts
4013             endif  ! fcont.gt.0
4014           endif    ! j.gt.i+1
4015           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4016             do k=1,4
4017               do l=1,3
4018                 ghalf=0.5d0*agg(l,k)
4019                 aggi(l,k)=aggi(l,k)+ghalf
4020                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4021                 aggj(l,k)=aggj(l,k)+ghalf
4022               enddo
4023             enddo
4024             if (j.eq.nres-1 .and. i.lt.j-2) then
4025               do k=1,4
4026                 do l=1,3
4027                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4028                 enddo
4029               enddo
4030             endif
4031           endif
4032  128  continue
4033 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4034       return
4035       end subroutine eelecij
4036 !-----------------------------------------------------------------------------
4037       subroutine eturn3(i,eello_turn3)
4038 ! Third- and fourth-order contributions from turns
4039
4040       use comm_locel
4041 !      implicit real*8 (a-h,o-z)
4042 !      include 'DIMENSIONS'
4043 !      include 'COMMON.IOUNITS'
4044 !      include 'COMMON.GEO'
4045 !      include 'COMMON.VAR'
4046 !      include 'COMMON.LOCAL'
4047 !      include 'COMMON.CHAIN'
4048 !      include 'COMMON.DERIV'
4049 !      include 'COMMON.INTERACT'
4050 !      include 'COMMON.CONTACTS'
4051 !      include 'COMMON.TORSION'
4052 !      include 'COMMON.VECTORS'
4053 !      include 'COMMON.FFIELD'
4054 !      include 'COMMON.CONTROL'
4055       real(kind=8),dimension(3) :: ggg
4056       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4057         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4058       real(kind=8),dimension(2) :: auxvec,auxvec1
4059 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4060       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4061 !el      integer :: num_conti,j1,j2
4062 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4063 !el        dz_normi,xmedi,ymedi,zmedi
4064
4065 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4066 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4067 !el         num_conti,j1,j2
4068 !el local variables
4069       integer :: i,j,l,k,ilist,iresshield
4070       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4071
4072       j=i+2
4073 !      write (iout,*) "eturn3",i,j,j1,j2
4074           zj=(c(3,j)+c(3,j+1))/2.0d0
4075           zj=mod(zj,boxzsize)
4076           if (zj.lt.0) zj=zj+boxzsize
4077           if ((zj.lt.0)) write (*,*) "CHUJ"
4078        if ((zj.gt.bordlipbot)  &
4079         .and.(zj.lt.bordliptop)) then
4080 !C the energy transfer exist
4081         if (zj.lt.buflipbot) then
4082 !C what fraction I am in
4083          fracinbuf=1.0d0-     &
4084              ((zj-bordlipbot)/lipbufthick)
4085 !C lipbufthick is thickenes of lipid buffore
4086          sslipj=sscalelip(fracinbuf)
4087          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4088         elseif (zj.gt.bufliptop) then
4089          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4090          sslipj=sscalelip(fracinbuf)
4091          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4092         else
4093          sslipj=1.0d0
4094          ssgradlipj=0.0
4095         endif
4096        else
4097          sslipj=0.0d0
4098          ssgradlipj=0.0
4099        endif
4100
4101       a_temp(1,1)=a22
4102       a_temp(1,2)=a23
4103       a_temp(2,1)=a32
4104       a_temp(2,2)=a33
4105 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4106 !
4107 !               Third-order contributions
4108 !
4109 !                 (i+2)o----(i+3)
4110 !                      | |
4111 !                      | |
4112 !                 (i+1)o----i
4113 !
4114 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4115 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4116         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4117         call transpose2(auxmat(1,1),auxmat1(1,1))
4118         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4119         if (shield_mode.eq.0) then
4120         fac_shield(i)=1.0d0
4121         fac_shield(j)=1.0d0
4122         endif
4123
4124         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4125          *fac_shield(i)*fac_shield(j)  &
4126          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4127         eello_t3= &
4128         0.5d0*(pizda(1,1)+pizda(2,2)) &
4129         *fac_shield(i)*fac_shield(j)
4130
4131         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4132                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4133           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4134        (shield_mode.gt.0)) then
4135 !C          print *,i,j
4136
4137           do ilist=1,ishield_list(i)
4138            iresshield=shield_list(ilist,i)
4139            do k=1,3
4140            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4141            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4142                    rlocshield &
4143            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4144             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4145              +rlocshield
4146            enddo
4147           enddo
4148           do ilist=1,ishield_list(j)
4149            iresshield=shield_list(ilist,j)
4150            do k=1,3
4151            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4152            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4153                    rlocshield &
4154            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4155            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4156                   +rlocshield
4157
4158            enddo
4159           enddo
4160
4161           do k=1,3
4162             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4163                    grad_shield(k,i)*eello_t3/fac_shield(i)
4164             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4165                    grad_shield(k,j)*eello_t3/fac_shield(j)
4166             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4167                    grad_shield(k,i)*eello_t3/fac_shield(i)
4168             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4169                    grad_shield(k,j)*eello_t3/fac_shield(j)
4170            enddo
4171            endif
4172
4173 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4174 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4175 !d     &    ' eello_turn3_num',4*eello_turn3_num
4176 ! Derivatives in gamma(i)
4177         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4178         call transpose2(auxmat2(1,1),auxmat3(1,1))
4179         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4180         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4181           *fac_shield(i)*fac_shield(j)        &
4182           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4183 ! Derivatives in gamma(i+1)
4184         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4185         call transpose2(auxmat2(1,1),auxmat3(1,1))
4186         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4187         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4188           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4189           *fac_shield(i)*fac_shield(j)        &
4190           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4191
4192 ! Cartesian derivatives
4193         do l=1,3
4194 !            ghalf1=0.5d0*agg(l,1)
4195 !            ghalf2=0.5d0*agg(l,2)
4196 !            ghalf3=0.5d0*agg(l,3)
4197 !            ghalf4=0.5d0*agg(l,4)
4198           a_temp(1,1)=aggi(l,1)!+ghalf1
4199           a_temp(1,2)=aggi(l,2)!+ghalf2
4200           a_temp(2,1)=aggi(l,3)!+ghalf3
4201           a_temp(2,2)=aggi(l,4)!+ghalf4
4202           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4203           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4204             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4205           *fac_shield(i)*fac_shield(j)      &
4206           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4207
4208           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4209           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4210           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4211           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4212           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4213           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4214             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4215           *fac_shield(i)*fac_shield(j)        &
4216           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4217
4218           a_temp(1,1)=aggj(l,1)!+ghalf1
4219           a_temp(1,2)=aggj(l,2)!+ghalf2
4220           a_temp(2,1)=aggj(l,3)!+ghalf3
4221           a_temp(2,2)=aggj(l,4)!+ghalf4
4222           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4223           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4224             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4225           *fac_shield(i)*fac_shield(j)      &
4226           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4227
4228           a_temp(1,1)=aggj1(l,1)
4229           a_temp(1,2)=aggj1(l,2)
4230           a_temp(2,1)=aggj1(l,3)
4231           a_temp(2,2)=aggj1(l,4)
4232           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4233           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4234             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4235           *fac_shield(i)*fac_shield(j)        &
4236           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4237         enddo
4238          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4239           ssgradlipi*eello_t3/4.0d0*lipscale
4240          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4241           ssgradlipj*eello_t3/4.0d0*lipscale
4242          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4243           ssgradlipi*eello_t3/4.0d0*lipscale
4244          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4245           ssgradlipj*eello_t3/4.0d0*lipscale
4246
4247       return
4248       end subroutine eturn3
4249 !-----------------------------------------------------------------------------
4250       subroutine eturn4(i,eello_turn4)
4251 ! Third- and fourth-order contributions from turns
4252
4253       use comm_locel
4254 !      implicit real*8 (a-h,o-z)
4255 !      include 'DIMENSIONS'
4256 !      include 'COMMON.IOUNITS'
4257 !      include 'COMMON.GEO'
4258 !      include 'COMMON.VAR'
4259 !      include 'COMMON.LOCAL'
4260 !      include 'COMMON.CHAIN'
4261 !      include 'COMMON.DERIV'
4262 !      include 'COMMON.INTERACT'
4263 !      include 'COMMON.CONTACTS'
4264 !      include 'COMMON.TORSION'
4265 !      include 'COMMON.VECTORS'
4266 !      include 'COMMON.FFIELD'
4267 !      include 'COMMON.CONTROL'
4268       real(kind=8),dimension(3) :: ggg
4269       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4270         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4271       real(kind=8),dimension(2) :: auxvec,auxvec1
4272 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4273       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4274 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4275 !el        dz_normi,xmedi,ymedi,zmedi
4276 !el      integer :: num_conti,j1,j2
4277 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4278 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4279 !el          num_conti,j1,j2
4280 !el local variables
4281       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4282       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4283          rlocshield
4284
4285       j=i+3
4286 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4287 !
4288 !               Fourth-order contributions
4289 !
4290 !                 (i+3)o----(i+4)
4291 !                     /  |
4292 !               (i+2)o   |
4293 !                     \  |
4294 !                 (i+1)o----i
4295 !
4296 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4297 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4298 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4299           zj=(c(3,j)+c(3,j+1))/2.0d0
4300           zj=mod(zj,boxzsize)
4301           if (zj.lt.0) zj=zj+boxzsize
4302        if ((zj.gt.bordlipbot)  &
4303         .and.(zj.lt.bordliptop)) then
4304 !C the energy transfer exist
4305         if (zj.lt.buflipbot) then
4306 !C what fraction I am in
4307          fracinbuf=1.0d0-     &
4308              ((zj-bordlipbot)/lipbufthick)
4309 !C lipbufthick is thickenes of lipid buffore
4310          sslipj=sscalelip(fracinbuf)
4311          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4312         elseif (zj.gt.bufliptop) then
4313          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4314          sslipj=sscalelip(fracinbuf)
4315          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4316         else
4317          sslipj=1.0d0
4318          ssgradlipj=0.0
4319         endif
4320        else
4321          sslipj=0.0d0
4322          ssgradlipj=0.0
4323        endif
4324
4325         a_temp(1,1)=a22
4326         a_temp(1,2)=a23
4327         a_temp(2,1)=a32
4328         a_temp(2,2)=a33
4329         iti1=itortyp(itype(i+1,1))
4330         iti2=itortyp(itype(i+2,1))
4331         iti3=itortyp(itype(i+3,1))
4332 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4333         call transpose2(EUg(1,1,i+1),e1t(1,1))
4334         call transpose2(Eug(1,1,i+2),e2t(1,1))
4335         call transpose2(Eug(1,1,i+3),e3t(1,1))
4336         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4337         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4338         s1=scalar2(b1(1,iti2),auxvec(1))
4339         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4340         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4341         s2=scalar2(b1(1,iti1),auxvec(1))
4342         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4343         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4344         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4345         if (shield_mode.eq.0) then
4346         fac_shield(i)=1.0
4347         fac_shield(j)=1.0
4348         endif
4349
4350         eello_turn4=eello_turn4-(s1+s2+s3) &
4351         *fac_shield(i)*fac_shield(j)       &
4352         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4353         eello_t4=-(s1+s2+s3)  &
4354           *fac_shield(i)*fac_shield(j)
4355 !C Now derivative over shield:
4356           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4357          (shield_mode.gt.0)) then
4358 !C          print *,i,j
4359
4360           do ilist=1,ishield_list(i)
4361            iresshield=shield_list(ilist,i)
4362            do k=1,3
4363            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4364            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4365                    rlocshield &
4366             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4367             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4368            +rlocshield
4369            enddo
4370           enddo
4371           do ilist=1,ishield_list(j)
4372            iresshield=shield_list(ilist,j)
4373            do k=1,3
4374            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4375            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4376                    rlocshield  &
4377            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4378            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4379                   +rlocshield
4380
4381            enddo
4382           enddo
4383
4384           do k=1,3
4385             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4386                    grad_shield(k,i)*eello_t4/fac_shield(i)
4387             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4388                    grad_shield(k,j)*eello_t4/fac_shield(j)
4389             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4390                    grad_shield(k,i)*eello_t4/fac_shield(i)
4391             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4392                    grad_shield(k,j)*eello_t4/fac_shield(j)
4393            enddo
4394            endif
4395
4396         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4397            'eturn4',i,j,-(s1+s2+s3)
4398 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4399 !d     &    ' eello_turn4_num',8*eello_turn4_num
4400 ! Derivatives in gamma(i)
4401         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4402         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4403         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4404         s1=scalar2(b1(1,iti2),auxvec(1))
4405         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4406         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4407         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4408        *fac_shield(i)*fac_shield(j)  &
4409        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4410
4411 ! Derivatives in gamma(i+1)
4412         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4413         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4414         s2=scalar2(b1(1,iti1),auxvec(1))
4415         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4416         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4417         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4418         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4419        *fac_shield(i)*fac_shield(j)  &
4420        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4421
4422 ! Derivatives in gamma(i+2)
4423         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4424         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4425         s1=scalar2(b1(1,iti2),auxvec(1))
4426         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4427         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4428         s2=scalar2(b1(1,iti1),auxvec(1))
4429         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4430         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4431         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4432         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4433        *fac_shield(i)*fac_shield(j)  &
4434        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4435
4436 ! Cartesian derivatives
4437 ! Derivatives of this turn contributions in DC(i+2)
4438         if (j.lt.nres-1) then
4439           do l=1,3
4440             a_temp(1,1)=agg(l,1)
4441             a_temp(1,2)=agg(l,2)
4442             a_temp(2,1)=agg(l,3)
4443             a_temp(2,2)=agg(l,4)
4444             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4445             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4446             s1=scalar2(b1(1,iti2),auxvec(1))
4447             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4448             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4449             s2=scalar2(b1(1,iti1),auxvec(1))
4450             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4451             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4452             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4453             ggg(l)=-(s1+s2+s3)
4454             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4455        *fac_shield(i)*fac_shield(j)  &
4456        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4457
4458           enddo
4459         endif
4460 ! Remaining derivatives of this turn contribution
4461         do l=1,3
4462           a_temp(1,1)=aggi(l,1)
4463           a_temp(1,2)=aggi(l,2)
4464           a_temp(2,1)=aggi(l,3)
4465           a_temp(2,2)=aggi(l,4)
4466           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4467           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4468           s1=scalar2(b1(1,iti2),auxvec(1))
4469           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4470           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4471           s2=scalar2(b1(1,iti1),auxvec(1))
4472           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4473           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4474           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4475           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4476          *fac_shield(i)*fac_shield(j)  &
4477          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4478
4479
4480           a_temp(1,1)=aggi1(l,1)
4481           a_temp(1,2)=aggi1(l,2)
4482           a_temp(2,1)=aggi1(l,3)
4483           a_temp(2,2)=aggi1(l,4)
4484           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4485           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4486           s1=scalar2(b1(1,iti2),auxvec(1))
4487           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4488           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4489           s2=scalar2(b1(1,iti1),auxvec(1))
4490           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4491           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4492           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4493           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4494          *fac_shield(i)*fac_shield(j)  &
4495          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4496
4497
4498           a_temp(1,1)=aggj(l,1)
4499           a_temp(1,2)=aggj(l,2)
4500           a_temp(2,1)=aggj(l,3)
4501           a_temp(2,2)=aggj(l,4)
4502           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4503           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4504           s1=scalar2(b1(1,iti2),auxvec(1))
4505           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4506           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4507           s2=scalar2(b1(1,iti1),auxvec(1))
4508           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4509           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4510           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4511           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4512          *fac_shield(i)*fac_shield(j)  &
4513          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4514
4515
4516           a_temp(1,1)=aggj1(l,1)
4517           a_temp(1,2)=aggj1(l,2)
4518           a_temp(2,1)=aggj1(l,3)
4519           a_temp(2,2)=aggj1(l,4)
4520           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4521           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4522           s1=scalar2(b1(1,iti2),auxvec(1))
4523           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4524           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4525           s2=scalar2(b1(1,iti1),auxvec(1))
4526           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4527           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4528           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4529 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4530           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4531          *fac_shield(i)*fac_shield(j)  &
4532          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4533
4534         enddo
4535          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4536           ssgradlipi*eello_t4/4.0d0*lipscale
4537          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4538           ssgradlipj*eello_t4/4.0d0*lipscale
4539          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4540           ssgradlipi*eello_t4/4.0d0*lipscale
4541          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4542           ssgradlipj*eello_t4/4.0d0*lipscale
4543
4544       return
4545       end subroutine eturn4
4546 !-----------------------------------------------------------------------------
4547       subroutine unormderiv(u,ugrad,unorm,ungrad)
4548 ! This subroutine computes the derivatives of a normalized vector u, given
4549 ! the derivatives computed without normalization conditions, ugrad. Returns
4550 ! ungrad.
4551 !      implicit none
4552       real(kind=8),dimension(3) :: u,vec
4553       real(kind=8),dimension(3,3) ::ugrad,ungrad
4554       real(kind=8) :: unorm     !,scalar
4555       integer :: i,j
4556 !      write (2,*) 'ugrad',ugrad
4557 !      write (2,*) 'u',u
4558       do i=1,3
4559         vec(i)=scalar(ugrad(1,i),u(1))
4560       enddo
4561 !      write (2,*) 'vec',vec
4562       do i=1,3
4563         do j=1,3
4564           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4565         enddo
4566       enddo
4567 !      write (2,*) 'ungrad',ungrad
4568       return
4569       end subroutine unormderiv
4570 !-----------------------------------------------------------------------------
4571       subroutine escp_soft_sphere(evdw2,evdw2_14)
4572 !
4573 ! This subroutine calculates the excluded-volume interaction energy between
4574 ! peptide-group centers and side chains and its gradient in virtual-bond and
4575 ! side-chain vectors.
4576 !
4577 !      implicit real*8 (a-h,o-z)
4578 !      include 'DIMENSIONS'
4579 !      include 'COMMON.GEO'
4580 !      include 'COMMON.VAR'
4581 !      include 'COMMON.LOCAL'
4582 !      include 'COMMON.CHAIN'
4583 !      include 'COMMON.DERIV'
4584 !      include 'COMMON.INTERACT'
4585 !      include 'COMMON.FFIELD'
4586 !      include 'COMMON.IOUNITS'
4587 !      include 'COMMON.CONTROL'
4588       real(kind=8),dimension(3) :: ggg
4589 !el local variables
4590       integer :: i,iint,j,k,iteli,itypj
4591       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4592                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4593
4594       evdw2=0.0D0
4595       evdw2_14=0.0d0
4596       r0_scp=4.5d0
4597 !d    print '(a)','Enter ESCP'
4598 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4599       do i=iatscp_s,iatscp_e
4600         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4601         iteli=itel(i)
4602         xi=0.5D0*(c(1,i)+c(1,i+1))
4603         yi=0.5D0*(c(2,i)+c(2,i+1))
4604         zi=0.5D0*(c(3,i)+c(3,i+1))
4605
4606         do iint=1,nscp_gr(i)
4607
4608         do j=iscpstart(i,iint),iscpend(i,iint)
4609           if (itype(j,1).eq.ntyp1) cycle
4610           itypj=iabs(itype(j,1))
4611 ! Uncomment following three lines for SC-p interactions
4612 !         xj=c(1,nres+j)-xi
4613 !         yj=c(2,nres+j)-yi
4614 !         zj=c(3,nres+j)-zi
4615 ! Uncomment following three lines for Ca-p interactions
4616           xj=c(1,j)-xi
4617           yj=c(2,j)-yi
4618           zj=c(3,j)-zi
4619           rij=xj*xj+yj*yj+zj*zj
4620           r0ij=r0_scp
4621           r0ijsq=r0ij*r0ij
4622           if (rij.lt.r0ijsq) then
4623             evdwij=0.25d0*(rij-r0ijsq)**2
4624             fac=rij-r0ijsq
4625           else
4626             evdwij=0.0d0
4627             fac=0.0d0
4628           endif
4629           evdw2=evdw2+evdwij
4630 !
4631 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4632 !
4633           ggg(1)=xj*fac
4634           ggg(2)=yj*fac
4635           ggg(3)=zj*fac
4636 !grad          if (j.lt.i) then
4637 !d          write (iout,*) 'j<i'
4638 ! Uncomment following three lines for SC-p interactions
4639 !           do k=1,3
4640 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4641 !           enddo
4642 !grad          else
4643 !d          write (iout,*) 'j>i'
4644 !grad            do k=1,3
4645 !grad              ggg(k)=-ggg(k)
4646 ! Uncomment following line for SC-p interactions
4647 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4648 !grad            enddo
4649 !grad          endif
4650 !grad          do k=1,3
4651 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4652 !grad          enddo
4653 !grad          kstart=min0(i+1,j)
4654 !grad          kend=max0(i-1,j-1)
4655 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4656 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4657 !grad          do k=kstart,kend
4658 !grad            do l=1,3
4659 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4660 !grad            enddo
4661 !grad          enddo
4662           do k=1,3
4663             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4664             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4665           enddo
4666         enddo
4667
4668         enddo ! iint
4669       enddo ! i
4670       return
4671       end subroutine escp_soft_sphere
4672 !-----------------------------------------------------------------------------
4673       subroutine escp(evdw2,evdw2_14)
4674 !
4675 ! This subroutine calculates the excluded-volume interaction energy between
4676 ! peptide-group centers and side chains and its gradient in virtual-bond and
4677 ! side-chain vectors.
4678 !
4679 !      implicit real*8 (a-h,o-z)
4680 !      include 'DIMENSIONS'
4681 !      include 'COMMON.GEO'
4682 !      include 'COMMON.VAR'
4683 !      include 'COMMON.LOCAL'
4684 !      include 'COMMON.CHAIN'
4685 !      include 'COMMON.DERIV'
4686 !      include 'COMMON.INTERACT'
4687 !      include 'COMMON.FFIELD'
4688 !      include 'COMMON.IOUNITS'
4689 !      include 'COMMON.CONTROL'
4690       real(kind=8),dimension(3) :: ggg
4691 !el local variables
4692       integer :: i,iint,j,k,iteli,itypj,subchap
4693       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4694                    e1,e2,evdwij,rij
4695       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4696                     dist_temp, dist_init
4697       integer xshift,yshift,zshift
4698
4699       evdw2=0.0D0
4700       evdw2_14=0.0d0
4701 !d    print '(a)','Enter ESCP'
4702 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4703       do i=iatscp_s,iatscp_e
4704         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4705         iteli=itel(i)
4706         xi=0.5D0*(c(1,i)+c(1,i+1))
4707         yi=0.5D0*(c(2,i)+c(2,i+1))
4708         zi=0.5D0*(c(3,i)+c(3,i+1))
4709           xi=mod(xi,boxxsize)
4710           if (xi.lt.0) xi=xi+boxxsize
4711           yi=mod(yi,boxysize)
4712           if (yi.lt.0) yi=yi+boxysize
4713           zi=mod(zi,boxzsize)
4714           if (zi.lt.0) zi=zi+boxzsize
4715
4716         do iint=1,nscp_gr(i)
4717
4718         do j=iscpstart(i,iint),iscpend(i,iint)
4719           itypj=iabs(itype(j,1))
4720           if (itypj.eq.ntyp1) cycle
4721 ! Uncomment following three lines for SC-p interactions
4722 !         xj=c(1,nres+j)-xi
4723 !         yj=c(2,nres+j)-yi
4724 !         zj=c(3,nres+j)-zi
4725 ! Uncomment following three lines for Ca-p interactions
4726 !          xj=c(1,j)-xi
4727 !          yj=c(2,j)-yi
4728 !          zj=c(3,j)-zi
4729           xj=c(1,j)
4730           yj=c(2,j)
4731           zj=c(3,j)
4732           xj=mod(xj,boxxsize)
4733           if (xj.lt.0) xj=xj+boxxsize
4734           yj=mod(yj,boxysize)
4735           if (yj.lt.0) yj=yj+boxysize
4736           zj=mod(zj,boxzsize)
4737           if (zj.lt.0) zj=zj+boxzsize
4738       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4739       xj_safe=xj
4740       yj_safe=yj
4741       zj_safe=zj
4742       subchap=0
4743       do xshift=-1,1
4744       do yshift=-1,1
4745       do zshift=-1,1
4746           xj=xj_safe+xshift*boxxsize
4747           yj=yj_safe+yshift*boxysize
4748           zj=zj_safe+zshift*boxzsize
4749           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4750           if(dist_temp.lt.dist_init) then
4751             dist_init=dist_temp
4752             xj_temp=xj
4753             yj_temp=yj
4754             zj_temp=zj
4755             subchap=1
4756           endif
4757        enddo
4758        enddo
4759        enddo
4760        if (subchap.eq.1) then
4761           xj=xj_temp-xi
4762           yj=yj_temp-yi
4763           zj=zj_temp-zi
4764        else
4765           xj=xj_safe-xi
4766           yj=yj_safe-yi
4767           zj=zj_safe-zi
4768        endif
4769
4770           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4771           rij=dsqrt(1.0d0/rrij)
4772             sss_ele_cut=sscale_ele(rij)
4773             sss_ele_grad=sscagrad_ele(rij)
4774 !            print *,sss_ele_cut,sss_ele_grad,&
4775 !            (rij),r_cut_ele,rlamb_ele
4776             if (sss_ele_cut.le.0.0) cycle
4777           fac=rrij**expon2
4778           e1=fac*fac*aad(itypj,iteli)
4779           e2=fac*bad(itypj,iteli)
4780           if (iabs(j-i) .le. 2) then
4781             e1=scal14*e1
4782             e2=scal14*e2
4783             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4784           endif
4785           evdwij=e1+e2
4786           evdw2=evdw2+evdwij*sss_ele_cut
4787 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4788 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4789           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4790              'evdw2',i,j,evdwij
4791 !
4792 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4793 !
4794           fac=-(evdwij+e1)*rrij*sss_ele_cut
4795           fac=fac+evdwij*sss_ele_grad/rij/expon
4796           ggg(1)=xj*fac
4797           ggg(2)=yj*fac
4798           ggg(3)=zj*fac
4799 !grad          if (j.lt.i) then
4800 !d          write (iout,*) 'j<i'
4801 ! Uncomment following three lines for SC-p interactions
4802 !           do k=1,3
4803 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4804 !           enddo
4805 !grad          else
4806 !d          write (iout,*) 'j>i'
4807 !grad            do k=1,3
4808 !grad              ggg(k)=-ggg(k)
4809 ! Uncomment following line for SC-p interactions
4810 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4811 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4812 !grad            enddo
4813 !grad          endif
4814 !grad          do k=1,3
4815 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4816 !grad          enddo
4817 !grad          kstart=min0(i+1,j)
4818 !grad          kend=max0(i-1,j-1)
4819 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4820 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4821 !grad          do k=kstart,kend
4822 !grad            do l=1,3
4823 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4824 !grad            enddo
4825 !grad          enddo
4826           do k=1,3
4827             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4828             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4829           enddo
4830         enddo
4831
4832         enddo ! iint
4833       enddo ! i
4834       do i=1,nct
4835         do j=1,3
4836           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4837           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4838           gradx_scp(j,i)=expon*gradx_scp(j,i)
4839         enddo
4840       enddo
4841 !******************************************************************************
4842 !
4843 !                              N O T E !!!
4844 !
4845 ! To save time the factor EXPON has been extracted from ALL components
4846 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4847 ! use!
4848 !
4849 !******************************************************************************
4850       return
4851       end subroutine escp
4852 !-----------------------------------------------------------------------------
4853       subroutine edis(ehpb)
4854 !
4855 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4856 !
4857 !      implicit real*8 (a-h,o-z)
4858 !      include 'DIMENSIONS'
4859 !      include 'COMMON.SBRIDGE'
4860 !      include 'COMMON.CHAIN'
4861 !      include 'COMMON.DERIV'
4862 !      include 'COMMON.VAR'
4863 !      include 'COMMON.INTERACT'
4864 !      include 'COMMON.IOUNITS'
4865       real(kind=8),dimension(3) :: ggg
4866 !el local variables
4867       integer :: i,j,ii,jj,iii,jjj,k
4868       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4869
4870       ehpb=0.0D0
4871 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4872 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4873       if (link_end.eq.0) return
4874       do i=link_start,link_end
4875 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4876 ! CA-CA distance used in regularization of structure.
4877         ii=ihpb(i)
4878         jj=jhpb(i)
4879 ! iii and jjj point to the residues for which the distance is assigned.
4880         if (ii.gt.nres) then
4881           iii=ii-nres
4882           jjj=jj-nres
4883         else
4884           iii=ii
4885           jjj=jj
4886         endif
4887 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4888 !     &    dhpb(i),dhpb1(i),forcon(i)
4889 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4890 !    distance and angle dependent SS bond potential.
4891 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4892 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4893         if (.not.dyn_ss .and. i.le.nss) then
4894 ! 15/02/13 CC dynamic SSbond - additional check
4895          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
4896         iabs(itype(jjj,1)).eq.1) then
4897           call ssbond_ene(iii,jjj,eij)
4898           ehpb=ehpb+2*eij
4899 !d          write (iout,*) "eij",eij
4900          endif
4901         else if (ii.gt.nres .and. jj.gt.nres) then
4902 !c Restraints from contact prediction
4903           dd=dist(ii,jj)
4904           if (constr_dist.eq.11) then
4905             ehpb=ehpb+fordepth(i)**4.0d0 &
4906                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4907             fac=fordepth(i)**4.0d0 &
4908                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4909           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
4910             ehpb,fordepth(i),dd
4911            else
4912           if (dhpb1(i).gt.0.0d0) then
4913             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4914             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4915 !c            write (iout,*) "beta nmr",
4916 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4917           else
4918             dd=dist(ii,jj)
4919             rdis=dd-dhpb(i)
4920 !C Get the force constant corresponding to this distance.
4921             waga=forcon(i)
4922 !C Calculate the contribution to energy.
4923             ehpb=ehpb+waga*rdis*rdis
4924 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4925 !C
4926 !C Evaluate gradient.
4927 !C
4928             fac=waga*rdis/dd
4929           endif
4930           endif
4931           do j=1,3
4932             ggg(j)=fac*(c(j,jj)-c(j,ii))
4933           enddo
4934           do j=1,3
4935             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4936             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4937           enddo
4938           do k=1,3
4939             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4940             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4941           enddo
4942         else
4943           dd=dist(ii,jj)
4944           if (constr_dist.eq.11) then
4945             ehpb=ehpb+fordepth(i)**4.0d0 &
4946                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4947             fac=fordepth(i)**4.0d0 &
4948                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4949           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
4950          ehpb,fordepth(i),dd
4951            else
4952           if (dhpb1(i).gt.0.0d0) then
4953             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4954             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4955 !c            write (iout,*) "alph nmr",
4956 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4957           else
4958             rdis=dd-dhpb(i)
4959 !C Get the force constant corresponding to this distance.
4960             waga=forcon(i)
4961 !C Calculate the contribution to energy.
4962             ehpb=ehpb+waga*rdis*rdis
4963 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4964 !C
4965 !C Evaluate gradient.
4966 !C
4967             fac=waga*rdis/dd
4968           endif
4969           endif
4970
4971             do j=1,3
4972               ggg(j)=fac*(c(j,jj)-c(j,ii))
4973             enddo
4974 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4975 !C If this is a SC-SC distance, we need to calculate the contributions to the
4976 !C Cartesian gradient in the SC vectors (ghpbx).
4977           if (iii.lt.ii) then
4978           do j=1,3
4979             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4980             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4981           enddo
4982           endif
4983 !cgrad        do j=iii,jjj-1
4984 !cgrad          do k=1,3
4985 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4986 !cgrad          enddo
4987 !cgrad        enddo
4988           do k=1,3
4989             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4990             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4991           enddo
4992         endif
4993       enddo
4994       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4995
4996       return
4997       end subroutine edis
4998 !-----------------------------------------------------------------------------
4999       subroutine ssbond_ene(i,j,eij)
5000 !
5001 ! Calculate the distance and angle dependent SS-bond potential energy
5002 ! using a free-energy function derived based on RHF/6-31G** ab initio
5003 ! calculations of diethyl disulfide.
5004 !
5005 ! A. Liwo and U. Kozlowska, 11/24/03
5006 !
5007 !      implicit real*8 (a-h,o-z)
5008 !      include 'DIMENSIONS'
5009 !      include 'COMMON.SBRIDGE'
5010 !      include 'COMMON.CHAIN'
5011 !      include 'COMMON.DERIV'
5012 !      include 'COMMON.LOCAL'
5013 !      include 'COMMON.INTERACT'
5014 !      include 'COMMON.VAR'
5015 !      include 'COMMON.IOUNITS'
5016       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5017 !el local variables
5018       integer :: i,j,itypi,itypj,k
5019       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5020                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5021                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5022                    cosphi,ggk
5023
5024       itypi=iabs(itype(i,1))
5025       xi=c(1,nres+i)
5026       yi=c(2,nres+i)
5027       zi=c(3,nres+i)
5028       dxi=dc_norm(1,nres+i)
5029       dyi=dc_norm(2,nres+i)
5030       dzi=dc_norm(3,nres+i)
5031 !      dsci_inv=dsc_inv(itypi)
5032       dsci_inv=vbld_inv(nres+i)
5033       itypj=iabs(itype(j,1))
5034 !      dscj_inv=dsc_inv(itypj)
5035       dscj_inv=vbld_inv(nres+j)
5036       xj=c(1,nres+j)-xi
5037       yj=c(2,nres+j)-yi
5038       zj=c(3,nres+j)-zi
5039       dxj=dc_norm(1,nres+j)
5040       dyj=dc_norm(2,nres+j)
5041       dzj=dc_norm(3,nres+j)
5042       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5043       rij=dsqrt(rrij)
5044       erij(1)=xj*rij
5045       erij(2)=yj*rij
5046       erij(3)=zj*rij
5047       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5048       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5049       om12=dxi*dxj+dyi*dyj+dzi*dzj
5050       do k=1,3
5051         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5052         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5053       enddo
5054       rij=1.0d0/rij
5055       deltad=rij-d0cm
5056       deltat1=1.0d0-om1
5057       deltat2=1.0d0+om2
5058       deltat12=om2-om1+2.0d0
5059       cosphi=om12-om1*om2
5060       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5061         +akct*deltad*deltat12 &
5062         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5063 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5064 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5065 !     &  " deltat12",deltat12," eij",eij
5066       ed=2*akcm*deltad+akct*deltat12
5067       pom1=akct*deltad
5068       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5069       eom1=-2*akth*deltat1-pom1-om2*pom2
5070       eom2= 2*akth*deltat2+pom1-om1*pom2
5071       eom12=pom2
5072       do k=1,3
5073         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5074         ghpbx(k,i)=ghpbx(k,i)-ggk &
5075                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5076                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5077         ghpbx(k,j)=ghpbx(k,j)+ggk &
5078                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5079                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5080         ghpbc(k,i)=ghpbc(k,i)-ggk
5081         ghpbc(k,j)=ghpbc(k,j)+ggk
5082       enddo
5083 !
5084 ! Calculate the components of the gradient in DC and X
5085 !
5086 !grad      do k=i,j-1
5087 !grad        do l=1,3
5088 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5089 !grad        enddo
5090 !grad      enddo
5091       return
5092       end subroutine ssbond_ene
5093 !-----------------------------------------------------------------------------
5094       subroutine ebond(estr)
5095 !
5096 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5097 !
5098 !      implicit real*8 (a-h,o-z)
5099 !      include 'DIMENSIONS'
5100 !      include 'COMMON.LOCAL'
5101 !      include 'COMMON.GEO'
5102 !      include 'COMMON.INTERACT'
5103 !      include 'COMMON.DERIV'
5104 !      include 'COMMON.VAR'
5105 !      include 'COMMON.CHAIN'
5106 !      include 'COMMON.IOUNITS'
5107 !      include 'COMMON.NAMES'
5108 !      include 'COMMON.FFIELD'
5109 !      include 'COMMON.CONTROL'
5110 !      include 'COMMON.SETUP'
5111       real(kind=8),dimension(3) :: u,ud
5112 !el local variables
5113       integer :: i,j,iti,nbi,k
5114       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5115                    uprod1,uprod2
5116
5117       estr=0.0d0
5118       estr1=0.0d0
5119 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5120 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5121
5122       do i=ibondp_start,ibondp_end
5123         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5124         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5125 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5126 !C          do j=1,3
5127 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5128 !C            *dc(j,i-1)/vbld(i)
5129 !C          enddo
5130 !C          if (energy_dec) write(iout,*) &
5131 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5132         diff = vbld(i)-vbldpDUM
5133         else
5134         diff = vbld(i)-vbldp0
5135         endif
5136         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5137            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5138         estr=estr+diff*diff
5139         do j=1,3
5140           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5141         enddo
5142 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5143 !        endif
5144       enddo
5145       estr=0.5d0*AKP*estr+estr1
5146 !
5147 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5148 !
5149       do i=ibond_start,ibond_end
5150         iti=iabs(itype(i,1))
5151         if (iti.ne.10 .and. iti.ne.ntyp1) then
5152           nbi=nbondterm(iti)
5153           if (nbi.eq.1) then
5154             diff=vbld(i+nres)-vbldsc0(1,iti)
5155             if (energy_dec) write (iout,*) &
5156             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5157             AKSC(1,iti),AKSC(1,iti)*diff*diff
5158             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5159             do j=1,3
5160               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5161             enddo
5162           else
5163             do j=1,nbi
5164               diff=vbld(i+nres)-vbldsc0(j,iti)
5165               ud(j)=aksc(j,iti)*diff
5166               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5167             enddo
5168             uprod=u(1)
5169             do j=2,nbi
5170               uprod=uprod*u(j)
5171             enddo
5172             usum=0.0d0
5173             usumsqder=0.0d0
5174             do j=1,nbi
5175               uprod1=1.0d0
5176               uprod2=1.0d0
5177               do k=1,nbi
5178                 if (k.ne.j) then
5179                   uprod1=uprod1*u(k)
5180                   uprod2=uprod2*u(k)*u(k)
5181                 endif
5182               enddo
5183               usum=usum+uprod1
5184               usumsqder=usumsqder+ud(j)*uprod2
5185             enddo
5186             estr=estr+uprod/usum
5187             if (energy_dec) write (iout,*) &
5188             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5189             AKSC(1,iti),AKSC(1,iti)*diff*diff
5190             do j=1,3
5191              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5192             enddo
5193           endif
5194         endif
5195       enddo
5196       return
5197       end subroutine ebond
5198 #ifdef CRYST_THETA
5199 !-----------------------------------------------------------------------------
5200       subroutine ebend(etheta)
5201 !
5202 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5203 ! angles gamma and its derivatives in consecutive thetas and gammas.
5204 !
5205       use comm_calcthet
5206 !      implicit real*8 (a-h,o-z)
5207 !      include 'DIMENSIONS'
5208 !      include 'COMMON.LOCAL'
5209 !      include 'COMMON.GEO'
5210 !      include 'COMMON.INTERACT'
5211 !      include 'COMMON.DERIV'
5212 !      include 'COMMON.VAR'
5213 !      include 'COMMON.CHAIN'
5214 !      include 'COMMON.IOUNITS'
5215 !      include 'COMMON.NAMES'
5216 !      include 'COMMON.FFIELD'
5217 !      include 'COMMON.CONTROL'
5218 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5219 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5220 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5221 !el      integer :: it
5222 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5223 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5224 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5225 !el local variables
5226       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5227        ichir21,ichir22
5228       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5229        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5230        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5231       real(kind=8),dimension(2) :: y,z
5232
5233       delta=0.02d0*pi
5234 !      time11=dexp(-2*time)
5235 !      time12=1.0d0
5236       etheta=0.0D0
5237 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5238       do i=ithet_start,ithet_end
5239         if (itype(i-1,1).eq.ntyp1) cycle
5240 ! Zero the energy function and its derivative at 0 or pi.
5241         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5242         it=itype(i-1,1)
5243         ichir1=isign(1,itype(i-2,1))
5244         ichir2=isign(1,itype(i,1))
5245          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5246          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5247          if (itype(i-1,1).eq.10) then
5248           itype1=isign(10,itype(i-2,1))
5249           ichir11=isign(1,itype(i-2,1))
5250           ichir12=isign(1,itype(i-2,1))
5251           itype2=isign(10,itype(i,1))
5252           ichir21=isign(1,itype(i,1))
5253           ichir22=isign(1,itype(i,1))
5254          endif
5255
5256         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5257 #ifdef OSF
5258           phii=phi(i)
5259           if (phii.ne.phii) phii=150.0
5260 #else
5261           phii=phi(i)
5262 #endif
5263           y(1)=dcos(phii)
5264           y(2)=dsin(phii)
5265         else
5266           y(1)=0.0D0
5267           y(2)=0.0D0
5268         endif
5269         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5270 #ifdef OSF
5271           phii1=phi(i+1)
5272           if (phii1.ne.phii1) phii1=150.0
5273           phii1=pinorm(phii1)
5274           z(1)=cos(phii1)
5275 #else
5276           phii1=phi(i+1)
5277           z(1)=dcos(phii1)
5278 #endif
5279           z(2)=dsin(phii1)
5280         else
5281           z(1)=0.0D0
5282           z(2)=0.0D0
5283         endif
5284 ! Calculate the "mean" value of theta from the part of the distribution
5285 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5286 ! In following comments this theta will be referred to as t_c.
5287         thet_pred_mean=0.0d0
5288         do k=1,2
5289             athetk=athet(k,it,ichir1,ichir2)
5290             bthetk=bthet(k,it,ichir1,ichir2)
5291           if (it.eq.10) then
5292              athetk=athet(k,itype1,ichir11,ichir12)
5293              bthetk=bthet(k,itype2,ichir21,ichir22)
5294           endif
5295          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5296         enddo
5297         dthett=thet_pred_mean*ssd
5298         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5299 ! Derivatives of the "mean" values in gamma1 and gamma2.
5300         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5301                +athet(2,it,ichir1,ichir2)*y(1))*ss
5302         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5303                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5304          if (it.eq.10) then
5305         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5306              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5307         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5308                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5309          endif
5310         if (theta(i).gt.pi-delta) then
5311           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5312                E_tc0)
5313           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5314           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5315           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5316               E_theta)
5317           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5318               E_tc)
5319         else if (theta(i).lt.delta) then
5320           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5321           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5322           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5323               E_theta)
5324           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5325           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5326               E_tc)
5327         else
5328           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5329               E_theta,E_tc)
5330         endif
5331         etheta=etheta+ethetai
5332         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5333             'ebend',i,ethetai
5334         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5335         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5336         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5337       enddo
5338 ! Ufff.... We've done all this!!!
5339       return
5340       end subroutine ebend
5341 !-----------------------------------------------------------------------------
5342       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5343
5344       use comm_calcthet
5345 !      implicit real*8 (a-h,o-z)
5346 !      include 'DIMENSIONS'
5347 !      include 'COMMON.LOCAL'
5348 !      include 'COMMON.IOUNITS'
5349 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5350 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5351 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5352       integer :: i,j,k
5353       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5354 !el      integer :: it
5355 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5356 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5357 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5358 !el local variables
5359       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5360        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5361
5362 ! Calculate the contributions to both Gaussian lobes.
5363 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5364 ! The "polynomial part" of the "standard deviation" of this part of
5365 ! the distribution.
5366         sig=polthet(3,it)
5367         do j=2,0,-1
5368           sig=sig*thet_pred_mean+polthet(j,it)
5369         enddo
5370 ! Derivative of the "interior part" of the "standard deviation of the"
5371 ! gamma-dependent Gaussian lobe in t_c.
5372         sigtc=3*polthet(3,it)
5373         do j=2,1,-1
5374           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5375         enddo
5376         sigtc=sig*sigtc
5377 ! Set the parameters of both Gaussian lobes of the distribution.
5378 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5379         fac=sig*sig+sigc0(it)
5380         sigcsq=fac+fac
5381         sigc=1.0D0/sigcsq
5382 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5383         sigsqtc=-4.0D0*sigcsq*sigtc
5384 !       print *,i,sig,sigtc,sigsqtc
5385 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5386         sigtc=-sigtc/(fac*fac)
5387 ! Following variable is sigma(t_c)**(-2)
5388         sigcsq=sigcsq*sigcsq
5389         sig0i=sig0(it)
5390         sig0inv=1.0D0/sig0i**2
5391         delthec=thetai-thet_pred_mean
5392         delthe0=thetai-theta0i
5393         term1=-0.5D0*sigcsq*delthec*delthec
5394         term2=-0.5D0*sig0inv*delthe0*delthe0
5395 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5396 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5397 ! to the energy (this being the log of the distribution) at the end of energy
5398 ! term evaluation for this virtual-bond angle.
5399         if (term1.gt.term2) then
5400           termm=term1
5401           term2=dexp(term2-termm)
5402           term1=1.0d0
5403         else
5404           termm=term2
5405           term1=dexp(term1-termm)
5406           term2=1.0d0
5407         endif
5408 ! The ratio between the gamma-independent and gamma-dependent lobes of
5409 ! the distribution is a Gaussian function of thet_pred_mean too.
5410         diffak=gthet(2,it)-thet_pred_mean
5411         ratak=diffak/gthet(3,it)**2
5412         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5413 ! Let's differentiate it in thet_pred_mean NOW.
5414         aktc=ak*ratak
5415 ! Now put together the distribution terms to make complete distribution.
5416         termexp=term1+ak*term2
5417         termpre=sigc+ak*sig0i
5418 ! Contribution of the bending energy from this theta is just the -log of
5419 ! the sum of the contributions from the two lobes and the pre-exponential
5420 ! factor. Simple enough, isn't it?
5421         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5422 ! NOW the derivatives!!!
5423 ! 6/6/97 Take into account the deformation.
5424         E_theta=(delthec*sigcsq*term1 &
5425              +ak*delthe0*sig0inv*term2)/termexp
5426         E_tc=((sigtc+aktc*sig0i)/termpre &
5427             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5428              aktc*term2)/termexp)
5429       return
5430       end subroutine theteng
5431 #else
5432 !-----------------------------------------------------------------------------
5433       subroutine ebend(etheta,ethetacnstr)
5434 !
5435 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5436 ! angles gamma and its derivatives in consecutive thetas and gammas.
5437 ! ab initio-derived potentials from
5438 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5439 !
5440 !      implicit real*8 (a-h,o-z)
5441 !      include 'DIMENSIONS'
5442 !      include 'COMMON.LOCAL'
5443 !      include 'COMMON.GEO'
5444 !      include 'COMMON.INTERACT'
5445 !      include 'COMMON.DERIV'
5446 !      include 'COMMON.VAR'
5447 !      include 'COMMON.CHAIN'
5448 !      include 'COMMON.IOUNITS'
5449 !      include 'COMMON.NAMES'
5450 !      include 'COMMON.FFIELD'
5451 !      include 'COMMON.CONTROL'
5452       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5453       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5454       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5455       logical :: lprn=.false., lprn1=.false.
5456 !el local variables
5457       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5458       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5459       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5460 ! local variables for constrains
5461       real(kind=8) :: difi,thetiii
5462        integer itheta
5463
5464       etheta=0.0D0
5465       do i=ithet_start,ithet_end
5466         if (itype(i-1,1).eq.ntyp1) cycle
5467         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5468         if (iabs(itype(i+1,1)).eq.20) iblock=2
5469         if (iabs(itype(i+1,1)).ne.20) iblock=1
5470         dethetai=0.0d0
5471         dephii=0.0d0
5472         dephii1=0.0d0
5473         theti2=0.5d0*theta(i)
5474         ityp2=ithetyp((itype(i-1,1)))
5475         do k=1,nntheterm
5476           coskt(k)=dcos(k*theti2)
5477           sinkt(k)=dsin(k*theti2)
5478         enddo
5479         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5480 #ifdef OSF
5481           phii=phi(i)
5482           if (phii.ne.phii) phii=150.0
5483 #else
5484           phii=phi(i)
5485 #endif
5486           ityp1=ithetyp((itype(i-2,1)))
5487 ! propagation of chirality for glycine type
5488           do k=1,nsingle
5489             cosph1(k)=dcos(k*phii)
5490             sinph1(k)=dsin(k*phii)
5491           enddo
5492         else
5493           phii=0.0d0
5494           ityp1=ithetyp(itype(i-2,1))
5495           do k=1,nsingle
5496             cosph1(k)=0.0d0
5497             sinph1(k)=0.0d0
5498           enddo
5499         endif
5500         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5501 #ifdef OSF
5502           phii1=phi(i+1)
5503           if (phii1.ne.phii1) phii1=150.0
5504           phii1=pinorm(phii1)
5505 #else
5506           phii1=phi(i+1)
5507 #endif
5508           ityp3=ithetyp((itype(i,1)))
5509           do k=1,nsingle
5510             cosph2(k)=dcos(k*phii1)
5511             sinph2(k)=dsin(k*phii1)
5512           enddo
5513         else
5514           phii1=0.0d0
5515           ityp3=ithetyp(itype(i,1))
5516           do k=1,nsingle
5517             cosph2(k)=0.0d0
5518             sinph2(k)=0.0d0
5519           enddo
5520         endif
5521         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5522         do k=1,ndouble
5523           do l=1,k-1
5524             ccl=cosph1(l)*cosph2(k-l)
5525             ssl=sinph1(l)*sinph2(k-l)
5526             scl=sinph1(l)*cosph2(k-l)
5527             csl=cosph1(l)*sinph2(k-l)
5528             cosph1ph2(l,k)=ccl-ssl
5529             cosph1ph2(k,l)=ccl+ssl
5530             sinph1ph2(l,k)=scl+csl
5531             sinph1ph2(k,l)=scl-csl
5532           enddo
5533         enddo
5534         if (lprn) then
5535         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5536           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5537         write (iout,*) "coskt and sinkt"
5538         do k=1,nntheterm
5539           write (iout,*) k,coskt(k),sinkt(k)
5540         enddo
5541         endif
5542         do k=1,ntheterm
5543           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5544           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5545             *coskt(k)
5546           if (lprn) &
5547           write (iout,*) "k",k,&
5548            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5549            " ethetai",ethetai
5550         enddo
5551         if (lprn) then
5552         write (iout,*) "cosph and sinph"
5553         do k=1,nsingle
5554           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5555         enddo
5556         write (iout,*) "cosph1ph2 and sinph2ph2"
5557         do k=2,ndouble
5558           do l=1,k-1
5559             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5560                sinph1ph2(l,k),sinph1ph2(k,l)
5561           enddo
5562         enddo
5563         write(iout,*) "ethetai",ethetai
5564         endif
5565         do m=1,ntheterm2
5566           do k=1,nsingle
5567             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5568                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5569                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5570                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5571             ethetai=ethetai+sinkt(m)*aux
5572             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5573             dephii=dephii+k*sinkt(m)* &
5574                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5575                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5576             dephii1=dephii1+k*sinkt(m)* &
5577                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5578                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5579             if (lprn) &
5580             write (iout,*) "m",m," k",k," bbthet", &
5581                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5582                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5583                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5584                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5585           enddo
5586         enddo
5587         if (lprn) &
5588         write(iout,*) "ethetai",ethetai
5589         do m=1,ntheterm3
5590           do k=2,ndouble
5591             do l=1,k-1
5592               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5593                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5594                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5595                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5596               ethetai=ethetai+sinkt(m)*aux
5597               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5598               dephii=dephii+l*sinkt(m)* &
5599                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5600                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5601                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5602                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5603               dephii1=dephii1+(k-l)*sinkt(m)* &
5604                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5605                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5606                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5607                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5608               if (lprn) then
5609               write (iout,*) "m",m," k",k," l",l," ffthet",&
5610                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5611                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5612                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5613                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5614                   " ethetai",ethetai
5615               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5616                   cosph1ph2(k,l)*sinkt(m),&
5617                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5618               endif
5619             enddo
5620           enddo
5621         enddo
5622 10      continue
5623 !        lprn1=.true.
5624         if (lprn1) &
5625           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5626          i,theta(i)*rad2deg,phii*rad2deg,&
5627          phii1*rad2deg,ethetai
5628 !        lprn1=.false.
5629         etheta=etheta+ethetai
5630         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5631                                     'ebend',i,ethetai
5632         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5633         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5634         gloc(nphi+i-2,icg)=wang*dethetai
5635       enddo
5636 !-----------thete constrains
5637 !      if (tor_mode.ne.2) then
5638       ethetacnstr=0.0d0
5639 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5640       do i=ithetaconstr_start,ithetaconstr_end
5641         itheta=itheta_constr(i)
5642         thetiii=theta(itheta)
5643         difi=pinorm(thetiii-theta_constr0(i))
5644         if (difi.gt.theta_drange(i)) then
5645           difi=difi-theta_drange(i)
5646           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5647           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5648          +for_thet_constr(i)*difi**3
5649         else if (difi.lt.-drange(i)) then
5650           difi=difi+drange(i)
5651           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5652           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5653          +for_thet_constr(i)*difi**3
5654         else
5655           difi=0.0
5656         endif
5657        if (energy_dec) then
5658         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5659          i,itheta,rad2deg*thetiii, &
5660          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5661          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5662          gloc(itheta+nphi-2,icg)
5663         endif
5664       enddo
5665 !      endif
5666
5667       return
5668       end subroutine ebend
5669 #endif
5670 #ifdef CRYST_SC
5671 !-----------------------------------------------------------------------------
5672       subroutine esc(escloc)
5673 ! Calculate the local energy of a side chain and its derivatives in the
5674 ! corresponding virtual-bond valence angles THETA and the spherical angles
5675 ! ALPHA and OMEGA.
5676 !
5677       use comm_sccalc
5678 !      implicit real*8 (a-h,o-z)
5679 !      include 'DIMENSIONS'
5680 !      include 'COMMON.GEO'
5681 !      include 'COMMON.LOCAL'
5682 !      include 'COMMON.VAR'
5683 !      include 'COMMON.INTERACT'
5684 !      include 'COMMON.DERIV'
5685 !      include 'COMMON.CHAIN'
5686 !      include 'COMMON.IOUNITS'
5687 !      include 'COMMON.NAMES'
5688 !      include 'COMMON.FFIELD'
5689 !      include 'COMMON.CONTROL'
5690       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5691          ddersc0,ddummy,xtemp,temp
5692 !el      real(kind=8) :: time11,time12,time112,theti
5693       real(kind=8) :: escloc,delta
5694 !el      integer :: it,nlobit
5695 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5696 !el local variables
5697       integer :: i,k
5698       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5699        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5700       delta=0.02d0*pi
5701       escloc=0.0D0
5702 !     write (iout,'(a)') 'ESC'
5703       do i=loc_start,loc_end
5704         it=itype(i,1)
5705         if (it.eq.ntyp1) cycle
5706         if (it.eq.10) goto 1
5707         nlobit=nlob(iabs(it))
5708 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5709 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5710         theti=theta(i+1)-pipol
5711         x(1)=dtan(theti)
5712         x(2)=alph(i)
5713         x(3)=omeg(i)
5714
5715         if (x(2).gt.pi-delta) then
5716           xtemp(1)=x(1)
5717           xtemp(2)=pi-delta
5718           xtemp(3)=x(3)
5719           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5720           xtemp(2)=pi
5721           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5722           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5723               escloci,dersc(2))
5724           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5725               ddersc0(1),dersc(1))
5726           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5727               ddersc0(3),dersc(3))
5728           xtemp(2)=pi-delta
5729           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5730           xtemp(2)=pi
5731           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5732           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5733                   dersc0(2),esclocbi,dersc02)
5734           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5735                   dersc12,dersc01)
5736           call splinthet(x(2),0.5d0*delta,ss,ssd)
5737           dersc0(1)=dersc01
5738           dersc0(2)=dersc02
5739           dersc0(3)=0.0d0
5740           do k=1,3
5741             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5742           enddo
5743           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5744 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5745 !    &             esclocbi,ss,ssd
5746           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5747 !         escloci=esclocbi
5748 !         write (iout,*) escloci
5749         else if (x(2).lt.delta) then
5750           xtemp(1)=x(1)
5751           xtemp(2)=delta
5752           xtemp(3)=x(3)
5753           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5754           xtemp(2)=0.0d0
5755           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5756           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5757               escloci,dersc(2))
5758           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5759               ddersc0(1),dersc(1))
5760           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5761               ddersc0(3),dersc(3))
5762           xtemp(2)=delta
5763           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5764           xtemp(2)=0.0d0
5765           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5766           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5767                   dersc0(2),esclocbi,dersc02)
5768           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5769                   dersc12,dersc01)
5770           dersc0(1)=dersc01
5771           dersc0(2)=dersc02
5772           dersc0(3)=0.0d0
5773           call splinthet(x(2),0.5d0*delta,ss,ssd)
5774           do k=1,3
5775             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5776           enddo
5777           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5778 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5779 !    &             esclocbi,ss,ssd
5780           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5781 !         write (iout,*) escloci
5782         else
5783           call enesc(x,escloci,dersc,ddummy,.false.)
5784         endif
5785
5786         escloc=escloc+escloci
5787         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5788            'escloc',i,escloci
5789 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5790
5791         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5792          wscloc*dersc(1)
5793         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5794         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5795     1   continue
5796       enddo
5797       return
5798       end subroutine esc
5799 !-----------------------------------------------------------------------------
5800       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5801
5802       use comm_sccalc
5803 !      implicit real*8 (a-h,o-z)
5804 !      include 'DIMENSIONS'
5805 !      include 'COMMON.GEO'
5806 !      include 'COMMON.LOCAL'
5807 !      include 'COMMON.IOUNITS'
5808 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5809       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5810       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5811       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5812       real(kind=8) :: escloci
5813       logical :: mixed
5814 !el local variables
5815       integer :: j,iii,l,k !el,it,nlobit
5816       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5817 !el       time11,time12,time112
5818 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5819         escloc_i=0.0D0
5820         do j=1,3
5821           dersc(j)=0.0D0
5822           if (mixed) ddersc(j)=0.0d0
5823         enddo
5824         x3=x(3)
5825
5826 ! Because of periodicity of the dependence of the SC energy in omega we have
5827 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5828 ! To avoid underflows, first compute & store the exponents.
5829
5830         do iii=-1,1
5831
5832           x(3)=x3+iii*dwapi
5833
5834           do j=1,nlobit
5835             do k=1,3
5836               z(k)=x(k)-censc(k,j,it)
5837             enddo
5838             do k=1,3
5839               Axk=0.0D0
5840               do l=1,3
5841                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5842               enddo
5843               Ax(k,j,iii)=Axk
5844             enddo
5845             expfac=0.0D0
5846             do k=1,3
5847               expfac=expfac+Ax(k,j,iii)*z(k)
5848             enddo
5849             contr(j,iii)=expfac
5850           enddo ! j
5851
5852         enddo ! iii
5853
5854         x(3)=x3
5855 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5856 ! subsequent NaNs and INFs in energy calculation.
5857 ! Find the largest exponent
5858         emin=contr(1,-1)
5859         do iii=-1,1
5860           do j=1,nlobit
5861             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5862           enddo
5863         enddo
5864         emin=0.5D0*emin
5865 !d      print *,'it=',it,' emin=',emin
5866
5867 ! Compute the contribution to SC energy and derivatives
5868         do iii=-1,1
5869
5870           do j=1,nlobit
5871 #ifdef OSF
5872             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5873             if(adexp.ne.adexp) adexp=1.0
5874             expfac=dexp(adexp)
5875 #else
5876             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5877 #endif
5878 !d          print *,'j=',j,' expfac=',expfac
5879             escloc_i=escloc_i+expfac
5880             do k=1,3
5881               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5882             enddo
5883             if (mixed) then
5884               do k=1,3,2
5885                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5886                   +gaussc(k,2,j,it))*expfac
5887               enddo
5888             endif
5889           enddo
5890
5891         enddo ! iii
5892
5893         dersc(1)=dersc(1)/cos(theti)**2
5894         ddersc(1)=ddersc(1)/cos(theti)**2
5895         ddersc(3)=ddersc(3)
5896
5897         escloci=-(dlog(escloc_i)-emin)
5898         do j=1,3
5899           dersc(j)=dersc(j)/escloc_i
5900         enddo
5901         if (mixed) then
5902           do j=1,3,2
5903             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5904           enddo
5905         endif
5906       return
5907       end subroutine enesc
5908 !-----------------------------------------------------------------------------
5909       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5910
5911       use comm_sccalc
5912 !      implicit real*8 (a-h,o-z)
5913 !      include 'DIMENSIONS'
5914 !      include 'COMMON.GEO'
5915 !      include 'COMMON.LOCAL'
5916 !      include 'COMMON.IOUNITS'
5917 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5918       real(kind=8),dimension(3) :: x,z,dersc
5919       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5920       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5921       real(kind=8) :: escloci,dersc12,emin
5922       logical :: mixed
5923 !el local varables
5924       integer :: j,k,l !el,it,nlobit
5925       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5926
5927       escloc_i=0.0D0
5928
5929       do j=1,3
5930         dersc(j)=0.0D0
5931       enddo
5932
5933       do j=1,nlobit
5934         do k=1,2
5935           z(k)=x(k)-censc(k,j,it)
5936         enddo
5937         z(3)=dwapi
5938         do k=1,3
5939           Axk=0.0D0
5940           do l=1,3
5941             Axk=Axk+gaussc(l,k,j,it)*z(l)
5942           enddo
5943           Ax(k,j)=Axk
5944         enddo
5945         expfac=0.0D0
5946         do k=1,3
5947           expfac=expfac+Ax(k,j)*z(k)
5948         enddo
5949         contr(j)=expfac
5950       enddo ! j
5951
5952 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5953 ! subsequent NaNs and INFs in energy calculation.
5954 ! Find the largest exponent
5955       emin=contr(1)
5956       do j=1,nlobit
5957         if (emin.gt.contr(j)) emin=contr(j)
5958       enddo
5959       emin=0.5D0*emin
5960
5961 ! Compute the contribution to SC energy and derivatives
5962
5963       dersc12=0.0d0
5964       do j=1,nlobit
5965         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5966         escloc_i=escloc_i+expfac
5967         do k=1,2
5968           dersc(k)=dersc(k)+Ax(k,j)*expfac
5969         enddo
5970         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5971                   +gaussc(1,2,j,it))*expfac
5972         dersc(3)=0.0d0
5973       enddo
5974
5975       dersc(1)=dersc(1)/cos(theti)**2
5976       dersc12=dersc12/cos(theti)**2
5977       escloci=-(dlog(escloc_i)-emin)
5978       do j=1,2
5979         dersc(j)=dersc(j)/escloc_i
5980       enddo
5981       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5982       return
5983       end subroutine enesc_bound
5984 #else
5985 !-----------------------------------------------------------------------------
5986       subroutine esc(escloc)
5987 ! Calculate the local energy of a side chain and its derivatives in the
5988 ! corresponding virtual-bond valence angles THETA and the spherical angles
5989 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5990 ! added by Urszula Kozlowska. 07/11/2007
5991 !
5992       use comm_sccalc
5993 !      implicit real*8 (a-h,o-z)
5994 !      include 'DIMENSIONS'
5995 !      include 'COMMON.GEO'
5996 !      include 'COMMON.LOCAL'
5997 !      include 'COMMON.VAR'
5998 !      include 'COMMON.SCROT'
5999 !      include 'COMMON.INTERACT'
6000 !      include 'COMMON.DERIV'
6001 !      include 'COMMON.CHAIN'
6002 !      include 'COMMON.IOUNITS'
6003 !      include 'COMMON.NAMES'
6004 !      include 'COMMON.FFIELD'
6005 !      include 'COMMON.CONTROL'
6006 !      include 'COMMON.VECTORS'
6007       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6008       real(kind=8),dimension(65) :: x
6009       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6010          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6011       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6012       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6013          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6014 !el local variables
6015       integer :: i,j,k !el,it,nlobit
6016       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6017 !el      real(kind=8) :: time11,time12,time112,theti
6018 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6019       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6020                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6021                    sumene1x,sumene2x,sumene3x,sumene4x,&
6022                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6023                    cosfac2xx,sinfac2yy
6024 #ifdef DEBUG
6025       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6026                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6027                    de_dt_num
6028 #endif
6029 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6030
6031       delta=0.02d0*pi
6032       escloc=0.0D0
6033       do i=loc_start,loc_end
6034         if (itype(i,1).eq.ntyp1) cycle
6035         costtab(i+1) =dcos(theta(i+1))
6036         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6037         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6038         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6039         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6040         cosfac=dsqrt(cosfac2)
6041         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6042         sinfac=dsqrt(sinfac2)
6043         it=iabs(itype(i,1))
6044         if (it.eq.10) goto 1
6045 !
6046 !  Compute the axes of tghe local cartesian coordinates system; store in
6047 !   x_prime, y_prime and z_prime
6048 !
6049         do j=1,3
6050           x_prime(j) = 0.00
6051           y_prime(j) = 0.00
6052           z_prime(j) = 0.00
6053         enddo
6054 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6055 !     &   dc_norm(3,i+nres)
6056         do j = 1,3
6057           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6058           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6059         enddo
6060         do j = 1,3
6061           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6062         enddo
6063 !       write (2,*) "i",i
6064 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6065 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6066 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6067 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6068 !      & " xy",scalar(x_prime(1),y_prime(1)),
6069 !      & " xz",scalar(x_prime(1),z_prime(1)),
6070 !      & " yy",scalar(y_prime(1),y_prime(1)),
6071 !      & " yz",scalar(y_prime(1),z_prime(1)),
6072 !      & " zz",scalar(z_prime(1),z_prime(1))
6073 !
6074 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6075 ! to local coordinate system. Store in xx, yy, zz.
6076 !
6077         xx=0.0d0
6078         yy=0.0d0
6079         zz=0.0d0
6080         do j = 1,3
6081           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6082           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6083           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6084         enddo
6085
6086         xxtab(i)=xx
6087         yytab(i)=yy
6088         zztab(i)=zz
6089 !
6090 ! Compute the energy of the ith side cbain
6091 !
6092 !        write (2,*) "xx",xx," yy",yy," zz",zz
6093         it=iabs(itype(i,1))
6094         do j = 1,65
6095           x(j) = sc_parmin(j,it)
6096         enddo
6097 #ifdef CHECK_COORD
6098 !c diagnostics - remove later
6099         xx1 = dcos(alph(2))
6100         yy1 = dsin(alph(2))*dcos(omeg(2))
6101         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6102         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6103           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6104           xx1,yy1,zz1
6105 !,"  --- ", xx_w,yy_w,zz_w
6106 ! end diagnostics
6107 #endif
6108         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6109          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6110          + x(10)*yy*zz
6111         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6112          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6113          + x(20)*yy*zz
6114         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6115          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6116          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6117          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6118          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6119          +x(40)*xx*yy*zz
6120         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6121          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6122          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6123          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6124          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6125          +x(60)*xx*yy*zz
6126         dsc_i   = 0.743d0+x(61)
6127         dp2_i   = 1.9d0+x(62)
6128         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6129                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6130         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6131                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6132         s1=(1+x(63))/(0.1d0 + dscp1)
6133         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6134         s2=(1+x(65))/(0.1d0 + dscp2)
6135         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6136         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6137       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6138 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6139 !     &   sumene4,
6140 !     &   dscp1,dscp2,sumene
6141 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6142         escloc = escloc + sumene
6143 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6144 !     & ,zz,xx,yy
6145 !#define DEBUG
6146 #ifdef DEBUG
6147 !
6148 ! This section to check the numerical derivatives of the energy of ith side
6149 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6150 ! #define DEBUG in the code to turn it on.
6151 !
6152         write (2,*) "sumene               =",sumene
6153         aincr=1.0d-7
6154         xxsave=xx
6155         xx=xx+aincr
6156         write (2,*) xx,yy,zz
6157         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6158         de_dxx_num=(sumenep-sumene)/aincr
6159         xx=xxsave
6160         write (2,*) "xx+ sumene from enesc=",sumenep
6161         yysave=yy
6162         yy=yy+aincr
6163         write (2,*) xx,yy,zz
6164         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6165         de_dyy_num=(sumenep-sumene)/aincr
6166         yy=yysave
6167         write (2,*) "yy+ sumene from enesc=",sumenep
6168         zzsave=zz
6169         zz=zz+aincr
6170         write (2,*) xx,yy,zz
6171         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6172         de_dzz_num=(sumenep-sumene)/aincr
6173         zz=zzsave
6174         write (2,*) "zz+ sumene from enesc=",sumenep
6175         costsave=cost2tab(i+1)
6176         sintsave=sint2tab(i+1)
6177         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6178         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6179         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6180         de_dt_num=(sumenep-sumene)/aincr
6181         write (2,*) " t+ sumene from enesc=",sumenep
6182         cost2tab(i+1)=costsave
6183         sint2tab(i+1)=sintsave
6184 ! End of diagnostics section.
6185 #endif
6186 !
6187 ! Compute the gradient of esc
6188 !
6189 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6190         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6191         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6192         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6193         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6194         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6195         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6196         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6197         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6198         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6199            *(pom_s1/dscp1+pom_s16*dscp1**4)
6200         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6201            *(pom_s2/dscp2+pom_s26*dscp2**4)
6202         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6203         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6204         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6205         +x(40)*yy*zz
6206         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6207         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6208         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6209         +x(60)*yy*zz
6210         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6211               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6212               +(pom1+pom2)*pom_dx
6213 #ifdef DEBUG
6214         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6215 #endif
6216 !
6217         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6218         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6219         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6220         +x(40)*xx*zz
6221         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6222         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6223         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6224         +x(59)*zz**2 +x(60)*xx*zz
6225         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6226               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6227               +(pom1-pom2)*pom_dy
6228 #ifdef DEBUG
6229         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6230 #endif
6231 !
6232         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6233         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6234         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6235         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6236         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6237         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6238         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6239         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6240 #ifdef DEBUG
6241         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6242 #endif
6243 !
6244         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6245         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6246         +pom1*pom_dt1+pom2*pom_dt2
6247 #ifdef DEBUG
6248         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6249 #endif
6250 !
6251 !
6252        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6253        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6254        cosfac2xx=cosfac2*xx
6255        sinfac2yy=sinfac2*yy
6256        do k = 1,3
6257          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6258             vbld_inv(i+1)
6259          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6260             vbld_inv(i)
6261          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6262          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6263 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6264 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6265 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6266 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6267          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6268          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6269          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6270          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6271          dZZ_Ci1(k)=0.0d0
6272          dZZ_Ci(k)=0.0d0
6273          do j=1,3
6274            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6275            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6276            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6277            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6278          enddo
6279
6280          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6281          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6282          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6283          (z_prime(k)-zz*dC_norm(k,i+nres))
6284 !
6285          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6286          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6287        enddo
6288
6289        do k=1,3
6290          dXX_Ctab(k,i)=dXX_Ci(k)
6291          dXX_C1tab(k,i)=dXX_Ci1(k)
6292          dYY_Ctab(k,i)=dYY_Ci(k)
6293          dYY_C1tab(k,i)=dYY_Ci1(k)
6294          dZZ_Ctab(k,i)=dZZ_Ci(k)
6295          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6296          dXX_XYZtab(k,i)=dXX_XYZ(k)
6297          dYY_XYZtab(k,i)=dYY_XYZ(k)
6298          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6299        enddo
6300
6301        do k = 1,3
6302 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6303 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6304 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6305 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6306 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6307 !     &    dt_dci(k)
6308 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6309 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6310          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6311           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6312          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6313           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6314          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6315           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6316        enddo
6317 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6318 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6319
6320 ! to check gradient call subroutine check_grad
6321
6322     1 continue
6323       enddo
6324       return
6325       end subroutine esc
6326 !-----------------------------------------------------------------------------
6327       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6328 !      implicit none
6329       real(kind=8),dimension(65) :: x
6330       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6331         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6332
6333       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6334         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6335         + x(10)*yy*zz
6336       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6337         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6338         + x(20)*yy*zz
6339       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6340         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6341         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6342         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6343         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6344         +x(40)*xx*yy*zz
6345       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6346         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6347         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6348         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6349         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6350         +x(60)*xx*yy*zz
6351       dsc_i   = 0.743d0+x(61)
6352       dp2_i   = 1.9d0+x(62)
6353       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6354                 *(xx*cost2+yy*sint2))
6355       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6356                 *(xx*cost2-yy*sint2))
6357       s1=(1+x(63))/(0.1d0 + dscp1)
6358       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6359       s2=(1+x(65))/(0.1d0 + dscp2)
6360       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6361       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6362        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6363       enesc=sumene
6364       return
6365       end function enesc
6366 #endif
6367 !-----------------------------------------------------------------------------
6368       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6369 !
6370 ! This procedure calculates two-body contact function g(rij) and its derivative:
6371 !
6372 !           eps0ij                                     !       x < -1
6373 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6374 !            0                                         !       x > 1
6375 !
6376 ! where x=(rij-r0ij)/delta
6377 !
6378 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6379 !
6380 !      implicit none
6381       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6382       real(kind=8) :: x,x2,x4,delta
6383 !     delta=0.02D0*r0ij
6384 !      delta=0.2D0*r0ij
6385       x=(rij-r0ij)/delta
6386       if (x.lt.-1.0D0) then
6387         fcont=eps0ij
6388         fprimcont=0.0D0
6389       else if (x.le.1.0D0) then
6390         x2=x*x
6391         x4=x2*x2
6392         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6393         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6394       else
6395         fcont=0.0D0
6396         fprimcont=0.0D0
6397       endif
6398       return
6399       end subroutine gcont
6400 !-----------------------------------------------------------------------------
6401       subroutine splinthet(theti,delta,ss,ssder)
6402 !      implicit real*8 (a-h,o-z)
6403 !      include 'DIMENSIONS'
6404 !      include 'COMMON.VAR'
6405 !      include 'COMMON.GEO'
6406       real(kind=8) :: theti,delta,ss,ssder
6407       real(kind=8) :: thetup,thetlow
6408       thetup=pi-delta
6409       thetlow=delta
6410       if (theti.gt.pipol) then
6411         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6412       else
6413         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6414         ssder=-ssder
6415       endif
6416       return
6417       end subroutine splinthet
6418 !-----------------------------------------------------------------------------
6419       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6420 !      implicit none
6421       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6422       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6423       a1=fprim0*delta/(f1-f0)
6424       a2=3.0d0-2.0d0*a1
6425       a3=a1-2.0d0
6426       ksi=(x-x0)/delta
6427       ksi2=ksi*ksi
6428       ksi3=ksi2*ksi
6429       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6430       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6431       return
6432       end subroutine spline1
6433 !-----------------------------------------------------------------------------
6434       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6435 !      implicit none
6436       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6437       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6438       ksi=(x-x0)/delta
6439       ksi2=ksi*ksi
6440       ksi3=ksi2*ksi
6441       a1=fprim0x*delta
6442       a2=3*(f1x-f0x)-2*fprim0x*delta
6443       a3=fprim0x*delta-2*(f1x-f0x)
6444       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6445       return
6446       end subroutine spline2
6447 !-----------------------------------------------------------------------------
6448 #ifdef CRYST_TOR
6449 !-----------------------------------------------------------------------------
6450       subroutine etor(etors,edihcnstr)
6451 !      implicit real*8 (a-h,o-z)
6452 !      include 'DIMENSIONS'
6453 !      include 'COMMON.VAR'
6454 !      include 'COMMON.GEO'
6455 !      include 'COMMON.LOCAL'
6456 !      include 'COMMON.TORSION'
6457 !      include 'COMMON.INTERACT'
6458 !      include 'COMMON.DERIV'
6459 !      include 'COMMON.CHAIN'
6460 !      include 'COMMON.NAMES'
6461 !      include 'COMMON.IOUNITS'
6462 !      include 'COMMON.FFIELD'
6463 !      include 'COMMON.TORCNSTR'
6464 !      include 'COMMON.CONTROL'
6465       real(kind=8) :: etors,edihcnstr
6466       logical :: lprn
6467 !el local variables
6468       integer :: i,j,
6469       real(kind=8) :: phii,fac,etors_ii
6470
6471 ! Set lprn=.true. for debugging
6472       lprn=.false.
6473 !      lprn=.true.
6474       etors=0.0D0
6475       do i=iphi_start,iphi_end
6476       etors_ii=0.0D0
6477         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6478             .or. itype(i,1).eq.ntyp1) cycle
6479         itori=itortyp(itype(i-2,1))
6480         itori1=itortyp(itype(i-1,1))
6481         phii=phi(i)
6482         gloci=0.0D0
6483 ! Proline-Proline pair is a special case...
6484         if (itori.eq.3 .and. itori1.eq.3) then
6485           if (phii.gt.-dwapi3) then
6486             cosphi=dcos(3*phii)
6487             fac=1.0D0/(1.0D0-cosphi)
6488             etorsi=v1(1,3,3)*fac
6489             etorsi=etorsi+etorsi
6490             etors=etors+etorsi-v1(1,3,3)
6491             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6492             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6493           endif
6494           do j=1,3
6495             v1ij=v1(j+1,itori,itori1)
6496             v2ij=v2(j+1,itori,itori1)
6497             cosphi=dcos(j*phii)
6498             sinphi=dsin(j*phii)
6499             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6500             if (energy_dec) etors_ii=etors_ii+ &
6501                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6502             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6503           enddo
6504         else
6505           do j=1,nterm_old
6506             v1ij=v1(j,itori,itori1)
6507             v2ij=v2(j,itori,itori1)
6508             cosphi=dcos(j*phii)
6509             sinphi=dsin(j*phii)
6510             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6511             if (energy_dec) etors_ii=etors_ii+ &
6512                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6513             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6514           enddo
6515         endif
6516         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6517              'etor',i,etors_ii
6518         if (lprn) &
6519         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6520         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6521         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6522         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6523 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6524       enddo
6525 ! 6/20/98 - dihedral angle constraints
6526       edihcnstr=0.0d0
6527       do i=1,ndih_constr
6528         itori=idih_constr(i)
6529         phii=phi(itori)
6530         difi=phii-phi0(i)
6531         if (difi.gt.drange(i)) then
6532           difi=difi-drange(i)
6533           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6534           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6535         else if (difi.lt.-drange(i)) then
6536           difi=difi+drange(i)
6537           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6538           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6539         endif
6540 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6541 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6542       enddo
6543 !      write (iout,*) 'edihcnstr',edihcnstr
6544       return
6545       end subroutine etor
6546 !-----------------------------------------------------------------------------
6547       subroutine etor_d(etors_d)
6548       real(kind=8) :: etors_d
6549       etors_d=0.0d0
6550       return
6551       end subroutine etor_d
6552 #else
6553 !-----------------------------------------------------------------------------
6554       subroutine etor(etors,edihcnstr)
6555 !      implicit real*8 (a-h,o-z)
6556 !      include 'DIMENSIONS'
6557 !      include 'COMMON.VAR'
6558 !      include 'COMMON.GEO'
6559 !      include 'COMMON.LOCAL'
6560 !      include 'COMMON.TORSION'
6561 !      include 'COMMON.INTERACT'
6562 !      include 'COMMON.DERIV'
6563 !      include 'COMMON.CHAIN'
6564 !      include 'COMMON.NAMES'
6565 !      include 'COMMON.IOUNITS'
6566 !      include 'COMMON.FFIELD'
6567 !      include 'COMMON.TORCNSTR'
6568 !      include 'COMMON.CONTROL'
6569       real(kind=8) :: etors,edihcnstr
6570       logical :: lprn
6571 !el local variables
6572       integer :: i,j,iblock,itori,itori1
6573       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6574                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6575 ! Set lprn=.true. for debugging
6576       lprn=.false.
6577 !     lprn=.true.
6578       etors=0.0D0
6579       do i=iphi_start,iphi_end
6580         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6581              .or. itype(i-3,1).eq.ntyp1 &
6582              .or. itype(i,1).eq.ntyp1) cycle
6583         etors_ii=0.0D0
6584          if (iabs(itype(i,1)).eq.20) then
6585          iblock=2
6586          else
6587          iblock=1
6588          endif
6589         itori=itortyp(itype(i-2,1))
6590         itori1=itortyp(itype(i-1,1))
6591         phii=phi(i)
6592         gloci=0.0D0
6593 ! Regular cosine and sine terms
6594         do j=1,nterm(itori,itori1,iblock)
6595           v1ij=v1(j,itori,itori1,iblock)
6596           v2ij=v2(j,itori,itori1,iblock)
6597           cosphi=dcos(j*phii)
6598           sinphi=dsin(j*phii)
6599           etors=etors+v1ij*cosphi+v2ij*sinphi
6600           if (energy_dec) etors_ii=etors_ii+ &
6601                      v1ij*cosphi+v2ij*sinphi
6602           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6603         enddo
6604 ! Lorentz terms
6605 !                         v1
6606 !  E = SUM ----------------------------------- - v1
6607 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6608 !
6609         cosphi=dcos(0.5d0*phii)
6610         sinphi=dsin(0.5d0*phii)
6611         do j=1,nlor(itori,itori1,iblock)
6612           vl1ij=vlor1(j,itori,itori1)
6613           vl2ij=vlor2(j,itori,itori1)
6614           vl3ij=vlor3(j,itori,itori1)
6615           pom=vl2ij*cosphi+vl3ij*sinphi
6616           pom1=1.0d0/(pom*pom+1.0d0)
6617           etors=etors+vl1ij*pom1
6618           if (energy_dec) etors_ii=etors_ii+ &
6619                      vl1ij*pom1
6620           pom=-pom*pom1*pom1
6621           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6622         enddo
6623 ! Subtract the constant term
6624         etors=etors-v0(itori,itori1,iblock)
6625           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6626                'etor',i,etors_ii-v0(itori,itori1,iblock)
6627         if (lprn) &
6628         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6629         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6630         (v1(j,itori,itori1,iblock),j=1,6),&
6631         (v2(j,itori,itori1,iblock),j=1,6)
6632         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6633 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6634       enddo
6635 ! 6/20/98 - dihedral angle constraints
6636       edihcnstr=0.0d0
6637 !      do i=1,ndih_constr
6638       do i=idihconstr_start,idihconstr_end
6639         itori=idih_constr(i)
6640         phii=phi(itori)
6641         difi=pinorm(phii-phi0(i))
6642         if (difi.gt.drange(i)) then
6643           difi=difi-drange(i)
6644           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6645           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6646         else if (difi.lt.-drange(i)) then
6647           difi=difi+drange(i)
6648           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6649           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6650         else
6651           difi=0.0
6652         endif
6653 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6654 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6655 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6656       enddo
6657 !d       write (iout,*) 'edihcnstr',edihcnstr
6658       return
6659       end subroutine etor
6660 !-----------------------------------------------------------------------------
6661       subroutine etor_d(etors_d)
6662 ! 6/23/01 Compute double torsional energy
6663 !      implicit real*8 (a-h,o-z)
6664 !      include 'DIMENSIONS'
6665 !      include 'COMMON.VAR'
6666 !      include 'COMMON.GEO'
6667 !      include 'COMMON.LOCAL'
6668 !      include 'COMMON.TORSION'
6669 !      include 'COMMON.INTERACT'
6670 !      include 'COMMON.DERIV'
6671 !      include 'COMMON.CHAIN'
6672 !      include 'COMMON.NAMES'
6673 !      include 'COMMON.IOUNITS'
6674 !      include 'COMMON.FFIELD'
6675 !      include 'COMMON.TORCNSTR'
6676       real(kind=8) :: etors_d,etors_d_ii
6677       logical :: lprn
6678 !el local variables
6679       integer :: i,j,k,l,itori,itori1,itori2,iblock
6680       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6681                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6682                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6683                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6684 ! Set lprn=.true. for debugging
6685       lprn=.false.
6686 !     lprn=.true.
6687       etors_d=0.0D0
6688 !      write(iout,*) "a tu??"
6689       do i=iphid_start,iphid_end
6690         etors_d_ii=0.0D0
6691         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6692             .or. itype(i-3,1).eq.ntyp1 &
6693             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6694         itori=itortyp(itype(i-2,1))
6695         itori1=itortyp(itype(i-1,1))
6696         itori2=itortyp(itype(i,1))
6697         phii=phi(i)
6698         phii1=phi(i+1)
6699         gloci1=0.0D0
6700         gloci2=0.0D0
6701         iblock=1
6702         if (iabs(itype(i+1,1)).eq.20) iblock=2
6703
6704 ! Regular cosine and sine terms
6705         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6706           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6707           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6708           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6709           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6710           cosphi1=dcos(j*phii)
6711           sinphi1=dsin(j*phii)
6712           cosphi2=dcos(j*phii1)
6713           sinphi2=dsin(j*phii1)
6714           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6715            v2cij*cosphi2+v2sij*sinphi2
6716           if (energy_dec) etors_d_ii=etors_d_ii+ &
6717            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6718           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6719           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6720         enddo
6721         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6722           do l=1,k-1
6723             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6724             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6725             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6726             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6727             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6728             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6729             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6730             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6731             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6732               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6733             if (energy_dec) etors_d_ii=etors_d_ii+ &
6734               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6735               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6736             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6737               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6738             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6739               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6740           enddo
6741         enddo
6742         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6743                             'etor_d',i,etors_d_ii
6744         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6745         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6746       enddo
6747       return
6748       end subroutine etor_d
6749 #endif
6750 !-----------------------------------------------------------------------------
6751       subroutine eback_sc_corr(esccor)
6752 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6753 !        conformational states; temporarily implemented as differences
6754 !        between UNRES torsional potentials (dependent on three types of
6755 !        residues) and the torsional potentials dependent on all 20 types
6756 !        of residues computed from AM1  energy surfaces of terminally-blocked
6757 !        amino-acid residues.
6758 !      implicit real*8 (a-h,o-z)
6759 !      include 'DIMENSIONS'
6760 !      include 'COMMON.VAR'
6761 !      include 'COMMON.GEO'
6762 !      include 'COMMON.LOCAL'
6763 !      include 'COMMON.TORSION'
6764 !      include 'COMMON.SCCOR'
6765 !      include 'COMMON.INTERACT'
6766 !      include 'COMMON.DERIV'
6767 !      include 'COMMON.CHAIN'
6768 !      include 'COMMON.NAMES'
6769 !      include 'COMMON.IOUNITS'
6770 !      include 'COMMON.FFIELD'
6771 !      include 'COMMON.CONTROL'
6772       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6773                    cosphi,sinphi
6774       logical :: lprn
6775       integer :: i,interty,j,isccori,isccori1,intertyp
6776 ! Set lprn=.true. for debugging
6777       lprn=.false.
6778 !      lprn=.true.
6779 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6780       esccor=0.0D0
6781       do i=itau_start,itau_end
6782         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
6783         esccor_ii=0.0D0
6784         isccori=isccortyp(itype(i-2,1))
6785         isccori1=isccortyp(itype(i-1,1))
6786
6787 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6788         phii=phi(i)
6789         do intertyp=1,3 !intertyp
6790          esccor_ii=0.0D0
6791 !c Added 09 May 2012 (Adasko)
6792 !c  Intertyp means interaction type of backbone mainchain correlation:
6793 !   1 = SC...Ca...Ca...Ca
6794 !   2 = Ca...Ca...Ca...SC
6795 !   3 = SC...Ca...Ca...SCi
6796         gloci=0.0D0
6797         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
6798             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
6799             (itype(i-1,1).eq.ntyp1))) &
6800           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
6801            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
6802            .or.(itype(i,1).eq.ntyp1))) &
6803           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
6804             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
6805             (itype(i-3,1).eq.ntyp1)))) cycle
6806         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
6807         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
6808        cycle
6809        do j=1,nterm_sccor(isccori,isccori1)
6810           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6811           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6812           cosphi=dcos(j*tauangle(intertyp,i))
6813           sinphi=dsin(j*tauangle(intertyp,i))
6814           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6815           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6816           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6817         enddo
6818         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6819                                 'esccor',i,intertyp,esccor_ii
6820 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6821         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6822         if (lprn) &
6823         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6824         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
6825         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6826         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6827         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6828        enddo !intertyp
6829       enddo
6830
6831       return
6832       end subroutine eback_sc_corr
6833 !-----------------------------------------------------------------------------
6834       subroutine multibody(ecorr)
6835 ! This subroutine calculates multi-body contributions to energy following
6836 ! the idea of Skolnick et al. If side chains I and J make a contact and
6837 ! at the same time side chains I+1 and J+1 make a contact, an extra
6838 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6839 !      implicit real*8 (a-h,o-z)
6840 !      include 'DIMENSIONS'
6841 !      include 'COMMON.IOUNITS'
6842 !      include 'COMMON.DERIV'
6843 !      include 'COMMON.INTERACT'
6844 !      include 'COMMON.CONTACTS'
6845       real(kind=8),dimension(3) :: gx,gx1
6846       logical :: lprn
6847       real(kind=8) :: ecorr
6848       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6849 ! Set lprn=.true. for debugging
6850       lprn=.false.
6851
6852       if (lprn) then
6853         write (iout,'(a)') 'Contact function values:'
6854         do i=nnt,nct-2
6855           write (iout,'(i2,20(1x,i2,f10.5))') &
6856               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6857         enddo
6858       endif
6859       ecorr=0.0D0
6860
6861 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6862 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6863       do i=nnt,nct
6864         do j=1,3
6865           gradcorr(j,i)=0.0D0
6866           gradxorr(j,i)=0.0D0
6867         enddo
6868       enddo
6869       do i=nnt,nct-2
6870
6871         DO ISHIFT = 3,4
6872
6873         i1=i+ishift
6874         num_conti=num_cont(i)
6875         num_conti1=num_cont(i1)
6876         do jj=1,num_conti
6877           j=jcont(jj,i)
6878           do kk=1,num_conti1
6879             j1=jcont(kk,i1)
6880             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6881 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6882 !d   &                   ' ishift=',ishift
6883 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6884 ! The system gains extra energy.
6885               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6886             endif   ! j1==j+-ishift
6887           enddo     ! kk
6888         enddo       ! jj
6889
6890         ENDDO ! ISHIFT
6891
6892       enddo         ! i
6893       return
6894       end subroutine multibody
6895 !-----------------------------------------------------------------------------
6896       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6897 !      implicit real*8 (a-h,o-z)
6898 !      include 'DIMENSIONS'
6899 !      include 'COMMON.IOUNITS'
6900 !      include 'COMMON.DERIV'
6901 !      include 'COMMON.INTERACT'
6902 !      include 'COMMON.CONTACTS'
6903       real(kind=8),dimension(3) :: gx,gx1
6904       logical :: lprn
6905       integer :: i,j,k,l,jj,kk,m,ll
6906       real(kind=8) :: eij,ekl
6907       lprn=.false.
6908       eij=facont(jj,i)
6909       ekl=facont(kk,k)
6910 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6911 ! Calculate the multi-body contribution to energy.
6912 ! Calculate multi-body contributions to the gradient.
6913 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6914 !d   & k,l,(gacont(m,kk,k),m=1,3)
6915       do m=1,3
6916         gx(m) =ekl*gacont(m,jj,i)
6917         gx1(m)=eij*gacont(m,kk,k)
6918         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6919         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6920         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6921         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6922       enddo
6923       do m=i,j-1
6924         do ll=1,3
6925           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6926         enddo
6927       enddo
6928       do m=k,l-1
6929         do ll=1,3
6930           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6931         enddo
6932       enddo
6933       esccorr=-eij*ekl
6934       return
6935       end function esccorr
6936 !-----------------------------------------------------------------------------
6937       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6938 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6939 !      implicit real*8 (a-h,o-z)
6940 !      include 'DIMENSIONS'
6941 !      include 'COMMON.IOUNITS'
6942 #ifdef MPI
6943       include "mpif.h"
6944 !      integer :: maxconts !max_cont=maxconts  =nres/4
6945       integer,parameter :: max_dim=26
6946       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6947       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6948 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6949 !el      common /przechowalnia/ zapas
6950       integer :: status(MPI_STATUS_SIZE)
6951       integer,dimension((nres/4)*2) :: req !maxconts*2
6952       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6953 #endif
6954 !      include 'COMMON.SETUP'
6955 !      include 'COMMON.FFIELD'
6956 !      include 'COMMON.DERIV'
6957 !      include 'COMMON.INTERACT'
6958 !      include 'COMMON.CONTACTS'
6959 !      include 'COMMON.CONTROL'
6960 !      include 'COMMON.LOCAL'
6961       real(kind=8),dimension(3) :: gx,gx1
6962       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6963       logical :: lprn,ldone
6964 !el local variables
6965       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6966               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6967
6968 ! Set lprn=.true. for debugging
6969       lprn=.false.
6970 #ifdef MPI
6971 !      maxconts=nres/4
6972       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6973       n_corr=0
6974       n_corr1=0
6975       if (nfgtasks.le.1) goto 30
6976       if (lprn) then
6977         write (iout,'(a)') 'Contact function values before RECEIVE:'
6978         do i=nnt,nct-2
6979           write (iout,'(2i3,50(1x,i2,f5.2))') &
6980           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6981           j=1,num_cont_hb(i))
6982         enddo
6983       endif
6984       call flush(iout)
6985       do i=1,ntask_cont_from
6986         ncont_recv(i)=0
6987       enddo
6988       do i=1,ntask_cont_to
6989         ncont_sent(i)=0
6990       enddo
6991 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6992 !     & ntask_cont_to
6993 ! Make the list of contacts to send to send to other procesors
6994 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6995 !      call flush(iout)
6996       do i=iturn3_start,iturn3_end
6997 !        write (iout,*) "make contact list turn3",i," num_cont",
6998 !     &    num_cont_hb(i)
6999         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7000       enddo
7001       do i=iturn4_start,iturn4_end
7002 !        write (iout,*) "make contact list turn4",i," num_cont",
7003 !     &   num_cont_hb(i)
7004         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7005       enddo
7006       do ii=1,nat_sent
7007         i=iat_sent(ii)
7008 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7009 !     &    num_cont_hb(i)
7010         do j=1,num_cont_hb(i)
7011         do k=1,4
7012           jjc=jcont_hb(j,i)
7013           iproc=iint_sent_local(k,jjc,ii)
7014 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7015           if (iproc.gt.0) then
7016             ncont_sent(iproc)=ncont_sent(iproc)+1
7017             nn=ncont_sent(iproc)
7018             zapas(1,nn,iproc)=i
7019             zapas(2,nn,iproc)=jjc
7020             zapas(3,nn,iproc)=facont_hb(j,i)
7021             zapas(4,nn,iproc)=ees0p(j,i)
7022             zapas(5,nn,iproc)=ees0m(j,i)
7023             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7024             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7025             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7026             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7027             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7028             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7029             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7030             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7031             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7032             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7033             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7034             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7035             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7036             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7037             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7038             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7039             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7040             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7041             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7042             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7043             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7044           endif
7045         enddo
7046         enddo
7047       enddo
7048       if (lprn) then
7049       write (iout,*) &
7050         "Numbers of contacts to be sent to other processors",&
7051         (ncont_sent(i),i=1,ntask_cont_to)
7052       write (iout,*) "Contacts sent"
7053       do ii=1,ntask_cont_to
7054         nn=ncont_sent(ii)
7055         iproc=itask_cont_to(ii)
7056         write (iout,*) nn," contacts to processor",iproc,&
7057          " of CONT_TO_COMM group"
7058         do i=1,nn
7059           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7060         enddo
7061       enddo
7062       call flush(iout)
7063       endif
7064       CorrelType=477
7065       CorrelID=fg_rank+1
7066       CorrelType1=478
7067       CorrelID1=nfgtasks+fg_rank+1
7068       ireq=0
7069 ! Receive the numbers of needed contacts from other processors
7070       do ii=1,ntask_cont_from
7071         iproc=itask_cont_from(ii)
7072         ireq=ireq+1
7073         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7074           FG_COMM,req(ireq),IERR)
7075       enddo
7076 !      write (iout,*) "IRECV ended"
7077 !      call flush(iout)
7078 ! Send the number of contacts needed by other processors
7079       do ii=1,ntask_cont_to
7080         iproc=itask_cont_to(ii)
7081         ireq=ireq+1
7082         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7083           FG_COMM,req(ireq),IERR)
7084       enddo
7085 !      write (iout,*) "ISEND ended"
7086 !      write (iout,*) "number of requests (nn)",ireq
7087       call flush(iout)
7088       if (ireq.gt.0) &
7089         call MPI_Waitall(ireq,req,status_array,ierr)
7090 !      write (iout,*)
7091 !     &  "Numbers of contacts to be received from other processors",
7092 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7093 !      call flush(iout)
7094 ! Receive contacts
7095       ireq=0
7096       do ii=1,ntask_cont_from
7097         iproc=itask_cont_from(ii)
7098         nn=ncont_recv(ii)
7099 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7100 !     &   " of CONT_TO_COMM group"
7101         call flush(iout)
7102         if (nn.gt.0) then
7103           ireq=ireq+1
7104           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7105           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7106 !          write (iout,*) "ireq,req",ireq,req(ireq)
7107         endif
7108       enddo
7109 ! Send the contacts to processors that need them
7110       do ii=1,ntask_cont_to
7111         iproc=itask_cont_to(ii)
7112         nn=ncont_sent(ii)
7113 !        write (iout,*) nn," contacts to processor",iproc,
7114 !     &   " of CONT_TO_COMM group"
7115         if (nn.gt.0) then
7116           ireq=ireq+1
7117           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7118             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7119 !          write (iout,*) "ireq,req",ireq,req(ireq)
7120 !          do i=1,nn
7121 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7122 !          enddo
7123         endif
7124       enddo
7125 !      write (iout,*) "number of requests (contacts)",ireq
7126 !      write (iout,*) "req",(req(i),i=1,4)
7127 !      call flush(iout)
7128       if (ireq.gt.0) &
7129        call MPI_Waitall(ireq,req,status_array,ierr)
7130       do iii=1,ntask_cont_from
7131         iproc=itask_cont_from(iii)
7132         nn=ncont_recv(iii)
7133         if (lprn) then
7134         write (iout,*) "Received",nn," contacts from processor",iproc,&
7135          " of CONT_FROM_COMM group"
7136         call flush(iout)
7137         do i=1,nn
7138           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7139         enddo
7140         call flush(iout)
7141         endif
7142         do i=1,nn
7143           ii=zapas_recv(1,i,iii)
7144 ! Flag the received contacts to prevent double-counting
7145           jj=-zapas_recv(2,i,iii)
7146 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7147 !          call flush(iout)
7148           nnn=num_cont_hb(ii)+1
7149           num_cont_hb(ii)=nnn
7150           jcont_hb(nnn,ii)=jj
7151           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7152           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7153           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7154           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7155           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7156           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7157           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7158           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7159           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7160           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7161           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7162           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7163           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7164           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7165           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7166           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7167           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7168           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7169           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7170           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7171           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7172           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7173           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7174           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7175         enddo
7176       enddo
7177       call flush(iout)
7178       if (lprn) then
7179         write (iout,'(a)') 'Contact function values after receive:'
7180         do i=nnt,nct-2
7181           write (iout,'(2i3,50(1x,i3,f5.2))') &
7182           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7183           j=1,num_cont_hb(i))
7184         enddo
7185         call flush(iout)
7186       endif
7187    30 continue
7188 #endif
7189       if (lprn) then
7190         write (iout,'(a)') 'Contact function values:'
7191         do i=nnt,nct-2
7192           write (iout,'(2i3,50(1x,i3,f5.2))') &
7193           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7194           j=1,num_cont_hb(i))
7195         enddo
7196       endif
7197       ecorr=0.0D0
7198
7199 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7200 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7201 ! Remove the loop below after debugging !!!
7202       do i=nnt,nct
7203         do j=1,3
7204           gradcorr(j,i)=0.0D0
7205           gradxorr(j,i)=0.0D0
7206         enddo
7207       enddo
7208 ! Calculate the local-electrostatic correlation terms
7209       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7210         i1=i+1
7211         num_conti=num_cont_hb(i)
7212         num_conti1=num_cont_hb(i+1)
7213         do jj=1,num_conti
7214           j=jcont_hb(jj,i)
7215           jp=iabs(j)
7216           do kk=1,num_conti1
7217             j1=jcont_hb(kk,i1)
7218             jp1=iabs(j1)
7219 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7220 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7221             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7222                 .or. j.lt.0 .and. j1.gt.0) .and. &
7223                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7224 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7225 ! The system gains extra energy.
7226               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7227               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7228                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7229               n_corr=n_corr+1
7230             else if (j1.eq.j) then
7231 ! Contacts I-J and I-(J+1) occur simultaneously.
7232 ! The system loses extra energy.
7233 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7234             endif
7235           enddo ! kk
7236           do kk=1,num_conti
7237             j1=jcont_hb(kk,i)
7238 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7239 !    &         ' jj=',jj,' kk=',kk
7240             if (j1.eq.j+1) then
7241 ! Contacts I-J and (I+1)-J occur simultaneously.
7242 ! The system loses extra energy.
7243 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7244             endif ! j1==j+1
7245           enddo ! kk
7246         enddo ! jj
7247       enddo ! i
7248       return
7249       end subroutine multibody_hb
7250 !-----------------------------------------------------------------------------
7251       subroutine add_hb_contact(ii,jj,itask)
7252 !      implicit real*8 (a-h,o-z)
7253 !      include "DIMENSIONS"
7254 !      include "COMMON.IOUNITS"
7255 !      include "COMMON.CONTACTS"
7256 !      integer,parameter :: maxconts=nres/4
7257       integer,parameter :: max_dim=26
7258       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7259 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7260 !      common /przechowalnia/ zapas
7261       integer :: i,j,ii,jj,iproc,nn,jjc
7262       integer,dimension(4) :: itask
7263 !      write (iout,*) "itask",itask
7264       do i=1,2
7265         iproc=itask(i)
7266         if (iproc.gt.0) then
7267           do j=1,num_cont_hb(ii)
7268             jjc=jcont_hb(j,ii)
7269 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7270             if (jjc.eq.jj) then
7271               ncont_sent(iproc)=ncont_sent(iproc)+1
7272               nn=ncont_sent(iproc)
7273               zapas(1,nn,iproc)=ii
7274               zapas(2,nn,iproc)=jjc
7275               zapas(3,nn,iproc)=facont_hb(j,ii)
7276               zapas(4,nn,iproc)=ees0p(j,ii)
7277               zapas(5,nn,iproc)=ees0m(j,ii)
7278               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7279               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7280               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7281               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7282               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7283               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7284               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7285               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7286               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7287               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7288               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7289               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7290               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7291               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7292               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7293               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7294               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7295               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7296               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7297               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7298               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7299               exit
7300             endif
7301           enddo
7302         endif
7303       enddo
7304       return
7305       end subroutine add_hb_contact
7306 !-----------------------------------------------------------------------------
7307       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7308 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7309 !      implicit real*8 (a-h,o-z)
7310 !      include 'DIMENSIONS'
7311 !      include 'COMMON.IOUNITS'
7312       integer,parameter :: max_dim=70
7313 #ifdef MPI
7314       include "mpif.h"
7315 !      integer :: maxconts !max_cont=maxconts=nres/4
7316       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7317       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7318 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7319 !      common /przechowalnia/ zapas
7320       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7321         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7322         ierr,iii,nnn
7323 #endif
7324 !      include 'COMMON.SETUP'
7325 !      include 'COMMON.FFIELD'
7326 !      include 'COMMON.DERIV'
7327 !      include 'COMMON.LOCAL'
7328 !      include 'COMMON.INTERACT'
7329 !      include 'COMMON.CONTACTS'
7330 !      include 'COMMON.CHAIN'
7331 !      include 'COMMON.CONTROL'
7332       real(kind=8),dimension(3) :: gx,gx1
7333       integer,dimension(nres) :: num_cont_hb_old
7334       logical :: lprn,ldone
7335 !EL      double precision eello4,eello5,eelo6,eello_turn6
7336 !EL      external eello4,eello5,eello6,eello_turn6
7337 !el local variables
7338       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7339               j1,jp1,i1,num_conti1
7340       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7341       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7342
7343 ! Set lprn=.true. for debugging
7344       lprn=.false.
7345       eturn6=0.0d0
7346 #ifdef MPI
7347 !      maxconts=nres/4
7348       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7349       do i=1,nres
7350         num_cont_hb_old(i)=num_cont_hb(i)
7351       enddo
7352       n_corr=0
7353       n_corr1=0
7354       if (nfgtasks.le.1) goto 30
7355       if (lprn) then
7356         write (iout,'(a)') 'Contact function values before RECEIVE:'
7357         do i=nnt,nct-2
7358           write (iout,'(2i3,50(1x,i2,f5.2))') &
7359           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7360           j=1,num_cont_hb(i))
7361         enddo
7362       endif
7363       call flush(iout)
7364       do i=1,ntask_cont_from
7365         ncont_recv(i)=0
7366       enddo
7367       do i=1,ntask_cont_to
7368         ncont_sent(i)=0
7369       enddo
7370 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7371 !     & ntask_cont_to
7372 ! Make the list of contacts to send to send to other procesors
7373       do i=iturn3_start,iturn3_end
7374 !        write (iout,*) "make contact list turn3",i," num_cont",
7375 !     &    num_cont_hb(i)
7376         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7377       enddo
7378       do i=iturn4_start,iturn4_end
7379 !        write (iout,*) "make contact list turn4",i," num_cont",
7380 !     &   num_cont_hb(i)
7381         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7382       enddo
7383       do ii=1,nat_sent
7384         i=iat_sent(ii)
7385 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7386 !     &    num_cont_hb(i)
7387         do j=1,num_cont_hb(i)
7388         do k=1,4
7389           jjc=jcont_hb(j,i)
7390           iproc=iint_sent_local(k,jjc,ii)
7391 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7392           if (iproc.ne.0) then
7393             ncont_sent(iproc)=ncont_sent(iproc)+1
7394             nn=ncont_sent(iproc)
7395             zapas(1,nn,iproc)=i
7396             zapas(2,nn,iproc)=jjc
7397             zapas(3,nn,iproc)=d_cont(j,i)
7398             ind=3
7399             do kk=1,3
7400               ind=ind+1
7401               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7402             enddo
7403             do kk=1,2
7404               do ll=1,2
7405                 ind=ind+1
7406                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7407               enddo
7408             enddo
7409             do jj=1,5
7410               do kk=1,3
7411                 do ll=1,2
7412                   do mm=1,2
7413                     ind=ind+1
7414                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7415                   enddo
7416                 enddo
7417               enddo
7418             enddo
7419           endif
7420         enddo
7421         enddo
7422       enddo
7423       if (lprn) then
7424       write (iout,*) &
7425         "Numbers of contacts to be sent to other processors",&
7426         (ncont_sent(i),i=1,ntask_cont_to)
7427       write (iout,*) "Contacts sent"
7428       do ii=1,ntask_cont_to
7429         nn=ncont_sent(ii)
7430         iproc=itask_cont_to(ii)
7431         write (iout,*) nn," contacts to processor",iproc,&
7432          " of CONT_TO_COMM group"
7433         do i=1,nn
7434           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7435         enddo
7436       enddo
7437       call flush(iout)
7438       endif
7439       CorrelType=477
7440       CorrelID=fg_rank+1
7441       CorrelType1=478
7442       CorrelID1=nfgtasks+fg_rank+1
7443       ireq=0
7444 ! Receive the numbers of needed contacts from other processors
7445       do ii=1,ntask_cont_from
7446         iproc=itask_cont_from(ii)
7447         ireq=ireq+1
7448         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7449           FG_COMM,req(ireq),IERR)
7450       enddo
7451 !      write (iout,*) "IRECV ended"
7452 !      call flush(iout)
7453 ! Send the number of contacts needed by other processors
7454       do ii=1,ntask_cont_to
7455         iproc=itask_cont_to(ii)
7456         ireq=ireq+1
7457         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7458           FG_COMM,req(ireq),IERR)
7459       enddo
7460 !      write (iout,*) "ISEND ended"
7461 !      write (iout,*) "number of requests (nn)",ireq
7462       call flush(iout)
7463       if (ireq.gt.0) &
7464         call MPI_Waitall(ireq,req,status_array,ierr)
7465 !      write (iout,*)
7466 !     &  "Numbers of contacts to be received from other processors",
7467 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7468 !      call flush(iout)
7469 ! Receive contacts
7470       ireq=0
7471       do ii=1,ntask_cont_from
7472         iproc=itask_cont_from(ii)
7473         nn=ncont_recv(ii)
7474 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7475 !     &   " of CONT_TO_COMM group"
7476         call flush(iout)
7477         if (nn.gt.0) then
7478           ireq=ireq+1
7479           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7480           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7481 !          write (iout,*) "ireq,req",ireq,req(ireq)
7482         endif
7483       enddo
7484 ! Send the contacts to processors that need them
7485       do ii=1,ntask_cont_to
7486         iproc=itask_cont_to(ii)
7487         nn=ncont_sent(ii)
7488 !        write (iout,*) nn," contacts to processor",iproc,
7489 !     &   " of CONT_TO_COMM group"
7490         if (nn.gt.0) then
7491           ireq=ireq+1
7492           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7493             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7494 !          write (iout,*) "ireq,req",ireq,req(ireq)
7495 !          do i=1,nn
7496 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7497 !          enddo
7498         endif
7499       enddo
7500 !      write (iout,*) "number of requests (contacts)",ireq
7501 !      write (iout,*) "req",(req(i),i=1,4)
7502 !      call flush(iout)
7503       if (ireq.gt.0) &
7504        call MPI_Waitall(ireq,req,status_array,ierr)
7505       do iii=1,ntask_cont_from
7506         iproc=itask_cont_from(iii)
7507         nn=ncont_recv(iii)
7508         if (lprn) then
7509         write (iout,*) "Received",nn," contacts from processor",iproc,&
7510          " of CONT_FROM_COMM group"
7511         call flush(iout)
7512         do i=1,nn
7513           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7514         enddo
7515         call flush(iout)
7516         endif
7517         do i=1,nn
7518           ii=zapas_recv(1,i,iii)
7519 ! Flag the received contacts to prevent double-counting
7520           jj=-zapas_recv(2,i,iii)
7521 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7522 !          call flush(iout)
7523           nnn=num_cont_hb(ii)+1
7524           num_cont_hb(ii)=nnn
7525           jcont_hb(nnn,ii)=jj
7526           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7527           ind=3
7528           do kk=1,3
7529             ind=ind+1
7530             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7531           enddo
7532           do kk=1,2
7533             do ll=1,2
7534               ind=ind+1
7535               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7536             enddo
7537           enddo
7538           do jj=1,5
7539             do kk=1,3
7540               do ll=1,2
7541                 do mm=1,2
7542                   ind=ind+1
7543                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7544                 enddo
7545               enddo
7546             enddo
7547           enddo
7548         enddo
7549       enddo
7550       call flush(iout)
7551       if (lprn) then
7552         write (iout,'(a)') 'Contact function values after receive:'
7553         do i=nnt,nct-2
7554           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7555           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7556           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7557         enddo
7558         call flush(iout)
7559       endif
7560    30 continue
7561 #endif
7562       if (lprn) then
7563         write (iout,'(a)') 'Contact function values:'
7564         do i=nnt,nct-2
7565           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7566           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7567           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7568         enddo
7569       endif
7570       ecorr=0.0D0
7571       ecorr5=0.0d0
7572       ecorr6=0.0d0
7573
7574 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7575 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7576 ! Remove the loop below after debugging !!!
7577       do i=nnt,nct
7578         do j=1,3
7579           gradcorr(j,i)=0.0D0
7580           gradxorr(j,i)=0.0D0
7581         enddo
7582       enddo
7583 ! Calculate the dipole-dipole interaction energies
7584       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7585       do i=iatel_s,iatel_e+1
7586         num_conti=num_cont_hb(i)
7587         do jj=1,num_conti
7588           j=jcont_hb(jj,i)
7589 #ifdef MOMENT
7590           call dipole(i,j,jj)
7591 #endif
7592         enddo
7593       enddo
7594       endif
7595 ! Calculate the local-electrostatic correlation terms
7596 !                write (iout,*) "gradcorr5 in eello5 before loop"
7597 !                do iii=1,nres
7598 !                  write (iout,'(i5,3f10.5)')
7599 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7600 !                enddo
7601       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7602 !        write (iout,*) "corr loop i",i
7603         i1=i+1
7604         num_conti=num_cont_hb(i)
7605         num_conti1=num_cont_hb(i+1)
7606         do jj=1,num_conti
7607           j=jcont_hb(jj,i)
7608           jp=iabs(j)
7609           do kk=1,num_conti1
7610             j1=jcont_hb(kk,i1)
7611             jp1=iabs(j1)
7612 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7613 !     &         ' jj=',jj,' kk=',kk
7614 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7615             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7616                 .or. j.lt.0 .and. j1.gt.0) .and. &
7617                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7618 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7619 ! The system gains extra energy.
7620               n_corr=n_corr+1
7621               sqd1=dsqrt(d_cont(jj,i))
7622               sqd2=dsqrt(d_cont(kk,i1))
7623               sred_geom = sqd1*sqd2
7624               IF (sred_geom.lt.cutoff_corr) THEN
7625                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7626                   ekont,fprimcont)
7627 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7628 !d     &         ' jj=',jj,' kk=',kk
7629                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7630                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7631                 do l=1,3
7632                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7633                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7634                 enddo
7635                 n_corr1=n_corr1+1
7636 !d               write (iout,*) 'sred_geom=',sred_geom,
7637 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7638 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7639 !d               write (iout,*) "g_contij",g_contij
7640 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7641 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7642                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7643                 if (wcorr4.gt.0.0d0) &
7644                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7645                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7646                        write (iout,'(a6,4i5,0pf7.3)') &
7647                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7648 !                write (iout,*) "gradcorr5 before eello5"
7649 !                do iii=1,nres
7650 !                  write (iout,'(i5,3f10.5)')
7651 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7652 !                enddo
7653                 if (wcorr5.gt.0.0d0) &
7654                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7655 !                write (iout,*) "gradcorr5 after eello5"
7656 !                do iii=1,nres
7657 !                  write (iout,'(i5,3f10.5)')
7658 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7659 !                enddo
7660                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7661                        write (iout,'(a6,4i5,0pf7.3)') &
7662                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7663 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7664 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7665                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7666                      .or. wturn6.eq.0.0d0))then
7667 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7668                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7669                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7670                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7671 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7672 !d     &            'ecorr6=',ecorr6
7673 !d                write (iout,'(4e15.5)') sred_geom,
7674 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7675 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7676 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7677                 else if (wturn6.gt.0.0d0 &
7678                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7679 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7680                   eturn6=eturn6+eello_turn6(i,jj,kk)
7681                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7682                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7683 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7684                 endif
7685               ENDIF
7686 1111          continue
7687             endif
7688           enddo ! kk
7689         enddo ! jj
7690       enddo ! i
7691       do i=1,nres
7692         num_cont_hb(i)=num_cont_hb_old(i)
7693       enddo
7694 !                write (iout,*) "gradcorr5 in eello5"
7695 !                do iii=1,nres
7696 !                  write (iout,'(i5,3f10.5)')
7697 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7698 !                enddo
7699       return
7700       end subroutine multibody_eello
7701 !-----------------------------------------------------------------------------
7702       subroutine add_hb_contact_eello(ii,jj,itask)
7703 !      implicit real*8 (a-h,o-z)
7704 !      include "DIMENSIONS"
7705 !      include "COMMON.IOUNITS"
7706 !      include "COMMON.CONTACTS"
7707 !      integer,parameter :: maxconts=nres/4
7708       integer,parameter :: max_dim=70
7709       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7710 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7711 !      common /przechowalnia/ zapas
7712
7713       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7714       integer,dimension(4) ::itask
7715 !      write (iout,*) "itask",itask
7716       do i=1,2
7717         iproc=itask(i)
7718         if (iproc.gt.0) then
7719           do j=1,num_cont_hb(ii)
7720             jjc=jcont_hb(j,ii)
7721 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7722             if (jjc.eq.jj) then
7723               ncont_sent(iproc)=ncont_sent(iproc)+1
7724               nn=ncont_sent(iproc)
7725               zapas(1,nn,iproc)=ii
7726               zapas(2,nn,iproc)=jjc
7727               zapas(3,nn,iproc)=d_cont(j,ii)
7728               ind=3
7729               do kk=1,3
7730                 ind=ind+1
7731                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7732               enddo
7733               do kk=1,2
7734                 do ll=1,2
7735                   ind=ind+1
7736                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7737                 enddo
7738               enddo
7739               do jj=1,5
7740                 do kk=1,3
7741                   do ll=1,2
7742                     do mm=1,2
7743                       ind=ind+1
7744                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7745                     enddo
7746                   enddo
7747                 enddo
7748               enddo
7749               exit
7750             endif
7751           enddo
7752         endif
7753       enddo
7754       return
7755       end subroutine add_hb_contact_eello
7756 !-----------------------------------------------------------------------------
7757       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7758 !      implicit real*8 (a-h,o-z)
7759 !      include 'DIMENSIONS'
7760 !      include 'COMMON.IOUNITS'
7761 !      include 'COMMON.DERIV'
7762 !      include 'COMMON.INTERACT'
7763 !      include 'COMMON.CONTACTS'
7764       real(kind=8),dimension(3) :: gx,gx1
7765       logical :: lprn
7766 !el local variables
7767       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7768       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7769                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7770                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7771                    rlocshield
7772
7773       lprn=.false.
7774       eij=facont_hb(jj,i)
7775       ekl=facont_hb(kk,k)
7776       ees0pij=ees0p(jj,i)
7777       ees0pkl=ees0p(kk,k)
7778       ees0mij=ees0m(jj,i)
7779       ees0mkl=ees0m(kk,k)
7780       ekont=eij*ekl
7781       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7782 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7783 ! Following 4 lines for diagnostics.
7784 !d    ees0pkl=0.0D0
7785 !d    ees0pij=1.0D0
7786 !d    ees0mkl=0.0D0
7787 !d    ees0mij=1.0D0
7788 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7789 !     & 'Contacts ',i,j,
7790 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7791 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7792 !     & 'gradcorr_long'
7793 ! Calculate the multi-body contribution to energy.
7794 !      ecorr=ecorr+ekont*ees
7795 ! Calculate multi-body contributions to the gradient.
7796       coeffpees0pij=coeffp*ees0pij
7797       coeffmees0mij=coeffm*ees0mij
7798       coeffpees0pkl=coeffp*ees0pkl
7799       coeffmees0mkl=coeffm*ees0mkl
7800       do ll=1,3
7801 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7802         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7803         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7804         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7805         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7806         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7807         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7808 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7809         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7810         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7811         coeffmees0mij*gacontm_hb1(ll,kk,k))
7812         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7813         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7814         coeffmees0mij*gacontm_hb2(ll,kk,k))
7815         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7816            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7817            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7818         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7819         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7820         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7821            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7822            coeffmees0mij*gacontm_hb3(ll,kk,k))
7823         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7824         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7825 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7826       enddo
7827 !      write (iout,*)
7828 !grad      do m=i+1,j-1
7829 !grad        do ll=1,3
7830 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7831 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7832 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7833 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7834 !grad        enddo
7835 !grad      enddo
7836 !grad      do m=k+1,l-1
7837 !grad        do ll=1,3
7838 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7839 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7840 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7841 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7842 !grad        enddo
7843 !grad      enddo
7844 !      write (iout,*) "ehbcorr",ekont*ees
7845       ehbcorr=ekont*ees
7846       if (shield_mode.gt.0) then
7847        j=ees0plist(jj,i)
7848        l=ees0plist(kk,k)
7849 !C        print *,i,j,fac_shield(i),fac_shield(j),
7850 !C     &fac_shield(k),fac_shield(l)
7851         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
7852            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7853           do ilist=1,ishield_list(i)
7854            iresshield=shield_list(ilist,i)
7855            do m=1,3
7856            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7857            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7858                    rlocshield  &
7859             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7860             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7861             +rlocshield
7862            enddo
7863           enddo
7864           do ilist=1,ishield_list(j)
7865            iresshield=shield_list(ilist,j)
7866            do m=1,3
7867            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7868            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7869                    rlocshield &
7870             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7871            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7872             +rlocshield
7873            enddo
7874           enddo
7875
7876           do ilist=1,ishield_list(k)
7877            iresshield=shield_list(ilist,k)
7878            do m=1,3
7879            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7880            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7881                    rlocshield &
7882             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7883            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7884             +rlocshield
7885            enddo
7886           enddo
7887           do ilist=1,ishield_list(l)
7888            iresshield=shield_list(ilist,l)
7889            do m=1,3
7890            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7891            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7892                    rlocshield &
7893             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7894            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7895             +rlocshield
7896            enddo
7897           enddo
7898           do m=1,3
7899             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
7900                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7901             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
7902                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7903             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
7904                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7905             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
7906                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7907
7908             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
7909                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7910             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
7911                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7912             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
7913                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7914             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
7915                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7916
7917            enddo
7918       endif
7919       endif
7920       return
7921       end function ehbcorr
7922 #ifdef MOMENT
7923 !-----------------------------------------------------------------------------
7924       subroutine dipole(i,j,jj)
7925 !      implicit real*8 (a-h,o-z)
7926 !      include 'DIMENSIONS'
7927 !      include 'COMMON.IOUNITS'
7928 !      include 'COMMON.CHAIN'
7929 !      include 'COMMON.FFIELD'
7930 !      include 'COMMON.DERIV'
7931 !      include 'COMMON.INTERACT'
7932 !      include 'COMMON.CONTACTS'
7933 !      include 'COMMON.TORSION'
7934 !      include 'COMMON.VAR'
7935 !      include 'COMMON.GEO'
7936       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7937       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7938       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7939
7940       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7941       allocate(dipderx(3,5,4,maxconts,nres))
7942 !
7943
7944       iti1 = itortyp(itype(i+1,1))
7945       if (j.lt.nres-1) then
7946         itj1 = itortyp(itype(j+1,1))
7947       else
7948         itj1=ntortyp+1
7949       endif
7950       do iii=1,2
7951         dipi(iii,1)=Ub2(iii,i)
7952         dipderi(iii)=Ub2der(iii,i)
7953         dipi(iii,2)=b1(iii,iti1)
7954         dipj(iii,1)=Ub2(iii,j)
7955         dipderj(iii)=Ub2der(iii,j)
7956         dipj(iii,2)=b1(iii,itj1)
7957       enddo
7958       kkk=0
7959       do iii=1,2
7960         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7961         do jjj=1,2
7962           kkk=kkk+1
7963           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7964         enddo
7965       enddo
7966       do kkk=1,5
7967         do lll=1,3
7968           mmm=0
7969           do iii=1,2
7970             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
7971               auxvec(1))
7972             do jjj=1,2
7973               mmm=mmm+1
7974               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7975             enddo
7976           enddo
7977         enddo
7978       enddo
7979       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7980       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7981       do iii=1,2
7982         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7983       enddo
7984       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7985       do iii=1,2
7986         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7987       enddo
7988       return
7989       end subroutine dipole
7990 #endif
7991 !-----------------------------------------------------------------------------
7992       subroutine calc_eello(i,j,k,l,jj,kk)
7993 !
7994 ! This subroutine computes matrices and vectors needed to calculate
7995 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7996 !
7997       use comm_kut
7998 !      implicit real*8 (a-h,o-z)
7999 !      include 'DIMENSIONS'
8000 !      include 'COMMON.IOUNITS'
8001 !      include 'COMMON.CHAIN'
8002 !      include 'COMMON.DERIV'
8003 !      include 'COMMON.INTERACT'
8004 !      include 'COMMON.CONTACTS'
8005 !      include 'COMMON.TORSION'
8006 !      include 'COMMON.VAR'
8007 !      include 'COMMON.GEO'
8008 !      include 'COMMON.FFIELD'
8009       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8010       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8011       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8012               itj1
8013 !el      logical :: lprn
8014 !el      common /kutas/ lprn
8015 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8016 !d     & ' jj=',jj,' kk=',kk
8017 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8018 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8019 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8020       do iii=1,2
8021         do jjj=1,2
8022           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8023           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8024         enddo
8025       enddo
8026       call transpose2(aa1(1,1),aa1t(1,1))
8027       call transpose2(aa2(1,1),aa2t(1,1))
8028       do kkk=1,5
8029         do lll=1,3
8030           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8031             aa1tder(1,1,lll,kkk))
8032           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8033             aa2tder(1,1,lll,kkk))
8034         enddo
8035       enddo
8036       if (l.eq.j+1) then
8037 ! parallel orientation of the two CA-CA-CA frames.
8038         if (i.gt.1) then
8039           iti=itortyp(itype(i,1))
8040         else
8041           iti=ntortyp+1
8042         endif
8043         itk1=itortyp(itype(k+1,1))
8044         itj=itortyp(itype(j,1))
8045         if (l.lt.nres-1) then
8046           itl1=itortyp(itype(l+1,1))
8047         else
8048           itl1=ntortyp+1
8049         endif
8050 ! A1 kernel(j+1) A2T
8051 !d        do iii=1,2
8052 !d          write (iout,'(3f10.5,5x,3f10.5)')
8053 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8054 !d        enddo
8055         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8056          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8057          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8058 ! Following matrices are needed only for 6-th order cumulants
8059         IF (wcorr6.gt.0.0d0) THEN
8060         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8061          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8062          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8063         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8064          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8065          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8066          ADtEAderx(1,1,1,1,1,1))
8067         lprn=.false.
8068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8069          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8070          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8071          ADtEA1derx(1,1,1,1,1,1))
8072         ENDIF
8073 ! End 6-th order cumulants
8074 !d        lprn=.false.
8075 !d        if (lprn) then
8076 !d        write (2,*) 'In calc_eello6'
8077 !d        do iii=1,2
8078 !d          write (2,*) 'iii=',iii
8079 !d          do kkk=1,5
8080 !d            write (2,*) 'kkk=',kkk
8081 !d            do jjj=1,2
8082 !d              write (2,'(3(2f10.5),5x)')
8083 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8084 !d            enddo
8085 !d          enddo
8086 !d        enddo
8087 !d        endif
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 ! A1T kernel(i+1) A2
8102         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8103          a_chuj_der(1,1,1,1,kk,k),1,.false.,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) THEN
8107         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8108          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8109          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8110         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8111          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8112          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8113          ADtEAderx(1,1,1,1,1,2))
8114         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8115          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8116          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8117          ADtEA1derx(1,1,1,1,1,2))
8118         ENDIF
8119 ! End 6-th order cumulants
8120         call transpose2(EUgder(1,1,l),auxmat(1,1))
8121         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8122         call transpose2(EUg(1,1,l),auxmat(1,1))
8123         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8124         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8125         do iii=1,2
8126           do kkk=1,5
8127             do lll=1,3
8128               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8129                 EAEAderx(1,1,lll,kkk,iii,2))
8130             enddo
8131           enddo
8132         enddo
8133 ! AEAb1 and AEAb2
8134 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8135 ! They are needed only when the fifth- or the sixth-order cumulants are
8136 ! indluded.
8137         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8138         call transpose2(AEA(1,1,1),auxmat(1,1))
8139         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8140         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8141         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8142         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8143         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8144         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8145         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8146         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8147         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8148         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8149         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8150         call transpose2(AEA(1,1,2),auxmat(1,1))
8151         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8152         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8153         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8154         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8155         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8156         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8157         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8158         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8159         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8160         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8161         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8162 ! Calculate the Cartesian derivatives of the vectors.
8163         do iii=1,2
8164           do kkk=1,5
8165             do lll=1,3
8166               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8167               call matvec2(auxmat(1,1),b1(1,iti),&
8168                 AEAb1derx(1,lll,kkk,iii,1,1))
8169               call matvec2(auxmat(1,1),Ub2(1,i),&
8170                 AEAb2derx(1,lll,kkk,iii,1,1))
8171               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8172                 AEAb1derx(1,lll,kkk,iii,2,1))
8173               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8174                 AEAb2derx(1,lll,kkk,iii,2,1))
8175               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8176               call matvec2(auxmat(1,1),b1(1,itj),&
8177                 AEAb1derx(1,lll,kkk,iii,1,2))
8178               call matvec2(auxmat(1,1),Ub2(1,j),&
8179                 AEAb2derx(1,lll,kkk,iii,1,2))
8180               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8181                 AEAb1derx(1,lll,kkk,iii,2,2))
8182               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8183                 AEAb2derx(1,lll,kkk,iii,2,2))
8184             enddo
8185           enddo
8186         enddo
8187         ENDIF
8188 ! End vectors
8189       else
8190 ! Antiparallel orientation of the two CA-CA-CA frames.
8191         if (i.gt.1) then
8192           iti=itortyp(itype(i,1))
8193         else
8194           iti=ntortyp+1
8195         endif
8196         itk1=itortyp(itype(k+1,1))
8197         itl=itortyp(itype(l,1))
8198         itj=itortyp(itype(j,1))
8199         if (j.lt.nres-1) then
8200           itj1=itortyp(itype(j+1,1))
8201         else
8202           itj1=ntortyp+1
8203         endif
8204 ! A2 kernel(j-1)T A1T
8205         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8206          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8207          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8208 ! Following matrices are needed only for 6-th order cumulants
8209         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8210            j.eq.i+4 .and. l.eq.i+3)) THEN
8211         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8212          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8213          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8214         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8215          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8216          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8217          ADtEAderx(1,1,1,1,1,1))
8218         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8219          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8220          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8221          ADtEA1derx(1,1,1,1,1,1))
8222         ENDIF
8223 ! End 6-th order cumulants
8224         call transpose2(EUgder(1,1,k),auxmat(1,1))
8225         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8226         call transpose2(EUg(1,1,k),auxmat(1,1))
8227         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8228         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8229         do iii=1,2
8230           do kkk=1,5
8231             do lll=1,3
8232               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8233                 EAEAderx(1,1,lll,kkk,iii,1))
8234             enddo
8235           enddo
8236         enddo
8237 ! A2T kernel(i+1)T A1
8238         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8239          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8240          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8241 ! Following matrices are needed only for 6-th order cumulants
8242         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8243            j.eq.i+4 .and. l.eq.i+3)) THEN
8244         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8245          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8246          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8247         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8248          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8249          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8250          ADtEAderx(1,1,1,1,1,2))
8251         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8252          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8253          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8254          ADtEA1derx(1,1,1,1,1,2))
8255         ENDIF
8256 ! End 6-th order cumulants
8257         call transpose2(EUgder(1,1,j),auxmat(1,1))
8258         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8259         call transpose2(EUg(1,1,j),auxmat(1,1))
8260         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8261         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8262         do iii=1,2
8263           do kkk=1,5
8264             do lll=1,3
8265               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8266                 EAEAderx(1,1,lll,kkk,iii,2))
8267             enddo
8268           enddo
8269         enddo
8270 ! AEAb1 and AEAb2
8271 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8272 ! They are needed only when the fifth- or the sixth-order cumulants are
8273 ! indluded.
8274         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8275           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8276         call transpose2(AEA(1,1,1),auxmat(1,1))
8277         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8278         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8279         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8280         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8281         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8282         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8283         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8284         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8285         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8286         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8287         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8288         call transpose2(AEA(1,1,2),auxmat(1,1))
8289         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8290         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8291         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8292         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8293         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8294         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8295         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8296         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8297         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8298         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8299         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8300 ! Calculate the Cartesian derivatives of the vectors.
8301         do iii=1,2
8302           do kkk=1,5
8303             do lll=1,3
8304               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8305               call matvec2(auxmat(1,1),b1(1,iti),&
8306                 AEAb1derx(1,lll,kkk,iii,1,1))
8307               call matvec2(auxmat(1,1),Ub2(1,i),&
8308                 AEAb2derx(1,lll,kkk,iii,1,1))
8309               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8310                 AEAb1derx(1,lll,kkk,iii,2,1))
8311               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8312                 AEAb2derx(1,lll,kkk,iii,2,1))
8313               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8314               call matvec2(auxmat(1,1),b1(1,itl),&
8315                 AEAb1derx(1,lll,kkk,iii,1,2))
8316               call matvec2(auxmat(1,1),Ub2(1,l),&
8317                 AEAb2derx(1,lll,kkk,iii,1,2))
8318               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8319                 AEAb1derx(1,lll,kkk,iii,2,2))
8320               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8321                 AEAb2derx(1,lll,kkk,iii,2,2))
8322             enddo
8323           enddo
8324         enddo
8325         ENDIF
8326 ! End vectors
8327       endif
8328       return
8329       end subroutine calc_eello
8330 !-----------------------------------------------------------------------------
8331       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8332       use comm_kut
8333       implicit none
8334       integer :: nderg
8335       logical :: transp
8336       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8337       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8338       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8339       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8340       integer :: iii,kkk,lll
8341       integer :: jjj,mmm
8342 !el      logical :: lprn
8343 !el      common /kutas/ lprn
8344       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8345       do iii=1,nderg
8346         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8347           AKAderg(1,1,iii))
8348       enddo
8349 !d      if (lprn) write (2,*) 'In kernel'
8350       do kkk=1,5
8351 !d        if (lprn) write (2,*) 'kkk=',kkk
8352         do lll=1,3
8353           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8354             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8355 !d          if (lprn) then
8356 !d            write (2,*) 'lll=',lll
8357 !d            write (2,*) 'iii=1'
8358 !d            do jjj=1,2
8359 !d              write (2,'(3(2f10.5),5x)')
8360 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8361 !d            enddo
8362 !d          endif
8363           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8364             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8365 !d          if (lprn) then
8366 !d            write (2,*) 'lll=',lll
8367 !d            write (2,*) 'iii=2'
8368 !d            do jjj=1,2
8369 !d              write (2,'(3(2f10.5),5x)')
8370 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8371 !d            enddo
8372 !d          endif
8373         enddo
8374       enddo
8375       return
8376       end subroutine kernel
8377 !-----------------------------------------------------------------------------
8378       real(kind=8) function eello4(i,j,k,l,jj,kk)
8379 !      implicit real*8 (a-h,o-z)
8380 !      include 'DIMENSIONS'
8381 !      include 'COMMON.IOUNITS'
8382 !      include 'COMMON.CHAIN'
8383 !      include 'COMMON.DERIV'
8384 !      include 'COMMON.INTERACT'
8385 !      include 'COMMON.CONTACTS'
8386 !      include 'COMMON.TORSION'
8387 !      include 'COMMON.VAR'
8388 !      include 'COMMON.GEO'
8389       real(kind=8),dimension(2,2) :: pizda
8390       real(kind=8),dimension(3) :: ggg1,ggg2
8391       real(kind=8) ::  eel4,glongij,glongkl
8392       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8393 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8394 !d        eello4=0.0d0
8395 !d        return
8396 !d      endif
8397 !d      print *,'eello4:',i,j,k,l,jj,kk
8398 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8399 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8400 !old      eij=facont_hb(jj,i)
8401 !old      ekl=facont_hb(kk,k)
8402 !old      ekont=eij*ekl
8403       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8404 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8405       gcorr_loc(k-1)=gcorr_loc(k-1) &
8406          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8407       if (l.eq.j+1) then
8408         gcorr_loc(l-1)=gcorr_loc(l-1) &
8409            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8410       else
8411         gcorr_loc(j-1)=gcorr_loc(j-1) &
8412            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8413       endif
8414       do iii=1,2
8415         do kkk=1,5
8416           do lll=1,3
8417             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8418                               -EAEAderx(2,2,lll,kkk,iii,1)
8419 !d            derx(lll,kkk,iii)=0.0d0
8420           enddo
8421         enddo
8422       enddo
8423 !d      gcorr_loc(l-1)=0.0d0
8424 !d      gcorr_loc(j-1)=0.0d0
8425 !d      gcorr_loc(k-1)=0.0d0
8426 !d      eel4=1.0d0
8427 !d      write (iout,*)'Contacts have occurred for peptide groups',
8428 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8429 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8430       if (j.lt.nres-1) then
8431         j1=j+1
8432         j2=j-1
8433       else
8434         j1=j-1
8435         j2=j-2
8436       endif
8437       if (l.lt.nres-1) then
8438         l1=l+1
8439         l2=l-1
8440       else
8441         l1=l-1
8442         l2=l-2
8443       endif
8444       do ll=1,3
8445 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8446 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8447         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8448         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8449 !grad        ghalf=0.5d0*ggg1(ll)
8450         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8451         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8452         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8453         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8454         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8455         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8456 !grad        ghalf=0.5d0*ggg2(ll)
8457         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8458         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8459         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8460         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8461         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8462         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8463       enddo
8464 !grad      do m=i+1,j-1
8465 !grad        do ll=1,3
8466 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8467 !grad        enddo
8468 !grad      enddo
8469 !grad      do m=k+1,l-1
8470 !grad        do ll=1,3
8471 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8472 !grad        enddo
8473 !grad      enddo
8474 !grad      do m=i+2,j2
8475 !grad        do ll=1,3
8476 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8477 !grad        enddo
8478 !grad      enddo
8479 !grad      do m=k+2,l2
8480 !grad        do ll=1,3
8481 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8482 !grad        enddo
8483 !grad      enddo
8484 !d      do iii=1,nres-3
8485 !d        write (2,*) iii,gcorr_loc(iii)
8486 !d      enddo
8487       eello4=ekont*eel4
8488 !d      write (2,*) 'ekont',ekont
8489 !d      write (iout,*) 'eello4',ekont*eel4
8490       return
8491       end function eello4
8492 !-----------------------------------------------------------------------------
8493       real(kind=8) function eello5(i,j,k,l,jj,kk)
8494 !      implicit real*8 (a-h,o-z)
8495 !      include 'DIMENSIONS'
8496 !      include 'COMMON.IOUNITS'
8497 !      include 'COMMON.CHAIN'
8498 !      include 'COMMON.DERIV'
8499 !      include 'COMMON.INTERACT'
8500 !      include 'COMMON.CONTACTS'
8501 !      include 'COMMON.TORSION'
8502 !      include 'COMMON.VAR'
8503 !      include 'COMMON.GEO'
8504       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8505       real(kind=8),dimension(2) :: vv
8506       real(kind=8),dimension(3) :: ggg1,ggg2
8507       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8508       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8509       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8510 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8511 !                                                                              C
8512 !                            Parallel chains                                   C
8513 !                                                                              C
8514 !          o             o                   o             o                   C
8515 !         /l\           / \             \   / \           / \   /              C
8516 !        /   \         /   \             \ /   \         /   \ /               C
8517 !       j| o |l1       | o |              o| o |         | o |o                C
8518 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8519 !      \i/   \         /   \ /             /   \         /   \                 C
8520 !       o    k1             o                                                  C
8521 !         (I)          (II)                (III)          (IV)                 C
8522 !                                                                              C
8523 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8524 !                                                                              C
8525 !                            Antiparallel chains                               C
8526 !                                                                              C
8527 !          o             o                   o             o                   C
8528 !         /j\           / \             \   / \           / \   /              C
8529 !        /   \         /   \             \ /   \         /   \ /               C
8530 !      j1| o |l        | o |              o| o |         | o |o                C
8531 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8532 !      \i/   \         /   \ /             /   \         /   \                 C
8533 !       o     k1            o                                                  C
8534 !         (I)          (II)                (III)          (IV)                 C
8535 !                                                                              C
8536 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8537 !                                                                              C
8538 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8539 !                                                                              C
8540 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8541 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8542 !d        eello5=0.0d0
8543 !d        return
8544 !d      endif
8545 !d      write (iout,*)
8546 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8547 !d     &   ' and',k,l
8548       itk=itortyp(itype(k,1))
8549       itl=itortyp(itype(l,1))
8550       itj=itortyp(itype(j,1))
8551       eello5_1=0.0d0
8552       eello5_2=0.0d0
8553       eello5_3=0.0d0
8554       eello5_4=0.0d0
8555 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8556 !d     &   eel5_3_num,eel5_4_num)
8557       do iii=1,2
8558         do kkk=1,5
8559           do lll=1,3
8560             derx(lll,kkk,iii)=0.0d0
8561           enddo
8562         enddo
8563       enddo
8564 !d      eij=facont_hb(jj,i)
8565 !d      ekl=facont_hb(kk,k)
8566 !d      ekont=eij*ekl
8567 !d      write (iout,*)'Contacts have occurred for peptide groups',
8568 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8569 !d      goto 1111
8570 ! Contribution from the graph I.
8571 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8572 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8573       call transpose2(EUg(1,1,k),auxmat(1,1))
8574       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8575       vv(1)=pizda(1,1)-pizda(2,2)
8576       vv(2)=pizda(1,2)+pizda(2,1)
8577       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8578        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8579 ! Explicit gradient in virtual-dihedral angles.
8580       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8581        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8582        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8583       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8584       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8585       vv(1)=pizda(1,1)-pizda(2,2)
8586       vv(2)=pizda(1,2)+pizda(2,1)
8587       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8588        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8589        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8590       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8591       vv(1)=pizda(1,1)-pizda(2,2)
8592       vv(2)=pizda(1,2)+pizda(2,1)
8593       if (l.eq.j+1) then
8594         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8595          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8596          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8597       else
8598         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8599          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8600          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8601       endif
8602 ! Cartesian gradient
8603       do iii=1,2
8604         do kkk=1,5
8605           do lll=1,3
8606             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8607               pizda(1,1))
8608             vv(1)=pizda(1,1)-pizda(2,2)
8609             vv(2)=pizda(1,2)+pizda(2,1)
8610             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8611              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8612              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8613           enddo
8614         enddo
8615       enddo
8616 !      goto 1112
8617 !1111  continue
8618 ! Contribution from graph II
8619       call transpose2(EE(1,1,itk),auxmat(1,1))
8620       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8621       vv(1)=pizda(1,1)+pizda(2,2)
8622       vv(2)=pizda(2,1)-pizda(1,2)
8623       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8624        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8625 ! Explicit gradient in virtual-dihedral angles.
8626       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8627        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8628       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8629       vv(1)=pizda(1,1)+pizda(2,2)
8630       vv(2)=pizda(2,1)-pizda(1,2)
8631       if (l.eq.j+1) then
8632         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8633          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8634          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8635       else
8636         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8637          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8638          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8639       endif
8640 ! Cartesian gradient
8641       do iii=1,2
8642         do kkk=1,5
8643           do lll=1,3
8644             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8645               pizda(1,1))
8646             vv(1)=pizda(1,1)+pizda(2,2)
8647             vv(2)=pizda(2,1)-pizda(1,2)
8648             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8649              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8650              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8651           enddo
8652         enddo
8653       enddo
8654 !d      goto 1112
8655 !d1111  continue
8656       if (l.eq.j+1) then
8657 !d        goto 1110
8658 ! Parallel orientation
8659 ! Contribution from graph III
8660         call transpose2(EUg(1,1,l),auxmat(1,1))
8661         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8662         vv(1)=pizda(1,1)-pizda(2,2)
8663         vv(2)=pizda(1,2)+pizda(2,1)
8664         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8665          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8666 ! Explicit gradient in virtual-dihedral angles.
8667         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8668          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8669          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8670         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8671         vv(1)=pizda(1,1)-pizda(2,2)
8672         vv(2)=pizda(1,2)+pizda(2,1)
8673         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8674          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8675          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8676         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8677         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8678         vv(1)=pizda(1,1)-pizda(2,2)
8679         vv(2)=pizda(1,2)+pizda(2,1)
8680         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8681          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8682          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8683 ! Cartesian gradient
8684         do iii=1,2
8685           do kkk=1,5
8686             do lll=1,3
8687               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8688                 pizda(1,1))
8689               vv(1)=pizda(1,1)-pizda(2,2)
8690               vv(2)=pizda(1,2)+pizda(2,1)
8691               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8692                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8693                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8694             enddo
8695           enddo
8696         enddo
8697 !d        goto 1112
8698 ! Contribution from graph IV
8699 !d1110    continue
8700         call transpose2(EE(1,1,itl),auxmat(1,1))
8701         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8702         vv(1)=pizda(1,1)+pizda(2,2)
8703         vv(2)=pizda(2,1)-pizda(1,2)
8704         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8705          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8706 ! Explicit gradient in virtual-dihedral angles.
8707         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8708          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8709         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8710         vv(1)=pizda(1,1)+pizda(2,2)
8711         vv(2)=pizda(2,1)-pizda(1,2)
8712         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8713          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8714          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8715 ! Cartesian gradient
8716         do iii=1,2
8717           do kkk=1,5
8718             do lll=1,3
8719               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8720                 pizda(1,1))
8721               vv(1)=pizda(1,1)+pizda(2,2)
8722               vv(2)=pizda(2,1)-pizda(1,2)
8723               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8724                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8725                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8726             enddo
8727           enddo
8728         enddo
8729       else
8730 ! Antiparallel orientation
8731 ! Contribution from graph III
8732 !        goto 1110
8733         call transpose2(EUg(1,1,j),auxmat(1,1))
8734         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8735         vv(1)=pizda(1,1)-pizda(2,2)
8736         vv(2)=pizda(1,2)+pizda(2,1)
8737         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8738          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8739 ! Explicit gradient in virtual-dihedral angles.
8740         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8741          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8742          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8743         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8744         vv(1)=pizda(1,1)-pizda(2,2)
8745         vv(2)=pizda(1,2)+pizda(2,1)
8746         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8747          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8748          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8749         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8750         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8751         vv(1)=pizda(1,1)-pizda(2,2)
8752         vv(2)=pizda(1,2)+pizda(2,1)
8753         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8754          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8755          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8756 ! Cartesian gradient
8757         do iii=1,2
8758           do kkk=1,5
8759             do lll=1,3
8760               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8761                 pizda(1,1))
8762               vv(1)=pizda(1,1)-pizda(2,2)
8763               vv(2)=pizda(1,2)+pizda(2,1)
8764               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8765                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8766                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8767             enddo
8768           enddo
8769         enddo
8770 !d        goto 1112
8771 ! Contribution from graph IV
8772 1110    continue
8773         call transpose2(EE(1,1,itj),auxmat(1,1))
8774         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8775         vv(1)=pizda(1,1)+pizda(2,2)
8776         vv(2)=pizda(2,1)-pizda(1,2)
8777         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8778          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8779 ! Explicit gradient in virtual-dihedral angles.
8780         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8781          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8782         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8783         vv(1)=pizda(1,1)+pizda(2,2)
8784         vv(2)=pizda(2,1)-pizda(1,2)
8785         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8786          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8787          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8788 ! Cartesian gradient
8789         do iii=1,2
8790           do kkk=1,5
8791             do lll=1,3
8792               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8793                 pizda(1,1))
8794               vv(1)=pizda(1,1)+pizda(2,2)
8795               vv(2)=pizda(2,1)-pizda(1,2)
8796               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8797                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8798                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8799             enddo
8800           enddo
8801         enddo
8802       endif
8803 1112  continue
8804       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8805 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8806 !d        write (2,*) 'ijkl',i,j,k,l
8807 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8808 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8809 !d      endif
8810 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8811 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8812 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8813 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8814       if (j.lt.nres-1) then
8815         j1=j+1
8816         j2=j-1
8817       else
8818         j1=j-1
8819         j2=j-2
8820       endif
8821       if (l.lt.nres-1) then
8822         l1=l+1
8823         l2=l-1
8824       else
8825         l1=l-1
8826         l2=l-2
8827       endif
8828 !d      eij=1.0d0
8829 !d      ekl=1.0d0
8830 !d      ekont=1.0d0
8831 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8832 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8833 !        summed up outside the subrouine as for the other subroutines
8834 !        handling long-range interactions. The old code is commented out
8835 !        with "cgrad" to keep track of changes.
8836       do ll=1,3
8837 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8838 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8839         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8840         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8841 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8842 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8843 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8844 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8845 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8846 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8847 !     &   gradcorr5ij,
8848 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8849 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8850 !grad        ghalf=0.5d0*ggg1(ll)
8851 !d        ghalf=0.0d0
8852         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8853         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8854         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8855         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8856         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8857         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8858 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8859 !grad        ghalf=0.5d0*ggg2(ll)
8860         ghalf=0.0d0
8861         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8862         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8863         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8864         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8865         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8866         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8867       enddo
8868 !d      goto 1112
8869 !grad      do m=i+1,j-1
8870 !grad        do ll=1,3
8871 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8872 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8873 !grad        enddo
8874 !grad      enddo
8875 !grad      do m=k+1,l-1
8876 !grad        do ll=1,3
8877 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8878 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8879 !grad        enddo
8880 !grad      enddo
8881 !1112  continue
8882 !grad      do m=i+2,j2
8883 !grad        do ll=1,3
8884 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8885 !grad        enddo
8886 !grad      enddo
8887 !grad      do m=k+2,l2
8888 !grad        do ll=1,3
8889 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8890 !grad        enddo
8891 !grad      enddo
8892 !d      do iii=1,nres-3
8893 !d        write (2,*) iii,g_corr5_loc(iii)
8894 !d      enddo
8895       eello5=ekont*eel5
8896 !d      write (2,*) 'ekont',ekont
8897 !d      write (iout,*) 'eello5',ekont*eel5
8898       return
8899       end function eello5
8900 !-----------------------------------------------------------------------------
8901       real(kind=8) function eello6(i,j,k,l,jj,kk)
8902 !      implicit real*8 (a-h,o-z)
8903 !      include 'DIMENSIONS'
8904 !      include 'COMMON.IOUNITS'
8905 !      include 'COMMON.CHAIN'
8906 !      include 'COMMON.DERIV'
8907 !      include 'COMMON.INTERACT'
8908 !      include 'COMMON.CONTACTS'
8909 !      include 'COMMON.TORSION'
8910 !      include 'COMMON.VAR'
8911 !      include 'COMMON.GEO'
8912 !      include 'COMMON.FFIELD'
8913       real(kind=8),dimension(3) :: ggg1,ggg2
8914       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
8915                    eello6_6,eel6
8916       real(kind=8) :: gradcorr6ij,gradcorr6kl
8917       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8918 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8919 !d        eello6=0.0d0
8920 !d        return
8921 !d      endif
8922 !d      write (iout,*)
8923 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8924 !d     &   ' and',k,l
8925       eello6_1=0.0d0
8926       eello6_2=0.0d0
8927       eello6_3=0.0d0
8928       eello6_4=0.0d0
8929       eello6_5=0.0d0
8930       eello6_6=0.0d0
8931 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8932 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8933       do iii=1,2
8934         do kkk=1,5
8935           do lll=1,3
8936             derx(lll,kkk,iii)=0.0d0
8937           enddo
8938         enddo
8939       enddo
8940 !d      eij=facont_hb(jj,i)
8941 !d      ekl=facont_hb(kk,k)
8942 !d      ekont=eij*ekl
8943 !d      eij=1.0d0
8944 !d      ekl=1.0d0
8945 !d      ekont=1.0d0
8946       if (l.eq.j+1) then
8947         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8948         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8949         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8950         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8951         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8952         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8953       else
8954         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8955         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8956         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8957         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8958         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8959           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8960         else
8961           eello6_5=0.0d0
8962         endif
8963         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8964       endif
8965 ! If turn contributions are considered, they will be handled separately.
8966       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8967 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8968 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8969 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8970 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8971 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8972 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8973 !d      goto 1112
8974       if (j.lt.nres-1) then
8975         j1=j+1
8976         j2=j-1
8977       else
8978         j1=j-1
8979         j2=j-2
8980       endif
8981       if (l.lt.nres-1) then
8982         l1=l+1
8983         l2=l-1
8984       else
8985         l1=l-1
8986         l2=l-2
8987       endif
8988       do ll=1,3
8989 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8990 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8991 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8992 !grad        ghalf=0.5d0*ggg1(ll)
8993 !d        ghalf=0.0d0
8994         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8995         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8996         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8997         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8998         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8999         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9000         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9001         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9002 !grad        ghalf=0.5d0*ggg2(ll)
9003 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9004 !d        ghalf=0.0d0
9005         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9006         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9007         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9008         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9009         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9010         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9011       enddo
9012 !d      goto 1112
9013 !grad      do m=i+1,j-1
9014 !grad        do ll=1,3
9015 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9016 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9017 !grad        enddo
9018 !grad      enddo
9019 !grad      do m=k+1,l-1
9020 !grad        do ll=1,3
9021 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9022 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9023 !grad        enddo
9024 !grad      enddo
9025 !grad1112  continue
9026 !grad      do m=i+2,j2
9027 !grad        do ll=1,3
9028 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9029 !grad        enddo
9030 !grad      enddo
9031 !grad      do m=k+2,l2
9032 !grad        do ll=1,3
9033 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9034 !grad        enddo
9035 !grad      enddo
9036 !d      do iii=1,nres-3
9037 !d        write (2,*) iii,g_corr6_loc(iii)
9038 !d      enddo
9039       eello6=ekont*eel6
9040 !d      write (2,*) 'ekont',ekont
9041 !d      write (iout,*) 'eello6',ekont*eel6
9042       return
9043       end function eello6
9044 !-----------------------------------------------------------------------------
9045       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9046       use comm_kut
9047 !      implicit real*8 (a-h,o-z)
9048 !      include 'DIMENSIONS'
9049 !      include 'COMMON.IOUNITS'
9050 !      include 'COMMON.CHAIN'
9051 !      include 'COMMON.DERIV'
9052 !      include 'COMMON.INTERACT'
9053 !      include 'COMMON.CONTACTS'
9054 !      include 'COMMON.TORSION'
9055 !      include 'COMMON.VAR'
9056 !      include 'COMMON.GEO'
9057       real(kind=8),dimension(2) :: vv,vv1
9058       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9059       logical :: swap
9060 !el      logical :: lprn
9061 !el      common /kutas/ lprn
9062       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9063       real(kind=8) :: s1,s2,s3,s4,s5
9064 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9065 !                                                                              C
9066 !      Parallel       Antiparallel                                             C
9067 !                                                                              C
9068 !          o             o                                                     C
9069 !         /l\           /j\                                                    C
9070 !        /   \         /   \                                                   C
9071 !       /| o |         | o |\                                                  C
9072 !     \ j|/k\|  /   \  |/k\|l /                                                C
9073 !      \ /   \ /     \ /   \ /                                                 C
9074 !       o     o       o     o                                                  C
9075 !       i             i                                                        C
9076 !                                                                              C
9077 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9078       itk=itortyp(itype(k,1))
9079       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9080       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9081       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9082       call transpose2(EUgC(1,1,k),auxmat(1,1))
9083       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9084       vv1(1)=pizda1(1,1)-pizda1(2,2)
9085       vv1(2)=pizda1(1,2)+pizda1(2,1)
9086       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9087       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9088       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9089       s5=scalar2(vv(1),Dtobr2(1,i))
9090 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9091       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9092       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9093        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9094        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9095        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9096        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9097        +scalar2(vv(1),Dtobr2der(1,i)))
9098       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9099       vv1(1)=pizda1(1,1)-pizda1(2,2)
9100       vv1(2)=pizda1(1,2)+pizda1(2,1)
9101       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9102       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9103       if (l.eq.j+1) then
9104         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9105        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9106        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9107        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9108        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9109       else
9110         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9111        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9112        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9113        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9114        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9115       endif
9116       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9117       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9118       vv1(1)=pizda1(1,1)-pizda1(2,2)
9119       vv1(2)=pizda1(1,2)+pizda1(2,1)
9120       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9121        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9122        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9123        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9124       do iii=1,2
9125         if (swap) then
9126           ind=3-iii
9127         else
9128           ind=iii
9129         endif
9130         do kkk=1,5
9131           do lll=1,3
9132             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9133             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9134             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9135             call transpose2(EUgC(1,1,k),auxmat(1,1))
9136             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9137               pizda1(1,1))
9138             vv1(1)=pizda1(1,1)-pizda1(2,2)
9139             vv1(2)=pizda1(1,2)+pizda1(2,1)
9140             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9141             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9142              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9143             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9144              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9145             s5=scalar2(vv(1),Dtobr2(1,i))
9146             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9147           enddo
9148         enddo
9149       enddo
9150       return
9151       end function eello6_graph1
9152 !-----------------------------------------------------------------------------
9153       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9154       use comm_kut
9155 !      implicit real*8 (a-h,o-z)
9156 !      include 'DIMENSIONS'
9157 !      include 'COMMON.IOUNITS'
9158 !      include 'COMMON.CHAIN'
9159 !      include 'COMMON.DERIV'
9160 !      include 'COMMON.INTERACT'
9161 !      include 'COMMON.CONTACTS'
9162 !      include 'COMMON.TORSION'
9163 !      include 'COMMON.VAR'
9164 !      include 'COMMON.GEO'
9165       logical :: swap
9166       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9167       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9168 !el      logical :: lprn
9169 !el      common /kutas/ lprn
9170       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9171       real(kind=8) :: s2,s3,s4
9172 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9173 !                                                                              C
9174 !      Parallel       Antiparallel                                             C
9175 !                                                                              C
9176 !          o             o                                                     C
9177 !     \   /l\           /j\   /                                                C
9178 !      \ /   \         /   \ /                                                 C
9179 !       o| o |         | o |o                                                  C
9180 !     \ j|/k\|      \  |/k\|l                                                  C
9181 !      \ /   \       \ /   \                                                   C
9182 !       o             o                                                        C
9183 !       i             i                                                        C
9184 !                                                                              C
9185 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9186 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9187 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9188 !           but not in a cluster cumulant
9189 #ifdef MOMENT
9190       s1=dip(1,jj,i)*dip(1,kk,k)
9191 #endif
9192       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9193       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9194       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9195       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9196       call transpose2(EUg(1,1,k),auxmat(1,1))
9197       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9198       vv(1)=pizda(1,1)-pizda(2,2)
9199       vv(2)=pizda(1,2)+pizda(2,1)
9200       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9201 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9202 #ifdef MOMENT
9203       eello6_graph2=-(s1+s2+s3+s4)
9204 #else
9205       eello6_graph2=-(s2+s3+s4)
9206 #endif
9207 !      eello6_graph2=-s3
9208 ! Derivatives in gamma(i-1)
9209       if (i.gt.1) then
9210 #ifdef MOMENT
9211         s1=dipderg(1,jj,i)*dip(1,kk,k)
9212 #endif
9213         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9214         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9215         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9216         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9217 #ifdef MOMENT
9218         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9219 #else
9220         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9221 #endif
9222 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9223       endif
9224 ! Derivatives in gamma(k-1)
9225 #ifdef MOMENT
9226       s1=dip(1,jj,i)*dipderg(1,kk,k)
9227 #endif
9228       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9229       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9230       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9231       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9232       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9233       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9234       vv(1)=pizda(1,1)-pizda(2,2)
9235       vv(2)=pizda(1,2)+pizda(2,1)
9236       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9237 #ifdef MOMENT
9238       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9239 #else
9240       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9241 #endif
9242 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9243 ! Derivatives in gamma(j-1) or gamma(l-1)
9244       if (j.gt.1) then
9245 #ifdef MOMENT
9246         s1=dipderg(3,jj,i)*dip(1,kk,k)
9247 #endif
9248         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9249         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9250         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9251         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9252         vv(1)=pizda(1,1)-pizda(2,2)
9253         vv(2)=pizda(1,2)+pizda(2,1)
9254         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9255 #ifdef MOMENT
9256         if (swap) then
9257           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9258         else
9259           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9260         endif
9261 #endif
9262         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9263 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9264       endif
9265 ! Derivatives in gamma(l-1) or gamma(j-1)
9266       if (l.gt.1) then
9267 #ifdef MOMENT
9268         s1=dip(1,jj,i)*dipderg(3,kk,k)
9269 #endif
9270         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9271         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9272         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9273         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9274         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9275         vv(1)=pizda(1,1)-pizda(2,2)
9276         vv(2)=pizda(1,2)+pizda(2,1)
9277         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9278 #ifdef MOMENT
9279         if (swap) then
9280           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9281         else
9282           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9283         endif
9284 #endif
9285         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9286 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9287       endif
9288 ! Cartesian derivatives.
9289       if (lprn) then
9290         write (2,*) 'In eello6_graph2'
9291         do iii=1,2
9292           write (2,*) 'iii=',iii
9293           do kkk=1,5
9294             write (2,*) 'kkk=',kkk
9295             do jjj=1,2
9296               write (2,'(3(2f10.5),5x)') &
9297               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9298             enddo
9299           enddo
9300         enddo
9301       endif
9302       do iii=1,2
9303         do kkk=1,5
9304           do lll=1,3
9305 #ifdef MOMENT
9306             if (iii.eq.1) then
9307               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9308             else
9309               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9310             endif
9311 #endif
9312             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9313               auxvec(1))
9314             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9315             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9316               auxvec(1))
9317             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9318             call transpose2(EUg(1,1,k),auxmat(1,1))
9319             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9320               pizda(1,1))
9321             vv(1)=pizda(1,1)-pizda(2,2)
9322             vv(2)=pizda(1,2)+pizda(2,1)
9323             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9324 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9325 #ifdef MOMENT
9326             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9327 #else
9328             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9329 #endif
9330             if (swap) then
9331               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9332             else
9333               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9334             endif
9335           enddo
9336         enddo
9337       enddo
9338       return
9339       end function eello6_graph2
9340 !-----------------------------------------------------------------------------
9341       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9342 !      implicit real*8 (a-h,o-z)
9343 !      include 'DIMENSIONS'
9344 !      include 'COMMON.IOUNITS'
9345 !      include 'COMMON.CHAIN'
9346 !      include 'COMMON.DERIV'
9347 !      include 'COMMON.INTERACT'
9348 !      include 'COMMON.CONTACTS'
9349 !      include 'COMMON.TORSION'
9350 !      include 'COMMON.VAR'
9351 !      include 'COMMON.GEO'
9352       real(kind=8),dimension(2) :: vv,auxvec
9353       real(kind=8),dimension(2,2) :: pizda,auxmat
9354       logical :: swap
9355       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9356       real(kind=8) :: s1,s2,s3,s4
9357 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9358 !                                                                              C
9359 !      Parallel       Antiparallel                                             C
9360 !                                                                              C
9361 !          o             o                                                     C
9362 !         /l\   /   \   /j\                                                    C
9363 !        /   \ /     \ /   \                                                   C
9364 !       /| o |o       o| o |\                                                  C
9365 !       j|/k\|  /      |/k\|l /                                                C
9366 !        /   \ /       /   \ /                                                 C
9367 !       /     o       /     o                                                  C
9368 !       i             i                                                        C
9369 !                                                                              C
9370 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9371 !
9372 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9373 !           energy moment and not to the cluster cumulant.
9374       iti=itortyp(itype(i,1))
9375       if (j.lt.nres-1) then
9376         itj1=itortyp(itype(j+1,1))
9377       else
9378         itj1=ntortyp+1
9379       endif
9380       itk=itortyp(itype(k,1))
9381       itk1=itortyp(itype(k+1,1))
9382       if (l.lt.nres-1) then
9383         itl1=itortyp(itype(l+1,1))
9384       else
9385         itl1=ntortyp+1
9386       endif
9387 #ifdef MOMENT
9388       s1=dip(4,jj,i)*dip(4,kk,k)
9389 #endif
9390       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9391       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9392       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9393       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9394       call transpose2(EE(1,1,itk),auxmat(1,1))
9395       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9396       vv(1)=pizda(1,1)+pizda(2,2)
9397       vv(2)=pizda(2,1)-pizda(1,2)
9398       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9399 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9400 !d     & "sum",-(s2+s3+s4)
9401 #ifdef MOMENT
9402       eello6_graph3=-(s1+s2+s3+s4)
9403 #else
9404       eello6_graph3=-(s2+s3+s4)
9405 #endif
9406 !      eello6_graph3=-s4
9407 ! Derivatives in gamma(k-1)
9408       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9409       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9410       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9411       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9412 ! Derivatives in gamma(l-1)
9413       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9414       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9415       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9416       vv(1)=pizda(1,1)+pizda(2,2)
9417       vv(2)=pizda(2,1)-pizda(1,2)
9418       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9419       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9420 ! Cartesian derivatives.
9421       do iii=1,2
9422         do kkk=1,5
9423           do lll=1,3
9424 #ifdef MOMENT
9425             if (iii.eq.1) then
9426               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9427             else
9428               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9429             endif
9430 #endif
9431             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9432               auxvec(1))
9433             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9434             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9435               auxvec(1))
9436             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9437             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9438               pizda(1,1))
9439             vv(1)=pizda(1,1)+pizda(2,2)
9440             vv(2)=pizda(2,1)-pizda(1,2)
9441             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9442 #ifdef MOMENT
9443             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9444 #else
9445             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9446 #endif
9447             if (swap) then
9448               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9449             else
9450               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9451             endif
9452 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9453           enddo
9454         enddo
9455       enddo
9456       return
9457       end function eello6_graph3
9458 !-----------------------------------------------------------------------------
9459       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9460 !      implicit real*8 (a-h,o-z)
9461 !      include 'DIMENSIONS'
9462 !      include 'COMMON.IOUNITS'
9463 !      include 'COMMON.CHAIN'
9464 !      include 'COMMON.DERIV'
9465 !      include 'COMMON.INTERACT'
9466 !      include 'COMMON.CONTACTS'
9467 !      include 'COMMON.TORSION'
9468 !      include 'COMMON.VAR'
9469 !      include 'COMMON.GEO'
9470 !      include 'COMMON.FFIELD'
9471       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9472       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9473       logical :: swap
9474       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9475               iii,kkk,lll
9476       real(kind=8) :: s1,s2,s3,s4
9477 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9478 !                                                                              C
9479 !      Parallel       Antiparallel                                             C
9480 !                                                                              C
9481 !          o             o                                                     C
9482 !         /l\   /   \   /j\                                                    C
9483 !        /   \ /     \ /   \                                                   C
9484 !       /| o |o       o| o |\                                                  C
9485 !     \ j|/k\|      \  |/k\|l                                                  C
9486 !      \ /   \       \ /   \                                                   C
9487 !       o     \       o     \                                                  C
9488 !       i             i                                                        C
9489 !                                                                              C
9490 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9491 !
9492 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9493 !           energy moment and not to the cluster cumulant.
9494 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9495       iti=itortyp(itype(i,1))
9496       itj=itortyp(itype(j,1))
9497       if (j.lt.nres-1) then
9498         itj1=itortyp(itype(j+1,1))
9499       else
9500         itj1=ntortyp+1
9501       endif
9502       itk=itortyp(itype(k,1))
9503       if (k.lt.nres-1) then
9504         itk1=itortyp(itype(k+1,1))
9505       else
9506         itk1=ntortyp+1
9507       endif
9508       itl=itortyp(itype(l,1))
9509       if (l.lt.nres-1) then
9510         itl1=itortyp(itype(l+1,1))
9511       else
9512         itl1=ntortyp+1
9513       endif
9514 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9515 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9516 !d     & ' itl',itl,' itl1',itl1
9517 #ifdef MOMENT
9518       if (imat.eq.1) then
9519         s1=dip(3,jj,i)*dip(3,kk,k)
9520       else
9521         s1=dip(2,jj,j)*dip(2,kk,l)
9522       endif
9523 #endif
9524       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9525       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9526       if (j.eq.l+1) then
9527         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9528         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9529       else
9530         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9531         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9532       endif
9533       call transpose2(EUg(1,1,k),auxmat(1,1))
9534       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9535       vv(1)=pizda(1,1)-pizda(2,2)
9536       vv(2)=pizda(2,1)+pizda(1,2)
9537       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9538 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9539 #ifdef MOMENT
9540       eello6_graph4=-(s1+s2+s3+s4)
9541 #else
9542       eello6_graph4=-(s2+s3+s4)
9543 #endif
9544 ! Derivatives in gamma(i-1)
9545       if (i.gt.1) then
9546 #ifdef MOMENT
9547         if (imat.eq.1) then
9548           s1=dipderg(2,jj,i)*dip(3,kk,k)
9549         else
9550           s1=dipderg(4,jj,j)*dip(2,kk,l)
9551         endif
9552 #endif
9553         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9554         if (j.eq.l+1) then
9555           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9556           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9557         else
9558           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9559           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9560         endif
9561         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9562         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9563 !d          write (2,*) 'turn6 derivatives'
9564 #ifdef MOMENT
9565           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9566 #else
9567           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9568 #endif
9569         else
9570 #ifdef MOMENT
9571           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9572 #else
9573           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9574 #endif
9575         endif
9576       endif
9577 ! Derivatives in gamma(k-1)
9578 #ifdef MOMENT
9579       if (imat.eq.1) then
9580         s1=dip(3,jj,i)*dipderg(2,kk,k)
9581       else
9582         s1=dip(2,jj,j)*dipderg(4,kk,l)
9583       endif
9584 #endif
9585       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9586       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9587       if (j.eq.l+1) then
9588         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9589         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9590       else
9591         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9592         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9593       endif
9594       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9595       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9596       vv(1)=pizda(1,1)-pizda(2,2)
9597       vv(2)=pizda(2,1)+pizda(1,2)
9598       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9599       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9600 #ifdef MOMENT
9601         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9602 #else
9603         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9604 #endif
9605       else
9606 #ifdef MOMENT
9607         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9608 #else
9609         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9610 #endif
9611       endif
9612 ! Derivatives in gamma(j-1) or gamma(l-1)
9613       if (l.eq.j+1 .and. l.gt.1) then
9614         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9615         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9616         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9617         vv(1)=pizda(1,1)-pizda(2,2)
9618         vv(2)=pizda(2,1)+pizda(1,2)
9619         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9620         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9621       else if (j.gt.1) then
9622         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9623         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9624         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9625         vv(1)=pizda(1,1)-pizda(2,2)
9626         vv(2)=pizda(2,1)+pizda(1,2)
9627         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9628         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9629           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9630         else
9631           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9632         endif
9633       endif
9634 ! Cartesian derivatives.
9635       do iii=1,2
9636         do kkk=1,5
9637           do lll=1,3
9638 #ifdef MOMENT
9639             if (iii.eq.1) then
9640               if (imat.eq.1) then
9641                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9642               else
9643                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9644               endif
9645             else
9646               if (imat.eq.1) then
9647                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9648               else
9649                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9650               endif
9651             endif
9652 #endif
9653             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9654               auxvec(1))
9655             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9656             if (j.eq.l+1) then
9657               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9658                 b1(1,itj1),auxvec(1))
9659               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9660             else
9661               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9662                 b1(1,itl1),auxvec(1))
9663               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9664             endif
9665             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9666               pizda(1,1))
9667             vv(1)=pizda(1,1)-pizda(2,2)
9668             vv(2)=pizda(2,1)+pizda(1,2)
9669             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9670             if (swap) then
9671               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9672 #ifdef MOMENT
9673                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9674                    -(s1+s2+s4)
9675 #else
9676                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9677                    -(s2+s4)
9678 #endif
9679                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9680               else
9681 #ifdef MOMENT
9682                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9683 #else
9684                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9685 #endif
9686                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9687               endif
9688             else
9689 #ifdef MOMENT
9690               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9691 #else
9692               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9693 #endif
9694               if (l.eq.j+1) then
9695                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9696               else
9697                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9698               endif
9699             endif
9700           enddo
9701         enddo
9702       enddo
9703       return
9704       end function eello6_graph4
9705 !-----------------------------------------------------------------------------
9706       real(kind=8) function eello_turn6(i,jj,kk)
9707 !      implicit real*8 (a-h,o-z)
9708 !      include 'DIMENSIONS'
9709 !      include 'COMMON.IOUNITS'
9710 !      include 'COMMON.CHAIN'
9711 !      include 'COMMON.DERIV'
9712 !      include 'COMMON.INTERACT'
9713 !      include 'COMMON.CONTACTS'
9714 !      include 'COMMON.TORSION'
9715 !      include 'COMMON.VAR'
9716 !      include 'COMMON.GEO'
9717       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9718       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9719       real(kind=8),dimension(3) :: ggg1,ggg2
9720       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9721       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9722 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9723 !           the respective energy moment and not to the cluster cumulant.
9724 !el local variables
9725       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9726       integer :: j1,j2,l1,l2,ll
9727       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9728       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9729       s1=0.0d0
9730       s8=0.0d0
9731       s13=0.0d0
9732 !
9733       eello_turn6=0.0d0
9734       j=i+4
9735       k=i+1
9736       l=i+3
9737       iti=itortyp(itype(i,1))
9738       itk=itortyp(itype(k,1))
9739       itk1=itortyp(itype(k+1,1))
9740       itl=itortyp(itype(l,1))
9741       itj=itortyp(itype(j,1))
9742 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9743 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9744 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9745 !d        eello6=0.0d0
9746 !d        return
9747 !d      endif
9748 !d      write (iout,*)
9749 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9750 !d     &   ' and',k,l
9751 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9752       do iii=1,2
9753         do kkk=1,5
9754           do lll=1,3
9755             derx_turn(lll,kkk,iii)=0.0d0
9756           enddo
9757         enddo
9758       enddo
9759 !d      eij=1.0d0
9760 !d      ekl=1.0d0
9761 !d      ekont=1.0d0
9762       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9763 !d      eello6_5=0.0d0
9764 !d      write (2,*) 'eello6_5',eello6_5
9765 #ifdef MOMENT
9766       call transpose2(AEA(1,1,1),auxmat(1,1))
9767       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9768       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9769       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9770 #endif
9771       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9772       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9773       s2 = scalar2(b1(1,itk),vtemp1(1))
9774 #ifdef MOMENT
9775       call transpose2(AEA(1,1,2),atemp(1,1))
9776       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9777       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9778       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9779 #endif
9780       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9781       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9782       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9783 #ifdef MOMENT
9784       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9785       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9786       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9787       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9788       ss13 = scalar2(b1(1,itk),vtemp4(1))
9789       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9790 #endif
9791 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9792 !      s1=0.0d0
9793 !      s2=0.0d0
9794 !      s8=0.0d0
9795 !      s12=0.0d0
9796 !      s13=0.0d0
9797       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9798 ! Derivatives in gamma(i+2)
9799       s1d =0.0d0
9800       s8d =0.0d0
9801 #ifdef MOMENT
9802       call transpose2(AEA(1,1,1),auxmatd(1,1))
9803       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9804       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9805       call transpose2(AEAderg(1,1,2),atempd(1,1))
9806       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9807       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9808 #endif
9809       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9810       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9811       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9812 !      s1d=0.0d0
9813 !      s2d=0.0d0
9814 !      s8d=0.0d0
9815 !      s12d=0.0d0
9816 !      s13d=0.0d0
9817       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9818 ! Derivatives in gamma(i+3)
9819 #ifdef MOMENT
9820       call transpose2(AEA(1,1,1),auxmatd(1,1))
9821       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9822       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9823       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9824 #endif
9825       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9826       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9827       s2d = scalar2(b1(1,itk),vtemp1d(1))
9828 #ifdef MOMENT
9829       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9830       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9831 #endif
9832       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9833 #ifdef MOMENT
9834       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9835       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9836       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9837 #endif
9838 !      s1d=0.0d0
9839 !      s2d=0.0d0
9840 !      s8d=0.0d0
9841 !      s12d=0.0d0
9842 !      s13d=0.0d0
9843 #ifdef MOMENT
9844       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9845                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9846 #else
9847       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9848                     -0.5d0*ekont*(s2d+s12d)
9849 #endif
9850 ! Derivatives in gamma(i+4)
9851       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9852       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9853       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9854 #ifdef MOMENT
9855       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9856       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9857       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9858 #endif
9859 !      s1d=0.0d0
9860 !      s2d=0.0d0
9861 !      s8d=0.0d0
9862 !      s12d=0.0d0
9863 !      s13d=0.0d0
9864 #ifdef MOMENT
9865       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9866 #else
9867       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9868 #endif
9869 ! Derivatives in gamma(i+5)
9870 #ifdef MOMENT
9871       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9872       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9873       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9874 #endif
9875       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9876       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9877       s2d = scalar2(b1(1,itk),vtemp1d(1))
9878 #ifdef MOMENT
9879       call transpose2(AEA(1,1,2),atempd(1,1))
9880       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9881       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9882 #endif
9883       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9884       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9885 #ifdef MOMENT
9886       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9887       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9888       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9889 #endif
9890 !      s1d=0.0d0
9891 !      s2d=0.0d0
9892 !      s8d=0.0d0
9893 !      s12d=0.0d0
9894 !      s13d=0.0d0
9895 #ifdef MOMENT
9896       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9897                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9898 #else
9899       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9900                     -0.5d0*ekont*(s2d+s12d)
9901 #endif
9902 ! Cartesian derivatives
9903       do iii=1,2
9904         do kkk=1,5
9905           do lll=1,3
9906 #ifdef MOMENT
9907             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9908             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9909             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9910 #endif
9911             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9912             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
9913                 vtemp1d(1))
9914             s2d = scalar2(b1(1,itk),vtemp1d(1))
9915 #ifdef MOMENT
9916             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9917             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9918             s8d = -(atempd(1,1)+atempd(2,2))* &
9919                  scalar2(cc(1,1,itl),vtemp2(1))
9920 #endif
9921             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
9922                  auxmatd(1,1))
9923             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9924             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9925 !      s1d=0.0d0
9926 !      s2d=0.0d0
9927 !      s8d=0.0d0
9928 !      s12d=0.0d0
9929 !      s13d=0.0d0
9930 #ifdef MOMENT
9931             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9932               - 0.5d0*(s1d+s2d)
9933 #else
9934             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9935               - 0.5d0*s2d
9936 #endif
9937 #ifdef MOMENT
9938             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9939               - 0.5d0*(s8d+s12d)
9940 #else
9941             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9942               - 0.5d0*s12d
9943 #endif
9944           enddo
9945         enddo
9946       enddo
9947 #ifdef MOMENT
9948       do kkk=1,5
9949         do lll=1,3
9950           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
9951             achuj_tempd(1,1))
9952           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9953           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9954           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9955           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9956           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
9957             vtemp4d(1))
9958           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9959           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9960           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9961         enddo
9962       enddo
9963 #endif
9964 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9965 !d     &  16*eel_turn6_num
9966 !d      goto 1112
9967       if (j.lt.nres-1) then
9968         j1=j+1
9969         j2=j-1
9970       else
9971         j1=j-1
9972         j2=j-2
9973       endif
9974       if (l.lt.nres-1) then
9975         l1=l+1
9976         l2=l-1
9977       else
9978         l1=l-1
9979         l2=l-2
9980       endif
9981       do ll=1,3
9982 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9983 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9984 !grad        ghalf=0.5d0*ggg1(ll)
9985 !d        ghalf=0.0d0
9986         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9987         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9988         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9989           +ekont*derx_turn(ll,2,1)
9990         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9991         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9992           +ekont*derx_turn(ll,4,1)
9993         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9994         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9995         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9996 !grad        ghalf=0.5d0*ggg2(ll)
9997 !d        ghalf=0.0d0
9998         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9999           +ekont*derx_turn(ll,2,2)
10000         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10001         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10002           +ekont*derx_turn(ll,4,2)
10003         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10004         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10005         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10006       enddo
10007 !d      goto 1112
10008 !grad      do m=i+1,j-1
10009 !grad        do ll=1,3
10010 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10011 !grad        enddo
10012 !grad      enddo
10013 !grad      do m=k+1,l-1
10014 !grad        do ll=1,3
10015 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10016 !grad        enddo
10017 !grad      enddo
10018 !grad1112  continue
10019 !grad      do m=i+2,j2
10020 !grad        do ll=1,3
10021 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10022 !grad        enddo
10023 !grad      enddo
10024 !grad      do m=k+2,l2
10025 !grad        do ll=1,3
10026 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10027 !grad        enddo
10028 !grad      enddo
10029 !d      do iii=1,nres-3
10030 !d        write (2,*) iii,g_corr6_loc(iii)
10031 !d      enddo
10032       eello_turn6=ekont*eel_turn6
10033 !d      write (2,*) 'ekont',ekont
10034 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10035       return
10036       end function eello_turn6
10037 !-----------------------------------------------------------------------------
10038       subroutine MATVEC2(A1,V1,V2)
10039 !DIR$ INLINEALWAYS MATVEC2
10040 #ifndef OSF
10041 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10042 #endif
10043 !      implicit real*8 (a-h,o-z)
10044 !      include 'DIMENSIONS'
10045       real(kind=8),dimension(2) :: V1,V2
10046       real(kind=8),dimension(2,2) :: A1
10047       real(kind=8) :: vaux1,vaux2
10048 !      DO 1 I=1,2
10049 !        VI=0.0
10050 !        DO 3 K=1,2
10051 !    3     VI=VI+A1(I,K)*V1(K)
10052 !        Vaux(I)=VI
10053 !    1 CONTINUE
10054
10055       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10056       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10057
10058       v2(1)=vaux1
10059       v2(2)=vaux2
10060       end subroutine MATVEC2
10061 !-----------------------------------------------------------------------------
10062       subroutine MATMAT2(A1,A2,A3)
10063 #ifndef OSF
10064 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10065 #endif
10066 !      implicit real*8 (a-h,o-z)
10067 !      include 'DIMENSIONS'
10068       real(kind=8),dimension(2,2) :: A1,A2,A3
10069       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10070 !      DIMENSION AI3(2,2)
10071 !        DO  J=1,2
10072 !          A3IJ=0.0
10073 !          DO K=1,2
10074 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10075 !          enddo
10076 !          A3(I,J)=A3IJ
10077 !       enddo
10078 !      enddo
10079
10080       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10081       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10082       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10083       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10084
10085       A3(1,1)=AI3_11
10086       A3(2,1)=AI3_21
10087       A3(1,2)=AI3_12
10088       A3(2,2)=AI3_22
10089       end subroutine MATMAT2
10090 !-----------------------------------------------------------------------------
10091       real(kind=8) function scalar2(u,v)
10092 !DIR$ INLINEALWAYS scalar2
10093       implicit none
10094       real(kind=8),dimension(2) :: u,v
10095       real(kind=8) :: sc
10096       integer :: i
10097       scalar2=u(1)*v(1)+u(2)*v(2)
10098       return
10099       end function scalar2
10100 !-----------------------------------------------------------------------------
10101       subroutine transpose2(a,at)
10102 !DIR$ INLINEALWAYS transpose2
10103 #ifndef OSF
10104 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10105 #endif
10106       implicit none
10107       real(kind=8),dimension(2,2) :: a,at
10108       at(1,1)=a(1,1)
10109       at(1,2)=a(2,1)
10110       at(2,1)=a(1,2)
10111       at(2,2)=a(2,2)
10112       return
10113       end subroutine transpose2
10114 !-----------------------------------------------------------------------------
10115       subroutine transpose(n,a,at)
10116       implicit none
10117       integer :: n,i,j
10118       real(kind=8),dimension(n,n) :: a,at
10119       do i=1,n
10120         do j=1,n
10121           at(j,i)=a(i,j)
10122         enddo
10123       enddo
10124       return
10125       end subroutine transpose
10126 !-----------------------------------------------------------------------------
10127       subroutine prodmat3(a1,a2,kk,transp,prod)
10128 !DIR$ INLINEALWAYS prodmat3
10129 #ifndef OSF
10130 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10131 #endif
10132       implicit none
10133       integer :: i,j
10134       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10135       logical :: transp
10136 !rc      double precision auxmat(2,2),prod_(2,2)
10137
10138       if (transp) then
10139 !rc        call transpose2(kk(1,1),auxmat(1,1))
10140 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10141 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10142
10143            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10144        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10145            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10146        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10147            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10148        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10149            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10150        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10151
10152       else
10153 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10154 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10155
10156            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10157         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10158            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10159         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10160            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10161         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10162            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10163         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10164
10165       endif
10166 !      call transpose2(a2(1,1),a2t(1,1))
10167
10168 !rc      print *,transp
10169 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10170 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10171
10172       return
10173       end subroutine prodmat3
10174 !-----------------------------------------------------------------------------
10175 ! energy_p_new_barrier.F
10176 !-----------------------------------------------------------------------------
10177       subroutine sum_gradient
10178 !      implicit real*8 (a-h,o-z)
10179       use io_base, only: pdbout
10180 !      include 'DIMENSIONS'
10181 #ifndef ISNAN
10182       external proc_proc
10183 #ifdef WINPGI
10184 !MS$ATTRIBUTES C ::  proc_proc
10185 #endif
10186 #endif
10187 #ifdef MPI
10188       include 'mpif.h'
10189 #endif
10190       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10191                    gloc_scbuf !(3,maxres)
10192
10193       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10194 !#endif
10195 !el local variables
10196       integer :: i,j,k,ierror,ierr
10197       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10198                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10199                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10200                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10201                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10202                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10203                    gsccorr_max,gsccorrx_max,time00
10204
10205 !      include 'COMMON.SETUP'
10206 !      include 'COMMON.IOUNITS'
10207 !      include 'COMMON.FFIELD'
10208 !      include 'COMMON.DERIV'
10209 !      include 'COMMON.INTERACT'
10210 !      include 'COMMON.SBRIDGE'
10211 !      include 'COMMON.CHAIN'
10212 !      include 'COMMON.VAR'
10213 !      include 'COMMON.CONTROL'
10214 !      include 'COMMON.TIME1'
10215 !      include 'COMMON.MAXGRAD'
10216 !      include 'COMMON.SCCOR'
10217 #ifdef TIMING
10218       time01=MPI_Wtime()
10219 #endif
10220 #ifdef DEBUG
10221       write (iout,*) "sum_gradient gvdwc, gvdwx"
10222       do i=1,nres
10223         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10224          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10225       enddo
10226       call flush(iout)
10227 #endif
10228 #ifdef MPI
10229         gradbufc=0.0d0
10230         gradbufx=0.0d0
10231         gradbufc_sum=0.0d0
10232         gloc_scbuf=0.0d0
10233         glocbuf=0.0d0
10234 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10235         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10236           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10237 #endif
10238 !
10239 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10240 !            in virtual-bond-vector coordinates
10241 !
10242 #ifdef DEBUG
10243 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10244 !      do i=1,nres-1
10245 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10246 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10247 !      enddo
10248 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10249 !      do i=1,nres-1
10250 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10251 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10252 !      enddo
10253       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10254       do i=1,nres
10255         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10256          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10257          (gvdwc_scpp(j,i),j=1,3)
10258       enddo
10259       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10260       do i=1,nres
10261         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10262          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10263          (gelc_loc_long(j,i),j=1,3)
10264       enddo
10265       call flush(iout)
10266 #endif
10267 #ifdef SPLITELE
10268       do i=0,nct
10269         do j=1,3
10270           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10271                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10272                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10273                       wel_loc*gel_loc_long(j,i)+ &
10274                       wcorr*gradcorr_long(j,i)+ &
10275                       wcorr5*gradcorr5_long(j,i)+ &
10276                       wcorr6*gradcorr6_long(j,i)+ &
10277                       wturn6*gcorr6_turn_long(j,i)+ &
10278                       wstrain*ghpbc(j,i) &
10279                      +wliptran*gliptranc(j,i) &
10280                      +gradafm(j,i) &
10281                      +welec*gshieldc(j,i) &
10282                      +wcorr*gshieldc_ec(j,i) &
10283                      +wturn3*gshieldc_t3(j,i)&
10284                      +wturn4*gshieldc_t4(j,i)&
10285                      +wel_loc*gshieldc_ll(j,i)&
10286                      +wtube*gg_tube(j,i)
10287
10288
10289
10290         enddo
10291       enddo
10292 #else
10293       do i=0,nct
10294         do j=1,3
10295           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10296                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10297                       welec*gelc_long(j,i)+ &
10298                       wbond*gradb(j,i)+ &
10299                       wel_loc*gel_loc_long(j,i)+ &
10300                       wcorr*gradcorr_long(j,i)+ &
10301                       wcorr5*gradcorr5_long(j,i)+ &
10302                       wcorr6*gradcorr6_long(j,i)+ &
10303                       wturn6*gcorr6_turn_long(j,i)+ &
10304                       wstrain*ghpbc(j,i) &
10305                      +wliptran*gliptranc(j,i) &
10306                      +gradafm(j,i) &
10307                      +welec*gshieldc(j,i)&
10308                      +wcorr*gshieldc_ec(j,i) &
10309                      +wturn4*gshieldc_t4(j,i) &
10310                      +wel_loc*gshieldc_ll(j,i)&
10311                      +wtube*gg_tube(j,i)
10312
10313
10314
10315         enddo
10316       enddo
10317 #endif
10318 #ifdef MPI
10319       if (nfgtasks.gt.1) then
10320       time00=MPI_Wtime()
10321 #ifdef DEBUG
10322       write (iout,*) "gradbufc before allreduce"
10323       do i=1,nres
10324         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10325       enddo
10326       call flush(iout)
10327 #endif
10328       do i=0,nres
10329         do j=1,3
10330           gradbufc_sum(j,i)=gradbufc(j,i)
10331         enddo
10332       enddo
10333 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10334 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10335 !      time_reduce=time_reduce+MPI_Wtime()-time00
10336 #ifdef DEBUG
10337 !      write (iout,*) "gradbufc_sum after allreduce"
10338 !      do i=1,nres
10339 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10340 !      enddo
10341 !      call flush(iout)
10342 #endif
10343 #ifdef TIMING
10344 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10345 #endif
10346       do i=0,nres
10347         do k=1,3
10348           gradbufc(k,i)=0.0d0
10349         enddo
10350       enddo
10351 #ifdef DEBUG
10352       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10353       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10354                         " jgrad_end  ",jgrad_end(i),&
10355                         i=igrad_start,igrad_end)
10356 #endif
10357 !
10358 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10359 ! do not parallelize this part.
10360 !
10361 !      do i=igrad_start,igrad_end
10362 !        do j=jgrad_start(i),jgrad_end(i)
10363 !          do k=1,3
10364 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10365 !          enddo
10366 !        enddo
10367 !      enddo
10368       do j=1,3
10369         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10370       enddo
10371       do i=nres-2,-1,-1
10372         do j=1,3
10373           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10374         enddo
10375       enddo
10376 #ifdef DEBUG
10377       write (iout,*) "gradbufc after summing"
10378       do i=1,nres
10379         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10380       enddo
10381       call flush(iout)
10382 #endif
10383       else
10384 #endif
10385 !el#define DEBUG
10386 #ifdef DEBUG
10387       write (iout,*) "gradbufc"
10388       do i=1,nres
10389         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10390       enddo
10391       call flush(iout)
10392 #endif
10393 !el#undef DEBUG
10394       do i=-1,nres
10395         do j=1,3
10396           gradbufc_sum(j,i)=gradbufc(j,i)
10397           gradbufc(j,i)=0.0d0
10398         enddo
10399       enddo
10400       do j=1,3
10401         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10402       enddo
10403       do i=nres-2,-1,-1
10404         do j=1,3
10405           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10406         enddo
10407       enddo
10408 !      do i=nnt,nres-1
10409 !        do k=1,3
10410 !          gradbufc(k,i)=0.0d0
10411 !        enddo
10412 !        do j=i+1,nres
10413 !          do k=1,3
10414 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10415 !          enddo
10416 !        enddo
10417 !      enddo
10418 !el#define DEBUG
10419 #ifdef DEBUG
10420       write (iout,*) "gradbufc after summing"
10421       do i=1,nres
10422         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10423       enddo
10424       call flush(iout)
10425 #endif
10426 !el#undef DEBUG
10427 #ifdef MPI
10428       endif
10429 #endif
10430       do k=1,3
10431         gradbufc(k,nres)=0.0d0
10432       enddo
10433 !el----------------
10434 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10435 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10436 !el-----------------
10437       do i=-1,nct
10438         do j=1,3
10439 #ifdef SPLITELE
10440           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10441                       wel_loc*gel_loc(j,i)+ &
10442                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10443                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10444                       wel_loc*gel_loc_long(j,i)+ &
10445                       wcorr*gradcorr_long(j,i)+ &
10446                       wcorr5*gradcorr5_long(j,i)+ &
10447                       wcorr6*gradcorr6_long(j,i)+ &
10448                       wturn6*gcorr6_turn_long(j,i))+ &
10449                       wbond*gradb(j,i)+ &
10450                       wcorr*gradcorr(j,i)+ &
10451                       wturn3*gcorr3_turn(j,i)+ &
10452                       wturn4*gcorr4_turn(j,i)+ &
10453                       wcorr5*gradcorr5(j,i)+ &
10454                       wcorr6*gradcorr6(j,i)+ &
10455                       wturn6*gcorr6_turn(j,i)+ &
10456                       wsccor*gsccorc(j,i) &
10457                      +wscloc*gscloc(j,i)  &
10458                      +wliptran*gliptranc(j,i) &
10459                      +gradafm(j,i) &
10460                      +welec*gshieldc(j,i) &
10461                      +welec*gshieldc_loc(j,i) &
10462                      +wcorr*gshieldc_ec(j,i) &
10463                      +wcorr*gshieldc_loc_ec(j,i) &
10464                      +wturn3*gshieldc_t3(j,i) &
10465                      +wturn3*gshieldc_loc_t3(j,i) &
10466                      +wturn4*gshieldc_t4(j,i) &
10467                      +wturn4*gshieldc_loc_t4(j,i) &
10468                      +wel_loc*gshieldc_ll(j,i) &
10469                      +wel_loc*gshieldc_loc_ll(j,i) &
10470                      +wtube*gg_tube(j,i)
10471
10472
10473 #else
10474           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10475                       wel_loc*gel_loc(j,i)+ &
10476                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10477                       welec*gelc_long(j,i)+ &
10478                       wel_loc*gel_loc_long(j,i)+ &
10479 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10480                       wcorr5*gradcorr5_long(j,i)+ &
10481                       wcorr6*gradcorr6_long(j,i)+ &
10482                       wturn6*gcorr6_turn_long(j,i))+ &
10483                       wbond*gradb(j,i)+ &
10484                       wcorr*gradcorr(j,i)+ &
10485                       wturn3*gcorr3_turn(j,i)+ &
10486                       wturn4*gcorr4_turn(j,i)+ &
10487                       wcorr5*gradcorr5(j,i)+ &
10488                       wcorr6*gradcorr6(j,i)+ &
10489                       wturn6*gcorr6_turn(j,i)+ &
10490                       wsccor*gsccorc(j,i) &
10491                      +wscloc*gscloc(j,i) &
10492                      +gradafm(j,i) &
10493                      +wliptran*gliptranc(j,i) &
10494                      +welec*gshieldc(j,i) &
10495                      +welec*gshieldc_loc(j,) &
10496                      +wcorr*gshieldc_ec(j,i) &
10497                      +wcorr*gshieldc_loc_ec(j,i) &
10498                      +wturn3*gshieldc_t3(j,i) &
10499                      +wturn3*gshieldc_loc_t3(j,i) &
10500                      +wturn4*gshieldc_t4(j,i) &
10501                      +wturn4*gshieldc_loc_t4(j,i) &
10502                      +wel_loc*gshieldc_ll(j,i) &
10503                      +wel_loc*gshieldc_loc_ll(j,i) &
10504                      +wtube*gg_tube(j,i)
10505
10506
10507
10508 #endif
10509           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10510                         wbond*gradbx(j,i)+ &
10511                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10512                         wsccor*gsccorx(j,i) &
10513                        +wscloc*gsclocx(j,i) &
10514                        +wliptran*gliptranx(j,i) &
10515                        +welec*gshieldx(j,i)     &
10516                        +wcorr*gshieldx_ec(j,i)  &
10517                        +wturn3*gshieldx_t3(j,i) &
10518                        +wturn4*gshieldx_t4(j,i) &
10519                        +wel_loc*gshieldx_ll(j,i)&
10520                        +wtube*gg_tube_sc(j,i)
10521
10522
10523         enddo
10524       enddo
10525 #ifdef DEBUG
10526       write (iout,*) "gloc before adding corr"
10527       do i=1,4*nres
10528         write (iout,*) i,gloc(i,icg)
10529       enddo
10530 #endif
10531       do i=1,nres-3
10532         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10533          +wcorr5*g_corr5_loc(i) &
10534          +wcorr6*g_corr6_loc(i) &
10535          +wturn4*gel_loc_turn4(i) &
10536          +wturn3*gel_loc_turn3(i) &
10537          +wturn6*gel_loc_turn6(i) &
10538          +wel_loc*gel_loc_loc(i)
10539       enddo
10540 #ifdef DEBUG
10541       write (iout,*) "gloc after adding corr"
10542       do i=1,4*nres
10543         write (iout,*) i,gloc(i,icg)
10544       enddo
10545 #endif
10546 #ifdef MPI
10547       if (nfgtasks.gt.1) then
10548         do j=1,3
10549           do i=1,nres
10550             gradbufc(j,i)=gradc(j,i,icg)
10551             gradbufx(j,i)=gradx(j,i,icg)
10552           enddo
10553         enddo
10554         do i=1,4*nres
10555           glocbuf(i)=gloc(i,icg)
10556         enddo
10557 !#define DEBUG
10558 #ifdef DEBUG
10559       write (iout,*) "gloc_sc before reduce"
10560       do i=1,nres
10561        do j=1,1
10562         write (iout,*) i,j,gloc_sc(j,i,icg)
10563        enddo
10564       enddo
10565 #endif
10566 !#undef DEBUG
10567         do i=1,nres
10568          do j=1,3
10569           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10570          enddo
10571         enddo
10572         time00=MPI_Wtime()
10573         call MPI_Barrier(FG_COMM,IERR)
10574         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10575         time00=MPI_Wtime()
10576         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10577           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10578         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
10579           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10580         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10581           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10582         time_reduce=time_reduce+MPI_Wtime()-time00
10583         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10584           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10585         time_reduce=time_reduce+MPI_Wtime()-time00
10586 !#define DEBUG
10587 #ifdef DEBUG
10588       write (iout,*) "gloc_sc after reduce"
10589       do i=1,nres
10590        do j=1,1
10591         write (iout,*) i,j,gloc_sc(j,i,icg)
10592        enddo
10593       enddo
10594 #endif
10595 !#undef DEBUG
10596 #ifdef DEBUG
10597       write (iout,*) "gloc after reduce"
10598       do i=1,4*nres
10599         write (iout,*) i,gloc(i,icg)
10600       enddo
10601 #endif
10602       endif
10603 #endif
10604       if (gnorm_check) then
10605 !
10606 ! Compute the maximum elements of the gradient
10607 !
10608       gvdwc_max=0.0d0
10609       gvdwc_scp_max=0.0d0
10610       gelc_max=0.0d0
10611       gvdwpp_max=0.0d0
10612       gradb_max=0.0d0
10613       ghpbc_max=0.0d0
10614       gradcorr_max=0.0d0
10615       gel_loc_max=0.0d0
10616       gcorr3_turn_max=0.0d0
10617       gcorr4_turn_max=0.0d0
10618       gradcorr5_max=0.0d0
10619       gradcorr6_max=0.0d0
10620       gcorr6_turn_max=0.0d0
10621       gsccorc_max=0.0d0
10622       gscloc_max=0.0d0
10623       gvdwx_max=0.0d0
10624       gradx_scp_max=0.0d0
10625       ghpbx_max=0.0d0
10626       gradxorr_max=0.0d0
10627       gsccorx_max=0.0d0
10628       gsclocx_max=0.0d0
10629       do i=1,nct
10630         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10631         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10632         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10633         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10634          gvdwc_scp_max=gvdwc_scp_norm
10635         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10636         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10637         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10638         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10639         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10640         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10641         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10642         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10643         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10644         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10645         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10646         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10647         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10648           gcorr3_turn(1,i)))
10649         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10650           gcorr3_turn_max=gcorr3_turn_norm
10651         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10652           gcorr4_turn(1,i)))
10653         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10654           gcorr4_turn_max=gcorr4_turn_norm
10655         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10656         if (gradcorr5_norm.gt.gradcorr5_max) &
10657           gradcorr5_max=gradcorr5_norm
10658         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10659         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10660         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10661           gcorr6_turn(1,i)))
10662         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10663           gcorr6_turn_max=gcorr6_turn_norm
10664         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10665         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10666         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10667         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10668         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10669         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10670         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10671         if (gradx_scp_norm.gt.gradx_scp_max) &
10672           gradx_scp_max=gradx_scp_norm
10673         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10674         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10675         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10676         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10677         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10678         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10679         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10680         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10681       enddo
10682       if (gradout) then
10683 #ifdef AIX
10684         open(istat,file=statname,position="append")
10685 #else
10686         open(istat,file=statname,access="append")
10687 #endif
10688         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10689            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10690            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10691            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10692            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10693            gsccorx_max,gsclocx_max
10694         close(istat)
10695         if (gvdwc_max.gt.1.0d4) then
10696           write (iout,*) "gvdwc gvdwx gradb gradbx"
10697           do i=nnt,nct
10698             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10699               gradb(j,i),gradbx(j,i),j=1,3)
10700           enddo
10701           call pdbout(0.0d0,'cipiszcze',iout)
10702           call flush(iout)
10703         endif
10704       endif
10705       endif
10706 !el#define DEBUG
10707 #ifdef DEBUG
10708       write (iout,*) "gradc gradx gloc"
10709       do i=1,nres
10710         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10711          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10712       enddo
10713 #endif
10714 !el#undef DEBUG
10715 #ifdef TIMING
10716       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10717 #endif
10718       return
10719       end subroutine sum_gradient
10720 !-----------------------------------------------------------------------------
10721       subroutine sc_grad
10722 !      implicit real*8 (a-h,o-z)
10723       use calc_data
10724 !      include 'DIMENSIONS'
10725 !      include 'COMMON.CHAIN'
10726 !      include 'COMMON.DERIV'
10727 !      include 'COMMON.CALC'
10728 !      include 'COMMON.IOUNITS'
10729       real(kind=8), dimension(3) :: dcosom1,dcosom2
10730
10731       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10732       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10733       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10734            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10735 ! diagnostics only
10736 !      eom1=0.0d0
10737 !      eom2=0.0d0
10738 !      eom12=evdwij*eps1_om12
10739 ! end diagnostics
10740 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10741 !       " sigder",sigder
10742 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10743 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10744 !C      print *,sss_ele_cut,'in sc_grad'
10745       do k=1,3
10746         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10747         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10748       enddo
10749       do k=1,3
10750         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10751 !C      print *,'gg',k,gg(k)
10752        enddo
10753 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10754 !      write (iout,*) "gg",(gg(k),k=1,3)
10755       do k=1,3
10756         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10757                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10758                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10759                   *sss_ele_cut
10760
10761         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10762                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10763                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10764                   *sss_ele_cut
10765
10766 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10767 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10768 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10769 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10770       enddo
10771 !
10772 ! Calculate the components of the gradient in DC and X
10773 !
10774 !grad      do k=i,j-1
10775 !grad        do l=1,3
10776 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10777 !grad        enddo
10778 !grad      enddo
10779       do l=1,3
10780         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10781         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10782       enddo
10783       return
10784       end subroutine sc_grad
10785 #ifdef CRYST_THETA
10786 !-----------------------------------------------------------------------------
10787       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
10788
10789       use comm_calcthet
10790 !      implicit real*8 (a-h,o-z)
10791 !      include 'DIMENSIONS'
10792 !      include 'COMMON.LOCAL'
10793 !      include 'COMMON.IOUNITS'
10794 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
10795 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10796 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
10797       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
10798       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
10799 !el      integer :: it
10800 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
10801 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10802 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
10803 !el local variables
10804
10805       delthec=thetai-thet_pred_mean
10806       delthe0=thetai-theta0i
10807 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
10808       t3 = thetai-thet_pred_mean
10809       t6 = t3**2
10810       t9 = term1
10811       t12 = t3*sigcsq
10812       t14 = t12+t6*sigsqtc
10813       t16 = 1.0d0
10814       t21 = thetai-theta0i
10815       t23 = t21**2
10816       t26 = term2
10817       t27 = t21*t26
10818       t32 = termexp
10819       t40 = t32**2
10820       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
10821        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
10822        *(-t12*t9-ak*sig0inv*t27)
10823       return
10824       end subroutine mixder
10825 #endif
10826 !-----------------------------------------------------------------------------
10827 ! cartder.F
10828 !-----------------------------------------------------------------------------
10829       subroutine cartder
10830 !-----------------------------------------------------------------------------
10831 ! This subroutine calculates the derivatives of the consecutive virtual
10832 ! bond vectors and the SC vectors in the virtual-bond angles theta and
10833 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
10834 ! in the angles alpha and omega, describing the location of a side chain
10835 ! in its local coordinate system.
10836 !
10837 ! The derivatives are stored in the following arrays:
10838 !
10839 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
10840 ! The structure is as follows:
10841 !
10842 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
10843 ! 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)
10844 !         . . . . . . . . . . . .  . . . . . .
10845 ! 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)
10846 !                          .
10847 !                          .
10848 !                          .
10849 ! 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)
10850 !
10851 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
10852 ! The structure is same as above.
10853 !
10854 ! DCDS - the derivatives of the side chain vectors in the local spherical
10855 ! andgles alph and omega:
10856 !
10857 ! 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)
10858 ! 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)
10859 !                          .
10860 !                          .
10861 !                          .
10862 ! 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)
10863 !
10864 ! Version of March '95, based on an early version of November '91.
10865 !
10866 !**********************************************************************
10867 !      implicit real*8 (a-h,o-z)
10868 !      include 'DIMENSIONS'
10869 !      include 'COMMON.VAR'
10870 !      include 'COMMON.CHAIN'
10871 !      include 'COMMON.DERIV'
10872 !      include 'COMMON.GEO'
10873 !      include 'COMMON.LOCAL'
10874 !      include 'COMMON.INTERACT'
10875       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
10876       real(kind=8),dimension(3,3) :: dp,temp
10877 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
10878       real(kind=8),dimension(3) :: xx,xx1
10879 !el local variables
10880       integer :: i,k,l,j,m,ind,ind1,jjj
10881       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
10882                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
10883                  sint2,xp,yp,xxp,yyp,zzp,dj
10884
10885 !      common /przechowalnia/ fromto
10886       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
10887 ! get the position of the jth ijth fragment of the chain coordinate system
10888 ! in the fromto array.
10889 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10890 !
10891 !      maxdim=(nres-1)*(nres-2)/2
10892 !      allocate(dcdv(6,maxdim),dxds(6,nres))
10893 ! calculate the derivatives of transformation matrix elements in theta
10894 !
10895
10896 !el      call flush(iout) !el
10897       do i=1,nres-2
10898         rdt(1,1,i)=-rt(1,2,i)
10899         rdt(1,2,i)= rt(1,1,i)
10900         rdt(1,3,i)= 0.0d0
10901         rdt(2,1,i)=-rt(2,2,i)
10902         rdt(2,2,i)= rt(2,1,i)
10903         rdt(2,3,i)= 0.0d0
10904         rdt(3,1,i)=-rt(3,2,i)
10905         rdt(3,2,i)= rt(3,1,i)
10906         rdt(3,3,i)= 0.0d0
10907       enddo
10908 !
10909 ! derivatives in phi
10910 !
10911       do i=2,nres-2
10912         drt(1,1,i)= 0.0d0
10913         drt(1,2,i)= 0.0d0
10914         drt(1,3,i)= 0.0d0
10915         drt(2,1,i)= rt(3,1,i)
10916         drt(2,2,i)= rt(3,2,i)
10917         drt(2,3,i)= rt(3,3,i)
10918         drt(3,1,i)=-rt(2,1,i)
10919         drt(3,2,i)=-rt(2,2,i)
10920         drt(3,3,i)=-rt(2,3,i)
10921       enddo
10922 !
10923 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
10924 !
10925       do i=2,nres-2
10926         ind=indmat(i,i+1)
10927         do k=1,3
10928           do l=1,3
10929             temp(k,l)=rt(k,l,i)
10930           enddo
10931         enddo
10932         do k=1,3
10933           do l=1,3
10934             fromto(k,l,ind)=temp(k,l)
10935           enddo
10936         enddo
10937         do j=i+1,nres-2
10938           ind=indmat(i,j+1)
10939           do k=1,3
10940             do l=1,3
10941               dpkl=0.0d0
10942               do m=1,3
10943                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
10944               enddo
10945               dp(k,l)=dpkl
10946               fromto(k,l,ind)=dpkl
10947             enddo
10948           enddo
10949           do k=1,3
10950             do l=1,3
10951               temp(k,l)=dp(k,l)
10952             enddo
10953           enddo
10954         enddo
10955       enddo
10956 !
10957 ! Calculate derivatives.
10958 !
10959       ind1=0
10960       do i=1,nres-2
10961         ind1=ind1+1
10962 !
10963 ! Derivatives of DC(i+1) in theta(i+2)
10964 !
10965         do j=1,3
10966           do k=1,2
10967             dpjk=0.0D0
10968             do l=1,3
10969               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
10970             enddo
10971             dp(j,k)=dpjk
10972             prordt(j,k,i)=dp(j,k)
10973           enddo
10974           dp(j,3)=0.0D0
10975           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
10976         enddo
10977 !
10978 ! Derivatives of SC(i+1) in theta(i+2)
10979 !
10980         xx1(1)=-0.5D0*xloc(2,i+1)
10981         xx1(2)= 0.5D0*xloc(1,i+1)
10982         do j=1,3
10983           xj=0.0D0
10984           do k=1,2
10985             xj=xj+r(j,k,i)*xx1(k)
10986           enddo
10987           xx(j)=xj
10988         enddo
10989         do j=1,3
10990           rj=0.0D0
10991           do k=1,3
10992             rj=rj+prod(j,k,i)*xx(k)
10993           enddo
10994           dxdv(j,ind1)=rj
10995         enddo
10996 !
10997 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
10998 ! than the other off-diagonal derivatives.
10999 !
11000         do j=1,3
11001           dxoiij=0.0D0
11002           do k=1,3
11003             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11004           enddo
11005           dxdv(j,ind1+1)=dxoiij
11006         enddo
11007 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11008 !
11009 ! Derivatives of DC(i+1) in phi(i+2)
11010 !
11011         do j=1,3
11012           do k=1,3
11013             dpjk=0.0
11014             do l=2,3
11015               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11016             enddo
11017             dp(j,k)=dpjk
11018             prodrt(j,k,i)=dp(j,k)
11019           enddo
11020           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11021         enddo
11022 !
11023 ! Derivatives of SC(i+1) in phi(i+2)
11024 !
11025         xx(1)= 0.0D0
11026         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11027         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11028         do j=1,3
11029           rj=0.0D0
11030           do k=2,3
11031             rj=rj+prod(j,k,i)*xx(k)
11032           enddo
11033           dxdv(j+3,ind1)=-rj
11034         enddo
11035 !
11036 ! Derivatives of SC(i+1) in phi(i+3).
11037 !
11038         do j=1,3
11039           dxoiij=0.0D0
11040           do k=1,3
11041             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11042           enddo
11043           dxdv(j+3,ind1+1)=dxoiij
11044         enddo
11045 !
11046 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11047 ! theta(nres) and phi(i+3) thru phi(nres).
11048 !
11049         do j=i+1,nres-2
11050           ind1=ind1+1
11051           ind=indmat(i+1,j+1)
11052 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11053           do k=1,3
11054             do l=1,3
11055               tempkl=0.0D0
11056               do m=1,2
11057                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11058               enddo
11059               temp(k,l)=tempkl
11060             enddo
11061           enddo
11062 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11063 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11064 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11065 ! Derivatives of virtual-bond vectors in theta
11066           do k=1,3
11067             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11068           enddo
11069 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11070 ! Derivatives of SC vectors in theta
11071           do k=1,3
11072             dxoijk=0.0D0
11073             do l=1,3
11074               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11075             enddo
11076             dxdv(k,ind1+1)=dxoijk
11077           enddo
11078 !
11079 !--- Calculate the derivatives in phi
11080 !
11081           do k=1,3
11082             do l=1,3
11083               tempkl=0.0D0
11084               do m=1,3
11085                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11086               enddo
11087               temp(k,l)=tempkl
11088             enddo
11089           enddo
11090           do k=1,3
11091             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11092           enddo
11093           do k=1,3
11094             dxoijk=0.0D0
11095             do l=1,3
11096               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11097             enddo
11098             dxdv(k+3,ind1+1)=dxoijk
11099           enddo
11100         enddo
11101       enddo
11102 !
11103 ! Derivatives in alpha and omega:
11104 !
11105       do i=2,nres-1
11106 !       dsci=dsc(itype(i,1))
11107         dsci=vbld(i+nres)
11108 #ifdef OSF
11109         alphi=alph(i)
11110         omegi=omeg(i)
11111         if(alphi.ne.alphi) alphi=100.0
11112         if(omegi.ne.omegi) omegi=-100.0
11113 #else
11114         alphi=alph(i)
11115         omegi=omeg(i)
11116 #endif
11117 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11118         cosalphi=dcos(alphi)
11119         sinalphi=dsin(alphi)
11120         cosomegi=dcos(omegi)
11121         sinomegi=dsin(omegi)
11122         temp(1,1)=-dsci*sinalphi
11123         temp(2,1)= dsci*cosalphi*cosomegi
11124         temp(3,1)=-dsci*cosalphi*sinomegi
11125         temp(1,2)=0.0D0
11126         temp(2,2)=-dsci*sinalphi*sinomegi
11127         temp(3,2)=-dsci*sinalphi*cosomegi
11128         theta2=pi-0.5D0*theta(i+1)
11129         cost2=dcos(theta2)
11130         sint2=dsin(theta2)
11131         jjj=0
11132 !d      print *,((temp(l,k),l=1,3),k=1,2)
11133         do j=1,2
11134           xp=temp(1,j)
11135           yp=temp(2,j)
11136           xxp= xp*cost2+yp*sint2
11137           yyp=-xp*sint2+yp*cost2
11138           zzp=temp(3,j)
11139           xx(1)=xxp
11140           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11141           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11142           do k=1,3
11143             dj=0.0D0
11144             do l=1,3
11145               dj=dj+prod(k,l,i-1)*xx(l)
11146             enddo
11147             dxds(jjj+k,i)=dj
11148           enddo
11149           jjj=jjj+3
11150         enddo
11151       enddo
11152       return
11153       end subroutine cartder
11154 !-----------------------------------------------------------------------------
11155 ! checkder_p.F
11156 !-----------------------------------------------------------------------------
11157       subroutine check_cartgrad
11158 ! Check the gradient of Cartesian coordinates in internal coordinates.
11159 !      implicit real*8 (a-h,o-z)
11160 !      include 'DIMENSIONS'
11161 !      include 'COMMON.IOUNITS'
11162 !      include 'COMMON.VAR'
11163 !      include 'COMMON.CHAIN'
11164 !      include 'COMMON.GEO'
11165 !      include 'COMMON.LOCAL'
11166 !      include 'COMMON.DERIV'
11167       real(kind=8),dimension(6,nres) :: temp
11168       real(kind=8),dimension(3) :: xx,gg
11169       integer :: i,k,j,ii
11170       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11171 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11172 !
11173 ! Check the gradient of the virtual-bond and SC vectors in the internal
11174 ! coordinates.
11175 !
11176       aincr=1.0d-6
11177       aincr2=5.0d-7
11178       call cartder
11179       write (iout,'(a)') '**************** dx/dalpha'
11180       write (iout,'(a)')
11181       do i=2,nres-1
11182         alphi=alph(i)
11183         alph(i)=alph(i)+aincr
11184         do k=1,3
11185           temp(k,i)=dc(k,nres+i)
11186         enddo
11187         call chainbuild
11188         do k=1,3
11189           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11190           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11191         enddo
11192         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11193         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11194         write (iout,'(a)')
11195         alph(i)=alphi
11196         call chainbuild
11197       enddo
11198       write (iout,'(a)')
11199       write (iout,'(a)') '**************** dx/domega'
11200       write (iout,'(a)')
11201       do i=2,nres-1
11202         omegi=omeg(i)
11203         omeg(i)=omeg(i)+aincr
11204         do k=1,3
11205           temp(k,i)=dc(k,nres+i)
11206         enddo
11207         call chainbuild
11208         do k=1,3
11209           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11210           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11211                 (aincr*dabs(dxds(k+3,i))+aincr))
11212         enddo
11213         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11214             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11215         write (iout,'(a)')
11216         omeg(i)=omegi
11217         call chainbuild
11218       enddo
11219       write (iout,'(a)')
11220       write (iout,'(a)') '**************** dx/dtheta'
11221       write (iout,'(a)')
11222       do i=3,nres
11223         theti=theta(i)
11224         theta(i)=theta(i)+aincr
11225         do j=i-1,nres-1
11226           do k=1,3
11227             temp(k,j)=dc(k,nres+j)
11228           enddo
11229         enddo
11230         call chainbuild
11231         do j=i-1,nres-1
11232           ii = indmat(i-2,j)
11233 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11234           do k=1,3
11235             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11236             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11237                   (aincr*dabs(dxdv(k,ii))+aincr))
11238           enddo
11239           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11240               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11241           write(iout,'(a)')
11242         enddo
11243         write (iout,'(a)')
11244         theta(i)=theti
11245         call chainbuild
11246       enddo
11247       write (iout,'(a)') '***************** dx/dphi'
11248       write (iout,'(a)')
11249       do i=4,nres
11250         phi(i)=phi(i)+aincr
11251         do j=i-1,nres-1
11252           do k=1,3
11253             temp(k,j)=dc(k,nres+j)
11254           enddo
11255         enddo
11256         call chainbuild
11257         do j=i-1,nres-1
11258           ii = indmat(i-2,j)
11259 !         print *,'ii=',ii
11260           do k=1,3
11261             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11262             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11263                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11264           enddo
11265           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11266               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11267           write(iout,'(a)')
11268         enddo
11269         phi(i)=phi(i)-aincr
11270         call chainbuild
11271       enddo
11272       write (iout,'(a)') '****************** ddc/dtheta'
11273       do i=1,nres-2
11274         thet=theta(i+2)
11275         theta(i+2)=thet+aincr
11276         do j=i,nres
11277           do k=1,3
11278             temp(k,j)=dc(k,j)
11279           enddo
11280         enddo
11281         call chainbuild
11282         do j=i+1,nres-1
11283           ii = indmat(i,j)
11284 !         print *,'ii=',ii
11285           do k=1,3
11286             gg(k)=(dc(k,j)-temp(k,j))/aincr
11287             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11288                  (aincr*dabs(dcdv(k,ii))+aincr))
11289           enddo
11290           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11291                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11292           write (iout,'(a)')
11293         enddo
11294         do j=1,nres
11295           do k=1,3
11296             dc(k,j)=temp(k,j)
11297           enddo
11298         enddo
11299         theta(i+2)=thet
11300       enddo
11301       write (iout,'(a)') '******************* ddc/dphi'
11302       do i=1,nres-3
11303         phii=phi(i+3)
11304         phi(i+3)=phii+aincr
11305         do j=1,nres
11306           do k=1,3
11307             temp(k,j)=dc(k,j)
11308           enddo
11309         enddo
11310         call chainbuild
11311         do j=i+2,nres-1
11312           ii = indmat(i+1,j)
11313 !         print *,'ii=',ii
11314           do k=1,3
11315             gg(k)=(dc(k,j)-temp(k,j))/aincr
11316             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11317                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11318           enddo
11319           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11320                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11321           write (iout,'(a)')
11322         enddo
11323         do j=1,nres
11324           do k=1,3
11325             dc(k,j)=temp(k,j)
11326           enddo
11327         enddo
11328         phi(i+3)=phii
11329       enddo
11330       return
11331       end subroutine check_cartgrad
11332 !-----------------------------------------------------------------------------
11333       subroutine check_ecart
11334 ! Check the gradient of the energy in Cartesian coordinates.
11335 !     implicit real*8 (a-h,o-z)
11336 !     include 'DIMENSIONS'
11337 !     include 'COMMON.CHAIN'
11338 !     include 'COMMON.DERIV'
11339 !     include 'COMMON.IOUNITS'
11340 !     include 'COMMON.VAR'
11341 !     include 'COMMON.CONTACTS'
11342       use comm_srutu
11343 !el      integer :: icall
11344 !el      common /srutu/ icall
11345       real(kind=8),dimension(6) :: ggg
11346       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11347       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11348       real(kind=8),dimension(6,nres) :: grad_s
11349       real(kind=8),dimension(0:n_ene) :: energia,energia1
11350       integer :: uiparm(1)
11351       real(kind=8) :: urparm(1)
11352 !EL      external fdum
11353       integer :: nf,i,j,k
11354       real(kind=8) :: aincr,etot,etot1
11355       icg=1
11356       nf=0
11357       nfl=0
11358       call zerograd
11359       aincr=1.0D-5
11360       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11361       nf=0
11362       icall=0
11363       call geom_to_var(nvar,x)
11364       call etotal(energia)
11365       etot=energia(0)
11366 !el      call enerprint(energia)
11367       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11368       icall =1
11369       do i=1,nres
11370         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11371       enddo
11372       do i=1,nres
11373         do j=1,3
11374           grad_s(j,i)=gradc(j,i,icg)
11375           grad_s(j+3,i)=gradx(j,i,icg)
11376         enddo
11377       enddo
11378       call flush(iout)
11379       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11380       do i=1,nres
11381         do j=1,3
11382           xx(j)=c(j,i+nres)
11383           ddc(j)=dc(j,i)
11384           ddx(j)=dc(j,i+nres)
11385         enddo
11386         do j=1,3
11387           dc(j,i)=dc(j,i)+aincr
11388           do k=i+1,nres
11389             c(j,k)=c(j,k)+aincr
11390             c(j,k+nres)=c(j,k+nres)+aincr
11391           enddo
11392           call etotal(energia1)
11393           etot1=energia1(0)
11394           ggg(j)=(etot1-etot)/aincr
11395           dc(j,i)=ddc(j)
11396           do k=i+1,nres
11397             c(j,k)=c(j,k)-aincr
11398             c(j,k+nres)=c(j,k+nres)-aincr
11399           enddo
11400         enddo
11401         do j=1,3
11402           c(j,i+nres)=c(j,i+nres)+aincr
11403           dc(j,i+nres)=dc(j,i+nres)+aincr
11404           call etotal(energia1)
11405           etot1=energia1(0)
11406           ggg(j+3)=(etot1-etot)/aincr
11407           c(j,i+nres)=xx(j)
11408           dc(j,i+nres)=ddx(j)
11409         enddo
11410         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11411          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11412       enddo
11413       return
11414       end subroutine check_ecart
11415 #ifdef CARGRAD
11416 !-----------------------------------------------------------------------------
11417       subroutine check_ecartint
11418 ! Check the gradient of the energy in Cartesian coordinates.
11419       use io_base, only: intout
11420 !      implicit real*8 (a-h,o-z)
11421 !      include 'DIMENSIONS'
11422 !      include 'COMMON.CONTROL'
11423 !      include 'COMMON.CHAIN'
11424 !      include 'COMMON.DERIV'
11425 !      include 'COMMON.IOUNITS'
11426 !      include 'COMMON.VAR'
11427 !      include 'COMMON.CONTACTS'
11428 !      include 'COMMON.MD'
11429 !      include 'COMMON.LOCAL'
11430 !      include 'COMMON.SPLITELE'
11431       use comm_srutu
11432 !el      integer :: icall
11433 !el      common /srutu/ icall
11434       real(kind=8),dimension(6) :: ggg,ggg1
11435       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11436       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11437       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11438       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11439       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11440       real(kind=8),dimension(0:n_ene) :: energia,energia1
11441       integer :: uiparm(1)
11442       real(kind=8) :: urparm(1)
11443 !EL      external fdum
11444       integer :: i,j,k,nf
11445       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11446                    etot21,etot22
11447       r_cut=2.0d0
11448       rlambd=0.3d0
11449       icg=1
11450       nf=0
11451       nfl=0
11452       call intout
11453 !      call intcartderiv
11454 !      call checkintcartgrad
11455       call zerograd
11456       aincr=1.0D-5
11457       write(iout,*) 'Calling CHECK_ECARTINT.'
11458       nf=0
11459       icall=0
11460       write (iout,*) "Before geom_to_var"
11461       call geom_to_var(nvar,x)
11462       write (iout,*) "after geom_to_var"
11463       write (iout,*) "split_ene ",split_ene
11464       call flush(iout)
11465       if (.not.split_ene) then
11466         write(iout,*) 'Calling CHECK_ECARTINT if'
11467         call etotal(energia)
11468 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11469         etot=energia(0)
11470         write (iout,*) "etot",etot
11471         call flush(iout)
11472 !el        call enerprint(energia)
11473 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11474         call flush(iout)
11475         write (iout,*) "enter cartgrad"
11476         call flush(iout)
11477         call cartgrad
11478 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11479         write (iout,*) "exit cartgrad"
11480         call flush(iout)
11481         icall =1
11482         do i=1,nres
11483           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11484         enddo
11485         do j=1,3
11486           grad_s(j,0)=gcart(j,0)
11487         enddo
11488 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11489         do i=1,nres
11490           do j=1,3
11491             grad_s(j,i)=gcart(j,i)
11492             grad_s(j+3,i)=gxcart(j,i)
11493           enddo
11494         enddo
11495       else
11496 write(iout,*) 'Calling CHECK_ECARTIN else.'
11497 !- split gradient check
11498         call zerograd
11499         call etotal_long(energia)
11500 !el        call enerprint(energia)
11501         call flush(iout)
11502         write (iout,*) "enter cartgrad"
11503         call flush(iout)
11504         call cartgrad
11505         write (iout,*) "exit cartgrad"
11506         call flush(iout)
11507         icall =1
11508         write (iout,*) "longrange grad"
11509         do i=1,nres
11510           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11511           (gxcart(j,i),j=1,3)
11512         enddo
11513         do j=1,3
11514           grad_s(j,0)=gcart(j,0)
11515         enddo
11516         do i=1,nres
11517           do j=1,3
11518             grad_s(j,i)=gcart(j,i)
11519             grad_s(j+3,i)=gxcart(j,i)
11520           enddo
11521         enddo
11522         call zerograd
11523         call etotal_short(energia)
11524 !el        call enerprint(energia)
11525         call flush(iout)
11526         write (iout,*) "enter cartgrad"
11527         call flush(iout)
11528         call cartgrad
11529         write (iout,*) "exit cartgrad"
11530         call flush(iout)
11531         icall =1
11532         write (iout,*) "shortrange grad"
11533         do i=1,nres
11534           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11535           (gxcart(j,i),j=1,3)
11536         enddo
11537         do j=1,3
11538           grad_s1(j,0)=gcart(j,0)
11539         enddo
11540         do i=1,nres
11541           do j=1,3
11542             grad_s1(j,i)=gcart(j,i)
11543             grad_s1(j+3,i)=gxcart(j,i)
11544           enddo
11545         enddo
11546       endif
11547       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11548 !      do i=1,nres
11549       do i=nnt,nct
11550         do j=1,3
11551           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11552           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11553           ddc(j)=c(j,i)
11554           ddx(j)=c(j,i+nres)
11555           dcnorm_safe1(j)=dc_norm(j,i-1)
11556           dcnorm_safe2(j)=dc_norm(j,i)
11557           dxnorm_safe(j)=dc_norm(j,i+nres)
11558         enddo
11559         do j=1,3
11560           c(j,i)=ddc(j)+aincr
11561           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11562           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11563           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11564           dc(j,i)=c(j,i+1)-c(j,i)
11565           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11566           call int_from_cart1(.false.)
11567           if (.not.split_ene) then
11568             call etotal(energia1)
11569             etot1=energia1(0)
11570             write (iout,*) "ij",i,j," etot1",etot1
11571           else
11572 !- split gradient
11573             call etotal_long(energia1)
11574             etot11=energia1(0)
11575             call etotal_short(energia1)
11576             etot12=energia1(0)
11577           endif
11578 !- end split gradient
11579 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11580           c(j,i)=ddc(j)-aincr
11581           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11582           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11583           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11584           dc(j,i)=c(j,i+1)-c(j,i)
11585           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11586           call int_from_cart1(.false.)
11587           if (.not.split_ene) then
11588             call etotal(energia1)
11589             etot2=energia1(0)
11590             write (iout,*) "ij",i,j," etot2",etot2
11591             ggg(j)=(etot1-etot2)/(2*aincr)
11592           else
11593 !- split gradient
11594             call etotal_long(energia1)
11595             etot21=energia1(0)
11596             ggg(j)=(etot11-etot21)/(2*aincr)
11597             call etotal_short(energia1)
11598             etot22=energia1(0)
11599             ggg1(j)=(etot12-etot22)/(2*aincr)
11600 !- end split gradient
11601 !            write (iout,*) "etot21",etot21," etot22",etot22
11602           endif
11603 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11604           c(j,i)=ddc(j)
11605           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11606           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11607           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11608           dc(j,i)=c(j,i+1)-c(j,i)
11609           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11610           dc_norm(j,i-1)=dcnorm_safe1(j)
11611           dc_norm(j,i)=dcnorm_safe2(j)
11612           dc_norm(j,i+nres)=dxnorm_safe(j)
11613         enddo
11614         do j=1,3
11615           c(j,i+nres)=ddx(j)+aincr
11616           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11617           call int_from_cart1(.false.)
11618           if (.not.split_ene) then
11619             call etotal(energia1)
11620             etot1=energia1(0)
11621           else
11622 !- split gradient
11623             call etotal_long(energia1)
11624             etot11=energia1(0)
11625             call etotal_short(energia1)
11626             etot12=energia1(0)
11627           endif
11628 !- end split gradient
11629           c(j,i+nres)=ddx(j)-aincr
11630           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11631           call int_from_cart1(.false.)
11632           if (.not.split_ene) then
11633             call etotal(energia1)
11634             etot2=energia1(0)
11635             ggg(j+3)=(etot1-etot2)/(2*aincr)
11636           else
11637 !- split gradient
11638             call etotal_long(energia1)
11639             etot21=energia1(0)
11640             ggg(j+3)=(etot11-etot21)/(2*aincr)
11641             call etotal_short(energia1)
11642             etot22=energia1(0)
11643             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11644 !- end split gradient
11645           endif
11646 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11647           c(j,i+nres)=ddx(j)
11648           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11649           dc_norm(j,i+nres)=dxnorm_safe(j)
11650           call int_from_cart1(.false.)
11651         enddo
11652         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11653          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11654         if (split_ene) then
11655           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11656          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11657          k=1,6)
11658          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11659          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11660          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11661         endif
11662       enddo
11663       return
11664       end subroutine check_ecartint
11665 #else
11666 !-----------------------------------------------------------------------------
11667       subroutine check_ecartint
11668 ! Check the gradient of the energy in Cartesian coordinates.
11669       use io_base, only: intout
11670 !      implicit real*8 (a-h,o-z)
11671 !      include 'DIMENSIONS'
11672 !      include 'COMMON.CONTROL'
11673 !      include 'COMMON.CHAIN'
11674 !      include 'COMMON.DERIV'
11675 !      include 'COMMON.IOUNITS'
11676 !      include 'COMMON.VAR'
11677 !      include 'COMMON.CONTACTS'
11678 !      include 'COMMON.MD'
11679 !      include 'COMMON.LOCAL'
11680 !      include 'COMMON.SPLITELE'
11681       use comm_srutu
11682 !el      integer :: icall
11683 !el      common /srutu/ icall
11684       real(kind=8),dimension(6) :: ggg,ggg1
11685       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11686       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11687       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11688       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11689       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11690       real(kind=8),dimension(0:n_ene) :: energia,energia1
11691       integer :: uiparm(1)
11692       real(kind=8) :: urparm(1)
11693 !EL      external fdum
11694       integer :: i,j,k,nf
11695       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11696                    etot21,etot22
11697       r_cut=2.0d0
11698       rlambd=0.3d0
11699       icg=1
11700       nf=0
11701       nfl=0
11702       call intout
11703 !      call intcartderiv
11704 !      call checkintcartgrad
11705       call zerograd
11706       aincr=2.0D-5
11707       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11708       nf=0
11709       icall=0
11710       call geom_to_var(nvar,x)
11711       if (.not.split_ene) then
11712         call etotal(energia)
11713         etot=energia(0)
11714 !el        call enerprint(energia)
11715         call flush(iout)
11716         write (iout,*) "enter cartgrad"
11717         call flush(iout)
11718         call cartgrad
11719         write (iout,*) "exit cartgrad"
11720         call flush(iout)
11721         icall =1
11722         do i=1,nres
11723           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11724         enddo
11725         do j=1,3
11726           grad_s(j,0)=gcart(j,0)
11727         enddo
11728         do i=1,nres
11729           do j=1,3
11730             grad_s(j,i)=gcart(j,i)
11731             grad_s(j+3,i)=gxcart(j,i)
11732           enddo
11733         enddo
11734       else
11735 !- split gradient check
11736         call zerograd
11737         call etotal_long(energia)
11738 !el        call enerprint(energia)
11739         call flush(iout)
11740         write (iout,*) "enter cartgrad"
11741         call flush(iout)
11742         call cartgrad
11743         write (iout,*) "exit cartgrad"
11744         call flush(iout)
11745         icall =1
11746         write (iout,*) "longrange grad"
11747         do i=1,nres
11748           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11749           (gxcart(j,i),j=1,3)
11750         enddo
11751         do j=1,3
11752           grad_s(j,0)=gcart(j,0)
11753         enddo
11754         do i=1,nres
11755           do j=1,3
11756             grad_s(j,i)=gcart(j,i)
11757             grad_s(j+3,i)=gxcart(j,i)
11758           enddo
11759         enddo
11760         call zerograd
11761         call etotal_short(energia)
11762 !el        call enerprint(energia)
11763         call flush(iout)
11764         write (iout,*) "enter cartgrad"
11765         call flush(iout)
11766         call cartgrad
11767         write (iout,*) "exit cartgrad"
11768         call flush(iout)
11769         icall =1
11770         write (iout,*) "shortrange grad"
11771         do i=1,nres
11772           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11773           (gxcart(j,i),j=1,3)
11774         enddo
11775         do j=1,3
11776           grad_s1(j,0)=gcart(j,0)
11777         enddo
11778         do i=1,nres
11779           do j=1,3
11780             grad_s1(j,i)=gcart(j,i)
11781             grad_s1(j+3,i)=gxcart(j,i)
11782           enddo
11783         enddo
11784       endif
11785       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11786       do i=0,nres
11787         do j=1,3
11788           xx(j)=c(j,i+nres)
11789           ddc(j)=dc(j,i)
11790           ddx(j)=dc(j,i+nres)
11791           do k=1,3
11792             dcnorm_safe(k)=dc_norm(k,i)
11793             dxnorm_safe(k)=dc_norm(k,i+nres)
11794           enddo
11795         enddo
11796         do j=1,3
11797           dc(j,i)=ddc(j)+aincr
11798           call chainbuild_cart
11799 #ifdef MPI
11800 ! Broadcast the order to compute internal coordinates to the slaves.
11801 !          if (nfgtasks.gt.1)
11802 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
11803 #endif
11804 !          call int_from_cart1(.false.)
11805           if (.not.split_ene) then
11806             call etotal(energia1)
11807             etot1=energia1(0)
11808           else
11809 !- split gradient
11810             call etotal_long(energia1)
11811             etot11=energia1(0)
11812             call etotal_short(energia1)
11813             etot12=energia1(0)
11814 !            write (iout,*) "etot11",etot11," etot12",etot12
11815           endif
11816 !- end split gradient
11817 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11818           dc(j,i)=ddc(j)-aincr
11819           call chainbuild_cart
11820 !          call int_from_cart1(.false.)
11821           if (.not.split_ene) then
11822             call etotal(energia1)
11823             etot2=energia1(0)
11824             ggg(j)=(etot1-etot2)/(2*aincr)
11825           else
11826 !- split gradient
11827             call etotal_long(energia1)
11828             etot21=energia1(0)
11829             ggg(j)=(etot11-etot21)/(2*aincr)
11830             call etotal_short(energia1)
11831             etot22=energia1(0)
11832             ggg1(j)=(etot12-etot22)/(2*aincr)
11833 !- end split gradient
11834 !            write (iout,*) "etot21",etot21," etot22",etot22
11835           endif
11836 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11837           dc(j,i)=ddc(j)
11838           call chainbuild_cart
11839         enddo
11840         do j=1,3
11841           dc(j,i+nres)=ddx(j)+aincr
11842           call chainbuild_cart
11843 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
11844 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11845 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11846 !          write (iout,*) "dxnormnorm",dsqrt(
11847 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11848 !          write (iout,*) "dxnormnormsafe",dsqrt(
11849 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11850 !          write (iout,*)
11851           if (.not.split_ene) then
11852             call etotal(energia1)
11853             etot1=energia1(0)
11854           else
11855 !- split gradient
11856             call etotal_long(energia1)
11857             etot11=energia1(0)
11858             call etotal_short(energia1)
11859             etot12=energia1(0)
11860           endif
11861 !- end split gradient
11862 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11863           dc(j,i+nres)=ddx(j)-aincr
11864           call chainbuild_cart
11865 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
11866 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11867 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11868 !          write (iout,*)
11869 !          write (iout,*) "dxnormnorm",dsqrt(
11870 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11871 !          write (iout,*) "dxnormnormsafe",dsqrt(
11872 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11873           if (.not.split_ene) then
11874             call etotal(energia1)
11875             etot2=energia1(0)
11876             ggg(j+3)=(etot1-etot2)/(2*aincr)
11877           else
11878 !- split gradient
11879             call etotal_long(energia1)
11880             etot21=energia1(0)
11881             ggg(j+3)=(etot11-etot21)/(2*aincr)
11882             call etotal_short(energia1)
11883             etot22=energia1(0)
11884             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11885 !- end split gradient
11886           endif
11887 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11888           dc(j,i+nres)=ddx(j)
11889           call chainbuild_cart
11890         enddo
11891         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11892          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11893         if (split_ene) then
11894           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11895          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11896          k=1,6)
11897          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11898          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11899          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11900         endif
11901       enddo
11902       return
11903       end subroutine check_ecartint
11904 #endif
11905 !-----------------------------------------------------------------------------
11906       subroutine check_eint
11907 ! Check the gradient of energy in internal coordinates.
11908 !      implicit real*8 (a-h,o-z)
11909 !      include 'DIMENSIONS'
11910 !      include 'COMMON.CHAIN'
11911 !      include 'COMMON.DERIV'
11912 !      include 'COMMON.IOUNITS'
11913 !      include 'COMMON.VAR'
11914 !      include 'COMMON.GEO'
11915       use comm_srutu
11916 !el      integer :: icall
11917 !el      common /srutu/ icall
11918       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
11919       integer :: uiparm(1)
11920       real(kind=8) :: urparm(1)
11921       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
11922       character(len=6) :: key
11923 !EL      external fdum
11924       integer :: i,ii,nf
11925       real(kind=8) :: xi,aincr,etot,etot1,etot2
11926       call zerograd
11927       aincr=1.0D-7
11928       print '(a)','Calling CHECK_INT.'
11929       nf=0
11930       nfl=0
11931       icg=1
11932       call geom_to_var(nvar,x)
11933       call var_to_geom(nvar,x)
11934       call chainbuild
11935       icall=1
11936       print *,'ICG=',ICG
11937       call etotal(energia)
11938       etot = energia(0)
11939 !el      call enerprint(energia)
11940       print *,'ICG=',ICG
11941 #ifdef MPL
11942       if (MyID.ne.BossID) then
11943         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
11944         nf=x(nvar+1)
11945         nfl=x(nvar+2)
11946         icg=x(nvar+3)
11947       endif
11948 #endif
11949       nf=1
11950       nfl=3
11951 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
11952       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
11953 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
11954       icall=1
11955       do i=1,nvar
11956         xi=x(i)
11957         x(i)=xi-0.5D0*aincr
11958         call var_to_geom(nvar,x)
11959         call chainbuild
11960         call etotal(energia1)
11961         etot1=energia1(0)
11962         x(i)=xi+0.5D0*aincr
11963         call var_to_geom(nvar,x)
11964         call chainbuild
11965         call etotal(energia2)
11966         etot2=energia2(0)
11967         gg(i)=(etot2-etot1)/aincr
11968         write (iout,*) i,etot1,etot2
11969         x(i)=xi
11970       enddo
11971       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
11972           '     RelDiff*100% '
11973       do i=1,nvar
11974         if (i.le.nphi) then
11975           ii=i
11976           key = ' phi'
11977         else if (i.le.nphi+ntheta) then
11978           ii=i-nphi
11979           key=' theta'
11980         else if (i.le.nphi+ntheta+nside) then
11981            ii=i-(nphi+ntheta)
11982            key=' alpha'
11983         else
11984            ii=i-(nphi+ntheta+nside)
11985            key=' omega'
11986         endif
11987         write (iout,'(i3,a,i3,3(1pd16.6))') &
11988        i,key,ii,gg(i),gana(i),&
11989        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
11990       enddo
11991       return
11992       end subroutine check_eint
11993 !-----------------------------------------------------------------------------
11994 ! econstr_local.F
11995 !-----------------------------------------------------------------------------
11996       subroutine Econstr_back
11997 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
11998 !      implicit real*8 (a-h,o-z)
11999 !      include 'DIMENSIONS'
12000 !      include 'COMMON.CONTROL'
12001 !      include 'COMMON.VAR'
12002 !      include 'COMMON.MD'
12003       use MD_data
12004 !#ifndef LANG0
12005 !      include 'COMMON.LANGEVIN'
12006 !#else
12007 !      include 'COMMON.LANGEVIN.lang0'
12008 !#endif
12009 !      include 'COMMON.CHAIN'
12010 !      include 'COMMON.DERIV'
12011 !      include 'COMMON.GEO'
12012 !      include 'COMMON.LOCAL'
12013 !      include 'COMMON.INTERACT'
12014 !      include 'COMMON.IOUNITS'
12015 !      include 'COMMON.NAMES'
12016 !      include 'COMMON.TIME1'
12017       integer :: i,j,ii,k
12018       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12019
12020       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12021       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12022       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12023
12024       Uconst_back=0.0d0
12025       do i=1,nres
12026         dutheta(i)=0.0d0
12027         dugamma(i)=0.0d0
12028         do j=1,3
12029           duscdiff(j,i)=0.0d0
12030           duscdiffx(j,i)=0.0d0
12031         enddo
12032       enddo
12033       do i=1,nfrag_back
12034         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12035 !
12036 ! Deviations from theta angles
12037 !
12038         utheta_i=0.0d0
12039         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12040           dtheta_i=theta(j)-thetaref(j)
12041           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12042           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12043         enddo
12044         utheta(i)=utheta_i/(ii-1)
12045 !
12046 ! Deviations from gamma angles
12047 !
12048         ugamma_i=0.0d0
12049         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12050           dgamma_i=pinorm(phi(j)-phiref(j))
12051 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12052           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12053           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12054 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12055         enddo
12056         ugamma(i)=ugamma_i/(ii-2)
12057 !
12058 ! Deviations from local SC geometry
12059 !
12060         uscdiff(i)=0.0d0
12061         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12062           dxx=xxtab(j)-xxref(j)
12063           dyy=yytab(j)-yyref(j)
12064           dzz=zztab(j)-zzref(j)
12065           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12066           do k=1,3
12067             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12068              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12069              (ii-1)
12070             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12071              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12072              (ii-1)
12073             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12074            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12075             /(ii-1)
12076           enddo
12077 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12078 !     &      xxref(j),yyref(j),zzref(j)
12079         enddo
12080         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12081 !        write (iout,*) i," uscdiff",uscdiff(i)
12082 !
12083 ! Put together deviations from local geometry
12084 !
12085         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12086           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12087 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12088 !     &   " uconst_back",uconst_back
12089         utheta(i)=dsqrt(utheta(i))
12090         ugamma(i)=dsqrt(ugamma(i))
12091         uscdiff(i)=dsqrt(uscdiff(i))
12092       enddo
12093       return
12094       end subroutine Econstr_back
12095 !-----------------------------------------------------------------------------
12096 ! energy_p_new-sep_barrier.F
12097 !-----------------------------------------------------------------------------
12098       real(kind=8) function sscale(r)
12099 !      include "COMMON.SPLITELE"
12100       real(kind=8) :: r,gamm
12101       if(r.lt.r_cut-rlamb) then
12102         sscale=1.0d0
12103       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12104         gamm=(r-(r_cut-rlamb))/rlamb
12105         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12106       else
12107         sscale=0d0
12108       endif
12109       return
12110       end function sscale
12111       real(kind=8) function sscale_grad(r)
12112 !      include "COMMON.SPLITELE"
12113       real(kind=8) :: r,gamm
12114       if(r.lt.r_cut-rlamb) then
12115         sscale_grad=0.0d0
12116       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12117         gamm=(r-(r_cut-rlamb))/rlamb
12118         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12119       else
12120         sscale_grad=0d0
12121       endif
12122       return
12123       end function sscale_grad
12124
12125 !!!!!!!!!! PBCSCALE
12126       real(kind=8) function sscale_ele(r)
12127 !      include "COMMON.SPLITELE"
12128       real(kind=8) :: r,gamm
12129       if(r.lt.r_cut_ele-rlamb_ele) then
12130         sscale_ele=1.0d0
12131       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12132         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12133         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12134       else
12135         sscale_ele=0d0
12136       endif
12137       return
12138       end function sscale_ele
12139
12140       real(kind=8)  function sscagrad_ele(r)
12141       real(kind=8) :: r,gamm
12142 !      include "COMMON.SPLITELE"
12143       if(r.lt.r_cut_ele-rlamb_ele) then
12144         sscagrad_ele=0.0d0
12145       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12146         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12147         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12148       else
12149         sscagrad_ele=0.0d0
12150       endif
12151       return
12152       end function sscagrad_ele
12153       real(kind=8) function sscalelip(r)
12154       real(kind=8) r,gamm
12155         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12156       return
12157       end function sscalelip
12158 !C-----------------------------------------------------------------------
12159       real(kind=8) function sscagradlip(r)
12160       real(kind=8) r,gamm
12161         sscagradlip=r*(6.0d0*r-6.0d0)
12162       return
12163       end function sscagradlip
12164
12165 !!!!!!!!!!!!!!!
12166 !-----------------------------------------------------------------------------
12167       subroutine elj_long(evdw)
12168 !
12169 ! This subroutine calculates the interaction energy of nonbonded side chains
12170 ! assuming the LJ potential of interaction.
12171 !
12172 !      implicit real*8 (a-h,o-z)
12173 !      include 'DIMENSIONS'
12174 !      include 'COMMON.GEO'
12175 !      include 'COMMON.VAR'
12176 !      include 'COMMON.LOCAL'
12177 !      include 'COMMON.CHAIN'
12178 !      include 'COMMON.DERIV'
12179 !      include 'COMMON.INTERACT'
12180 !      include 'COMMON.TORSION'
12181 !      include 'COMMON.SBRIDGE'
12182 !      include 'COMMON.NAMES'
12183 !      include 'COMMON.IOUNITS'
12184 !      include 'COMMON.CONTACTS'
12185       real(kind=8),parameter :: accur=1.0d-10
12186       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12187 !el local variables
12188       integer :: i,iint,j,k,itypi,itypi1,itypj
12189       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12190       real(kind=8) :: e1,e2,evdwij,evdw
12191 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12192       evdw=0.0D0
12193       do i=iatsc_s,iatsc_e
12194         itypi=itype(i,1)
12195         if (itypi.eq.ntyp1) cycle
12196         itypi1=itype(i+1,1)
12197         xi=c(1,nres+i)
12198         yi=c(2,nres+i)
12199         zi=c(3,nres+i)
12200 !
12201 ! Calculate SC interaction energy.
12202 !
12203         do iint=1,nint_gr(i)
12204 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12205 !d   &                  'iend=',iend(i,iint)
12206           do j=istart(i,iint),iend(i,iint)
12207             itypj=itype(j,1)
12208             if (itypj.eq.ntyp1) cycle
12209             xj=c(1,nres+j)-xi
12210             yj=c(2,nres+j)-yi
12211             zj=c(3,nres+j)-zi
12212             rij=xj*xj+yj*yj+zj*zj
12213             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12214             if (sss.lt.1.0d0) then
12215               rrij=1.0D0/rij
12216               eps0ij=eps(itypi,itypj)
12217               fac=rrij**expon2
12218               e1=fac*fac*aa_aq(itypi,itypj)
12219               e2=fac*bb_aq(itypi,itypj)
12220               evdwij=e1+e2
12221               evdw=evdw+(1.0d0-sss)*evdwij
12222 !
12223 ! Calculate the components of the gradient in DC and X
12224 !
12225               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12226               gg(1)=xj*fac
12227               gg(2)=yj*fac
12228               gg(3)=zj*fac
12229               do k=1,3
12230                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12231                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12232                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12233                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12234               enddo
12235             endif
12236           enddo      ! j
12237         enddo        ! iint
12238       enddo          ! i
12239       do i=1,nct
12240         do j=1,3
12241           gvdwc(j,i)=expon*gvdwc(j,i)
12242           gvdwx(j,i)=expon*gvdwx(j,i)
12243         enddo
12244       enddo
12245 !******************************************************************************
12246 !
12247 !                              N O T E !!!
12248 !
12249 ! To save time, the factor of EXPON has been extracted from ALL components
12250 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12251 ! use!
12252 !
12253 !******************************************************************************
12254       return
12255       end subroutine elj_long
12256 !-----------------------------------------------------------------------------
12257       subroutine elj_short(evdw)
12258 !
12259 ! This subroutine calculates the interaction energy of nonbonded side chains
12260 ! assuming the LJ potential of interaction.
12261 !
12262 !      implicit real*8 (a-h,o-z)
12263 !      include 'DIMENSIONS'
12264 !      include 'COMMON.GEO'
12265 !      include 'COMMON.VAR'
12266 !      include 'COMMON.LOCAL'
12267 !      include 'COMMON.CHAIN'
12268 !      include 'COMMON.DERIV'
12269 !      include 'COMMON.INTERACT'
12270 !      include 'COMMON.TORSION'
12271 !      include 'COMMON.SBRIDGE'
12272 !      include 'COMMON.NAMES'
12273 !      include 'COMMON.IOUNITS'
12274 !      include 'COMMON.CONTACTS'
12275       real(kind=8),parameter :: accur=1.0d-10
12276       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12277 !el local variables
12278       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12279       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12280       real(kind=8) :: e1,e2,evdwij,evdw
12281 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12282       evdw=0.0D0
12283       do i=iatsc_s,iatsc_e
12284         itypi=itype(i,1)
12285         if (itypi.eq.ntyp1) cycle
12286         itypi1=itype(i+1,1)
12287         xi=c(1,nres+i)
12288         yi=c(2,nres+i)
12289         zi=c(3,nres+i)
12290 ! Change 12/1/95
12291         num_conti=0
12292 !
12293 ! Calculate SC interaction energy.
12294 !
12295         do iint=1,nint_gr(i)
12296 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12297 !d   &                  'iend=',iend(i,iint)
12298           do j=istart(i,iint),iend(i,iint)
12299             itypj=itype(j,1)
12300             if (itypj.eq.ntyp1) cycle
12301             xj=c(1,nres+j)-xi
12302             yj=c(2,nres+j)-yi
12303             zj=c(3,nres+j)-zi
12304 ! Change 12/1/95 to calculate four-body interactions
12305             rij=xj*xj+yj*yj+zj*zj
12306             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12307             if (sss.gt.0.0d0) then
12308               rrij=1.0D0/rij
12309               eps0ij=eps(itypi,itypj)
12310               fac=rrij**expon2
12311               e1=fac*fac*aa_aq(itypi,itypj)
12312               e2=fac*bb_aq(itypi,itypj)
12313               evdwij=e1+e2
12314               evdw=evdw+sss*evdwij
12315 !
12316 ! Calculate the components of the gradient in DC and X
12317 !
12318               fac=-rrij*(e1+evdwij)*sss
12319               gg(1)=xj*fac
12320               gg(2)=yj*fac
12321               gg(3)=zj*fac
12322               do k=1,3
12323                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12324                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12325                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12326                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12327               enddo
12328             endif
12329           enddo      ! j
12330         enddo        ! iint
12331       enddo          ! i
12332       do i=1,nct
12333         do j=1,3
12334           gvdwc(j,i)=expon*gvdwc(j,i)
12335           gvdwx(j,i)=expon*gvdwx(j,i)
12336         enddo
12337       enddo
12338 !******************************************************************************
12339 !
12340 !                              N O T E !!!
12341 !
12342 ! To save time, the factor of EXPON has been extracted from ALL components
12343 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12344 ! use!
12345 !
12346 !******************************************************************************
12347       return
12348       end subroutine elj_short
12349 !-----------------------------------------------------------------------------
12350       subroutine eljk_long(evdw)
12351 !
12352 ! This subroutine calculates the interaction energy of nonbonded side chains
12353 ! assuming the LJK potential of interaction.
12354 !
12355 !      implicit real*8 (a-h,o-z)
12356 !      include 'DIMENSIONS'
12357 !      include 'COMMON.GEO'
12358 !      include 'COMMON.VAR'
12359 !      include 'COMMON.LOCAL'
12360 !      include 'COMMON.CHAIN'
12361 !      include 'COMMON.DERIV'
12362 !      include 'COMMON.INTERACT'
12363 !      include 'COMMON.IOUNITS'
12364 !      include 'COMMON.NAMES'
12365       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12366       logical :: scheck
12367 !el local variables
12368       integer :: i,iint,j,k,itypi,itypi1,itypj
12369       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12370                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12371 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12372       evdw=0.0D0
12373       do i=iatsc_s,iatsc_e
12374         itypi=itype(i,1)
12375         if (itypi.eq.ntyp1) cycle
12376         itypi1=itype(i+1,1)
12377         xi=c(1,nres+i)
12378         yi=c(2,nres+i)
12379         zi=c(3,nres+i)
12380 !
12381 ! Calculate SC interaction energy.
12382 !
12383         do iint=1,nint_gr(i)
12384           do j=istart(i,iint),iend(i,iint)
12385             itypj=itype(j,1)
12386             if (itypj.eq.ntyp1) cycle
12387             xj=c(1,nres+j)-xi
12388             yj=c(2,nres+j)-yi
12389             zj=c(3,nres+j)-zi
12390             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12391             fac_augm=rrij**expon
12392             e_augm=augm(itypi,itypj)*fac_augm
12393             r_inv_ij=dsqrt(rrij)
12394             rij=1.0D0/r_inv_ij
12395             sss=sscale(rij/sigma(itypi,itypj))
12396             if (sss.lt.1.0d0) then
12397               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12398               fac=r_shift_inv**expon
12399               e1=fac*fac*aa_aq(itypi,itypj)
12400               e2=fac*bb_aq(itypi,itypj)
12401               evdwij=e_augm+e1+e2
12402 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12403 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12404 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12405 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12406 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12407 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12408 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12409               evdw=evdw+(1.0d0-sss)*evdwij
12410 !
12411 ! Calculate the components of the gradient in DC and X
12412 !
12413               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12414               fac=fac*(1.0d0-sss)
12415               gg(1)=xj*fac
12416               gg(2)=yj*fac
12417               gg(3)=zj*fac
12418               do k=1,3
12419                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12420                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12421                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12422                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12423               enddo
12424             endif
12425           enddo      ! j
12426         enddo        ! iint
12427       enddo          ! i
12428       do i=1,nct
12429         do j=1,3
12430           gvdwc(j,i)=expon*gvdwc(j,i)
12431           gvdwx(j,i)=expon*gvdwx(j,i)
12432         enddo
12433       enddo
12434       return
12435       end subroutine eljk_long
12436 !-----------------------------------------------------------------------------
12437       subroutine eljk_short(evdw)
12438 !
12439 ! This subroutine calculates the interaction energy of nonbonded side chains
12440 ! assuming the LJK potential of interaction.
12441 !
12442 !      implicit real*8 (a-h,o-z)
12443 !      include 'DIMENSIONS'
12444 !      include 'COMMON.GEO'
12445 !      include 'COMMON.VAR'
12446 !      include 'COMMON.LOCAL'
12447 !      include 'COMMON.CHAIN'
12448 !      include 'COMMON.DERIV'
12449 !      include 'COMMON.INTERACT'
12450 !      include 'COMMON.IOUNITS'
12451 !      include 'COMMON.NAMES'
12452       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12453       logical :: scheck
12454 !el local variables
12455       integer :: i,iint,j,k,itypi,itypi1,itypj
12456       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12457                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12458 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12459       evdw=0.0D0
12460       do i=iatsc_s,iatsc_e
12461         itypi=itype(i,1)
12462         if (itypi.eq.ntyp1) cycle
12463         itypi1=itype(i+1,1)
12464         xi=c(1,nres+i)
12465         yi=c(2,nres+i)
12466         zi=c(3,nres+i)
12467 !
12468 ! Calculate SC interaction energy.
12469 !
12470         do iint=1,nint_gr(i)
12471           do j=istart(i,iint),iend(i,iint)
12472             itypj=itype(j,1)
12473             if (itypj.eq.ntyp1) cycle
12474             xj=c(1,nres+j)-xi
12475             yj=c(2,nres+j)-yi
12476             zj=c(3,nres+j)-zi
12477             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12478             fac_augm=rrij**expon
12479             e_augm=augm(itypi,itypj)*fac_augm
12480             r_inv_ij=dsqrt(rrij)
12481             rij=1.0D0/r_inv_ij
12482             sss=sscale(rij/sigma(itypi,itypj))
12483             if (sss.gt.0.0d0) then
12484               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12485               fac=r_shift_inv**expon
12486               e1=fac*fac*aa_aq(itypi,itypj)
12487               e2=fac*bb_aq(itypi,itypj)
12488               evdwij=e_augm+e1+e2
12489 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12490 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12491 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12492 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12493 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12494 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12495 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12496               evdw=evdw+sss*evdwij
12497 !
12498 ! Calculate the components of the gradient in DC and X
12499 !
12500               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12501               fac=fac*sss
12502               gg(1)=xj*fac
12503               gg(2)=yj*fac
12504               gg(3)=zj*fac
12505               do k=1,3
12506                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12507                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12508                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12509                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12510               enddo
12511             endif
12512           enddo      ! j
12513         enddo        ! iint
12514       enddo          ! i
12515       do i=1,nct
12516         do j=1,3
12517           gvdwc(j,i)=expon*gvdwc(j,i)
12518           gvdwx(j,i)=expon*gvdwx(j,i)
12519         enddo
12520       enddo
12521       return
12522       end subroutine eljk_short
12523 !-----------------------------------------------------------------------------
12524       subroutine ebp_long(evdw)
12525 !
12526 ! This subroutine calculates the interaction energy of nonbonded side chains
12527 ! assuming the Berne-Pechukas potential of interaction.
12528 !
12529       use calc_data
12530 !      implicit real*8 (a-h,o-z)
12531 !      include 'DIMENSIONS'
12532 !      include 'COMMON.GEO'
12533 !      include 'COMMON.VAR'
12534 !      include 'COMMON.LOCAL'
12535 !      include 'COMMON.CHAIN'
12536 !      include 'COMMON.DERIV'
12537 !      include 'COMMON.NAMES'
12538 !      include 'COMMON.INTERACT'
12539 !      include 'COMMON.IOUNITS'
12540 !      include 'COMMON.CALC'
12541       use comm_srutu
12542 !el      integer :: icall
12543 !el      common /srutu/ icall
12544 !     double precision rrsave(maxdim)
12545       logical :: lprn
12546 !el local variables
12547       integer :: iint,itypi,itypi1,itypj
12548       real(kind=8) :: rrij,xi,yi,zi,fac
12549       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12550       evdw=0.0D0
12551 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12552       evdw=0.0D0
12553 !     if (icall.eq.0) then
12554 !       lprn=.true.
12555 !     else
12556         lprn=.false.
12557 !     endif
12558 !el      ind=0
12559       do i=iatsc_s,iatsc_e
12560         itypi=itype(i,1)
12561         if (itypi.eq.ntyp1) cycle
12562         itypi1=itype(i+1,1)
12563         xi=c(1,nres+i)
12564         yi=c(2,nres+i)
12565         zi=c(3,nres+i)
12566         dxi=dc_norm(1,nres+i)
12567         dyi=dc_norm(2,nres+i)
12568         dzi=dc_norm(3,nres+i)
12569 !        dsci_inv=dsc_inv(itypi)
12570         dsci_inv=vbld_inv(i+nres)
12571 !
12572 ! Calculate SC interaction energy.
12573 !
12574         do iint=1,nint_gr(i)
12575           do j=istart(i,iint),iend(i,iint)
12576 !el            ind=ind+1
12577             itypj=itype(j,1)
12578             if (itypj.eq.ntyp1) cycle
12579 !            dscj_inv=dsc_inv(itypj)
12580             dscj_inv=vbld_inv(j+nres)
12581             chi1=chi(itypi,itypj)
12582             chi2=chi(itypj,itypi)
12583             chi12=chi1*chi2
12584             chip1=chip(itypi)
12585             chip2=chip(itypj)
12586             chip12=chip1*chip2
12587             alf1=alp(itypi)
12588             alf2=alp(itypj)
12589             alf12=0.5D0*(alf1+alf2)
12590             xj=c(1,nres+j)-xi
12591             yj=c(2,nres+j)-yi
12592             zj=c(3,nres+j)-zi
12593             dxj=dc_norm(1,nres+j)
12594             dyj=dc_norm(2,nres+j)
12595             dzj=dc_norm(3,nres+j)
12596             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12597             rij=dsqrt(rrij)
12598             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12599
12600             if (sss.lt.1.0d0) then
12601
12602 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12603               call sc_angular
12604 ! Calculate whole angle-dependent part of epsilon and contributions
12605 ! to its derivatives
12606               fac=(rrij*sigsq)**expon2
12607               e1=fac*fac*aa_aq(itypi,itypj)
12608               e2=fac*bb_aq(itypi,itypj)
12609               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12610               eps2der=evdwij*eps3rt
12611               eps3der=evdwij*eps2rt
12612               evdwij=evdwij*eps2rt*eps3rt
12613               evdw=evdw+evdwij*(1.0d0-sss)
12614               if (lprn) then
12615               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12616               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12617 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12618 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12619 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12620 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12621 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12622 !d     &          evdwij
12623               endif
12624 ! Calculate gradient components.
12625               e1=e1*eps1*eps2rt**2*eps3rt**2
12626               fac=-expon*(e1+evdwij)
12627               sigder=fac/sigsq
12628               fac=rrij*fac
12629 ! Calculate radial part of the gradient
12630               gg(1)=xj*fac
12631               gg(2)=yj*fac
12632               gg(3)=zj*fac
12633 ! Calculate the angular part of the gradient and sum add the contributions
12634 ! to the appropriate components of the Cartesian gradient.
12635               call sc_grad_scale(1.0d0-sss)
12636             endif
12637           enddo      ! j
12638         enddo        ! iint
12639       enddo          ! i
12640 !     stop
12641       return
12642       end subroutine ebp_long
12643 !-----------------------------------------------------------------------------
12644       subroutine ebp_short(evdw)
12645 !
12646 ! This subroutine calculates the interaction energy of nonbonded side chains
12647 ! assuming the Berne-Pechukas potential of interaction.
12648 !
12649       use calc_data
12650 !      implicit real*8 (a-h,o-z)
12651 !      include 'DIMENSIONS'
12652 !      include 'COMMON.GEO'
12653 !      include 'COMMON.VAR'
12654 !      include 'COMMON.LOCAL'
12655 !      include 'COMMON.CHAIN'
12656 !      include 'COMMON.DERIV'
12657 !      include 'COMMON.NAMES'
12658 !      include 'COMMON.INTERACT'
12659 !      include 'COMMON.IOUNITS'
12660 !      include 'COMMON.CALC'
12661       use comm_srutu
12662 !el      integer :: icall
12663 !el      common /srutu/ icall
12664 !     double precision rrsave(maxdim)
12665       logical :: lprn
12666 !el local variables
12667       integer :: iint,itypi,itypi1,itypj
12668       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12669       real(kind=8) :: sss,e1,e2,evdw
12670       evdw=0.0D0
12671 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12672       evdw=0.0D0
12673 !     if (icall.eq.0) then
12674 !       lprn=.true.
12675 !     else
12676         lprn=.false.
12677 !     endif
12678 !el      ind=0
12679       do i=iatsc_s,iatsc_e
12680         itypi=itype(i,1)
12681         if (itypi.eq.ntyp1) cycle
12682         itypi1=itype(i+1,1)
12683         xi=c(1,nres+i)
12684         yi=c(2,nres+i)
12685         zi=c(3,nres+i)
12686         dxi=dc_norm(1,nres+i)
12687         dyi=dc_norm(2,nres+i)
12688         dzi=dc_norm(3,nres+i)
12689 !        dsci_inv=dsc_inv(itypi)
12690         dsci_inv=vbld_inv(i+nres)
12691 !
12692 ! Calculate SC interaction energy.
12693 !
12694         do iint=1,nint_gr(i)
12695           do j=istart(i,iint),iend(i,iint)
12696 !el            ind=ind+1
12697             itypj=itype(j,1)
12698             if (itypj.eq.ntyp1) cycle
12699 !            dscj_inv=dsc_inv(itypj)
12700             dscj_inv=vbld_inv(j+nres)
12701             chi1=chi(itypi,itypj)
12702             chi2=chi(itypj,itypi)
12703             chi12=chi1*chi2
12704             chip1=chip(itypi)
12705             chip2=chip(itypj)
12706             chip12=chip1*chip2
12707             alf1=alp(itypi)
12708             alf2=alp(itypj)
12709             alf12=0.5D0*(alf1+alf2)
12710             xj=c(1,nres+j)-xi
12711             yj=c(2,nres+j)-yi
12712             zj=c(3,nres+j)-zi
12713             dxj=dc_norm(1,nres+j)
12714             dyj=dc_norm(2,nres+j)
12715             dzj=dc_norm(3,nres+j)
12716             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12717             rij=dsqrt(rrij)
12718             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12719
12720             if (sss.gt.0.0d0) then
12721
12722 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12723               call sc_angular
12724 ! Calculate whole angle-dependent part of epsilon and contributions
12725 ! to its derivatives
12726               fac=(rrij*sigsq)**expon2
12727               e1=fac*fac*aa_aq(itypi,itypj)
12728               e2=fac*bb_aq(itypi,itypj)
12729               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12730               eps2der=evdwij*eps3rt
12731               eps3der=evdwij*eps2rt
12732               evdwij=evdwij*eps2rt*eps3rt
12733               evdw=evdw+evdwij*sss
12734               if (lprn) then
12735               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12736               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12737 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12738 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12739 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12740 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12741 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12742 !d     &          evdwij
12743               endif
12744 ! Calculate gradient components.
12745               e1=e1*eps1*eps2rt**2*eps3rt**2
12746               fac=-expon*(e1+evdwij)
12747               sigder=fac/sigsq
12748               fac=rrij*fac
12749 ! Calculate radial part of the gradient
12750               gg(1)=xj*fac
12751               gg(2)=yj*fac
12752               gg(3)=zj*fac
12753 ! Calculate the angular part of the gradient and sum add the contributions
12754 ! to the appropriate components of the Cartesian gradient.
12755               call sc_grad_scale(sss)
12756             endif
12757           enddo      ! j
12758         enddo        ! iint
12759       enddo          ! i
12760 !     stop
12761       return
12762       end subroutine ebp_short
12763 !-----------------------------------------------------------------------------
12764       subroutine egb_long(evdw)
12765 !
12766 ! This subroutine calculates the interaction energy of nonbonded side chains
12767 ! assuming the Gay-Berne potential of interaction.
12768 !
12769       use calc_data
12770 !      implicit real*8 (a-h,o-z)
12771 !      include 'DIMENSIONS'
12772 !      include 'COMMON.GEO'
12773 !      include 'COMMON.VAR'
12774 !      include 'COMMON.LOCAL'
12775 !      include 'COMMON.CHAIN'
12776 !      include 'COMMON.DERIV'
12777 !      include 'COMMON.NAMES'
12778 !      include 'COMMON.INTERACT'
12779 !      include 'COMMON.IOUNITS'
12780 !      include 'COMMON.CALC'
12781 !      include 'COMMON.CONTROL'
12782       logical :: lprn
12783 !el local variables
12784       integer :: iint,itypi,itypi1,itypj,subchap
12785       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
12786       real(kind=8) :: sss,e1,e2,evdw,sss_grad
12787       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12788                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12789                     ssgradlipi,ssgradlipj
12790
12791
12792       evdw=0.0D0
12793 !cccc      energy_dec=.false.
12794 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12795       evdw=0.0D0
12796       lprn=.false.
12797 !     if (icall.eq.0) lprn=.false.
12798 !el      ind=0
12799       do i=iatsc_s,iatsc_e
12800         itypi=itype(i,1)
12801         if (itypi.eq.ntyp1) cycle
12802         itypi1=itype(i+1,1)
12803         xi=c(1,nres+i)
12804         yi=c(2,nres+i)
12805         zi=c(3,nres+i)
12806           xi=mod(xi,boxxsize)
12807           if (xi.lt.0) xi=xi+boxxsize
12808           yi=mod(yi,boxysize)
12809           if (yi.lt.0) yi=yi+boxysize
12810           zi=mod(zi,boxzsize)
12811           if (zi.lt.0) zi=zi+boxzsize
12812        if ((zi.gt.bordlipbot)    &
12813         .and.(zi.lt.bordliptop)) then
12814 !C the energy transfer exist
12815         if (zi.lt.buflipbot) then
12816 !C what fraction I am in
12817          fracinbuf=1.0d0-    &
12818              ((zi-bordlipbot)/lipbufthick)
12819 !C lipbufthick is thickenes of lipid buffore
12820          sslipi=sscalelip(fracinbuf)
12821          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12822         elseif (zi.gt.bufliptop) then
12823          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12824          sslipi=sscalelip(fracinbuf)
12825          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12826         else
12827          sslipi=1.0d0
12828          ssgradlipi=0.0
12829         endif
12830        else
12831          sslipi=0.0d0
12832          ssgradlipi=0.0
12833        endif
12834
12835         dxi=dc_norm(1,nres+i)
12836         dyi=dc_norm(2,nres+i)
12837         dzi=dc_norm(3,nres+i)
12838 !        dsci_inv=dsc_inv(itypi)
12839         dsci_inv=vbld_inv(i+nres)
12840 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12841 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12842 !
12843 ! Calculate SC interaction energy.
12844 !
12845         do iint=1,nint_gr(i)
12846           do j=istart(i,iint),iend(i,iint)
12847             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12848 !              call dyn_ssbond_ene(i,j,evdwij)
12849 !              evdw=evdw+evdwij
12850 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12851 !                              'evdw',i,j,evdwij,' ss'
12852 !              if (energy_dec) write (iout,*) &
12853 !                              'evdw',i,j,evdwij,' ss'
12854 !             do k=j+1,iend(i,iint)
12855 !C search over all next residues
12856 !              if (dyn_ss_mask(k)) then
12857 !C check if they are cysteins
12858 !C              write(iout,*) 'k=',k
12859
12860 !c              write(iout,*) "PRZED TRI", evdwij
12861 !               evdwij_przed_tri=evdwij
12862 !              call triple_ssbond_ene(i,j,k,evdwij)
12863 !c               if(evdwij_przed_tri.ne.evdwij) then
12864 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
12865 !c               endif
12866
12867 !c              write(iout,*) "PO TRI", evdwij
12868 !C call the energy function that removes the artifical triple disulfide
12869 !C bond the soubroutine is located in ssMD.F
12870 !              evdw=evdw+evdwij
12871               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12872                             'evdw',i,j,evdwij,'tss'
12873 !              endif!dyn_ss_mask(k)
12874 !             enddo! k
12875
12876             ELSE
12877 !el            ind=ind+1
12878             itypj=itype(j,1)
12879             if (itypj.eq.ntyp1) cycle
12880 !            dscj_inv=dsc_inv(itypj)
12881             dscj_inv=vbld_inv(j+nres)
12882 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12883 !     &       1.0d0/vbld(j+nres)
12884 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
12885             sig0ij=sigma(itypi,itypj)
12886             chi1=chi(itypi,itypj)
12887             chi2=chi(itypj,itypi)
12888             chi12=chi1*chi2
12889             chip1=chip(itypi)
12890             chip2=chip(itypj)
12891             chip12=chip1*chip2
12892             alf1=alp(itypi)
12893             alf2=alp(itypj)
12894             alf12=0.5D0*(alf1+alf2)
12895             xj=c(1,nres+j)
12896             yj=c(2,nres+j)
12897             zj=c(3,nres+j)
12898 ! Searching for nearest neighbour
12899           xj=mod(xj,boxxsize)
12900           if (xj.lt.0) xj=xj+boxxsize
12901           yj=mod(yj,boxysize)
12902           if (yj.lt.0) yj=yj+boxysize
12903           zj=mod(zj,boxzsize)
12904           if (zj.lt.0) zj=zj+boxzsize
12905        if ((zj.gt.bordlipbot)   &
12906       .and.(zj.lt.bordliptop)) then
12907 !C the energy transfer exist
12908         if (zj.lt.buflipbot) then
12909 !C what fraction I am in
12910          fracinbuf=1.0d0-  &
12911              ((zj-bordlipbot)/lipbufthick)
12912 !C lipbufthick is thickenes of lipid buffore
12913          sslipj=sscalelip(fracinbuf)
12914          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
12915         elseif (zj.gt.bufliptop) then
12916          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
12917          sslipj=sscalelip(fracinbuf)
12918          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
12919         else
12920          sslipj=1.0d0
12921          ssgradlipj=0.0
12922         endif
12923        else
12924          sslipj=0.0d0
12925          ssgradlipj=0.0
12926        endif
12927       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12928        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12929       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12930        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12931
12932           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12933           xj_safe=xj
12934           yj_safe=yj
12935           zj_safe=zj
12936           subchap=0
12937           do xshift=-1,1
12938           do yshift=-1,1
12939           do zshift=-1,1
12940           xj=xj_safe+xshift*boxxsize
12941           yj=yj_safe+yshift*boxysize
12942           zj=zj_safe+zshift*boxzsize
12943           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12944           if(dist_temp.lt.dist_init) then
12945             dist_init=dist_temp
12946             xj_temp=xj
12947             yj_temp=yj
12948             zj_temp=zj
12949             subchap=1
12950           endif
12951           enddo
12952           enddo
12953           enddo
12954           if (subchap.eq.1) then
12955           xj=xj_temp-xi
12956           yj=yj_temp-yi
12957           zj=zj_temp-zi
12958           else
12959           xj=xj_safe-xi
12960           yj=yj_safe-yi
12961           zj=zj_safe-zi
12962           endif
12963
12964             dxj=dc_norm(1,nres+j)
12965             dyj=dc_norm(2,nres+j)
12966             dzj=dc_norm(3,nres+j)
12967             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12968             rij=dsqrt(rrij)
12969             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12970             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12971             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12972             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12973             if (sss_ele_cut.le.0.0) cycle
12974             if (sss.lt.1.0d0) then
12975
12976 ! Calculate angle-dependent terms of energy and contributions to their
12977 ! derivatives.
12978               call sc_angular
12979               sigsq=1.0D0/sigsq
12980               sig=sig0ij*dsqrt(sigsq)
12981               rij_shift=1.0D0/rij-sig+sig0ij
12982 ! for diagnostics; uncomment
12983 !              rij_shift=1.2*sig0ij
12984 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12985               if (rij_shift.le.0.0D0) then
12986                 evdw=1.0D20
12987 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12988 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12989 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12990                 return
12991               endif
12992               sigder=-sig*sigsq
12993 !---------------------------------------------------------------
12994               rij_shift=1.0D0/rij_shift
12995               fac=rij_shift**expon
12996               e1=fac*fac*aa
12997               e2=fac*bb
12998               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12999               eps2der=evdwij*eps3rt
13000               eps3der=evdwij*eps2rt
13001 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13002 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13003               evdwij=evdwij*eps2rt*eps3rt
13004               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13005               if (lprn) then
13006               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13007               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13008               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13009                 restyp(itypi,1),i,restyp(itypj,1),j,&
13010                 epsi,sigm,chi1,chi2,chip1,chip2,&
13011                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13012                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13013                 evdwij
13014               endif
13015
13016               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13017                               'evdw',i,j,evdwij
13018 !              if (energy_dec) write (iout,*) &
13019 !                              'evdw',i,j,evdwij,"egb_long"
13020
13021 ! Calculate gradient components.
13022               e1=e1*eps1*eps2rt**2*eps3rt**2
13023               fac=-expon*(e1+evdwij)*rij_shift
13024               sigder=fac*sigder
13025               fac=rij*fac
13026               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13027             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13028             /sigmaii(itypi,itypj))
13029 !              fac=0.0d0
13030 ! Calculate the radial part of the gradient
13031               gg(1)=xj*fac
13032               gg(2)=yj*fac
13033               gg(3)=zj*fac
13034 ! Calculate angular part of the gradient.
13035               call sc_grad_scale(1.0d0-sss)
13036             ENDIF    !mask_dyn_ss
13037             endif
13038           enddo      ! j
13039         enddo        ! iint
13040       enddo          ! i
13041 !      write (iout,*) "Number of loop steps in EGB:",ind
13042 !ccc      energy_dec=.false.
13043       return
13044       end subroutine egb_long
13045 !-----------------------------------------------------------------------------
13046       subroutine egb_short(evdw)
13047 !
13048 ! This subroutine calculates the interaction energy of nonbonded side chains
13049 ! assuming the Gay-Berne potential of interaction.
13050 !
13051       use calc_data
13052 !      implicit real*8 (a-h,o-z)
13053 !      include 'DIMENSIONS'
13054 !      include 'COMMON.GEO'
13055 !      include 'COMMON.VAR'
13056 !      include 'COMMON.LOCAL'
13057 !      include 'COMMON.CHAIN'
13058 !      include 'COMMON.DERIV'
13059 !      include 'COMMON.NAMES'
13060 !      include 'COMMON.INTERACT'
13061 !      include 'COMMON.IOUNITS'
13062 !      include 'COMMON.CALC'
13063 !      include 'COMMON.CONTROL'
13064       logical :: lprn
13065 !el local variables
13066       integer :: iint,itypi,itypi1,itypj,subchap
13067       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13068       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13069       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13070                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13071                     ssgradlipi,ssgradlipj
13072       evdw=0.0D0
13073 !cccc      energy_dec=.false.
13074 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13075       evdw=0.0D0
13076       lprn=.false.
13077 !     if (icall.eq.0) lprn=.false.
13078 !el      ind=0
13079       do i=iatsc_s,iatsc_e
13080         itypi=itype(i,1)
13081         if (itypi.eq.ntyp1) cycle
13082         itypi1=itype(i+1,1)
13083         xi=c(1,nres+i)
13084         yi=c(2,nres+i)
13085         zi=c(3,nres+i)
13086           xi=mod(xi,boxxsize)
13087           if (xi.lt.0) xi=xi+boxxsize
13088           yi=mod(yi,boxysize)
13089           if (yi.lt.0) yi=yi+boxysize
13090           zi=mod(zi,boxzsize)
13091           if (zi.lt.0) zi=zi+boxzsize
13092        if ((zi.gt.bordlipbot)    &
13093         .and.(zi.lt.bordliptop)) then
13094 !C the energy transfer exist
13095         if (zi.lt.buflipbot) then
13096 !C what fraction I am in
13097          fracinbuf=1.0d0-    &
13098              ((zi-bordlipbot)/lipbufthick)
13099 !C lipbufthick is thickenes of lipid buffore
13100          sslipi=sscalelip(fracinbuf)
13101          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13102         elseif (zi.gt.bufliptop) then
13103          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13104          sslipi=sscalelip(fracinbuf)
13105          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13106         else
13107          sslipi=1.0d0
13108          ssgradlipi=0.0
13109         endif
13110        else
13111          sslipi=0.0d0
13112          ssgradlipi=0.0
13113        endif
13114
13115         dxi=dc_norm(1,nres+i)
13116         dyi=dc_norm(2,nres+i)
13117         dzi=dc_norm(3,nres+i)
13118 !        dsci_inv=dsc_inv(itypi)
13119         dsci_inv=vbld_inv(i+nres)
13120
13121         dxi=dc_norm(1,nres+i)
13122         dyi=dc_norm(2,nres+i)
13123         dzi=dc_norm(3,nres+i)
13124 !        dsci_inv=dsc_inv(itypi)
13125         dsci_inv=vbld_inv(i+nres)
13126 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13127 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13128 !
13129 ! Calculate SC interaction energy.
13130 !
13131         do iint=1,nint_gr(i)
13132           do j=istart(i,iint),iend(i,iint)
13133             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13134               call dyn_ssbond_ene(i,j,evdwij)
13135               evdw=evdw+evdwij
13136               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13137                               'evdw',i,j,evdwij,' ss'
13138              do k=j+1,iend(i,iint)
13139 !C search over all next residues
13140               if (dyn_ss_mask(k)) then
13141 !C check if they are cysteins
13142 !C              write(iout,*) 'k=',k
13143
13144 !c              write(iout,*) "PRZED TRI", evdwij
13145 !               evdwij_przed_tri=evdwij
13146               call triple_ssbond_ene(i,j,k,evdwij)
13147 !c               if(evdwij_przed_tri.ne.evdwij) then
13148 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13149 !c               endif
13150
13151 !c              write(iout,*) "PO TRI", evdwij
13152 !C call the energy function that removes the artifical triple disulfide
13153 !C bond the soubroutine is located in ssMD.F
13154               evdw=evdw+evdwij
13155               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13156                             'evdw',i,j,evdwij,'tss'
13157               endif!dyn_ss_mask(k)
13158              enddo! k
13159
13160 !              if (energy_dec) write (iout,*) &
13161 !                              'evdw',i,j,evdwij,' ss'
13162             ELSE
13163 !el            ind=ind+1
13164             itypj=itype(j,1)
13165             if (itypj.eq.ntyp1) cycle
13166 !            dscj_inv=dsc_inv(itypj)
13167             dscj_inv=vbld_inv(j+nres)
13168 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13169 !     &       1.0d0/vbld(j+nres)
13170 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13171             sig0ij=sigma(itypi,itypj)
13172             chi1=chi(itypi,itypj)
13173             chi2=chi(itypj,itypi)
13174             chi12=chi1*chi2
13175             chip1=chip(itypi)
13176             chip2=chip(itypj)
13177             chip12=chip1*chip2
13178             alf1=alp(itypi)
13179             alf2=alp(itypj)
13180             alf12=0.5D0*(alf1+alf2)
13181 !            xj=c(1,nres+j)-xi
13182 !            yj=c(2,nres+j)-yi
13183 !            zj=c(3,nres+j)-zi
13184             xj=c(1,nres+j)
13185             yj=c(2,nres+j)
13186             zj=c(3,nres+j)
13187 ! Searching for nearest neighbour
13188           xj=mod(xj,boxxsize)
13189           if (xj.lt.0) xj=xj+boxxsize
13190           yj=mod(yj,boxysize)
13191           if (yj.lt.0) yj=yj+boxysize
13192           zj=mod(zj,boxzsize)
13193           if (zj.lt.0) zj=zj+boxzsize
13194        if ((zj.gt.bordlipbot)   &
13195       .and.(zj.lt.bordliptop)) then
13196 !C the energy transfer exist
13197         if (zj.lt.buflipbot) then
13198 !C what fraction I am in
13199          fracinbuf=1.0d0-  &
13200              ((zj-bordlipbot)/lipbufthick)
13201 !C lipbufthick is thickenes of lipid buffore
13202          sslipj=sscalelip(fracinbuf)
13203          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13204         elseif (zj.gt.bufliptop) then
13205          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13206          sslipj=sscalelip(fracinbuf)
13207          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13208         else
13209          sslipj=1.0d0
13210          ssgradlipj=0.0
13211         endif
13212        else
13213          sslipj=0.0d0
13214          ssgradlipj=0.0
13215        endif
13216       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13217        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13218       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13219        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13220
13221           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13222           xj_safe=xj
13223           yj_safe=yj
13224           zj_safe=zj
13225           subchap=0
13226
13227           do xshift=-1,1
13228           do yshift=-1,1
13229           do zshift=-1,1
13230           xj=xj_safe+xshift*boxxsize
13231           yj=yj_safe+yshift*boxysize
13232           zj=zj_safe+zshift*boxzsize
13233           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13234           if(dist_temp.lt.dist_init) then
13235             dist_init=dist_temp
13236             xj_temp=xj
13237             yj_temp=yj
13238             zj_temp=zj
13239             subchap=1
13240           endif
13241           enddo
13242           enddo
13243           enddo
13244           if (subchap.eq.1) then
13245           xj=xj_temp-xi
13246           yj=yj_temp-yi
13247           zj=zj_temp-zi
13248           else
13249           xj=xj_safe-xi
13250           yj=yj_safe-yi
13251           zj=zj_safe-zi
13252           endif
13253
13254             dxj=dc_norm(1,nres+j)
13255             dyj=dc_norm(2,nres+j)
13256             dzj=dc_norm(3,nres+j)
13257             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13258             rij=dsqrt(rrij)
13259             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13260             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13261             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13262             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13263             if (sss_ele_cut.le.0.0) cycle
13264
13265             if (sss.gt.0.0d0) then
13266
13267 ! Calculate angle-dependent terms of energy and contributions to their
13268 ! derivatives.
13269               call sc_angular
13270               sigsq=1.0D0/sigsq
13271               sig=sig0ij*dsqrt(sigsq)
13272               rij_shift=1.0D0/rij-sig+sig0ij
13273 ! for diagnostics; uncomment
13274 !              rij_shift=1.2*sig0ij
13275 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13276               if (rij_shift.le.0.0D0) then
13277                 evdw=1.0D20
13278 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13279 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13280 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13281                 return
13282               endif
13283               sigder=-sig*sigsq
13284 !---------------------------------------------------------------
13285               rij_shift=1.0D0/rij_shift
13286               fac=rij_shift**expon
13287               e1=fac*fac*aa
13288               e2=fac*bb
13289               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13290               eps2der=evdwij*eps3rt
13291               eps3der=evdwij*eps2rt
13292 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13293 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13294               evdwij=evdwij*eps2rt*eps3rt
13295               evdw=evdw+evdwij*sss*sss_ele_cut
13296               if (lprn) then
13297               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13298               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13299               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13300                 restyp(itypi,1),i,restyp(itypj,1),j,&
13301                 epsi,sigm,chi1,chi2,chip1,chip2,&
13302                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13303                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13304                 evdwij
13305               endif
13306
13307               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13308                               'evdw',i,j,evdwij
13309 !              if (energy_dec) write (iout,*) &
13310 !                              'evdw',i,j,evdwij,"egb_short"
13311
13312 ! Calculate gradient components.
13313               e1=e1*eps1*eps2rt**2*eps3rt**2
13314               fac=-expon*(e1+evdwij)*rij_shift
13315               sigder=fac*sigder
13316               fac=rij*fac
13317               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13318             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13319             /sigmaii(itypi,itypj))
13320
13321 !              fac=0.0d0
13322 ! Calculate the radial part of the gradient
13323               gg(1)=xj*fac
13324               gg(2)=yj*fac
13325               gg(3)=zj*fac
13326 ! Calculate angular part of the gradient.
13327               call sc_grad_scale(sss)
13328             endif
13329           ENDIF !mask_dyn_ss
13330           enddo      ! j
13331         enddo        ! iint
13332       enddo          ! i
13333 !      write (iout,*) "Number of loop steps in EGB:",ind
13334 !ccc      energy_dec=.false.
13335       return
13336       end subroutine egb_short
13337 !-----------------------------------------------------------------------------
13338       subroutine egbv_long(evdw)
13339 !
13340 ! This subroutine calculates the interaction energy of nonbonded side chains
13341 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13342 !
13343       use calc_data
13344 !      implicit real*8 (a-h,o-z)
13345 !      include 'DIMENSIONS'
13346 !      include 'COMMON.GEO'
13347 !      include 'COMMON.VAR'
13348 !      include 'COMMON.LOCAL'
13349 !      include 'COMMON.CHAIN'
13350 !      include 'COMMON.DERIV'
13351 !      include 'COMMON.NAMES'
13352 !      include 'COMMON.INTERACT'
13353 !      include 'COMMON.IOUNITS'
13354 !      include 'COMMON.CALC'
13355       use comm_srutu
13356 !el      integer :: icall
13357 !el      common /srutu/ icall
13358       logical :: lprn
13359 !el local variables
13360       integer :: iint,itypi,itypi1,itypj
13361       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13362       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13363       evdw=0.0D0
13364 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13365       evdw=0.0D0
13366       lprn=.false.
13367 !     if (icall.eq.0) lprn=.true.
13368 !el      ind=0
13369       do i=iatsc_s,iatsc_e
13370         itypi=itype(i,1)
13371         if (itypi.eq.ntyp1) cycle
13372         itypi1=itype(i+1,1)
13373         xi=c(1,nres+i)
13374         yi=c(2,nres+i)
13375         zi=c(3,nres+i)
13376         dxi=dc_norm(1,nres+i)
13377         dyi=dc_norm(2,nres+i)
13378         dzi=dc_norm(3,nres+i)
13379 !        dsci_inv=dsc_inv(itypi)
13380         dsci_inv=vbld_inv(i+nres)
13381 !
13382 ! Calculate SC interaction energy.
13383 !
13384         do iint=1,nint_gr(i)
13385           do j=istart(i,iint),iend(i,iint)
13386 !el            ind=ind+1
13387             itypj=itype(j,1)
13388             if (itypj.eq.ntyp1) cycle
13389 !            dscj_inv=dsc_inv(itypj)
13390             dscj_inv=vbld_inv(j+nres)
13391             sig0ij=sigma(itypi,itypj)
13392             r0ij=r0(itypi,itypj)
13393             chi1=chi(itypi,itypj)
13394             chi2=chi(itypj,itypi)
13395             chi12=chi1*chi2
13396             chip1=chip(itypi)
13397             chip2=chip(itypj)
13398             chip12=chip1*chip2
13399             alf1=alp(itypi)
13400             alf2=alp(itypj)
13401             alf12=0.5D0*(alf1+alf2)
13402             xj=c(1,nres+j)-xi
13403             yj=c(2,nres+j)-yi
13404             zj=c(3,nres+j)-zi
13405             dxj=dc_norm(1,nres+j)
13406             dyj=dc_norm(2,nres+j)
13407             dzj=dc_norm(3,nres+j)
13408             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13409             rij=dsqrt(rrij)
13410
13411             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13412
13413             if (sss.lt.1.0d0) then
13414
13415 ! Calculate angle-dependent terms of energy and contributions to their
13416 ! derivatives.
13417               call sc_angular
13418               sigsq=1.0D0/sigsq
13419               sig=sig0ij*dsqrt(sigsq)
13420               rij_shift=1.0D0/rij-sig+r0ij
13421 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13422               if (rij_shift.le.0.0D0) then
13423                 evdw=1.0D20
13424                 return
13425               endif
13426               sigder=-sig*sigsq
13427 !---------------------------------------------------------------
13428               rij_shift=1.0D0/rij_shift
13429               fac=rij_shift**expon
13430               e1=fac*fac*aa_aq(itypi,itypj)
13431               e2=fac*bb_aq(itypi,itypj)
13432               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13433               eps2der=evdwij*eps3rt
13434               eps3der=evdwij*eps2rt
13435               fac_augm=rrij**expon
13436               e_augm=augm(itypi,itypj)*fac_augm
13437               evdwij=evdwij*eps2rt*eps3rt
13438               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13439               if (lprn) then
13440               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13441               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13442               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13443                 restyp(itypi,1),i,restyp(itypj,1),j,&
13444                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13445                 chi1,chi2,chip1,chip2,&
13446                 eps1,eps2rt**2,eps3rt**2,&
13447                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13448                 evdwij+e_augm
13449               endif
13450 ! Calculate gradient components.
13451               e1=e1*eps1*eps2rt**2*eps3rt**2
13452               fac=-expon*(e1+evdwij)*rij_shift
13453               sigder=fac*sigder
13454               fac=rij*fac-2*expon*rrij*e_augm
13455 ! Calculate the radial part of the gradient
13456               gg(1)=xj*fac
13457               gg(2)=yj*fac
13458               gg(3)=zj*fac
13459 ! Calculate angular part of the gradient.
13460               call sc_grad_scale(1.0d0-sss)
13461             endif
13462           enddo      ! j
13463         enddo        ! iint
13464       enddo          ! i
13465       end subroutine egbv_long
13466 !-----------------------------------------------------------------------------
13467       subroutine egbv_short(evdw)
13468 !
13469 ! This subroutine calculates the interaction energy of nonbonded side chains
13470 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13471 !
13472       use calc_data
13473 !      implicit real*8 (a-h,o-z)
13474 !      include 'DIMENSIONS'
13475 !      include 'COMMON.GEO'
13476 !      include 'COMMON.VAR'
13477 !      include 'COMMON.LOCAL'
13478 !      include 'COMMON.CHAIN'
13479 !      include 'COMMON.DERIV'
13480 !      include 'COMMON.NAMES'
13481 !      include 'COMMON.INTERACT'
13482 !      include 'COMMON.IOUNITS'
13483 !      include 'COMMON.CALC'
13484       use comm_srutu
13485 !el      integer :: icall
13486 !el      common /srutu/ icall
13487       logical :: lprn
13488 !el local variables
13489       integer :: iint,itypi,itypi1,itypj
13490       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13491       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13492       evdw=0.0D0
13493 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13494       evdw=0.0D0
13495       lprn=.false.
13496 !     if (icall.eq.0) lprn=.true.
13497 !el      ind=0
13498       do i=iatsc_s,iatsc_e
13499         itypi=itype(i,1)
13500         if (itypi.eq.ntyp1) cycle
13501         itypi1=itype(i+1,1)
13502         xi=c(1,nres+i)
13503         yi=c(2,nres+i)
13504         zi=c(3,nres+i)
13505         dxi=dc_norm(1,nres+i)
13506         dyi=dc_norm(2,nres+i)
13507         dzi=dc_norm(3,nres+i)
13508 !        dsci_inv=dsc_inv(itypi)
13509         dsci_inv=vbld_inv(i+nres)
13510 !
13511 ! Calculate SC interaction energy.
13512 !
13513         do iint=1,nint_gr(i)
13514           do j=istart(i,iint),iend(i,iint)
13515 !el            ind=ind+1
13516             itypj=itype(j,1)
13517             if (itypj.eq.ntyp1) cycle
13518 !            dscj_inv=dsc_inv(itypj)
13519             dscj_inv=vbld_inv(j+nres)
13520             sig0ij=sigma(itypi,itypj)
13521             r0ij=r0(itypi,itypj)
13522             chi1=chi(itypi,itypj)
13523             chi2=chi(itypj,itypi)
13524             chi12=chi1*chi2
13525             chip1=chip(itypi)
13526             chip2=chip(itypj)
13527             chip12=chip1*chip2
13528             alf1=alp(itypi)
13529             alf2=alp(itypj)
13530             alf12=0.5D0*(alf1+alf2)
13531             xj=c(1,nres+j)-xi
13532             yj=c(2,nres+j)-yi
13533             zj=c(3,nres+j)-zi
13534             dxj=dc_norm(1,nres+j)
13535             dyj=dc_norm(2,nres+j)
13536             dzj=dc_norm(3,nres+j)
13537             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13538             rij=dsqrt(rrij)
13539
13540             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13541
13542             if (sss.gt.0.0d0) then
13543
13544 ! Calculate angle-dependent terms of energy and contributions to their
13545 ! derivatives.
13546               call sc_angular
13547               sigsq=1.0D0/sigsq
13548               sig=sig0ij*dsqrt(sigsq)
13549               rij_shift=1.0D0/rij-sig+r0ij
13550 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13551               if (rij_shift.le.0.0D0) then
13552                 evdw=1.0D20
13553                 return
13554               endif
13555               sigder=-sig*sigsq
13556 !---------------------------------------------------------------
13557               rij_shift=1.0D0/rij_shift
13558               fac=rij_shift**expon
13559               e1=fac*fac*aa_aq(itypi,itypj)
13560               e2=fac*bb_aq(itypi,itypj)
13561               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13562               eps2der=evdwij*eps3rt
13563               eps3der=evdwij*eps2rt
13564               fac_augm=rrij**expon
13565               e_augm=augm(itypi,itypj)*fac_augm
13566               evdwij=evdwij*eps2rt*eps3rt
13567               evdw=evdw+(evdwij+e_augm)*sss
13568               if (lprn) then
13569               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13570               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13571               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13572                 restyp(itypi,1),i,restyp(itypj,1),j,&
13573                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13574                 chi1,chi2,chip1,chip2,&
13575                 eps1,eps2rt**2,eps3rt**2,&
13576                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13577                 evdwij+e_augm
13578               endif
13579 ! Calculate gradient components.
13580               e1=e1*eps1*eps2rt**2*eps3rt**2
13581               fac=-expon*(e1+evdwij)*rij_shift
13582               sigder=fac*sigder
13583               fac=rij*fac-2*expon*rrij*e_augm
13584 ! Calculate the radial part of the gradient
13585               gg(1)=xj*fac
13586               gg(2)=yj*fac
13587               gg(3)=zj*fac
13588 ! Calculate angular part of the gradient.
13589               call sc_grad_scale(sss)
13590             endif
13591           enddo      ! j
13592         enddo        ! iint
13593       enddo          ! i
13594       end subroutine egbv_short
13595 !-----------------------------------------------------------------------------
13596       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13597 !
13598 ! This subroutine calculates the average interaction energy and its gradient
13599 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13600 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13601 ! The potential depends both on the distance of peptide-group centers and on
13602 ! the orientation of the CA-CA virtual bonds.
13603 !
13604 !      implicit real*8 (a-h,o-z)
13605
13606       use comm_locel
13607 #ifdef MPI
13608       include 'mpif.h'
13609 #endif
13610 !      include 'DIMENSIONS'
13611 !      include 'COMMON.CONTROL'
13612 !      include 'COMMON.SETUP'
13613 !      include 'COMMON.IOUNITS'
13614 !      include 'COMMON.GEO'
13615 !      include 'COMMON.VAR'
13616 !      include 'COMMON.LOCAL'
13617 !      include 'COMMON.CHAIN'
13618 !      include 'COMMON.DERIV'
13619 !      include 'COMMON.INTERACT'
13620 !      include 'COMMON.CONTACTS'
13621 !      include 'COMMON.TORSION'
13622 !      include 'COMMON.VECTORS'
13623 !      include 'COMMON.FFIELD'
13624 !      include 'COMMON.TIME1'
13625       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13626       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13627       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13628 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13629       real(kind=8),dimension(4) :: muij
13630 !el      integer :: num_conti,j1,j2
13631 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13632 !el                   dz_normi,xmedi,ymedi,zmedi
13633 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13634 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13635 !el          num_conti,j1,j2
13636 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13637 #ifdef MOMENT
13638       real(kind=8) :: scal_el=1.0d0
13639 #else
13640       real(kind=8) :: scal_el=0.5d0
13641 #endif
13642 ! 12/13/98
13643 ! 13-go grudnia roku pamietnego...
13644       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13645                                              0.0d0,1.0d0,0.0d0,&
13646                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13647 !el local variables
13648       integer :: i,j,k
13649       real(kind=8) :: fac
13650       real(kind=8) :: dxj,dyj,dzj
13651       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13652
13653 !      allocate(num_cont_hb(nres)) !(maxres)
13654 !d      write(iout,*) 'In EELEC'
13655 !d      do i=1,nloctyp
13656 !d        write(iout,*) 'Type',i
13657 !d        write(iout,*) 'B1',B1(:,i)
13658 !d        write(iout,*) 'B2',B2(:,i)
13659 !d        write(iout,*) 'CC',CC(:,:,i)
13660 !d        write(iout,*) 'DD',DD(:,:,i)
13661 !d        write(iout,*) 'EE',EE(:,:,i)
13662 !d      enddo
13663 !d      call check_vecgrad
13664 !d      stop
13665       if (icheckgrad.eq.1) then
13666         do i=1,nres-1
13667           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13668           do k=1,3
13669             dc_norm(k,i)=dc(k,i)*fac
13670           enddo
13671 !          write (iout,*) 'i',i,' fac',fac
13672         enddo
13673       endif
13674       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13675           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13676           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13677 !        call vec_and_deriv
13678 #ifdef TIMING
13679         time01=MPI_Wtime()
13680 #endif
13681 !        print *, "before set matrices"
13682         call set_matrices
13683 !        print *,"after set martices"
13684 #ifdef TIMING
13685         time_mat=time_mat+MPI_Wtime()-time01
13686 #endif
13687       endif
13688 !d      do i=1,nres-1
13689 !d        write (iout,*) 'i=',i
13690 !d        do k=1,3
13691 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13692 !d        enddo
13693 !d        do k=1,3
13694 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13695 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13696 !d        enddo
13697 !d      enddo
13698       t_eelecij=0.0d0
13699       ees=0.0D0
13700       evdw1=0.0D0
13701       eel_loc=0.0d0
13702       eello_turn3=0.0d0
13703       eello_turn4=0.0d0
13704 !el      ind=0
13705       do i=1,nres
13706         num_cont_hb(i)=0
13707       enddo
13708 !d      print '(a)','Enter EELEC'
13709 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13710 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13711 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13712       do i=1,nres
13713         gel_loc_loc(i)=0.0d0
13714         gcorr_loc(i)=0.0d0
13715       enddo
13716 !
13717 !
13718 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13719 !
13720 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13721 !
13722       do i=iturn3_start,iturn3_end
13723         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
13724         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
13725         dxi=dc(1,i)
13726         dyi=dc(2,i)
13727         dzi=dc(3,i)
13728         dx_normi=dc_norm(1,i)
13729         dy_normi=dc_norm(2,i)
13730         dz_normi=dc_norm(3,i)
13731         xmedi=c(1,i)+0.5d0*dxi
13732         ymedi=c(2,i)+0.5d0*dyi
13733         zmedi=c(3,i)+0.5d0*dzi
13734           xmedi=dmod(xmedi,boxxsize)
13735           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13736           ymedi=dmod(ymedi,boxysize)
13737           if (ymedi.lt.0) ymedi=ymedi+boxysize
13738           zmedi=dmod(zmedi,boxzsize)
13739           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13740         num_conti=0
13741         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13742         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13743         num_cont_hb(i)=num_conti
13744       enddo
13745       do i=iturn4_start,iturn4_end
13746         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
13747           .or. itype(i+3,1).eq.ntyp1 &
13748           .or. itype(i+4,1).eq.ntyp1) cycle
13749         dxi=dc(1,i)
13750         dyi=dc(2,i)
13751         dzi=dc(3,i)
13752         dx_normi=dc_norm(1,i)
13753         dy_normi=dc_norm(2,i)
13754         dz_normi=dc_norm(3,i)
13755         xmedi=c(1,i)+0.5d0*dxi
13756         ymedi=c(2,i)+0.5d0*dyi
13757         zmedi=c(3,i)+0.5d0*dzi
13758           xmedi=dmod(xmedi,boxxsize)
13759           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13760           ymedi=dmod(ymedi,boxysize)
13761           if (ymedi.lt.0) ymedi=ymedi+boxysize
13762           zmedi=dmod(zmedi,boxzsize)
13763           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13764         num_conti=num_cont_hb(i)
13765         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13766         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
13767           call eturn4(i,eello_turn4)
13768         num_cont_hb(i)=num_conti
13769       enddo   ! i
13770 !
13771 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13772 !
13773       do i=iatel_s,iatel_e
13774         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
13775         dxi=dc(1,i)
13776         dyi=dc(2,i)
13777         dzi=dc(3,i)
13778         dx_normi=dc_norm(1,i)
13779         dy_normi=dc_norm(2,i)
13780         dz_normi=dc_norm(3,i)
13781         xmedi=c(1,i)+0.5d0*dxi
13782         ymedi=c(2,i)+0.5d0*dyi
13783         zmedi=c(3,i)+0.5d0*dzi
13784           xmedi=dmod(xmedi,boxxsize)
13785           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13786           ymedi=dmod(ymedi,boxysize)
13787           if (ymedi.lt.0) ymedi=ymedi+boxysize
13788           zmedi=dmod(zmedi,boxzsize)
13789           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13790 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
13791         num_conti=num_cont_hb(i)
13792         do j=ielstart(i),ielend(i)
13793           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
13794           call eelecij_scale(i,j,ees,evdw1,eel_loc)
13795         enddo ! j
13796         num_cont_hb(i)=num_conti
13797       enddo   ! i
13798 !      write (iout,*) "Number of loop steps in EELEC:",ind
13799 !d      do i=1,nres
13800 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
13801 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
13802 !d      enddo
13803 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
13804 !cc      eel_loc=eel_loc+eello_turn3
13805 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
13806       return
13807       end subroutine eelec_scale
13808 !-----------------------------------------------------------------------------
13809       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
13810 !      implicit real*8 (a-h,o-z)
13811
13812       use comm_locel
13813 !      include 'DIMENSIONS'
13814 #ifdef MPI
13815       include "mpif.h"
13816 #endif
13817 !      include 'COMMON.CONTROL'
13818 !      include 'COMMON.IOUNITS'
13819 !      include 'COMMON.GEO'
13820 !      include 'COMMON.VAR'
13821 !      include 'COMMON.LOCAL'
13822 !      include 'COMMON.CHAIN'
13823 !      include 'COMMON.DERIV'
13824 !      include 'COMMON.INTERACT'
13825 !      include 'COMMON.CONTACTS'
13826 !      include 'COMMON.TORSION'
13827 !      include 'COMMON.VECTORS'
13828 !      include 'COMMON.FFIELD'
13829 !      include 'COMMON.TIME1'
13830       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
13831       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
13832       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13833 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13834       real(kind=8),dimension(4) :: muij
13835       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13836                     dist_temp, dist_init,sss_grad
13837       integer xshift,yshift,zshift
13838
13839 !el      integer :: num_conti,j1,j2
13840 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13841 !el                   dz_normi,xmedi,ymedi,zmedi
13842 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13843 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13844 !el          num_conti,j1,j2
13845 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13846 #ifdef MOMENT
13847       real(kind=8) :: scal_el=1.0d0
13848 #else
13849       real(kind=8) :: scal_el=0.5d0
13850 #endif
13851 ! 12/13/98
13852 ! 13-go grudnia roku pamietnego...
13853       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13854                                              0.0d0,1.0d0,0.0d0,&
13855                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13856 !el local variables
13857       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
13858       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
13859       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
13860       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
13861       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
13862       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
13863       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
13864                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
13865                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
13866                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
13867                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
13868                   ecosam,ecosbm,ecosgm,ghalf,time00
13869 !      integer :: maxconts
13870 !      maxconts = nres/4
13871 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13872 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13873 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13874 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13875 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13876 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13877 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13878 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13879 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
13880 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
13881 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
13882 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
13883 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
13884
13885 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
13886 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
13887
13888 #ifdef MPI
13889           time00=MPI_Wtime()
13890 #endif
13891 !d      write (iout,*) "eelecij",i,j
13892 !el          ind=ind+1
13893           iteli=itel(i)
13894           itelj=itel(j)
13895           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13896           aaa=app(iteli,itelj)
13897           bbb=bpp(iteli,itelj)
13898           ael6i=ael6(iteli,itelj)
13899           ael3i=ael3(iteli,itelj)
13900           dxj=dc(1,j)
13901           dyj=dc(2,j)
13902           dzj=dc(3,j)
13903           dx_normj=dc_norm(1,j)
13904           dy_normj=dc_norm(2,j)
13905           dz_normj=dc_norm(3,j)
13906 !          xj=c(1,j)+0.5D0*dxj-xmedi
13907 !          yj=c(2,j)+0.5D0*dyj-ymedi
13908 !          zj=c(3,j)+0.5D0*dzj-zmedi
13909           xj=c(1,j)+0.5D0*dxj
13910           yj=c(2,j)+0.5D0*dyj
13911           zj=c(3,j)+0.5D0*dzj
13912           xj=mod(xj,boxxsize)
13913           if (xj.lt.0) xj=xj+boxxsize
13914           yj=mod(yj,boxysize)
13915           if (yj.lt.0) yj=yj+boxysize
13916           zj=mod(zj,boxzsize)
13917           if (zj.lt.0) zj=zj+boxzsize
13918       isubchap=0
13919       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13920       xj_safe=xj
13921       yj_safe=yj
13922       zj_safe=zj
13923       do xshift=-1,1
13924       do yshift=-1,1
13925       do zshift=-1,1
13926           xj=xj_safe+xshift*boxxsize
13927           yj=yj_safe+yshift*boxysize
13928           zj=zj_safe+zshift*boxzsize
13929           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13930           if(dist_temp.lt.dist_init) then
13931             dist_init=dist_temp
13932             xj_temp=xj
13933             yj_temp=yj
13934             zj_temp=zj
13935             isubchap=1
13936           endif
13937        enddo
13938        enddo
13939        enddo
13940        if (isubchap.eq.1) then
13941 !C          print *,i,j
13942           xj=xj_temp-xmedi
13943           yj=yj_temp-ymedi
13944           zj=zj_temp-zmedi
13945        else
13946           xj=xj_safe-xmedi
13947           yj=yj_safe-ymedi
13948           zj=zj_safe-zmedi
13949        endif
13950
13951           rij=xj*xj+yj*yj+zj*zj
13952           rrmij=1.0D0/rij
13953           rij=dsqrt(rij)
13954           rmij=1.0D0/rij
13955 ! For extracting the short-range part of Evdwpp
13956           sss=sscale(rij/rpp(iteli,itelj))
13957             sss_ele_cut=sscale_ele(rij)
13958             sss_ele_grad=sscagrad_ele(rij)
13959             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
13960 !             sss_ele_cut=1.0d0
13961 !             sss_ele_grad=0.0d0
13962             if (sss_ele_cut.le.0.0) go to 128
13963
13964           r3ij=rrmij*rmij
13965           r6ij=r3ij*r3ij
13966           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
13967           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
13968           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
13969           fac=cosa-3.0D0*cosb*cosg
13970           ev1=aaa*r6ij*r6ij
13971 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13972           if (j.eq.i+2) ev1=scal_el*ev1
13973           ev2=bbb*r6ij
13974           fac3=ael6i*r6ij
13975           fac4=ael3i*r3ij
13976           evdwij=ev1+ev2
13977           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
13978           el2=fac4*fac
13979           eesij=el1+el2
13980 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
13981           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
13982           ees=ees+eesij*sss_ele_cut
13983           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
13984 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
13985 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
13986 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
13987 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
13988
13989           if (energy_dec) then
13990               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13991               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
13992           endif
13993
13994 !
13995 ! Calculate contributions to the Cartesian gradient.
13996 !
13997 #ifdef SPLITELE
13998           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
13999           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14000           fac1=fac
14001           erij(1)=xj*rmij
14002           erij(2)=yj*rmij
14003           erij(3)=zj*rmij
14004 !
14005 ! Radial derivatives. First process both termini of the fragment (i,j)
14006 !
14007           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14008           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14009           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14010 !          do k=1,3
14011 !            ghalf=0.5D0*ggg(k)
14012 !            gelc(k,i)=gelc(k,i)+ghalf
14013 !            gelc(k,j)=gelc(k,j)+ghalf
14014 !          enddo
14015 ! 9/28/08 AL Gradient compotents will be summed only at the end
14016           do k=1,3
14017             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14018             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14019           enddo
14020 !
14021 ! Loop over residues i+1 thru j-1.
14022 !
14023 !grad          do k=i+1,j-1
14024 !grad            do l=1,3
14025 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14026 !grad            enddo
14027 !grad          enddo
14028           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14029           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14030           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14031           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14032           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14033           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14034 !          do k=1,3
14035 !            ghalf=0.5D0*ggg(k)
14036 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14037 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14038 !          enddo
14039 ! 9/28/08 AL Gradient compotents will be summed only at the end
14040           do k=1,3
14041             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14042             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14043           enddo
14044 !
14045 ! Loop over residues i+1 thru j-1.
14046 !
14047 !grad          do k=i+1,j-1
14048 !grad            do l=1,3
14049 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14050 !grad            enddo
14051 !grad          enddo
14052 #else
14053           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14054           facel=(el1+eesij)*sss_ele_cut
14055           fac1=fac
14056           fac=-3*rrmij*(facvdw+facvdw+facel)
14057           erij(1)=xj*rmij
14058           erij(2)=yj*rmij
14059           erij(3)=zj*rmij
14060 !
14061 ! Radial derivatives. First process both termini of the fragment (i,j)
14062 !
14063           ggg(1)=fac*xj
14064           ggg(2)=fac*yj
14065           ggg(3)=fac*zj
14066 !          do k=1,3
14067 !            ghalf=0.5D0*ggg(k)
14068 !            gelc(k,i)=gelc(k,i)+ghalf
14069 !            gelc(k,j)=gelc(k,j)+ghalf
14070 !          enddo
14071 ! 9/28/08 AL Gradient compotents will be summed only at the end
14072           do k=1,3
14073             gelc_long(k,j)=gelc(k,j)+ggg(k)
14074             gelc_long(k,i)=gelc(k,i)-ggg(k)
14075           enddo
14076 !
14077 ! Loop over residues i+1 thru j-1.
14078 !
14079 !grad          do k=i+1,j-1
14080 !grad            do l=1,3
14081 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14082 !grad            enddo
14083 !grad          enddo
14084 ! 9/28/08 AL Gradient compotents will be summed only at the end
14085           ggg(1)=facvdw*xj
14086           ggg(2)=facvdw*yj
14087           ggg(3)=facvdw*zj
14088           do k=1,3
14089             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14090             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14091           enddo
14092 #endif
14093 !
14094 ! Angular part
14095 !
14096           ecosa=2.0D0*fac3*fac1+fac4
14097           fac4=-3.0D0*fac4
14098           fac3=-6.0D0*fac3
14099           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14100           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14101           do k=1,3
14102             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14103             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14104           enddo
14105 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14106 !d   &          (dcosg(k),k=1,3)
14107           do k=1,3
14108             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14109           enddo
14110 !          do k=1,3
14111 !            ghalf=0.5D0*ggg(k)
14112 !            gelc(k,i)=gelc(k,i)+ghalf
14113 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14114 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14115 !            gelc(k,j)=gelc(k,j)+ghalf
14116 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14117 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14118 !          enddo
14119 !grad          do k=i+1,j-1
14120 !grad            do l=1,3
14121 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14122 !grad            enddo
14123 !grad          enddo
14124           do k=1,3
14125             gelc(k,i)=gelc(k,i) &
14126                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14127                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14128                      *sss_ele_cut
14129             gelc(k,j)=gelc(k,j) &
14130                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14131                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14132                      *sss_ele_cut
14133             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14134             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14135           enddo
14136           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14137               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14138               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14139 !
14140 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14141 !   energy of a peptide unit is assumed in the form of a second-order
14142 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14143 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14144 !   are computed for EVERY pair of non-contiguous peptide groups.
14145 !
14146           if (j.lt.nres-1) then
14147             j1=j+1
14148             j2=j-1
14149           else
14150             j1=j-1
14151             j2=j-2
14152           endif
14153           kkk=0
14154           do k=1,2
14155             do l=1,2
14156               kkk=kkk+1
14157               muij(kkk)=mu(k,i)*mu(l,j)
14158             enddo
14159           enddo
14160 !d         write (iout,*) 'EELEC: i',i,' j',j
14161 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14162 !d          write(iout,*) 'muij',muij
14163           ury=scalar(uy(1,i),erij)
14164           urz=scalar(uz(1,i),erij)
14165           vry=scalar(uy(1,j),erij)
14166           vrz=scalar(uz(1,j),erij)
14167           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14168           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14169           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14170           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14171           fac=dsqrt(-ael6i)*r3ij
14172           a22=a22*fac
14173           a23=a23*fac
14174           a32=a32*fac
14175           a33=a33*fac
14176 !d          write (iout,'(4i5,4f10.5)')
14177 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14178 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14179 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14180 !d     &      uy(:,j),uz(:,j)
14181 !d          write (iout,'(4f10.5)')
14182 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14183 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14184 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14185 !d           write (iout,'(9f10.5/)')
14186 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14187 ! Derivatives of the elements of A in virtual-bond vectors
14188           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14189           do k=1,3
14190             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14191             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14192             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14193             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14194             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14195             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14196             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14197             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14198             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14199             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14200             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14201             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14202           enddo
14203 ! Compute radial contributions to the gradient
14204           facr=-3.0d0*rrmij
14205           a22der=a22*facr
14206           a23der=a23*facr
14207           a32der=a32*facr
14208           a33der=a33*facr
14209           agg(1,1)=a22der*xj
14210           agg(2,1)=a22der*yj
14211           agg(3,1)=a22der*zj
14212           agg(1,2)=a23der*xj
14213           agg(2,2)=a23der*yj
14214           agg(3,2)=a23der*zj
14215           agg(1,3)=a32der*xj
14216           agg(2,3)=a32der*yj
14217           agg(3,3)=a32der*zj
14218           agg(1,4)=a33der*xj
14219           agg(2,4)=a33der*yj
14220           agg(3,4)=a33der*zj
14221 ! Add the contributions coming from er
14222           fac3=-3.0d0*fac
14223           do k=1,3
14224             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14225             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14226             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14227             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14228           enddo
14229           do k=1,3
14230 ! Derivatives in DC(i)
14231 !grad            ghalf1=0.5d0*agg(k,1)
14232 !grad            ghalf2=0.5d0*agg(k,2)
14233 !grad            ghalf3=0.5d0*agg(k,3)
14234 !grad            ghalf4=0.5d0*agg(k,4)
14235             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14236             -3.0d0*uryg(k,2)*vry)!+ghalf1
14237             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14238             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14239             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14240             -3.0d0*urzg(k,2)*vry)!+ghalf3
14241             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14242             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14243 ! Derivatives in DC(i+1)
14244             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14245             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14246             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14247             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14248             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14249             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14250             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14251             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14252 ! Derivatives in DC(j)
14253             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14254             -3.0d0*vryg(k,2)*ury)!+ghalf1
14255             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14256             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14257             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14258             -3.0d0*vryg(k,2)*urz)!+ghalf3
14259             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14260             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14261 ! Derivatives in DC(j+1) or DC(nres-1)
14262             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14263             -3.0d0*vryg(k,3)*ury)
14264             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14265             -3.0d0*vrzg(k,3)*ury)
14266             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14267             -3.0d0*vryg(k,3)*urz)
14268             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14269             -3.0d0*vrzg(k,3)*urz)
14270 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14271 !grad              do l=1,4
14272 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14273 !grad              enddo
14274 !grad            endif
14275           enddo
14276           acipa(1,1)=a22
14277           acipa(1,2)=a23
14278           acipa(2,1)=a32
14279           acipa(2,2)=a33
14280           a22=-a22
14281           a23=-a23
14282           do l=1,2
14283             do k=1,3
14284               agg(k,l)=-agg(k,l)
14285               aggi(k,l)=-aggi(k,l)
14286               aggi1(k,l)=-aggi1(k,l)
14287               aggj(k,l)=-aggj(k,l)
14288               aggj1(k,l)=-aggj1(k,l)
14289             enddo
14290           enddo
14291           if (j.lt.nres-1) then
14292             a22=-a22
14293             a32=-a32
14294             do l=1,3,2
14295               do k=1,3
14296                 agg(k,l)=-agg(k,l)
14297                 aggi(k,l)=-aggi(k,l)
14298                 aggi1(k,l)=-aggi1(k,l)
14299                 aggj(k,l)=-aggj(k,l)
14300                 aggj1(k,l)=-aggj1(k,l)
14301               enddo
14302             enddo
14303           else
14304             a22=-a22
14305             a23=-a23
14306             a32=-a32
14307             a33=-a33
14308             do l=1,4
14309               do k=1,3
14310                 agg(k,l)=-agg(k,l)
14311                 aggi(k,l)=-aggi(k,l)
14312                 aggi1(k,l)=-aggi1(k,l)
14313                 aggj(k,l)=-aggj(k,l)
14314                 aggj1(k,l)=-aggj1(k,l)
14315               enddo
14316             enddo
14317           endif
14318           ENDIF ! WCORR
14319           IF (wel_loc.gt.0.0d0) THEN
14320 ! Contribution to the local-electrostatic energy coming from the i-j pair
14321           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14322            +a33*muij(4)
14323 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14324
14325           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14326                   'eelloc',i,j,eel_loc_ij
14327 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14328
14329           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14330 ! Partial derivatives in virtual-bond dihedral angles gamma
14331           if (i.gt.1) &
14332           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14333                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14334                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14335                  *sss_ele_cut
14336           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14337                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14338                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14339                  *sss_ele_cut
14340            xtemp(1)=xj
14341            xtemp(2)=yj
14342            xtemp(3)=zj
14343
14344 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14345           do l=1,3
14346             ggg(l)=(agg(l,1)*muij(1)+ &
14347                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14348             *sss_ele_cut &
14349              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14350
14351             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14352             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14353 !grad            ghalf=0.5d0*ggg(l)
14354 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14355 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14356           enddo
14357 !grad          do k=i+1,j2
14358 !grad            do l=1,3
14359 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14360 !grad            enddo
14361 !grad          enddo
14362 ! Remaining derivatives of eello
14363           do l=1,3
14364             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14365                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14366             *sss_ele_cut
14367
14368             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14369                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14370             *sss_ele_cut
14371
14372             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14373                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14374             *sss_ele_cut
14375
14376             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14377                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14378             *sss_ele_cut
14379
14380           enddo
14381           ENDIF
14382 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14383 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14384           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14385              .and. num_conti.le.maxconts) then
14386 !            write (iout,*) i,j," entered corr"
14387 !
14388 ! Calculate the contact function. The ith column of the array JCONT will
14389 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14390 ! greater than I). The arrays FACONT and GACONT will contain the values of
14391 ! the contact function and its derivative.
14392 !           r0ij=1.02D0*rpp(iteli,itelj)
14393 !           r0ij=1.11D0*rpp(iteli,itelj)
14394             r0ij=2.20D0*rpp(iteli,itelj)
14395 !           r0ij=1.55D0*rpp(iteli,itelj)
14396             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14397 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14398             if (fcont.gt.0.0D0) then
14399               num_conti=num_conti+1
14400               if (num_conti.gt.maxconts) then
14401 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14402                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14403                                ' will skip next contacts for this conf.',num_conti
14404               else
14405                 jcont_hb(num_conti,i)=j
14406 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14407 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14408                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14409                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14410 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14411 !  terms.
14412                 d_cont(num_conti,i)=rij
14413 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14414 !     --- Electrostatic-interaction matrix ---
14415                 a_chuj(1,1,num_conti,i)=a22
14416                 a_chuj(1,2,num_conti,i)=a23
14417                 a_chuj(2,1,num_conti,i)=a32
14418                 a_chuj(2,2,num_conti,i)=a33
14419 !     --- Gradient of rij
14420                 do kkk=1,3
14421                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14422                 enddo
14423                 kkll=0
14424                 do k=1,2
14425                   do l=1,2
14426                     kkll=kkll+1
14427                     do m=1,3
14428                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14429                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14430                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14431                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14432                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14433                     enddo
14434                   enddo
14435                 enddo
14436                 ENDIF
14437                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14438 ! Calculate contact energies
14439                 cosa4=4.0D0*cosa
14440                 wij=cosa-3.0D0*cosb*cosg
14441                 cosbg1=cosb+cosg
14442                 cosbg2=cosb-cosg
14443 !               fac3=dsqrt(-ael6i)/r0ij**3
14444                 fac3=dsqrt(-ael6i)*r3ij
14445 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14446                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14447                 if (ees0tmp.gt.0) then
14448                   ees0pij=dsqrt(ees0tmp)
14449                 else
14450                   ees0pij=0
14451                 endif
14452 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14453                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14454                 if (ees0tmp.gt.0) then
14455                   ees0mij=dsqrt(ees0tmp)
14456                 else
14457                   ees0mij=0
14458                 endif
14459 !               ees0mij=0.0D0
14460                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14461                      *sss_ele_cut
14462
14463                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14464                      *sss_ele_cut
14465
14466 ! Diagnostics. Comment out or remove after debugging!
14467 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14468 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14469 !               ees0m(num_conti,i)=0.0D0
14470 ! End diagnostics.
14471 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14472 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14473 ! Angular derivatives of the contact function
14474                 ees0pij1=fac3/ees0pij
14475                 ees0mij1=fac3/ees0mij
14476                 fac3p=-3.0D0*fac3*rrmij
14477                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14478                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14479 !               ees0mij1=0.0D0
14480                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14481                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14482                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14483                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14484                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14485                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14486                 ecosap=ecosa1+ecosa2
14487                 ecosbp=ecosb1+ecosb2
14488                 ecosgp=ecosg1+ecosg2
14489                 ecosam=ecosa1-ecosa2
14490                 ecosbm=ecosb1-ecosb2
14491                 ecosgm=ecosg1-ecosg2
14492 ! Diagnostics
14493 !               ecosap=ecosa1
14494 !               ecosbp=ecosb1
14495 !               ecosgp=ecosg1
14496 !               ecosam=0.0D0
14497 !               ecosbm=0.0D0
14498 !               ecosgm=0.0D0
14499 ! End diagnostics
14500                 facont_hb(num_conti,i)=fcont
14501                 fprimcont=fprimcont/rij
14502 !d              facont_hb(num_conti,i)=1.0D0
14503 ! Following line is for diagnostics.
14504 !d              fprimcont=0.0D0
14505                 do k=1,3
14506                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14507                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14508                 enddo
14509                 do k=1,3
14510                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14511                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14512                 enddo
14513 !                gggp(1)=gggp(1)+ees0pijp*xj
14514 !                gggp(2)=gggp(2)+ees0pijp*yj
14515 !                gggp(3)=gggp(3)+ees0pijp*zj
14516 !                gggm(1)=gggm(1)+ees0mijp*xj
14517 !                gggm(2)=gggm(2)+ees0mijp*yj
14518 !                gggm(3)=gggm(3)+ees0mijp*zj
14519                 gggp(1)=gggp(1)+ees0pijp*xj &
14520                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14521                 gggp(2)=gggp(2)+ees0pijp*yj &
14522                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14523                 gggp(3)=gggp(3)+ees0pijp*zj &
14524                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14525
14526                 gggm(1)=gggm(1)+ees0mijp*xj &
14527                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14528
14529                 gggm(2)=gggm(2)+ees0mijp*yj &
14530                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14531
14532                 gggm(3)=gggm(3)+ees0mijp*zj &
14533                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14534
14535 ! Derivatives due to the contact function
14536                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14537                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14538                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14539                 do k=1,3
14540 !
14541 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14542 !          following the change of gradient-summation algorithm.
14543 !
14544 !grad                  ghalfp=0.5D0*gggp(k)
14545 !grad                  ghalfm=0.5D0*gggm(k)
14546 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14547 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14548 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14549 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14550 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14551 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14552 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14553 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14554 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14555 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14556 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14557 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14558 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14559 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14560                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14561                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14562                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14563                      *sss_ele_cut
14564
14565                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14566                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14567                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14568                      *sss_ele_cut
14569
14570                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14571                      *sss_ele_cut
14572
14573                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14574                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14575                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14576                      *sss_ele_cut
14577
14578                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14579                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14580                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14581                      *sss_ele_cut
14582
14583                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14584                      *sss_ele_cut
14585
14586                 enddo
14587               ENDIF ! wcorr
14588               endif  ! num_conti.le.maxconts
14589             endif  ! fcont.gt.0
14590           endif    ! j.gt.i+1
14591           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14592             do k=1,4
14593               do l=1,3
14594                 ghalf=0.5d0*agg(l,k)
14595                 aggi(l,k)=aggi(l,k)+ghalf
14596                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14597                 aggj(l,k)=aggj(l,k)+ghalf
14598               enddo
14599             enddo
14600             if (j.eq.nres-1 .and. i.lt.j-2) then
14601               do k=1,4
14602                 do l=1,3
14603                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14604                 enddo
14605               enddo
14606             endif
14607           endif
14608  128      continue
14609 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14610       return
14611       end subroutine eelecij_scale
14612 !-----------------------------------------------------------------------------
14613       subroutine evdwpp_short(evdw1)
14614 !
14615 ! Compute Evdwpp
14616 !
14617 !      implicit real*8 (a-h,o-z)
14618 !      include 'DIMENSIONS'
14619 !      include 'COMMON.CONTROL'
14620 !      include 'COMMON.IOUNITS'
14621 !      include 'COMMON.GEO'
14622 !      include 'COMMON.VAR'
14623 !      include 'COMMON.LOCAL'
14624 !      include 'COMMON.CHAIN'
14625 !      include 'COMMON.DERIV'
14626 !      include 'COMMON.INTERACT'
14627 !      include 'COMMON.CONTACTS'
14628 !      include 'COMMON.TORSION'
14629 !      include 'COMMON.VECTORS'
14630 !      include 'COMMON.FFIELD'
14631       real(kind=8),dimension(3) :: ggg
14632 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14633 #ifdef MOMENT
14634       real(kind=8) :: scal_el=1.0d0
14635 #else
14636       real(kind=8) :: scal_el=0.5d0
14637 #endif
14638 !el local variables
14639       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14640       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14641       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14642                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14643                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14644       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14645                     dist_temp, dist_init,sss_grad
14646       integer xshift,yshift,zshift
14647
14648
14649       evdw1=0.0D0
14650 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14651 !     & " iatel_e_vdw",iatel_e_vdw
14652       call flush(iout)
14653       do i=iatel_s_vdw,iatel_e_vdw
14654         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14655         dxi=dc(1,i)
14656         dyi=dc(2,i)
14657         dzi=dc(3,i)
14658         dx_normi=dc_norm(1,i)
14659         dy_normi=dc_norm(2,i)
14660         dz_normi=dc_norm(3,i)
14661         xmedi=c(1,i)+0.5d0*dxi
14662         ymedi=c(2,i)+0.5d0*dyi
14663         zmedi=c(3,i)+0.5d0*dzi
14664           xmedi=dmod(xmedi,boxxsize)
14665           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14666           ymedi=dmod(ymedi,boxysize)
14667           if (ymedi.lt.0) ymedi=ymedi+boxysize
14668           zmedi=dmod(zmedi,boxzsize)
14669           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14670         num_conti=0
14671 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14672 !     &   ' ielend',ielend_vdw(i)
14673         call flush(iout)
14674         do j=ielstart_vdw(i),ielend_vdw(i)
14675           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14676 !el          ind=ind+1
14677           iteli=itel(i)
14678           itelj=itel(j)
14679           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14680           aaa=app(iteli,itelj)
14681           bbb=bpp(iteli,itelj)
14682           dxj=dc(1,j)
14683           dyj=dc(2,j)
14684           dzj=dc(3,j)
14685           dx_normj=dc_norm(1,j)
14686           dy_normj=dc_norm(2,j)
14687           dz_normj=dc_norm(3,j)
14688 !          xj=c(1,j)+0.5D0*dxj-xmedi
14689 !          yj=c(2,j)+0.5D0*dyj-ymedi
14690 !          zj=c(3,j)+0.5D0*dzj-zmedi
14691           xj=c(1,j)+0.5D0*dxj
14692           yj=c(2,j)+0.5D0*dyj
14693           zj=c(3,j)+0.5D0*dzj
14694           xj=mod(xj,boxxsize)
14695           if (xj.lt.0) xj=xj+boxxsize
14696           yj=mod(yj,boxysize)
14697           if (yj.lt.0) yj=yj+boxysize
14698           zj=mod(zj,boxzsize)
14699           if (zj.lt.0) zj=zj+boxzsize
14700       isubchap=0
14701       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14702       xj_safe=xj
14703       yj_safe=yj
14704       zj_safe=zj
14705       do xshift=-1,1
14706       do yshift=-1,1
14707       do zshift=-1,1
14708           xj=xj_safe+xshift*boxxsize
14709           yj=yj_safe+yshift*boxysize
14710           zj=zj_safe+zshift*boxzsize
14711           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14712           if(dist_temp.lt.dist_init) then
14713             dist_init=dist_temp
14714             xj_temp=xj
14715             yj_temp=yj
14716             zj_temp=zj
14717             isubchap=1
14718           endif
14719        enddo
14720        enddo
14721        enddo
14722        if (isubchap.eq.1) then
14723 !C          print *,i,j
14724           xj=xj_temp-xmedi
14725           yj=yj_temp-ymedi
14726           zj=zj_temp-zmedi
14727        else
14728           xj=xj_safe-xmedi
14729           yj=yj_safe-ymedi
14730           zj=zj_safe-zmedi
14731        endif
14732
14733           rij=xj*xj+yj*yj+zj*zj
14734           rrmij=1.0D0/rij
14735           rij=dsqrt(rij)
14736           sss=sscale(rij/rpp(iteli,itelj))
14737             sss_ele_cut=sscale_ele(rij)
14738             sss_ele_grad=sscagrad_ele(rij)
14739             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14740             if (sss_ele_cut.le.0.0) cycle
14741           if (sss.gt.0.0d0) then
14742             rmij=1.0D0/rij
14743             r3ij=rrmij*rmij
14744             r6ij=r3ij*r3ij
14745             ev1=aaa*r6ij*r6ij
14746 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14747             if (j.eq.i+2) ev1=scal_el*ev1
14748             ev2=bbb*r6ij
14749             evdwij=ev1+ev2
14750             if (energy_dec) then
14751               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14752             endif
14753             evdw1=evdw1+evdwij*sss*sss_ele_cut
14754 !
14755 ! Calculate contributions to the Cartesian gradient.
14756 !
14757             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14758 !            ggg(1)=facvdw*xj
14759 !            ggg(2)=facvdw*yj
14760 !            ggg(3)=facvdw*zj
14761           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14762           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14763           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14764           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14765           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14766           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14767
14768             do k=1,3
14769               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14770               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14771             enddo
14772           endif
14773         enddo ! j
14774       enddo   ! i
14775       return
14776       end subroutine evdwpp_short
14777 !-----------------------------------------------------------------------------
14778       subroutine escp_long(evdw2,evdw2_14)
14779 !
14780 ! This subroutine calculates the excluded-volume interaction energy between
14781 ! peptide-group centers and side chains and its gradient in virtual-bond and
14782 ! side-chain vectors.
14783 !
14784 !      implicit real*8 (a-h,o-z)
14785 !      include 'DIMENSIONS'
14786 !      include 'COMMON.GEO'
14787 !      include 'COMMON.VAR'
14788 !      include 'COMMON.LOCAL'
14789 !      include 'COMMON.CHAIN'
14790 !      include 'COMMON.DERIV'
14791 !      include 'COMMON.INTERACT'
14792 !      include 'COMMON.FFIELD'
14793 !      include 'COMMON.IOUNITS'
14794 !      include 'COMMON.CONTROL'
14795       real(kind=8),dimension(3) :: ggg
14796 !el local variables
14797       integer :: i,iint,j,k,iteli,itypj,subchap
14798       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14799       real(kind=8) :: evdw2,evdw2_14,evdwij
14800       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14801                     dist_temp, dist_init
14802
14803       evdw2=0.0D0
14804       evdw2_14=0.0d0
14805 !d    print '(a)','Enter ESCP'
14806 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14807       do i=iatscp_s,iatscp_e
14808         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14809         iteli=itel(i)
14810         xi=0.5D0*(c(1,i)+c(1,i+1))
14811         yi=0.5D0*(c(2,i)+c(2,i+1))
14812         zi=0.5D0*(c(3,i)+c(3,i+1))
14813           xi=mod(xi,boxxsize)
14814           if (xi.lt.0) xi=xi+boxxsize
14815           yi=mod(yi,boxysize)
14816           if (yi.lt.0) yi=yi+boxysize
14817           zi=mod(zi,boxzsize)
14818           if (zi.lt.0) zi=zi+boxzsize
14819
14820         do iint=1,nscp_gr(i)
14821
14822         do j=iscpstart(i,iint),iscpend(i,iint)
14823           itypj=itype(j,1)
14824           if (itypj.eq.ntyp1) cycle
14825 ! Uncomment following three lines for SC-p interactions
14826 !         xj=c(1,nres+j)-xi
14827 !         yj=c(2,nres+j)-yi
14828 !         zj=c(3,nres+j)-zi
14829 ! Uncomment following three lines for Ca-p interactions
14830           xj=c(1,j)
14831           yj=c(2,j)
14832           zj=c(3,j)
14833           xj=mod(xj,boxxsize)
14834           if (xj.lt.0) xj=xj+boxxsize
14835           yj=mod(yj,boxysize)
14836           if (yj.lt.0) yj=yj+boxysize
14837           zj=mod(zj,boxzsize)
14838           if (zj.lt.0) zj=zj+boxzsize
14839       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14840       xj_safe=xj
14841       yj_safe=yj
14842       zj_safe=zj
14843       subchap=0
14844       do xshift=-1,1
14845       do yshift=-1,1
14846       do zshift=-1,1
14847           xj=xj_safe+xshift*boxxsize
14848           yj=yj_safe+yshift*boxysize
14849           zj=zj_safe+zshift*boxzsize
14850           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14851           if(dist_temp.lt.dist_init) then
14852             dist_init=dist_temp
14853             xj_temp=xj
14854             yj_temp=yj
14855             zj_temp=zj
14856             subchap=1
14857           endif
14858        enddo
14859        enddo
14860        enddo
14861        if (subchap.eq.1) then
14862           xj=xj_temp-xi
14863           yj=yj_temp-yi
14864           zj=zj_temp-zi
14865        else
14866           xj=xj_safe-xi
14867           yj=yj_safe-yi
14868           zj=zj_safe-zi
14869        endif
14870           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14871
14872           rij=dsqrt(1.0d0/rrij)
14873             sss_ele_cut=sscale_ele(rij)
14874             sss_ele_grad=sscagrad_ele(rij)
14875 !            print *,sss_ele_cut,sss_ele_grad,&
14876 !            (rij),r_cut_ele,rlamb_ele
14877             if (sss_ele_cut.le.0.0) cycle
14878           sss=sscale((rij/rscp(itypj,iteli)))
14879           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14880           if (sss.lt.1.0d0) then
14881
14882             fac=rrij**expon2
14883             e1=fac*fac*aad(itypj,iteli)
14884             e2=fac*bad(itypj,iteli)
14885             if (iabs(j-i) .le. 2) then
14886               e1=scal14*e1
14887               e2=scal14*e2
14888               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
14889             endif
14890             evdwij=e1+e2
14891             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
14892             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14893                 'evdw2',i,j,sss,evdwij
14894 !
14895 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14896 !
14897             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
14898             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
14899             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14900             ggg(1)=xj*fac
14901             ggg(2)=yj*fac
14902             ggg(3)=zj*fac
14903 ! Uncomment following three lines for SC-p interactions
14904 !           do k=1,3
14905 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14906 !           enddo
14907 ! Uncomment following line for SC-p interactions
14908 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14909             do k=1,3
14910               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14911               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14912             enddo
14913           endif
14914         enddo
14915
14916         enddo ! iint
14917       enddo ! i
14918       do i=1,nct
14919         do j=1,3
14920           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14921           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14922           gradx_scp(j,i)=expon*gradx_scp(j,i)
14923         enddo
14924       enddo
14925 !******************************************************************************
14926 !
14927 !                              N O T E !!!
14928 !
14929 ! To save time the factor EXPON has been extracted from ALL components
14930 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14931 ! use!
14932 !
14933 !******************************************************************************
14934       return
14935       end subroutine escp_long
14936 !-----------------------------------------------------------------------------
14937       subroutine escp_short(evdw2,evdw2_14)
14938 !
14939 ! This subroutine calculates the excluded-volume interaction energy between
14940 ! peptide-group centers and side chains and its gradient in virtual-bond and
14941 ! side-chain vectors.
14942 !
14943 !      implicit real*8 (a-h,o-z)
14944 !      include 'DIMENSIONS'
14945 !      include 'COMMON.GEO'
14946 !      include 'COMMON.VAR'
14947 !      include 'COMMON.LOCAL'
14948 !      include 'COMMON.CHAIN'
14949 !      include 'COMMON.DERIV'
14950 !      include 'COMMON.INTERACT'
14951 !      include 'COMMON.FFIELD'
14952 !      include 'COMMON.IOUNITS'
14953 !      include 'COMMON.CONTROL'
14954       real(kind=8),dimension(3) :: ggg
14955 !el local variables
14956       integer :: i,iint,j,k,iteli,itypj,subchap
14957       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14958       real(kind=8) :: evdw2,evdw2_14,evdwij
14959       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14960                     dist_temp, dist_init
14961
14962       evdw2=0.0D0
14963       evdw2_14=0.0d0
14964 !d    print '(a)','Enter ESCP'
14965 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14966       do i=iatscp_s,iatscp_e
14967         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14968         iteli=itel(i)
14969         xi=0.5D0*(c(1,i)+c(1,i+1))
14970         yi=0.5D0*(c(2,i)+c(2,i+1))
14971         zi=0.5D0*(c(3,i)+c(3,i+1))
14972           xi=mod(xi,boxxsize)
14973           if (xi.lt.0) xi=xi+boxxsize
14974           yi=mod(yi,boxysize)
14975           if (yi.lt.0) yi=yi+boxysize
14976           zi=mod(zi,boxzsize)
14977           if (zi.lt.0) zi=zi+boxzsize
14978
14979         do iint=1,nscp_gr(i)
14980
14981         do j=iscpstart(i,iint),iscpend(i,iint)
14982           itypj=itype(j,1)
14983           if (itypj.eq.ntyp1) cycle
14984 ! Uncomment following three lines for SC-p interactions
14985 !         xj=c(1,nres+j)-xi
14986 !         yj=c(2,nres+j)-yi
14987 !         zj=c(3,nres+j)-zi
14988 ! Uncomment following three lines for Ca-p interactions
14989 !          xj=c(1,j)-xi
14990 !          yj=c(2,j)-yi
14991 !          zj=c(3,j)-zi
14992           xj=c(1,j)
14993           yj=c(2,j)
14994           zj=c(3,j)
14995           xj=mod(xj,boxxsize)
14996           if (xj.lt.0) xj=xj+boxxsize
14997           yj=mod(yj,boxysize)
14998           if (yj.lt.0) yj=yj+boxysize
14999           zj=mod(zj,boxzsize)
15000           if (zj.lt.0) zj=zj+boxzsize
15001       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15002       xj_safe=xj
15003       yj_safe=yj
15004       zj_safe=zj
15005       subchap=0
15006       do xshift=-1,1
15007       do yshift=-1,1
15008       do zshift=-1,1
15009           xj=xj_safe+xshift*boxxsize
15010           yj=yj_safe+yshift*boxysize
15011           zj=zj_safe+zshift*boxzsize
15012           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15013           if(dist_temp.lt.dist_init) then
15014             dist_init=dist_temp
15015             xj_temp=xj
15016             yj_temp=yj
15017             zj_temp=zj
15018             subchap=1
15019           endif
15020        enddo
15021        enddo
15022        enddo
15023        if (subchap.eq.1) then
15024           xj=xj_temp-xi
15025           yj=yj_temp-yi
15026           zj=zj_temp-zi
15027        else
15028           xj=xj_safe-xi
15029           yj=yj_safe-yi
15030           zj=zj_safe-zi
15031        endif
15032
15033           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15034           rij=dsqrt(1.0d0/rrij)
15035             sss_ele_cut=sscale_ele(rij)
15036             sss_ele_grad=sscagrad_ele(rij)
15037 !            print *,sss_ele_cut,sss_ele_grad,&
15038 !            (rij),r_cut_ele,rlamb_ele
15039             if (sss_ele_cut.le.0.0) cycle
15040           sss=sscale(rij/rscp(itypj,iteli))
15041           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15042           if (sss.gt.0.0d0) then
15043
15044             fac=rrij**expon2
15045             e1=fac*fac*aad(itypj,iteli)
15046             e2=fac*bad(itypj,iteli)
15047             if (iabs(j-i) .le. 2) then
15048               e1=scal14*e1
15049               e2=scal14*e2
15050               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15051             endif
15052             evdwij=e1+e2
15053             evdw2=evdw2+evdwij*sss*sss_ele_cut
15054             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15055                 'evdw2',i,j,sss,evdwij
15056 !
15057 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15058 !
15059             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15060             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15061             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15062
15063             ggg(1)=xj*fac
15064             ggg(2)=yj*fac
15065             ggg(3)=zj*fac
15066 ! Uncomment following three lines for SC-p interactions
15067 !           do k=1,3
15068 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15069 !           enddo
15070 ! Uncomment following line for SC-p interactions
15071 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15072             do k=1,3
15073               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15074               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15075             enddo
15076           endif
15077         enddo
15078
15079         enddo ! iint
15080       enddo ! i
15081       do i=1,nct
15082         do j=1,3
15083           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15084           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15085           gradx_scp(j,i)=expon*gradx_scp(j,i)
15086         enddo
15087       enddo
15088 !******************************************************************************
15089 !
15090 !                              N O T E !!!
15091 !
15092 ! To save time the factor EXPON has been extracted from ALL components
15093 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15094 ! use!
15095 !
15096 !******************************************************************************
15097       return
15098       end subroutine escp_short
15099 !-----------------------------------------------------------------------------
15100 ! energy_p_new-sep_barrier.F
15101 !-----------------------------------------------------------------------------
15102       subroutine sc_grad_scale(scalfac)
15103 !      implicit real*8 (a-h,o-z)
15104       use calc_data
15105 !      include 'DIMENSIONS'
15106 !      include 'COMMON.CHAIN'
15107 !      include 'COMMON.DERIV'
15108 !      include 'COMMON.CALC'
15109 !      include 'COMMON.IOUNITS'
15110       real(kind=8),dimension(3) :: dcosom1,dcosom2
15111       real(kind=8) :: scalfac
15112 !el local variables
15113 !      integer :: i,j,k,l
15114
15115       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15116       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15117       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15118            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15119 ! diagnostics only
15120 !      eom1=0.0d0
15121 !      eom2=0.0d0
15122 !      eom12=evdwij*eps1_om12
15123 ! end diagnostics
15124 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15125 !     &  " sigder",sigder
15126 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15127 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15128       do k=1,3
15129         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15130         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15131       enddo
15132       do k=1,3
15133         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15134          *sss_ele_cut
15135       enddo
15136 !      write (iout,*) "gg",(gg(k),k=1,3)
15137       do k=1,3
15138         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15139                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15140                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15141                  *sss_ele_cut
15142         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15143                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15144                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15145          *sss_ele_cut
15146 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15147 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15148 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15149 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15150       enddo
15151 !
15152 ! Calculate the components of the gradient in DC and X
15153 !
15154       do l=1,3
15155         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15156         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15157       enddo
15158       return
15159       end subroutine sc_grad_scale
15160 !-----------------------------------------------------------------------------
15161 ! energy_split-sep.F
15162 !-----------------------------------------------------------------------------
15163       subroutine etotal_long(energia)
15164 !
15165 ! Compute the long-range slow-varying contributions to the energy
15166 !
15167 !      implicit real*8 (a-h,o-z)
15168 !      include 'DIMENSIONS'
15169       use MD_data, only: totT,usampl,eq_time
15170 #ifndef ISNAN
15171       external proc_proc
15172 #ifdef WINPGI
15173 !MS$ATTRIBUTES C ::  proc_proc
15174 #endif
15175 #endif
15176 #ifdef MPI
15177       include "mpif.h"
15178       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15179 #endif
15180 !      include 'COMMON.SETUP'
15181 !      include 'COMMON.IOUNITS'
15182 !      include 'COMMON.FFIELD'
15183 !      include 'COMMON.DERIV'
15184 !      include 'COMMON.INTERACT'
15185 !      include 'COMMON.SBRIDGE'
15186 !      include 'COMMON.CHAIN'
15187 !      include 'COMMON.VAR'
15188 !      include 'COMMON.LOCAL'
15189 !      include 'COMMON.MD'
15190       real(kind=8),dimension(0:n_ene) :: energia
15191 !el local variables
15192       integer :: i,n_corr,n_corr1,ierror,ierr
15193       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15194                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15195                   ecorr,ecorr5,ecorr6,eturn6,time00
15196 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15197 !elwrite(iout,*)"in etotal long"
15198
15199       if (modecalc.eq.12.or.modecalc.eq.14) then
15200 #ifdef MPI
15201 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15202 #else
15203         call int_from_cart1(.false.)
15204 #endif
15205       endif
15206 !elwrite(iout,*)"in etotal long"
15207
15208 #ifdef MPI
15209 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15210 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15211       call flush(iout)
15212       if (nfgtasks.gt.1) then
15213         time00=MPI_Wtime()
15214 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15215         if (fg_rank.eq.0) then
15216           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15217 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15218 !          call flush(iout)
15219 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15220 ! FG slaves as WEIGHTS array.
15221           weights_(1)=wsc
15222           weights_(2)=wscp
15223           weights_(3)=welec
15224           weights_(4)=wcorr
15225           weights_(5)=wcorr5
15226           weights_(6)=wcorr6
15227           weights_(7)=wel_loc
15228           weights_(8)=wturn3
15229           weights_(9)=wturn4
15230           weights_(10)=wturn6
15231           weights_(11)=wang
15232           weights_(12)=wscloc
15233           weights_(13)=wtor
15234           weights_(14)=wtor_d
15235           weights_(15)=wstrain
15236           weights_(16)=wvdwpp
15237           weights_(17)=wbond
15238           weights_(18)=scal14
15239           weights_(21)=wsccor
15240 ! FG Master broadcasts the WEIGHTS_ array
15241           call MPI_Bcast(weights_(1),n_ene,&
15242               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15243         else
15244 ! FG slaves receive the WEIGHTS array
15245           call MPI_Bcast(weights(1),n_ene,&
15246               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15247           wsc=weights(1)
15248           wscp=weights(2)
15249           welec=weights(3)
15250           wcorr=weights(4)
15251           wcorr5=weights(5)
15252           wcorr6=weights(6)
15253           wel_loc=weights(7)
15254           wturn3=weights(8)
15255           wturn4=weights(9)
15256           wturn6=weights(10)
15257           wang=weights(11)
15258           wscloc=weights(12)
15259           wtor=weights(13)
15260           wtor_d=weights(14)
15261           wstrain=weights(15)
15262           wvdwpp=weights(16)
15263           wbond=weights(17)
15264           scal14=weights(18)
15265           wsccor=weights(21)
15266         endif
15267         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15268           king,FG_COMM,IERR)
15269          time_Bcast=time_Bcast+MPI_Wtime()-time00
15270          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15271 !        call chainbuild_cart
15272 !        call int_from_cart1(.false.)
15273       endif
15274 !      write (iout,*) 'Processor',myrank,
15275 !     &  ' calling etotal_short ipot=',ipot
15276 !      call flush(iout)
15277 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15278 #endif
15279 !d    print *,'nnt=',nnt,' nct=',nct
15280 !
15281 !elwrite(iout,*)"in etotal long"
15282 ! Compute the side-chain and electrostatic interaction energy
15283 !
15284       goto (101,102,103,104,105,106) ipot
15285 ! Lennard-Jones potential.
15286   101 call elj_long(evdw)
15287 !d    print '(a)','Exit ELJ'
15288       goto 107
15289 ! Lennard-Jones-Kihara potential (shifted).
15290   102 call eljk_long(evdw)
15291       goto 107
15292 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15293   103 call ebp_long(evdw)
15294       goto 107
15295 ! Gay-Berne potential (shifted LJ, angular dependence).
15296   104 call egb_long(evdw)
15297       goto 107
15298 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15299   105 call egbv_long(evdw)
15300       goto 107
15301 ! Soft-sphere potential
15302   106 call e_softsphere(evdw)
15303 !
15304 ! Calculate electrostatic (H-bonding) energy of the main chain.
15305 !
15306   107 continue
15307       call vec_and_deriv
15308       if (ipot.lt.6) then
15309 #ifdef SPLITELE
15310          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15311              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15312              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15313              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15314 #else
15315          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15316              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15317              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15318              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15319 #endif
15320            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15321          else
15322             ees=0
15323             evdw1=0
15324             eel_loc=0
15325             eello_turn3=0
15326             eello_turn4=0
15327          endif
15328       else
15329 !        write (iout,*) "Soft-spheer ELEC potential"
15330         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15331          eello_turn4)
15332       endif
15333 !
15334 ! Calculate excluded-volume interaction energy between peptide groups
15335 ! and side chains.
15336 !
15337       if (ipot.lt.6) then
15338        if(wscp.gt.0d0) then
15339         call escp_long(evdw2,evdw2_14)
15340        else
15341         evdw2=0
15342         evdw2_14=0
15343        endif
15344       else
15345         call escp_soft_sphere(evdw2,evdw2_14)
15346       endif
15347 !
15348 ! 12/1/95 Multi-body terms
15349 !
15350       n_corr=0
15351       n_corr1=0
15352       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15353           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15354          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15355 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15356 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15357       else
15358          ecorr=0.0d0
15359          ecorr5=0.0d0
15360          ecorr6=0.0d0
15361          eturn6=0.0d0
15362       endif
15363       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15364          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15365       endif
15366 !
15367 ! If performing constraint dynamics, call the constraint energy
15368 !  after the equilibration time
15369       if(usampl.and.totT.gt.eq_time) then
15370          call EconstrQ
15371          call Econstr_back
15372       else
15373          Uconst=0.0d0
15374          Uconst_back=0.0d0
15375       endif
15376 !
15377 ! Sum the energies
15378 !
15379       do i=1,n_ene
15380         energia(i)=0.0d0
15381       enddo
15382       energia(1)=evdw
15383 #ifdef SCP14
15384       energia(2)=evdw2-evdw2_14
15385       energia(18)=evdw2_14
15386 #else
15387       energia(2)=evdw2
15388       energia(18)=0.0d0
15389 #endif
15390 #ifdef SPLITELE
15391       energia(3)=ees
15392       energia(16)=evdw1
15393 #else
15394       energia(3)=ees+evdw1
15395       energia(16)=0.0d0
15396 #endif
15397       energia(4)=ecorr
15398       energia(5)=ecorr5
15399       energia(6)=ecorr6
15400       energia(7)=eel_loc
15401       energia(8)=eello_turn3
15402       energia(9)=eello_turn4
15403       energia(10)=eturn6
15404       energia(20)=Uconst+Uconst_back
15405       call sum_energy(energia,.true.)
15406 !      write (iout,*) "Exit ETOTAL_LONG"
15407       call flush(iout)
15408       return
15409       end subroutine etotal_long
15410 !-----------------------------------------------------------------------------
15411       subroutine etotal_short(energia)
15412 !
15413 ! Compute the short-range fast-varying contributions to the energy
15414 !
15415 !      implicit real*8 (a-h,o-z)
15416 !      include 'DIMENSIONS'
15417 #ifndef ISNAN
15418       external proc_proc
15419 #ifdef WINPGI
15420 !MS$ATTRIBUTES C ::  proc_proc
15421 #endif
15422 #endif
15423 #ifdef MPI
15424       include "mpif.h"
15425       integer :: ierror,ierr
15426       real(kind=8),dimension(n_ene) :: weights_
15427       real(kind=8) :: time00
15428 #endif
15429 !      include 'COMMON.SETUP'
15430 !      include 'COMMON.IOUNITS'
15431 !      include 'COMMON.FFIELD'
15432 !      include 'COMMON.DERIV'
15433 !      include 'COMMON.INTERACT'
15434 !      include 'COMMON.SBRIDGE'
15435 !      include 'COMMON.CHAIN'
15436 !      include 'COMMON.VAR'
15437 !      include 'COMMON.LOCAL'
15438       real(kind=8),dimension(0:n_ene) :: energia
15439 !el local variables
15440       integer :: i,nres6
15441       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15442       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15443       nres6=6*nres
15444
15445 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15446 !      call flush(iout)
15447       if (modecalc.eq.12.or.modecalc.eq.14) then
15448 #ifdef MPI
15449         if (fg_rank.eq.0) call int_from_cart1(.false.)
15450 #else
15451         call int_from_cart1(.false.)
15452 #endif
15453       endif
15454 #ifdef MPI
15455 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15456 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15457 !      call flush(iout)
15458       if (nfgtasks.gt.1) then
15459         time00=MPI_Wtime()
15460 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15461         if (fg_rank.eq.0) then
15462           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15463 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15464 !          call flush(iout)
15465 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15466 ! FG slaves as WEIGHTS array.
15467           weights_(1)=wsc
15468           weights_(2)=wscp
15469           weights_(3)=welec
15470           weights_(4)=wcorr
15471           weights_(5)=wcorr5
15472           weights_(6)=wcorr6
15473           weights_(7)=wel_loc
15474           weights_(8)=wturn3
15475           weights_(9)=wturn4
15476           weights_(10)=wturn6
15477           weights_(11)=wang
15478           weights_(12)=wscloc
15479           weights_(13)=wtor
15480           weights_(14)=wtor_d
15481           weights_(15)=wstrain
15482           weights_(16)=wvdwpp
15483           weights_(17)=wbond
15484           weights_(18)=scal14
15485           weights_(21)=wsccor
15486 ! FG Master broadcasts the WEIGHTS_ array
15487           call MPI_Bcast(weights_(1),n_ene,&
15488               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15489         else
15490 ! FG slaves receive the WEIGHTS array
15491           call MPI_Bcast(weights(1),n_ene,&
15492               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15493           wsc=weights(1)
15494           wscp=weights(2)
15495           welec=weights(3)
15496           wcorr=weights(4)
15497           wcorr5=weights(5)
15498           wcorr6=weights(6)
15499           wel_loc=weights(7)
15500           wturn3=weights(8)
15501           wturn4=weights(9)
15502           wturn6=weights(10)
15503           wang=weights(11)
15504           wscloc=weights(12)
15505           wtor=weights(13)
15506           wtor_d=weights(14)
15507           wstrain=weights(15)
15508           wvdwpp=weights(16)
15509           wbond=weights(17)
15510           scal14=weights(18)
15511           wsccor=weights(21)
15512         endif
15513 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15514         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15515           king,FG_COMM,IERR)
15516 !        write (iout,*) "Processor",myrank," BROADCAST c"
15517         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15518           king,FG_COMM,IERR)
15519 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15520         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15521           king,FG_COMM,IERR)
15522 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15523         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15524           king,FG_COMM,IERR)
15525 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15526         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15527           king,FG_COMM,IERR)
15528 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15529         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15530           king,FG_COMM,IERR)
15531 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15532         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15533           king,FG_COMM,IERR)
15534 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15535         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15536           king,FG_COMM,IERR)
15537 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15538         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15539           king,FG_COMM,IERR)
15540          time_Bcast=time_Bcast+MPI_Wtime()-time00
15541 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15542       endif
15543 !      write (iout,*) 'Processor',myrank,
15544 !     &  ' calling etotal_short ipot=',ipot
15545 !      call flush(iout)
15546 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15547 #endif
15548 !      call int_from_cart1(.false.)
15549 !
15550 ! Compute the side-chain and electrostatic interaction energy
15551 !
15552       goto (101,102,103,104,105,106) ipot
15553 ! Lennard-Jones potential.
15554   101 call elj_short(evdw)
15555 !d    print '(a)','Exit ELJ'
15556       goto 107
15557 ! Lennard-Jones-Kihara potential (shifted).
15558   102 call eljk_short(evdw)
15559       goto 107
15560 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15561   103 call ebp_short(evdw)
15562       goto 107
15563 ! Gay-Berne potential (shifted LJ, angular dependence).
15564   104 call egb_short(evdw)
15565       goto 107
15566 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15567   105 call egbv_short(evdw)
15568       goto 107
15569 ! Soft-sphere potential - already dealt with in the long-range part
15570   106 evdw=0.0d0
15571 !  106 call e_softsphere_short(evdw)
15572 !
15573 ! Calculate electrostatic (H-bonding) energy of the main chain.
15574 !
15575   107 continue
15576 !
15577 ! Calculate the short-range part of Evdwpp
15578 !
15579       call evdwpp_short(evdw1)
15580 !
15581 ! Calculate the short-range part of ESCp
15582 !
15583       if (ipot.lt.6) then
15584         call escp_short(evdw2,evdw2_14)
15585       endif
15586 !
15587 ! Calculate the bond-stretching energy
15588 !
15589       call ebond(estr)
15590 !
15591 ! Calculate the disulfide-bridge and other energy and the contributions
15592 ! from other distance constraints.
15593       call edis(ehpb)
15594 !
15595 ! Calculate the virtual-bond-angle energy.
15596 !
15597       call ebend(ebe,ethetacnstr)
15598 !
15599 ! Calculate the SC local energy.
15600 !
15601       call vec_and_deriv
15602       call esc(escloc)
15603 !
15604 ! Calculate the virtual-bond torsional energy.
15605 !
15606       call etor(etors,edihcnstr)
15607 !
15608 ! 6/23/01 Calculate double-torsional energy
15609 !
15610       call etor_d(etors_d)
15611 !
15612 ! 21/5/07 Calculate local sicdechain correlation energy
15613 !
15614       if (wsccor.gt.0.0d0) then
15615         call eback_sc_corr(esccor)
15616       else
15617         esccor=0.0d0
15618       endif
15619 !
15620 ! Put energy components into an array
15621 !
15622       do i=1,n_ene
15623         energia(i)=0.0d0
15624       enddo
15625       energia(1)=evdw
15626 #ifdef SCP14
15627       energia(2)=evdw2-evdw2_14
15628       energia(18)=evdw2_14
15629 #else
15630       energia(2)=evdw2
15631       energia(18)=0.0d0
15632 #endif
15633 #ifdef SPLITELE
15634       energia(16)=evdw1
15635 #else
15636       energia(3)=evdw1
15637 #endif
15638       energia(11)=ebe
15639       energia(12)=escloc
15640       energia(13)=etors
15641       energia(14)=etors_d
15642       energia(15)=ehpb
15643       energia(17)=estr
15644       energia(19)=edihcnstr
15645       energia(21)=esccor
15646 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15647       call flush(iout)
15648       call sum_energy(energia,.true.)
15649 !      write (iout,*) "Exit ETOTAL_SHORT"
15650       call flush(iout)
15651       return
15652       end subroutine etotal_short
15653 !-----------------------------------------------------------------------------
15654 ! gnmr1.f
15655 !-----------------------------------------------------------------------------
15656       real(kind=8) function gnmr1(y,ymin,ymax)
15657 !      implicit none
15658       real(kind=8) :: y,ymin,ymax
15659       real(kind=8) :: wykl=4.0d0
15660       if (y.lt.ymin) then
15661         gnmr1=(ymin-y)**wykl/wykl
15662       else if (y.gt.ymax) then
15663         gnmr1=(y-ymax)**wykl/wykl
15664       else
15665         gnmr1=0.0d0
15666       endif
15667       return
15668       end function gnmr1
15669 !-----------------------------------------------------------------------------
15670       real(kind=8) function gnmr1prim(y,ymin,ymax)
15671 !      implicit none
15672       real(kind=8) :: y,ymin,ymax
15673       real(kind=8) :: wykl=4.0d0
15674       if (y.lt.ymin) then
15675         gnmr1prim=-(ymin-y)**(wykl-1)
15676       else if (y.gt.ymax) then
15677         gnmr1prim=(y-ymax)**(wykl-1)
15678       else
15679         gnmr1prim=0.0d0
15680       endif
15681       return
15682       end function gnmr1prim
15683 !----------------------------------------------------------------------------
15684       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15685       real(kind=8) y,ymin,ymax,sigma
15686       real(kind=8) wykl /4.0d0/
15687       if (y.lt.ymin) then
15688         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15689       else if (y.gt.ymax) then
15690         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15691       else
15692         rlornmr1=0.0d0
15693       endif
15694       return
15695       end function rlornmr1
15696 !------------------------------------------------------------------------------
15697       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15698       real(kind=8) y,ymin,ymax,sigma
15699       real(kind=8) wykl /4.0d0/
15700       if (y.lt.ymin) then
15701         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15702         ((ymin-y)**wykl+sigma**wykl)**2
15703       else if (y.gt.ymax) then
15704         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15705         ((y-ymax)**wykl+sigma**wykl)**2
15706       else
15707         rlornmr1prim=0.0d0
15708       endif
15709       return
15710       end function rlornmr1prim
15711
15712       real(kind=8) function harmonic(y,ymax)
15713 !      implicit none
15714       real(kind=8) :: y,ymax
15715       real(kind=8) :: wykl=2.0d0
15716       harmonic=(y-ymax)**wykl
15717       return
15718       end function harmonic
15719 !-----------------------------------------------------------------------------
15720       real(kind=8) function harmonicprim(y,ymax)
15721       real(kind=8) :: y,ymin,ymax
15722       real(kind=8) :: wykl=2.0d0
15723       harmonicprim=(y-ymax)*wykl
15724       return
15725       end function harmonicprim
15726 !-----------------------------------------------------------------------------
15727 ! gradient_p.F
15728 !-----------------------------------------------------------------------------
15729       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15730
15731       use io_base, only:intout,briefout
15732 !      implicit real*8 (a-h,o-z)
15733 !      include 'DIMENSIONS'
15734 !      include 'COMMON.CHAIN'
15735 !      include 'COMMON.DERIV'
15736 !      include 'COMMON.VAR'
15737 !      include 'COMMON.INTERACT'
15738 !      include 'COMMON.FFIELD'
15739 !      include 'COMMON.MD'
15740 !      include 'COMMON.IOUNITS'
15741       real(kind=8),external :: ufparm
15742       integer :: uiparm(1)
15743       real(kind=8) :: urparm(1)
15744       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15745       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15746       integer :: n,nf,ind,ind1,i,k,j
15747 !
15748 ! This subroutine calculates total internal coordinate gradient.
15749 ! Depending on the number of function evaluations, either whole energy
15750 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15751 ! internal coordinates are reevaluated or only the cartesian-in-internal
15752 ! coordinate derivatives are evaluated. The subroutine was designed to work
15753 ! with SUMSL.
15754 !
15755 !
15756       icg=mod(nf,2)+1
15757
15758 !d      print *,'grad',nf,icg
15759       if (nf-nfl+1) 20,30,40
15760    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15761 !    write (iout,*) 'grad 20'
15762       if (nf.eq.0) return
15763       goto 40
15764    30 call var_to_geom(n,x)
15765       call chainbuild
15766 !    write (iout,*) 'grad 30'
15767 !
15768 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15769 !
15770    40 call cartder
15771 !     write (iout,*) 'grad 40'
15772 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15773 !
15774 ! Convert the Cartesian gradient into internal-coordinate gradient.
15775 !
15776       ind=0
15777       ind1=0
15778       do i=1,nres-2
15779         gthetai=0.0D0
15780         gphii=0.0D0
15781         do j=i+1,nres-1
15782           ind=ind+1
15783 !         ind=indmat(i,j)
15784 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
15785           do k=1,3
15786             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
15787           enddo
15788           do k=1,3
15789             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
15790           enddo
15791         enddo
15792         do j=i+1,nres-1
15793           ind1=ind1+1
15794 !         ind1=indmat(i,j)
15795 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
15796           do k=1,3
15797             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
15798             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
15799           enddo
15800         enddo
15801         if (i.gt.1) g(i-1)=gphii
15802         if (n.gt.nphi) g(nphi+i)=gthetai
15803       enddo
15804       if (n.le.nphi+ntheta) goto 10
15805       do i=2,nres-1
15806         if (itype(i,1).ne.10) then
15807           galphai=0.0D0
15808           gomegai=0.0D0
15809           do k=1,3
15810             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
15811           enddo
15812           do k=1,3
15813             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
15814           enddo
15815           g(ialph(i,1))=galphai
15816           g(ialph(i,1)+nside)=gomegai
15817         endif
15818       enddo
15819 !
15820 ! Add the components corresponding to local energy terms.
15821 !
15822    10 continue
15823       do i=1,nvar
15824 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
15825         g(i)=g(i)+gloc(i,icg)
15826       enddo
15827 ! Uncomment following three lines for diagnostics.
15828 !d    call intout
15829 !elwrite(iout,*) "in gradient after calling intout"
15830 !d    call briefout(0,0.0d0)
15831 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
15832       return
15833       end subroutine gradient
15834 !-----------------------------------------------------------------------------
15835       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
15836
15837       use comm_chu
15838 !      implicit real*8 (a-h,o-z)
15839 !      include 'DIMENSIONS'
15840 !      include 'COMMON.DERIV'
15841 !      include 'COMMON.IOUNITS'
15842 !      include 'COMMON.GEO'
15843       integer :: n,nf
15844 !el      integer :: jjj
15845 !el      common /chuju/ jjj
15846       real(kind=8) :: energia(0:n_ene)
15847       integer :: uiparm(1)
15848       real(kind=8) :: urparm(1)
15849       real(kind=8) :: f
15850       real(kind=8),external :: ufparm
15851       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
15852 !     if (jjj.gt.0) then
15853 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15854 !     endif
15855       nfl=nf
15856       icg=mod(nf,2)+1
15857 !d      print *,'func',nf,nfl,icg
15858       call var_to_geom(n,x)
15859       call zerograd
15860       call chainbuild
15861 !d    write (iout,*) 'ETOTAL called from FUNC'
15862       call etotal(energia)
15863       call sum_gradient
15864       f=energia(0)
15865 !     if (jjj.gt.0) then
15866 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15867 !       write (iout,*) 'f=',etot
15868 !       jjj=0
15869 !     endif
15870       return
15871       end subroutine func
15872 !-----------------------------------------------------------------------------
15873       subroutine cartgrad
15874 !      implicit real*8 (a-h,o-z)
15875 !      include 'DIMENSIONS'
15876       use energy_data
15877       use MD_data, only: totT,usampl,eq_time
15878 #ifdef MPI
15879       include 'mpif.h'
15880 #endif
15881 !      include 'COMMON.CHAIN'
15882 !      include 'COMMON.DERIV'
15883 !      include 'COMMON.VAR'
15884 !      include 'COMMON.INTERACT'
15885 !      include 'COMMON.FFIELD'
15886 !      include 'COMMON.MD'
15887 !      include 'COMMON.IOUNITS'
15888 !      include 'COMMON.TIME1'
15889 !
15890       integer :: i,j
15891
15892 ! This subrouting calculates total Cartesian coordinate gradient.
15893 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
15894 !
15895 !el#define DEBUG
15896 #ifdef TIMING
15897       time00=MPI_Wtime()
15898 #endif
15899       icg=1
15900       call sum_gradient
15901 #ifdef TIMING
15902 #endif
15903 !el      write (iout,*) "After sum_gradient"
15904 #ifdef DEBUG
15905 !el      write (iout,*) "After sum_gradient"
15906       do i=1,nres-1
15907         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
15908         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
15909       enddo
15910 #endif
15911 ! If performing constraint dynamics, add the gradients of the constraint energy
15912       if(usampl.and.totT.gt.eq_time) then
15913          do i=1,nct
15914            do j=1,3
15915              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
15916              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
15917            enddo
15918          enddo
15919          do i=1,nres-3
15920            gloc(i,icg)=gloc(i,icg)+dugamma(i)
15921          enddo
15922          do i=1,nres-2
15923            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
15924          enddo
15925       endif
15926 !elwrite (iout,*) "After sum_gradient"
15927 #ifdef TIMING
15928       time01=MPI_Wtime()
15929 #endif
15930       call intcartderiv
15931 !elwrite (iout,*) "After sum_gradient"
15932 #ifdef TIMING
15933       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
15934 #endif
15935 !     call checkintcartgrad
15936 !     write(iout,*) 'calling int_to_cart'
15937 #ifdef DEBUG
15938       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
15939 #endif
15940       do i=0,nct
15941         do j=1,3
15942           gcart(j,i)=gradc(j,i,icg)
15943           gxcart(j,i)=gradx(j,i,icg)
15944         enddo
15945 #ifdef DEBUG
15946         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
15947           (gxcart(j,i),j=1,3),gloc(i,icg)
15948 #endif
15949       enddo
15950 #ifdef TIMING
15951       time01=MPI_Wtime()
15952 #endif
15953       call int_to_cart
15954 #ifdef TIMING
15955       time_inttocart=time_inttocart+MPI_Wtime()-time01
15956 #endif
15957 #ifdef DEBUG
15958       write (iout,*) "gcart and gxcart after int_to_cart"
15959       do i=0,nres-1
15960         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
15961             (gxcart(j,i),j=1,3)
15962       enddo
15963 #endif
15964 #ifdef CARGRAD
15965 #ifdef DEBUG
15966       write (iout,*) "CARGRAD"
15967 #endif
15968       do i=nres,0,-1
15969         do j=1,3
15970           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15971 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15972         enddo
15973 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
15974 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
15975       enddo
15976 ! Correction: dummy residues
15977         if (nnt.gt.1) then
15978           do j=1,3
15979 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
15980             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
15981           enddo
15982         endif
15983         if (nct.lt.nres) then
15984           do j=1,3
15985 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
15986             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
15987           enddo
15988         endif
15989 #endif
15990 #ifdef TIMING
15991       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
15992 #endif
15993 !el#undef DEBUG
15994       return
15995       end subroutine cartgrad
15996 !-----------------------------------------------------------------------------
15997       subroutine zerograd
15998 !      implicit real*8 (a-h,o-z)
15999 !      include 'DIMENSIONS'
16000 !      include 'COMMON.DERIV'
16001 !      include 'COMMON.CHAIN'
16002 !      include 'COMMON.VAR'
16003 !      include 'COMMON.MD'
16004 !      include 'COMMON.SCCOR'
16005 !
16006 !el local variables
16007       integer :: i,j,intertyp,k
16008 ! Initialize Cartesian-coordinate gradient
16009 !
16010 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16011 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16012
16013 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16014 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16015 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16016 !      allocate(gradcorr_long(3,nres))
16017 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16018 !      allocate(gcorr6_turn_long(3,nres))
16019 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16020
16021 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16022
16023 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16024 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16025
16026 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16027 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16028
16029 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16030 !      allocate(gscloc(3,nres)) !(3,maxres)
16031 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16032
16033
16034
16035 !      common /deriv_scloc/
16036 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16037 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16038 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
16039 !      common /mpgrad/
16040 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16041
16042
16043
16044 !          gradc(j,i,icg)=0.0d0
16045 !          gradx(j,i,icg)=0.0d0
16046
16047 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16048 !elwrite(iout,*) "icg",icg
16049       do i=-1,nres
16050         do j=1,3
16051           gvdwx(j,i)=0.0D0
16052           gradx_scp(j,i)=0.0D0
16053           gvdwc(j,i)=0.0D0
16054           gvdwc_scp(j,i)=0.0D0
16055           gvdwc_scpp(j,i)=0.0d0
16056           gelc(j,i)=0.0D0
16057           gelc_long(j,i)=0.0D0
16058           gradb(j,i)=0.0d0
16059           gradbx(j,i)=0.0d0
16060           gvdwpp(j,i)=0.0d0
16061           gel_loc(j,i)=0.0d0
16062           gel_loc_long(j,i)=0.0d0
16063           ghpbc(j,i)=0.0D0
16064           ghpbx(j,i)=0.0D0
16065           gcorr3_turn(j,i)=0.0d0
16066           gcorr4_turn(j,i)=0.0d0
16067           gradcorr(j,i)=0.0d0
16068           gradcorr_long(j,i)=0.0d0
16069           gradcorr5_long(j,i)=0.0d0
16070           gradcorr6_long(j,i)=0.0d0
16071           gcorr6_turn_long(j,i)=0.0d0
16072           gradcorr5(j,i)=0.0d0
16073           gradcorr6(j,i)=0.0d0
16074           gcorr6_turn(j,i)=0.0d0
16075           gsccorc(j,i)=0.0d0
16076           gsccorx(j,i)=0.0d0
16077           gradc(j,i,icg)=0.0d0
16078           gradx(j,i,icg)=0.0d0
16079           gscloc(j,i)=0.0d0
16080           gsclocx(j,i)=0.0d0
16081           gliptran(j,i)=0.0d0
16082           gliptranx(j,i)=0.0d0
16083           gliptranc(j,i)=0.0d0
16084           gshieldx(j,i)=0.0d0
16085           gshieldc(j,i)=0.0d0
16086           gshieldc_loc(j,i)=0.0d0
16087           gshieldx_ec(j,i)=0.0d0
16088           gshieldc_ec(j,i)=0.0d0
16089           gshieldc_loc_ec(j,i)=0.0d0
16090           gshieldx_t3(j,i)=0.0d0
16091           gshieldc_t3(j,i)=0.0d0
16092           gshieldc_loc_t3(j,i)=0.0d0
16093           gshieldx_t4(j,i)=0.0d0
16094           gshieldc_t4(j,i)=0.0d0
16095           gshieldc_loc_t4(j,i)=0.0d0
16096           gshieldx_ll(j,i)=0.0d0
16097           gshieldc_ll(j,i)=0.0d0
16098           gshieldc_loc_ll(j,i)=0.0d0
16099           gg_tube(j,i)=0.0d0
16100           gg_tube_sc(j,i)=0.0d0
16101           gradafm(j,i)=0.0d0
16102           do intertyp=1,3
16103            gloc_sc(intertyp,i,icg)=0.0d0
16104           enddo
16105         enddo
16106       enddo
16107       do i=1,nres
16108        do j=1,maxcontsshi
16109        shield_list(j,i)=0
16110         do k=1,3
16111 !C           print *,i,j,k
16112            grad_shield_side(k,j,i)=0.0d0
16113            grad_shield_loc(k,j,i)=0.0d0
16114          enddo
16115        enddo
16116        ishield_list(i)=0
16117       enddo
16118
16119 !
16120 ! Initialize the gradient of local energy terms.
16121 !
16122 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
16123 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16124 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16125 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
16126 !      allocate(gel_loc_turn3(nres))
16127 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16128 !      allocate(gsccor_loc(nres))       !(maxres)
16129
16130       do i=1,4*nres
16131         gloc(i,icg)=0.0D0
16132       enddo
16133       do i=1,nres
16134         gel_loc_loc(i)=0.0d0
16135         gcorr_loc(i)=0.0d0
16136         g_corr5_loc(i)=0.0d0
16137         g_corr6_loc(i)=0.0d0
16138         gel_loc_turn3(i)=0.0d0
16139         gel_loc_turn4(i)=0.0d0
16140         gel_loc_turn6(i)=0.0d0
16141         gsccor_loc(i)=0.0d0
16142       enddo
16143 ! initialize gcart and gxcart
16144 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16145       do i=0,nres
16146         do j=1,3
16147           gcart(j,i)=0.0d0
16148           gxcart(j,i)=0.0d0
16149         enddo
16150       enddo
16151       return
16152       end subroutine zerograd
16153 !-----------------------------------------------------------------------------
16154       real(kind=8) function fdum()
16155       fdum=0.0D0
16156       return
16157       end function fdum
16158 !-----------------------------------------------------------------------------
16159 ! intcartderiv.F
16160 !-----------------------------------------------------------------------------
16161       subroutine intcartderiv
16162 !      implicit real*8 (a-h,o-z)
16163 !      include 'DIMENSIONS'
16164 #ifdef MPI
16165       include 'mpif.h'
16166 #endif
16167 !      include 'COMMON.SETUP'
16168 !      include 'COMMON.CHAIN'
16169 !      include 'COMMON.VAR'
16170 !      include 'COMMON.GEO'
16171 !      include 'COMMON.INTERACT'
16172 !      include 'COMMON.DERIV'
16173 !      include 'COMMON.IOUNITS'
16174 !      include 'COMMON.LOCAL'
16175 !      include 'COMMON.SCCOR'
16176       real(kind=8) :: pi4,pi34
16177       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16178       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16179                     dcosomega,dsinomega !(3,3,maxres)
16180       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16181
16182       integer :: i,j,k
16183       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16184                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16185                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16186                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16187       integer :: nres2
16188       nres2=2*nres
16189
16190 !el from module energy-------------
16191 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16192 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16193 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16194
16195 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16196 !el      allocate(dsintau(3,3,3,0:nres2))
16197 !el      allocate(dtauangle(3,3,3,0:nres2))
16198 !el      allocate(domicron(3,2,2,0:nres2))
16199 !el      allocate(dcosomicron(3,2,2,0:nres2))
16200
16201
16202
16203 #if defined(MPI) && defined(PARINTDER)
16204       if (nfgtasks.gt.1 .and. me.eq.king) &
16205         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16206 #endif
16207       pi4 = 0.5d0*pipol
16208       pi34 = 3*pi4
16209
16210 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
16211 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16212
16213 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16214       do i=1,nres
16215         do j=1,3
16216           dtheta(j,1,i)=0.0d0
16217           dtheta(j,2,i)=0.0d0
16218           dphi(j,1,i)=0.0d0
16219           dphi(j,2,i)=0.0d0
16220           dphi(j,3,i)=0.0d0
16221         enddo
16222       enddo
16223 ! Derivatives of theta's
16224 #if defined(MPI) && defined(PARINTDER)
16225 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16226       do i=max0(ithet_start-1,3),ithet_end
16227 #else
16228       do i=3,nres
16229 #endif
16230         cost=dcos(theta(i))
16231         sint=sqrt(1-cost*cost)
16232         do j=1,3
16233           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16234           vbld(i-1)
16235           if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16236           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16237           vbld(i)
16238           if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16239         enddo
16240       enddo
16241 #if defined(MPI) && defined(PARINTDER)
16242 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16243       do i=max0(ithet_start-1,3),ithet_end
16244 #else
16245       do i=3,nres
16246 #endif
16247       if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16248         cost1=dcos(omicron(1,i))
16249         sint1=sqrt(1-cost1*cost1)
16250         cost2=dcos(omicron(2,i))
16251         sint2=sqrt(1-cost2*cost2)
16252        do j=1,3
16253 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16254           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16255           cost1*dc_norm(j,i-2))/ &
16256           vbld(i-1)
16257           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16258           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16259           +cost1*(dc_norm(j,i-1+nres)))/ &
16260           vbld(i-1+nres)
16261           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16262 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16263 !C Looks messy but better than if in loop
16264           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16265           +cost2*dc_norm(j,i-1))/ &
16266           vbld(i)
16267           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16268           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16269            +cost2*(-dc_norm(j,i-1+nres)))/ &
16270           vbld(i-1+nres)
16271 !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16272           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16273         enddo
16274        endif
16275       enddo
16276 !elwrite(iout,*) "after vbld write"
16277 ! Derivatives of phi:
16278 ! If phi is 0 or 180 degrees, then the formulas
16279 ! have to be derived by power series expansion of the
16280 ! conventional formulas around 0 and 180.
16281 #ifdef PARINTDER
16282       do i=iphi1_start,iphi1_end
16283 #else
16284       do i=4,nres
16285 #endif
16286 !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16287 ! the conventional case
16288         sint=dsin(theta(i))
16289         sint1=dsin(theta(i-1))
16290         sing=dsin(phi(i))
16291         cost=dcos(theta(i))
16292         cost1=dcos(theta(i-1))
16293         cosg=dcos(phi(i))
16294         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16295         fac0=1.0d0/(sint1*sint)
16296         fac1=cost*fac0
16297         fac2=cost1*fac0
16298         fac3=cosg*cost1/(sint1*sint1)
16299         fac4=cosg*cost/(sint*sint)
16300 !    Obtaining the gamma derivatives from sine derivative
16301        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16302            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16303            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16304          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16305          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16306          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16307          do j=1,3
16308             ctgt=cost/sint
16309             ctgt1=cost1/sint1
16310             cosg_inv=1.0d0/cosg
16311             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16312             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16313               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16314             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16315             dsinphi(j,2,i)= &
16316               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16317               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16318             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16319             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16320               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16321 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16322             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16323             endif
16324 ! Bug fixed 3/24/05 (AL)
16325          enddo
16326 !   Obtaining the gamma derivatives from cosine derivative
16327         else
16328            do j=1,3
16329            if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16330            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16331            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16332            dc_norm(j,i-3))/vbld(i-2)
16333            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16334            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16335            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16336            dcostheta(j,1,i)
16337            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16338            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16339            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16340            dc_norm(j,i-1))/vbld(i)
16341            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16342            endif
16343          enddo
16344         endif
16345       enddo
16346 !alculate derivative of Tauangle
16347 #ifdef PARINTDER
16348       do i=itau_start,itau_end
16349 #else
16350       do i=3,nres
16351 !elwrite(iout,*) " vecpr",i,nres
16352 #endif
16353        if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16354 !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16355 !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16356 !c dtauangle(j,intertyp,dervityp,residue number)
16357 !c INTERTYP=1 SC...Ca...Ca..Ca
16358 ! the conventional case
16359         sint=dsin(theta(i))
16360         sint1=dsin(omicron(2,i-1))
16361         sing=dsin(tauangle(1,i))
16362         cost=dcos(theta(i))
16363         cost1=dcos(omicron(2,i-1))
16364         cosg=dcos(tauangle(1,i))
16365 !elwrite(iout,*) " vecpr5",i,nres
16366         do j=1,3
16367 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16368 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16369         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16370 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16371         enddo
16372         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16373         fac0=1.0d0/(sint1*sint)
16374         fac1=cost*fac0
16375         fac2=cost1*fac0
16376         fac3=cosg*cost1/(sint1*sint1)
16377         fac4=cosg*cost/(sint*sint)
16378 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16379 !    Obtaining the gamma derivatives from sine derivative
16380        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16381            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16382            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16383          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16384          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16385          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16386         do j=1,3
16387             ctgt=cost/sint
16388             ctgt1=cost1/sint1
16389             cosg_inv=1.0d0/cosg
16390             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16391        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16392        *vbld_inv(i-2+nres)
16393             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16394             dsintau(j,1,2,i)= &
16395               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16396               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16397 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16398             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16399 ! Bug fixed 3/24/05 (AL)
16400             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16401               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16402 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16403             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16404          enddo
16405 !   Obtaining the gamma derivatives from cosine derivative
16406         else
16407            do j=1,3
16408            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16409            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16410            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16411            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16412            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16413            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16414            dcostheta(j,1,i)
16415            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16416            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16417            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16418            dc_norm(j,i-1))/vbld(i)
16419            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16420 !         write (iout,*) "else",i
16421          enddo
16422         endif
16423 !        do k=1,3
16424 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16425 !        enddo
16426       enddo
16427 !C Second case Ca...Ca...Ca...SC
16428 #ifdef PARINTDER
16429       do i=itau_start,itau_end
16430 #else
16431       do i=4,nres
16432 #endif
16433        if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16434           (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16435 ! the conventional case
16436         sint=dsin(omicron(1,i))
16437         sint1=dsin(theta(i-1))
16438         sing=dsin(tauangle(2,i))
16439         cost=dcos(omicron(1,i))
16440         cost1=dcos(theta(i-1))
16441         cosg=dcos(tauangle(2,i))
16442 !        do j=1,3
16443 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16444 !        enddo
16445         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16446         fac0=1.0d0/(sint1*sint)
16447         fac1=cost*fac0
16448         fac2=cost1*fac0
16449         fac3=cosg*cost1/(sint1*sint1)
16450         fac4=cosg*cost/(sint*sint)
16451 !    Obtaining the gamma derivatives from sine derivative
16452        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16453            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16454            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16455          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16456          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16457          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16458         do j=1,3
16459             ctgt=cost/sint
16460             ctgt1=cost1/sint1
16461             cosg_inv=1.0d0/cosg
16462             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16463               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16464 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16465 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16466             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16467             dsintau(j,2,2,i)= &
16468               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16469               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16470 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16471 !     & sing*ctgt*domicron(j,1,2,i),
16472 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16473             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16474 ! Bug fixed 3/24/05 (AL)
16475             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16476              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16477 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16478             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16479          enddo
16480 !   Obtaining the gamma derivatives from cosine derivative
16481         else
16482            do j=1,3
16483            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16484            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16485            dc_norm(j,i-3))/vbld(i-2)
16486            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16487            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16488            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16489            dcosomicron(j,1,1,i)
16490            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16491            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16492            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16493            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16494            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16495 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16496          enddo
16497         endif
16498       enddo
16499
16500 !CC third case SC...Ca...Ca...SC
16501 #ifdef PARINTDER
16502
16503       do i=itau_start,itau_end
16504 #else
16505       do i=3,nres
16506 #endif
16507 ! the conventional case
16508       if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16509       (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16510         sint=dsin(omicron(1,i))
16511         sint1=dsin(omicron(2,i-1))
16512         sing=dsin(tauangle(3,i))
16513         cost=dcos(omicron(1,i))
16514         cost1=dcos(omicron(2,i-1))
16515         cosg=dcos(tauangle(3,i))
16516         do j=1,3
16517         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16518 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16519         enddo
16520         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16521         fac0=1.0d0/(sint1*sint)
16522         fac1=cost*fac0
16523         fac2=cost1*fac0
16524         fac3=cosg*cost1/(sint1*sint1)
16525         fac4=cosg*cost/(sint*sint)
16526 !    Obtaining the gamma derivatives from sine derivative
16527        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16528            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16529            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16530          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16531          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16532          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16533         do j=1,3
16534             ctgt=cost/sint
16535             ctgt1=cost1/sint1
16536             cosg_inv=1.0d0/cosg
16537             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16538               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16539               *vbld_inv(i-2+nres)
16540             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16541             dsintau(j,3,2,i)= &
16542               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16543               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16544             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16545 ! Bug fixed 3/24/05 (AL)
16546             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16547               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16548               *vbld_inv(i-1+nres)
16549 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16550             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16551          enddo
16552 !   Obtaining the gamma derivatives from cosine derivative
16553         else
16554            do j=1,3
16555            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16556            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16557            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16558            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16559            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16560            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16561            dcosomicron(j,1,1,i)
16562            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16563            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16564            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16565            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16566            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16567 !          write(iout,*) "else",i
16568          enddo
16569         endif
16570       enddo
16571
16572 #ifdef CRYST_SC
16573 !   Derivatives of side-chain angles alpha and omega
16574 #if defined(MPI) && defined(PARINTDER)
16575         do i=ibond_start,ibond_end
16576 #else
16577         do i=2,nres-1
16578 #endif
16579           if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16580              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16581              fac6=fac5/vbld(i)
16582              fac7=fac5*fac5
16583              fac8=fac5/vbld(i+1)
16584              fac9=fac5/vbld(i+nres)
16585              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16586              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16587              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16588              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16589              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16590              sina=sqrt(1-cosa*cosa)
16591              sino=dsin(omeg(i))
16592 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16593              do j=1,3
16594                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16595                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16596                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16597                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16598                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16599                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16600                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16601                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16602                 vbld(i+nres))
16603                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16604             enddo
16605 ! obtaining the derivatives of omega from sines
16606             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16607                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16608                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16609                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16610                dsin(theta(i+1)))
16611                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16612                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16613                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16614                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16615                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16616                coso_inv=1.0d0/dcos(omeg(i))
16617                do j=1,3
16618                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16619                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16620                  (sino*dc_norm(j,i-1))/vbld(i)
16621                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16622                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16623                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16624                  -sino*dc_norm(j,i)/vbld(i+1)
16625                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16626                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16627                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16628                  vbld(i+nres)
16629                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16630               enddo
16631            else
16632 !   obtaining the derivatives of omega from cosines
16633              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16634              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16635              fac12=fac10*sina
16636              fac13=fac12*fac12
16637              fac14=sina*sina
16638              do j=1,3
16639                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16640                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16641                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16642                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16643                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16644                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16645                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16646                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16647                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16648                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16649                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16650                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16651                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16652                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16653                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16654             enddo
16655           endif
16656          else
16657            do j=1,3
16658              do k=1,3
16659                dalpha(k,j,i)=0.0d0
16660                domega(k,j,i)=0.0d0
16661              enddo
16662            enddo
16663          endif
16664        enddo
16665 #endif
16666 #if defined(MPI) && defined(PARINTDER)
16667       if (nfgtasks.gt.1) then
16668 #ifdef DEBUG
16669 !d      write (iout,*) "Gather dtheta"
16670 !d      call flush(iout)
16671       write (iout,*) "dtheta before gather"
16672       do i=1,nres
16673         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16674       enddo
16675 #endif
16676       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16677         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16678         king,FG_COMM,IERROR)
16679 #ifdef DEBUG
16680 !d      write (iout,*) "Gather dphi"
16681 !d      call flush(iout)
16682       write (iout,*) "dphi before gather"
16683       do i=1,nres
16684         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16685       enddo
16686 #endif
16687       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16688         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16689         king,FG_COMM,IERROR)
16690 !d      write (iout,*) "Gather dalpha"
16691 !d      call flush(iout)
16692 #ifdef CRYST_SC
16693       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16694         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16695         king,FG_COMM,IERROR)
16696 !d      write (iout,*) "Gather domega"
16697 !d      call flush(iout)
16698       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16699         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16700         king,FG_COMM,IERROR)
16701 #endif
16702       endif
16703 #endif
16704 #ifdef DEBUG
16705       write (iout,*) "dtheta after gather"
16706       do i=1,nres
16707         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16708       enddo
16709       write (iout,*) "dphi after gather"
16710       do i=1,nres
16711         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16712       enddo
16713       write (iout,*) "dalpha after gather"
16714       do i=1,nres
16715         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16716       enddo
16717       write (iout,*) "domega after gather"
16718       do i=1,nres
16719         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16720       enddo
16721 #endif
16722       return
16723       end subroutine intcartderiv
16724 !-----------------------------------------------------------------------------
16725       subroutine checkintcartgrad
16726 !      implicit real*8 (a-h,o-z)
16727 !      include 'DIMENSIONS'
16728 #ifdef MPI
16729       include 'mpif.h'
16730 #endif
16731 !      include 'COMMON.CHAIN'
16732 !      include 'COMMON.VAR'
16733 !      include 'COMMON.GEO'
16734 !      include 'COMMON.INTERACT'
16735 !      include 'COMMON.DERIV'
16736 !      include 'COMMON.IOUNITS'
16737 !      include 'COMMON.SETUP'
16738       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16739       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16740       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16741       real(kind=8),dimension(3) :: dc_norm_s
16742       real(kind=8) :: aincr=1.0d-5
16743       integer :: i,j
16744       real(kind=8) :: dcji
16745       do i=1,nres
16746         phi_s(i)=phi(i)
16747         theta_s(i)=theta(i)
16748         alph_s(i)=alph(i)
16749         omeg_s(i)=omeg(i)
16750       enddo
16751 ! Check theta gradient
16752       write (iout,*) &
16753        "Analytical (upper) and numerical (lower) gradient of theta"
16754       write (iout,*)
16755       do i=3,nres
16756         do j=1,3
16757           dcji=dc(j,i-2)
16758           dc(j,i-2)=dcji+aincr
16759           call chainbuild_cart
16760           call int_from_cart1(.false.)
16761           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
16762           dc(j,i-2)=dcji
16763           dcji=dc(j,i-1)
16764           dc(j,i-1)=dc(j,i-1)+aincr
16765           call chainbuild_cart
16766           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
16767           dc(j,i-1)=dcji
16768         enddo
16769 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
16770 !el          (dtheta(j,2,i),j=1,3)
16771 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
16772 !el          (dthetanum(j,2,i),j=1,3)
16773 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
16774 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
16775 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
16776 !el        write (iout,*)
16777       enddo
16778 ! Check gamma gradient
16779       write (iout,*) &
16780        "Analytical (upper) and numerical (lower) gradient of gamma"
16781       do i=4,nres
16782         do j=1,3
16783           dcji=dc(j,i-3)
16784           dc(j,i-3)=dcji+aincr
16785           call chainbuild_cart
16786           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
16787           dc(j,i-3)=dcji
16788           dcji=dc(j,i-2)
16789           dc(j,i-2)=dcji+aincr
16790           call chainbuild_cart
16791           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
16792           dc(j,i-2)=dcji
16793           dcji=dc(j,i-1)
16794           dc(j,i-1)=dc(j,i-1)+aincr
16795           call chainbuild_cart
16796           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
16797           dc(j,i-1)=dcji
16798         enddo
16799 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
16800 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
16801 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
16802 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
16803 !el        write (iout,'(5x,3(3f10.5,5x))') &
16804 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
16805 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
16806 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
16807 !el        write (iout,*)
16808       enddo
16809 ! Check alpha gradient
16810       write (iout,*) &
16811        "Analytical (upper) and numerical (lower) gradient of alpha"
16812       do i=2,nres-1
16813        if(itype(i,1).ne.10) then
16814             do j=1,3
16815               dcji=dc(j,i-1)
16816               dc(j,i-1)=dcji+aincr
16817               call chainbuild_cart
16818               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
16819               /aincr
16820               dc(j,i-1)=dcji
16821               dcji=dc(j,i)
16822               dc(j,i)=dcji+aincr
16823               call chainbuild_cart
16824               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
16825               /aincr
16826               dc(j,i)=dcji
16827               dcji=dc(j,i+nres)
16828               dc(j,i+nres)=dc(j,i+nres)+aincr
16829               call chainbuild_cart
16830               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
16831               /aincr
16832              dc(j,i+nres)=dcji
16833             enddo
16834           endif
16835 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
16836 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
16837 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
16838 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
16839 !el        write (iout,'(5x,3(3f10.5,5x))') &
16840 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
16841 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
16842 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
16843 !el        write (iout,*)
16844       enddo
16845 !     Check omega gradient
16846       write (iout,*) &
16847        "Analytical (upper) and numerical (lower) gradient of omega"
16848       do i=2,nres-1
16849        if(itype(i,1).ne.10) then
16850             do j=1,3
16851               dcji=dc(j,i-1)
16852               dc(j,i-1)=dcji+aincr
16853               call chainbuild_cart
16854               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
16855               /aincr
16856               dc(j,i-1)=dcji
16857               dcji=dc(j,i)
16858               dc(j,i)=dcji+aincr
16859               call chainbuild_cart
16860               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
16861               /aincr
16862               dc(j,i)=dcji
16863               dcji=dc(j,i+nres)
16864               dc(j,i+nres)=dc(j,i+nres)+aincr
16865               call chainbuild_cart
16866               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
16867               /aincr
16868              dc(j,i+nres)=dcji
16869             enddo
16870           endif
16871 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
16872 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
16873 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
16874 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
16875 !el        write (iout,'(5x,3(3f10.5,5x))') &
16876 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
16877 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
16878 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
16879 !el        write (iout,*)
16880       enddo
16881       return
16882       end subroutine checkintcartgrad
16883 !-----------------------------------------------------------------------------
16884 ! q_measure.F
16885 !-----------------------------------------------------------------------------
16886       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
16887 !      implicit real*8 (a-h,o-z)
16888 !      include 'DIMENSIONS'
16889 !      include 'COMMON.IOUNITS'
16890 !      include 'COMMON.CHAIN'
16891 !      include 'COMMON.INTERACT'
16892 !      include 'COMMON.VAR'
16893       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
16894       integer :: kkk,nsep=3
16895       real(kind=8) :: qm        !dist,
16896       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
16897       logical :: lprn=.false.
16898       logical :: flag
16899 !      real(kind=8) :: sigm,x
16900
16901 !el      sigm(x)=0.25d0*x     ! local function
16902       qqmax=1.0d10
16903       do kkk=1,nperm
16904       qq = 0.0d0
16905       nl=0
16906        if(flag) then
16907         do il=seg1+nsep,seg2
16908           do jl=seg1,il-nsep
16909             nl=nl+1
16910             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
16911                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
16912                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16913             dij=dist(il,jl)
16914             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16915             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
16916               nl=nl+1
16917               d0ijCM=dsqrt( &
16918                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16919                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16920                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16921               dijCM=dist(il+nres,jl+nres)
16922               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16923             endif
16924             qq = qq+qqij+qqijCM
16925           enddo
16926         enddo
16927         qq = qq/nl
16928       else
16929       do il=seg1,seg2
16930         if((seg3-il).lt.3) then
16931              secseg=il+3
16932         else
16933              secseg=seg3
16934         endif
16935           do jl=secseg,seg4
16936             nl=nl+1
16937             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16938                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16939                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16940             dij=dist(il,jl)
16941             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16942             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
16943               nl=nl+1
16944               d0ijCM=dsqrt( &
16945                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16946                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16947                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16948               dijCM=dist(il+nres,jl+nres)
16949               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16950             endif
16951             qq = qq+qqij+qqijCM
16952           enddo
16953         enddo
16954       qq = qq/nl
16955       endif
16956       if (qqmax.le.qq) qqmax=qq
16957       enddo
16958       qwolynes=1.0d0-qqmax
16959       return
16960       end function qwolynes
16961 !-----------------------------------------------------------------------------
16962       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
16963 !      implicit real*8 (a-h,o-z)
16964 !      include 'DIMENSIONS'
16965 !      include 'COMMON.IOUNITS'
16966 !      include 'COMMON.CHAIN'
16967 !      include 'COMMON.INTERACT'
16968 !      include 'COMMON.VAR'
16969 !      include 'COMMON.MD'
16970       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
16971       integer :: nsep=3, kkk
16972 !el      real(kind=8) :: dist
16973       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
16974       logical :: lprn=.false.
16975       logical :: flag
16976       real(kind=8) :: sim,dd0,fac,ddqij
16977 !el      sigm(x)=0.25d0*x            ! local function
16978       do kkk=1,nperm
16979       do i=0,nres
16980         do j=1,3
16981           dqwol(j,i)=0.0d0
16982           dxqwol(j,i)=0.0d0
16983         enddo
16984       enddo
16985       nl=0
16986        if(flag) then
16987         do il=seg1+nsep,seg2
16988           do jl=seg1,il-nsep
16989             nl=nl+1
16990             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16991                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16992                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16993             dij=dist(il,jl)
16994             sim = 1.0d0/sigm(d0ij)
16995             sim = sim*sim
16996             dd0 = dij-d0ij
16997             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
16998             do k=1,3
16999               ddqij = (c(k,il)-c(k,jl))*fac
17000               dqwol(k,il)=dqwol(k,il)+ddqij
17001               dqwol(k,jl)=dqwol(k,jl)-ddqij
17002             enddo
17003
17004             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17005               nl=nl+1
17006               d0ijCM=dsqrt( &
17007                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17008                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17009                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17010               dijCM=dist(il+nres,jl+nres)
17011               sim = 1.0d0/sigm(d0ijCM)
17012               sim = sim*sim
17013               dd0=dijCM-d0ijCM
17014               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17015               do k=1,3
17016                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17017                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17018                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17019               enddo
17020             endif
17021           enddo
17022         enddo
17023        else
17024         do il=seg1,seg2
17025         if((seg3-il).lt.3) then
17026              secseg=il+3
17027         else
17028              secseg=seg3
17029         endif
17030           do jl=secseg,seg4
17031             nl=nl+1
17032             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17033                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17034                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17035             dij=dist(il,jl)
17036             sim = 1.0d0/sigm(d0ij)
17037             sim = sim*sim
17038             dd0 = dij-d0ij
17039             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17040             do k=1,3
17041               ddqij = (c(k,il)-c(k,jl))*fac
17042               dqwol(k,il)=dqwol(k,il)+ddqij
17043               dqwol(k,jl)=dqwol(k,jl)-ddqij
17044             enddo
17045             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17046               nl=nl+1
17047               d0ijCM=dsqrt( &
17048                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17049                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17050                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17051               dijCM=dist(il+nres,jl+nres)
17052               sim = 1.0d0/sigm(d0ijCM)
17053               sim=sim*sim
17054               dd0 = dijCM-d0ijCM
17055               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17056               do k=1,3
17057                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17058                dxqwol(k,il)=dxqwol(k,il)+ddqij
17059                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17060               enddo
17061             endif
17062           enddo
17063         enddo
17064       endif
17065       enddo
17066        do i=0,nres
17067          do j=1,3
17068            dqwol(j,i)=dqwol(j,i)/nl
17069            dxqwol(j,i)=dxqwol(j,i)/nl
17070          enddo
17071        enddo
17072       return
17073       end subroutine qwolynes_prim
17074 !-----------------------------------------------------------------------------
17075       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17076 !      implicit real*8 (a-h,o-z)
17077 !      include 'DIMENSIONS'
17078 !      include 'COMMON.IOUNITS'
17079 !      include 'COMMON.CHAIN'
17080 !      include 'COMMON.INTERACT'
17081 !      include 'COMMON.VAR'
17082       integer :: seg1,seg2,seg3,seg4
17083       logical :: flag
17084       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17085       real(kind=8),dimension(3,0:2*nres) :: cdummy
17086       real(kind=8) :: q1,q2
17087       real(kind=8) :: delta=1.0d-10
17088       integer :: i,j
17089
17090       do i=0,nres
17091         do j=1,3
17092           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17093           cdummy(j,i)=c(j,i)
17094           c(j,i)=c(j,i)+delta
17095           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17096           qwolan(j,i)=(q2-q1)/delta
17097           c(j,i)=cdummy(j,i)
17098         enddo
17099       enddo
17100       do i=0,nres
17101         do j=1,3
17102           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17103           cdummy(j,i+nres)=c(j,i+nres)
17104           c(j,i+nres)=c(j,i+nres)+delta
17105           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17106           qwolxan(j,i)=(q2-q1)/delta
17107           c(j,i+nres)=cdummy(j,i+nres)
17108         enddo
17109       enddo
17110 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17111 !      do i=0,nct
17112 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17113 !      enddo
17114 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17115 !      do i=0,nct
17116 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17117 !      enddo
17118       return
17119       end subroutine qwol_num
17120 !-----------------------------------------------------------------------------
17121       subroutine EconstrQ
17122 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17123 !      implicit real*8 (a-h,o-z)
17124 !      include 'DIMENSIONS'
17125 !      include 'COMMON.CONTROL'
17126 !      include 'COMMON.VAR'
17127 !      include 'COMMON.MD'
17128       use MD_data
17129 !#ifndef LANG0
17130 !      include 'COMMON.LANGEVIN'
17131 !#else
17132 !      include 'COMMON.LANGEVIN.lang0'
17133 !#endif
17134 !      include 'COMMON.CHAIN'
17135 !      include 'COMMON.DERIV'
17136 !      include 'COMMON.GEO'
17137 !      include 'COMMON.LOCAL'
17138 !      include 'COMMON.INTERACT'
17139 !      include 'COMMON.IOUNITS'
17140 !      include 'COMMON.NAMES'
17141 !      include 'COMMON.TIME1'
17142       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17143       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17144                    duconst,duxconst
17145       integer :: kstart,kend,lstart,lend,idummy
17146       real(kind=8) :: delta=1.0d-7
17147       integer :: i,j,k,ii
17148       do i=0,nres
17149          do j=1,3
17150             duconst(j,i)=0.0d0
17151             dudconst(j,i)=0.0d0
17152             duxconst(j,i)=0.0d0
17153             dudxconst(j,i)=0.0d0
17154          enddo
17155       enddo
17156       Uconst=0.0d0
17157       do i=1,nfrag
17158          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17159            idummy,idummy)
17160          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17161 ! Calculating the derivatives of Constraint energy with respect to Q
17162          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17163            qinfrag(i,iset))
17164 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17165 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17166 !         hmnum=(hm2-hm1)/delta
17167 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17168 !     &   qinfrag(i,iset))
17169 !         write(iout,*) "harmonicnum frag", hmnum
17170 ! Calculating the derivatives of Q with respect to cartesian coordinates
17171          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17172           idummy,idummy)
17173 !         write(iout,*) "dqwol "
17174 !         do ii=1,nres
17175 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17176 !         enddo
17177 !         write(iout,*) "dxqwol "
17178 !         do ii=1,nres
17179 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17180 !         enddo
17181 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17182 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17183 !     &  ,idummy,idummy)
17184 !  The gradients of Uconst in Cs
17185          do ii=0,nres
17186             do j=1,3
17187                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17188                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17189             enddo
17190          enddo
17191       enddo
17192       do i=1,npair
17193          kstart=ifrag(1,ipair(1,i,iset),iset)
17194          kend=ifrag(2,ipair(1,i,iset),iset)
17195          lstart=ifrag(1,ipair(2,i,iset),iset)
17196          lend=ifrag(2,ipair(2,i,iset),iset)
17197          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17198          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17199 !  Calculating dU/dQ
17200          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17201 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17202 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17203 !         hmnum=(hm2-hm1)/delta
17204 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17205 !     &   qinpair(i,iset))
17206 !         write(iout,*) "harmonicnum pair ", hmnum
17207 ! Calculating dQ/dXi
17208          call qwolynes_prim(kstart,kend,.false.,&
17209           lstart,lend)
17210 !         write(iout,*) "dqwol "
17211 !         do ii=1,nres
17212 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17213 !         enddo
17214 !         write(iout,*) "dxqwol "
17215 !         do ii=1,nres
17216 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17217 !        enddo
17218 ! Calculating numerical gradients
17219 !        call qwol_num(kstart,kend,.false.
17220 !     &  ,lstart,lend)
17221 ! The gradients of Uconst in Cs
17222          do ii=0,nres
17223             do j=1,3
17224                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17225                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17226             enddo
17227          enddo
17228       enddo
17229 !      write(iout,*) "Uconst inside subroutine ", Uconst
17230 ! Transforming the gradients from Cs to dCs for the backbone
17231       do i=0,nres
17232          do j=i+1,nres
17233            do k=1,3
17234              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17235            enddo
17236          enddo
17237       enddo
17238 !  Transforming the gradients from Cs to dCs for the side chains
17239       do i=1,nres
17240          do j=1,3
17241            dudxconst(j,i)=duxconst(j,i)
17242          enddo
17243       enddo
17244 !      write(iout,*) "dU/ddc backbone "
17245 !       do ii=0,nres
17246 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17247 !      enddo
17248 !      write(iout,*) "dU/ddX side chain "
17249 !      do ii=1,nres
17250 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17251 !      enddo
17252 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17253 !      call dEconstrQ_num
17254       return
17255       end subroutine EconstrQ
17256 !-----------------------------------------------------------------------------
17257       subroutine dEconstrQ_num
17258 ! Calculating numerical dUconst/ddc and dUconst/ddx
17259 !      implicit real*8 (a-h,o-z)
17260 !      include 'DIMENSIONS'
17261 !      include 'COMMON.CONTROL'
17262 !      include 'COMMON.VAR'
17263 !      include 'COMMON.MD'
17264       use MD_data
17265 !#ifndef LANG0
17266 !      include 'COMMON.LANGEVIN'
17267 !#else
17268 !      include 'COMMON.LANGEVIN.lang0'
17269 !#endif
17270 !      include 'COMMON.CHAIN'
17271 !      include 'COMMON.DERIV'
17272 !      include 'COMMON.GEO'
17273 !      include 'COMMON.LOCAL'
17274 !      include 'COMMON.INTERACT'
17275 !      include 'COMMON.IOUNITS'
17276 !      include 'COMMON.NAMES'
17277 !      include 'COMMON.TIME1'
17278       real(kind=8) :: uzap1,uzap2
17279       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17280       integer :: kstart,kend,lstart,lend,idummy
17281       real(kind=8) :: delta=1.0d-7
17282 !el local variables
17283       integer :: i,ii,j
17284 !     real(kind=8) ::
17285 !     For the backbone
17286       do i=0,nres-1
17287          do j=1,3
17288             dUcartan(j,i)=0.0d0
17289             cdummy(j,i)=dc(j,i)
17290             dc(j,i)=dc(j,i)+delta
17291             call chainbuild_cart
17292             uzap2=0.0d0
17293             do ii=1,nfrag
17294              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17295                 idummy,idummy)
17296                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17297                 qinfrag(ii,iset))
17298             enddo
17299             do ii=1,npair
17300                kstart=ifrag(1,ipair(1,ii,iset),iset)
17301                kend=ifrag(2,ipair(1,ii,iset),iset)
17302                lstart=ifrag(1,ipair(2,ii,iset),iset)
17303                lend=ifrag(2,ipair(2,ii,iset),iset)
17304                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17305                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17306                  qinpair(ii,iset))
17307             enddo
17308             dc(j,i)=cdummy(j,i)
17309             call chainbuild_cart
17310             uzap1=0.0d0
17311              do ii=1,nfrag
17312              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17313                 idummy,idummy)
17314                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17315                 qinfrag(ii,iset))
17316             enddo
17317             do ii=1,npair
17318                kstart=ifrag(1,ipair(1,ii,iset),iset)
17319                kend=ifrag(2,ipair(1,ii,iset),iset)
17320                lstart=ifrag(1,ipair(2,ii,iset),iset)
17321                lend=ifrag(2,ipair(2,ii,iset),iset)
17322                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17323                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17324                 qinpair(ii,iset))
17325             enddo
17326             ducartan(j,i)=(uzap2-uzap1)/(delta)
17327          enddo
17328       enddo
17329 ! Calculating numerical gradients for dU/ddx
17330       do i=0,nres-1
17331          duxcartan(j,i)=0.0d0
17332          do j=1,3
17333             cdummy(j,i)=dc(j,i+nres)
17334             dc(j,i+nres)=dc(j,i+nres)+delta
17335             call chainbuild_cart
17336             uzap2=0.0d0
17337             do ii=1,nfrag
17338              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17339                 idummy,idummy)
17340                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17341                 qinfrag(ii,iset))
17342             enddo
17343             do ii=1,npair
17344                kstart=ifrag(1,ipair(1,ii,iset),iset)
17345                kend=ifrag(2,ipair(1,ii,iset),iset)
17346                lstart=ifrag(1,ipair(2,ii,iset),iset)
17347                lend=ifrag(2,ipair(2,ii,iset),iset)
17348                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17349                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17350                 qinpair(ii,iset))
17351             enddo
17352             dc(j,i+nres)=cdummy(j,i)
17353             call chainbuild_cart
17354             uzap1=0.0d0
17355              do ii=1,nfrag
17356                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17357                 ifrag(2,ii,iset),.true.,idummy,idummy)
17358                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17359                 qinfrag(ii,iset))
17360             enddo
17361             do ii=1,npair
17362                kstart=ifrag(1,ipair(1,ii,iset),iset)
17363                kend=ifrag(2,ipair(1,ii,iset),iset)
17364                lstart=ifrag(1,ipair(2,ii,iset),iset)
17365                lend=ifrag(2,ipair(2,ii,iset),iset)
17366                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17367                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17368                 qinpair(ii,iset))
17369             enddo
17370             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17371          enddo
17372       enddo
17373       write(iout,*) "Numerical dUconst/ddc backbone "
17374       do ii=0,nres
17375         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17376       enddo
17377 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17378 !      do ii=1,nres
17379 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17380 !      enddo
17381       return
17382       end subroutine dEconstrQ_num
17383 !-----------------------------------------------------------------------------
17384 ! ssMD.F
17385 !-----------------------------------------------------------------------------
17386       subroutine check_energies
17387
17388 !      use random, only: ran_number
17389
17390 !      implicit none
17391 !     Includes
17392 !      include 'DIMENSIONS'
17393 !      include 'COMMON.CHAIN'
17394 !      include 'COMMON.VAR'
17395 !      include 'COMMON.IOUNITS'
17396 !      include 'COMMON.SBRIDGE'
17397 !      include 'COMMON.LOCAL'
17398 !      include 'COMMON.GEO'
17399
17400 !     External functions
17401 !EL      double precision ran_number
17402 !EL      external ran_number
17403
17404 !     Local variables
17405       integer :: i,j,k,l,lmax,p,pmax
17406       real(kind=8) :: rmin,rmax
17407       real(kind=8) :: eij
17408
17409       real(kind=8) :: d
17410       real(kind=8) :: wi,rij,tj,pj
17411 !      return
17412
17413       i=5
17414       j=14
17415
17416       d=dsc(1)
17417       rmin=2.0D0
17418       rmax=12.0D0
17419
17420       lmax=10000
17421       pmax=1
17422
17423       do k=1,3
17424         c(k,i)=0.0D0
17425         c(k,j)=0.0D0
17426         c(k,nres+i)=0.0D0
17427         c(k,nres+j)=0.0D0
17428       enddo
17429
17430       do l=1,lmax
17431
17432 !t        wi=ran_number(0.0D0,pi)
17433 !        wi=ran_number(0.0D0,pi/6.0D0)
17434 !        wi=0.0D0
17435 !t        tj=ran_number(0.0D0,pi)
17436 !t        pj=ran_number(0.0D0,pi)
17437 !        pj=ran_number(0.0D0,pi/6.0D0)
17438 !        pj=0.0D0
17439
17440         do p=1,pmax
17441 !t           rij=ran_number(rmin,rmax)
17442
17443            c(1,j)=d*sin(pj)*cos(tj)
17444            c(2,j)=d*sin(pj)*sin(tj)
17445            c(3,j)=d*cos(pj)
17446
17447            c(3,nres+i)=-rij
17448
17449            c(1,i)=d*sin(wi)
17450            c(3,i)=-rij-d*cos(wi)
17451
17452            do k=1,3
17453               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17454               dc_norm(k,nres+i)=dc(k,nres+i)/d
17455               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17456               dc_norm(k,nres+j)=dc(k,nres+j)/d
17457            enddo
17458
17459            call dyn_ssbond_ene(i,j,eij)
17460         enddo
17461       enddo
17462       call exit(1)
17463       return
17464       end subroutine check_energies
17465 !-----------------------------------------------------------------------------
17466       subroutine dyn_ssbond_ene(resi,resj,eij)
17467 !      implicit none
17468 !      Includes
17469       use calc_data
17470       use comm_sschecks
17471 !      include 'DIMENSIONS'
17472 !      include 'COMMON.SBRIDGE'
17473 !      include 'COMMON.CHAIN'
17474 !      include 'COMMON.DERIV'
17475 !      include 'COMMON.LOCAL'
17476 !      include 'COMMON.INTERACT'
17477 !      include 'COMMON.VAR'
17478 !      include 'COMMON.IOUNITS'
17479 !      include 'COMMON.CALC'
17480 #ifndef CLUST
17481 #ifndef WHAM
17482        use MD_data
17483 !      include 'COMMON.MD'
17484 !      use MD, only: totT,t_bath
17485 #endif
17486 #endif
17487 !     External functions
17488 !EL      double precision h_base
17489 !EL      external h_base
17490
17491 !     Input arguments
17492       integer :: resi,resj
17493
17494 !     Output arguments
17495       real(kind=8) :: eij
17496
17497 !     Local variables
17498       logical :: havebond
17499       integer itypi,itypj
17500       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17501       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17502       real(kind=8),dimension(3) :: dcosom1,dcosom2
17503       real(kind=8) :: ed
17504       real(kind=8) :: pom1,pom2
17505       real(kind=8) :: ljA,ljB,ljXs
17506       real(kind=8),dimension(1:3) :: d_ljB
17507       real(kind=8) :: ssA,ssB,ssC,ssXs
17508       real(kind=8) :: ssxm,ljxm,ssm,ljm
17509       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17510       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17511       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17512 !-------FIRST METHOD
17513       real(kind=8) :: xm
17514       real(kind=8),dimension(1:3) :: d_xm
17515 !-------END FIRST METHOD
17516 !-------SECOND METHOD
17517 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17518 !-------END SECOND METHOD
17519
17520 !-------TESTING CODE
17521 !el      logical :: checkstop,transgrad
17522 !el      common /sschecks/ checkstop,transgrad
17523
17524       integer :: icheck,nicheck,jcheck,njcheck
17525       real(kind=8),dimension(-1:1) :: echeck
17526       real(kind=8) :: deps,ssx0,ljx0
17527 !-------END TESTING CODE
17528
17529       eij=0.0d0
17530       i=resi
17531       j=resj
17532
17533 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17534 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17535
17536       itypi=itype(i,1)
17537       dxi=dc_norm(1,nres+i)
17538       dyi=dc_norm(2,nres+i)
17539       dzi=dc_norm(3,nres+i)
17540       dsci_inv=vbld_inv(i+nres)
17541
17542       itypj=itype(j,1)
17543       xj=c(1,nres+j)-c(1,nres+i)
17544       yj=c(2,nres+j)-c(2,nres+i)
17545       zj=c(3,nres+j)-c(3,nres+i)
17546       dxj=dc_norm(1,nres+j)
17547       dyj=dc_norm(2,nres+j)
17548       dzj=dc_norm(3,nres+j)
17549       dscj_inv=vbld_inv(j+nres)
17550
17551       chi1=chi(itypi,itypj)
17552       chi2=chi(itypj,itypi)
17553       chi12=chi1*chi2
17554       chip1=chip(itypi)
17555       chip2=chip(itypj)
17556       chip12=chip1*chip2
17557       alf1=alp(itypi)
17558       alf2=alp(itypj)
17559       alf12=0.5D0*(alf1+alf2)
17560
17561       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17562       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17563 !     The following are set in sc_angular
17564 !      erij(1)=xj*rij
17565 !      erij(2)=yj*rij
17566 !      erij(3)=zj*rij
17567 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17568 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17569 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17570       call sc_angular
17571       rij=1.0D0/rij  ! Reset this so it makes sense
17572
17573       sig0ij=sigma(itypi,itypj)
17574       sig=sig0ij*dsqrt(1.0D0/sigsq)
17575
17576       ljXs=sig-sig0ij
17577       ljA=eps1*eps2rt**2*eps3rt**2
17578       ljB=ljA*bb_aq(itypi,itypj)
17579       ljA=ljA*aa_aq(itypi,itypj)
17580       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17581
17582       ssXs=d0cm
17583       deltat1=1.0d0-om1
17584       deltat2=1.0d0+om2
17585       deltat12=om2-om1+2.0d0
17586       cosphi=om12-om1*om2
17587       ssA=akcm
17588       ssB=akct*deltat12
17589       ssC=ss_depth &
17590            +akth*(deltat1*deltat1+deltat2*deltat2) &
17591            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17592       ssxm=ssXs-0.5D0*ssB/ssA
17593
17594 !-------TESTING CODE
17595 !$$$c     Some extra output
17596 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17597 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17598 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17599 !$$$      if (ssx0.gt.0.0d0) then
17600 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17601 !$$$      else
17602 !$$$        ssx0=ssxm
17603 !$$$      endif
17604 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17605 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17606 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17607 !$$$      return
17608 !-------END TESTING CODE
17609
17610 !-------TESTING CODE
17611 !     Stop and plot energy and derivative as a function of distance
17612       if (checkstop) then
17613         ssm=ssC-0.25D0*ssB*ssB/ssA
17614         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17615         if (ssm.lt.ljm .and. &
17616              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17617           nicheck=1000
17618           njcheck=1
17619           deps=0.5d-7
17620         else
17621           checkstop=.false.
17622         endif
17623       endif
17624       if (.not.checkstop) then
17625         nicheck=0
17626         njcheck=-1
17627       endif
17628
17629       do icheck=0,nicheck
17630       do jcheck=-1,njcheck
17631       if (checkstop) rij=(ssxm-1.0d0)+ &
17632              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17633 !-------END TESTING CODE
17634
17635       if (rij.gt.ljxm) then
17636         havebond=.false.
17637         ljd=rij-ljXs
17638         fac=(1.0D0/ljd)**expon
17639         e1=fac*fac*aa_aq(itypi,itypj)
17640         e2=fac*bb_aq(itypi,itypj)
17641         eij=eps1*eps2rt*eps3rt*(e1+e2)
17642         eps2der=eij*eps3rt
17643         eps3der=eij*eps2rt
17644         eij=eij*eps2rt*eps3rt
17645
17646         sigder=-sig/sigsq
17647         e1=e1*eps1*eps2rt**2*eps3rt**2
17648         ed=-expon*(e1+eij)/ljd
17649         sigder=ed*sigder
17650         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17651         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17652         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17653              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17654       else if (rij.lt.ssxm) then
17655         havebond=.true.
17656         ssd=rij-ssXs
17657         eij=ssA*ssd*ssd+ssB*ssd+ssC
17658
17659         ed=2*akcm*ssd+akct*deltat12
17660         pom1=akct*ssd
17661         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17662         eom1=-2*akth*deltat1-pom1-om2*pom2
17663         eom2= 2*akth*deltat2+pom1-om1*pom2
17664         eom12=pom2
17665       else
17666         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17667
17668         d_ssxm(1)=0.5D0*akct/ssA
17669         d_ssxm(2)=-d_ssxm(1)
17670         d_ssxm(3)=0.0D0
17671
17672         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17673         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17674         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17675         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17676
17677 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17678         xm=0.5d0*(ssxm+ljxm)
17679         do k=1,3
17680           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17681         enddo
17682         if (rij.lt.xm) then
17683           havebond=.true.
17684           ssm=ssC-0.25D0*ssB*ssB/ssA
17685           d_ssm(1)=0.5D0*akct*ssB/ssA
17686           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17687           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17688           d_ssm(3)=omega
17689           f1=(rij-xm)/(ssxm-xm)
17690           f2=(rij-ssxm)/(xm-ssxm)
17691           h1=h_base(f1,hd1)
17692           h2=h_base(f2,hd2)
17693           eij=ssm*h1+Ht*h2
17694           delta_inv=1.0d0/(xm-ssxm)
17695           deltasq_inv=delta_inv*delta_inv
17696           fac=ssm*hd1-Ht*hd2
17697           fac1=deltasq_inv*fac*(xm-rij)
17698           fac2=deltasq_inv*fac*(rij-ssxm)
17699           ed=delta_inv*(Ht*hd2-ssm*hd1)
17700           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17701           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17702           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17703         else
17704           havebond=.false.
17705           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17706           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17707           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17708           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17709                alf12/eps3rt)
17710           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17711           f1=(rij-ljxm)/(xm-ljxm)
17712           f2=(rij-xm)/(ljxm-xm)
17713           h1=h_base(f1,hd1)
17714           h2=h_base(f2,hd2)
17715           eij=Ht*h1+ljm*h2
17716           delta_inv=1.0d0/(ljxm-xm)
17717           deltasq_inv=delta_inv*delta_inv
17718           fac=Ht*hd1-ljm*hd2
17719           fac1=deltasq_inv*fac*(ljxm-rij)
17720           fac2=deltasq_inv*fac*(rij-xm)
17721           ed=delta_inv*(ljm*hd2-Ht*hd1)
17722           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17723           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17724           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17725         endif
17726 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17727
17728 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17729 !$$$        ssd=rij-ssXs
17730 !$$$        ljd=rij-ljXs
17731 !$$$        fac1=rij-ljxm
17732 !$$$        fac2=rij-ssxm
17733 !$$$
17734 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17735 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17736 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17737 !$$$
17738 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17739 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17740 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17741 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17742 !$$$        d_ssm(3)=omega
17743 !$$$
17744 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17745 !$$$        do k=1,3
17746 !$$$          d_ljm(k)=ljm*d_ljB(k)
17747 !$$$        enddo
17748 !$$$        ljm=ljm*ljB
17749 !$$$
17750 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17751 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17752 !$$$        d_ss(2)=akct*ssd
17753 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17754 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17755 !$$$        d_ss(3)=omega
17756 !$$$
17757 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17758 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17759 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
17760 !$$$        do k=1,3
17761 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
17762 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
17763 !$$$        enddo
17764 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
17765 !$$$
17766 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
17767 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
17768 !$$$        h1=h_base(f1,hd1)
17769 !$$$        h2=h_base(f2,hd2)
17770 !$$$        eij=ss*h1+ljf*h2
17771 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
17772 !$$$        deltasq_inv=delta_inv*delta_inv
17773 !$$$        fac=ljf*hd2-ss*hd1
17774 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
17775 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
17776 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
17777 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
17778 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
17779 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
17780 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
17781 !$$$
17782 !$$$        havebond=.false.
17783 !$$$        if (ed.gt.0.0d0) havebond=.true.
17784 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17785
17786       endif
17787
17788       if (havebond) then
17789 !#ifndef CLUST
17790 !#ifndef WHAM
17791 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
17792 !          write(iout,'(a15,f12.2,f8.1,2i5)')
17793 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
17794 !        endif
17795 !#endif
17796 !#endif
17797         dyn_ssbond_ij(i,j)=eij
17798       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
17799         dyn_ssbond_ij(i,j)=1.0d300
17800 !#ifndef CLUST
17801 !#ifndef WHAM
17802 !        write(iout,'(a15,f12.2,f8.1,2i5)')
17803 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
17804 !#endif
17805 !#endif
17806       endif
17807
17808 !-------TESTING CODE
17809 !el      if (checkstop) then
17810         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
17811              "CHECKSTOP",rij,eij,ed
17812         echeck(jcheck)=eij
17813 !el      endif
17814       enddo
17815       if (checkstop) then
17816         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
17817       endif
17818       enddo
17819       if (checkstop) then
17820         transgrad=.true.
17821         checkstop=.false.
17822       endif
17823 !-------END TESTING CODE
17824
17825       do k=1,3
17826         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
17827         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
17828       enddo
17829       do k=1,3
17830         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
17831       enddo
17832       do k=1,3
17833         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17834              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17835              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17836         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17837              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17838              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17839       enddo
17840 !grad      do k=i,j-1
17841 !grad        do l=1,3
17842 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
17843 !grad        enddo
17844 !grad      enddo
17845
17846       do l=1,3
17847         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17848         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17849       enddo
17850
17851       return
17852       end subroutine dyn_ssbond_ene
17853 !--------------------------------------------------------------------------
17854          subroutine triple_ssbond_ene(resi,resj,resk,eij)
17855 !      implicit none
17856 !      Includes
17857       use calc_data
17858       use comm_sschecks
17859 !      include 'DIMENSIONS'
17860 !      include 'COMMON.SBRIDGE'
17861 !      include 'COMMON.CHAIN'
17862 !      include 'COMMON.DERIV'
17863 !      include 'COMMON.LOCAL'
17864 !      include 'COMMON.INTERACT'
17865 !      include 'COMMON.VAR'
17866 !      include 'COMMON.IOUNITS'
17867 !      include 'COMMON.CALC'
17868 #ifndef CLUST
17869 #ifndef WHAM
17870        use MD_data
17871 !      include 'COMMON.MD'
17872 !      use MD, only: totT,t_bath
17873 #endif
17874 #endif
17875       double precision h_base
17876       external h_base
17877
17878 !c     Input arguments
17879       integer resi,resj,resk,m,itypi,itypj,itypk
17880
17881 !c     Output arguments
17882       double precision eij,eij1,eij2,eij3
17883
17884 !c     Local variables
17885       logical havebond
17886 !c      integer itypi,itypj,k,l
17887       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
17888       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
17889       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
17890       double precision sig0ij,ljd,sig,fac,e1,e2
17891       double precision dcosom1(3),dcosom2(3),ed
17892       double precision pom1,pom2
17893       double precision ljA,ljB,ljXs
17894       double precision d_ljB(1:3)
17895       double precision ssA,ssB,ssC,ssXs
17896       double precision ssxm,ljxm,ssm,ljm
17897       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
17898       eij=0.0
17899       if (dtriss.eq.0) return
17900       i=resi
17901       j=resj
17902       k=resk
17903 !C      write(iout,*) resi,resj,resk
17904       itypi=itype(i,1)
17905       dxi=dc_norm(1,nres+i)
17906       dyi=dc_norm(2,nres+i)
17907       dzi=dc_norm(3,nres+i)
17908       dsci_inv=vbld_inv(i+nres)
17909       xi=c(1,nres+i)
17910       yi=c(2,nres+i)
17911       zi=c(3,nres+i)
17912       itypj=itype(j,1)
17913       xj=c(1,nres+j)
17914       yj=c(2,nres+j)
17915       zj=c(3,nres+j)
17916
17917       dxj=dc_norm(1,nres+j)
17918       dyj=dc_norm(2,nres+j)
17919       dzj=dc_norm(3,nres+j)
17920       dscj_inv=vbld_inv(j+nres)
17921       itypk=itype(k,1)
17922       xk=c(1,nres+k)
17923       yk=c(2,nres+k)
17924       zk=c(3,nres+k)
17925
17926       dxk=dc_norm(1,nres+k)
17927       dyk=dc_norm(2,nres+k)
17928       dzk=dc_norm(3,nres+k)
17929       dscj_inv=vbld_inv(k+nres)
17930       xij=xj-xi
17931       xik=xk-xi
17932       xjk=xk-xj
17933       yij=yj-yi
17934       yik=yk-yi
17935       yjk=yk-yj
17936       zij=zj-zi
17937       zik=zk-zi
17938       zjk=zk-zj
17939       rrij=(xij*xij+yij*yij+zij*zij)
17940       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17941       rrik=(xik*xik+yik*yik+zik*zik)
17942       rik=dsqrt(rrik)
17943       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
17944       rjk=dsqrt(rrjk)
17945 !C there are three combination of distances for each trisulfide bonds
17946 !C The first case the ith atom is the center
17947 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
17948 !C distance y is second distance the a,b,c,d are parameters derived for
17949 !C this problem d parameter was set as a penalty currenlty set to 1.
17950       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
17951       eij1=0.0d0
17952       else
17953       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
17954       endif
17955 !C second case jth atom is center
17956       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
17957       eij2=0.0d0
17958       else
17959       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
17960       endif
17961 !C the third case kth atom is the center
17962       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
17963       eij3=0.0d0
17964       else
17965       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
17966       endif
17967 !C      eij2=0.0
17968 !C      eij3=0.0
17969 !C      eij1=0.0
17970       eij=eij1+eij2+eij3
17971 !C      write(iout,*)i,j,k,eij
17972 !C The energy penalty calculated now time for the gradient part
17973 !C derivative over rij
17974       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
17975       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
17976             gg(1)=xij*fac/rij
17977             gg(2)=yij*fac/rij
17978             gg(3)=zij*fac/rij
17979       do m=1,3
17980         gvdwx(m,i)=gvdwx(m,i)-gg(m)
17981         gvdwx(m,j)=gvdwx(m,j)+gg(m)
17982       enddo
17983
17984       do l=1,3
17985         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17986         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17987       enddo
17988 !C now derivative over rik
17989       fac=-eij1**2/dtriss* &
17990       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
17991       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
17992             gg(1)=xik*fac/rik
17993             gg(2)=yik*fac/rik
17994             gg(3)=zik*fac/rik
17995       do m=1,3
17996         gvdwx(m,i)=gvdwx(m,i)-gg(m)
17997         gvdwx(m,k)=gvdwx(m,k)+gg(m)
17998       enddo
17999       do l=1,3
18000         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18001         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18002       enddo
18003 !C now derivative over rjk
18004       fac=-eij2**2/dtriss* &
18005       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18006       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18007             gg(1)=xjk*fac/rjk
18008             gg(2)=yjk*fac/rjk
18009             gg(3)=zjk*fac/rjk
18010       do m=1,3
18011         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18012         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18013       enddo
18014       do l=1,3
18015         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18016         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18017       enddo
18018       return
18019       end subroutine triple_ssbond_ene
18020
18021
18022
18023 !-----------------------------------------------------------------------------
18024       real(kind=8) function h_base(x,deriv)
18025 !     A smooth function going 0->1 in range [0,1]
18026 !     It should NOT be called outside range [0,1], it will not work there.
18027       implicit none
18028
18029 !     Input arguments
18030       real(kind=8) :: x
18031
18032 !     Output arguments
18033       real(kind=8) :: deriv
18034
18035 !     Local variables
18036       real(kind=8) :: xsq
18037
18038
18039 !     Two parabolas put together.  First derivative zero at extrema
18040 !$$$      if (x.lt.0.5D0) then
18041 !$$$        h_base=2.0D0*x*x
18042 !$$$        deriv=4.0D0*x
18043 !$$$      else
18044 !$$$        deriv=1.0D0-x
18045 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18046 !$$$        deriv=4.0D0*deriv
18047 !$$$      endif
18048
18049 !     Third degree polynomial.  First derivative zero at extrema
18050       h_base=x*x*(3.0d0-2.0d0*x)
18051       deriv=6.0d0*x*(1.0d0-x)
18052
18053 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18054 !$$$      xsq=x*x
18055 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18056 !$$$      deriv=x-1.0d0
18057 !$$$      deriv=deriv*deriv
18058 !$$$      deriv=30.0d0*xsq*deriv
18059
18060       return
18061       end function h_base
18062 !-----------------------------------------------------------------------------
18063       subroutine dyn_set_nss
18064 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18065 !      implicit none
18066       use MD_data, only: totT,t_bath
18067 !     Includes
18068 !      include 'DIMENSIONS'
18069 #ifdef MPI
18070       include "mpif.h"
18071 #endif
18072 !      include 'COMMON.SBRIDGE'
18073 !      include 'COMMON.CHAIN'
18074 !      include 'COMMON.IOUNITS'
18075 !      include 'COMMON.SETUP'
18076 !      include 'COMMON.MD'
18077 !     Local variables
18078       real(kind=8) :: emin
18079       integer :: i,j,imin,ierr
18080       integer :: diff,allnss,newnss
18081       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18082                 newihpb,newjhpb
18083       logical :: found
18084       integer,dimension(0:nfgtasks) :: i_newnss
18085       integer,dimension(0:nfgtasks) :: displ
18086       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18087       integer :: g_newnss
18088
18089       allnss=0
18090       do i=1,nres-1
18091         do j=i+1,nres
18092           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18093             allnss=allnss+1
18094             allflag(allnss)=0
18095             allihpb(allnss)=i
18096             alljhpb(allnss)=j
18097           endif
18098         enddo
18099       enddo
18100
18101 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18102
18103  1    emin=1.0d300
18104       do i=1,allnss
18105         if (allflag(i).eq.0 .and. &
18106              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18107           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18108           imin=i
18109         endif
18110       enddo
18111       if (emin.lt.1.0d300) then
18112         allflag(imin)=1
18113         do i=1,allnss
18114           if (allflag(i).eq.0 .and. &
18115                (allihpb(i).eq.allihpb(imin) .or. &
18116                alljhpb(i).eq.allihpb(imin) .or. &
18117                allihpb(i).eq.alljhpb(imin) .or. &
18118                alljhpb(i).eq.alljhpb(imin))) then
18119             allflag(i)=-1
18120           endif
18121         enddo
18122         goto 1
18123       endif
18124
18125 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18126
18127       newnss=0
18128       do i=1,allnss
18129         if (allflag(i).eq.1) then
18130           newnss=newnss+1
18131           newihpb(newnss)=allihpb(i)
18132           newjhpb(newnss)=alljhpb(i)
18133         endif
18134       enddo
18135
18136 #ifdef MPI
18137       if (nfgtasks.gt.1)then
18138
18139         call MPI_Reduce(newnss,g_newnss,1,&
18140           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18141         call MPI_Gather(newnss,1,MPI_INTEGER,&
18142                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18143         displ(0)=0
18144         do i=1,nfgtasks-1,1
18145           displ(i)=i_newnss(i-1)+displ(i-1)
18146         enddo
18147         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18148                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18149                          king,FG_COMM,IERR)
18150         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18151                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18152                          king,FG_COMM,IERR)
18153         if(fg_rank.eq.0) then
18154 !         print *,'g_newnss',g_newnss
18155 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18156 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18157          newnss=g_newnss
18158          do i=1,newnss
18159           newihpb(i)=g_newihpb(i)
18160           newjhpb(i)=g_newjhpb(i)
18161          enddo
18162         endif
18163       endif
18164 #endif
18165
18166       diff=newnss-nss
18167
18168 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18169 !       print *,newnss,nss,maxdim
18170       do i=1,nss
18171         found=.false.
18172 !        print *,newnss
18173         do j=1,newnss
18174 !!          print *,j
18175           if (idssb(i).eq.newihpb(j) .and. &
18176                jdssb(i).eq.newjhpb(j)) found=.true.
18177         enddo
18178 #ifndef CLUST
18179 #ifndef WHAM
18180 !        write(iout,*) "found",found,i,j
18181         if (.not.found.and.fg_rank.eq.0) &
18182             write(iout,'(a15,f12.2,f8.1,2i5)') &
18183              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18184 #endif
18185 #endif
18186       enddo
18187
18188       do i=1,newnss
18189         found=.false.
18190         do j=1,nss
18191 !          print *,i,j
18192           if (newihpb(i).eq.idssb(j) .and. &
18193                newjhpb(i).eq.jdssb(j)) found=.true.
18194         enddo
18195 #ifndef CLUST
18196 #ifndef WHAM
18197 !        write(iout,*) "found",found,i,j
18198         if (.not.found.and.fg_rank.eq.0) &
18199             write(iout,'(a15,f12.2,f8.1,2i5)') &
18200              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18201 #endif
18202 #endif
18203       enddo
18204
18205       nss=newnss
18206       do i=1,nss
18207         idssb(i)=newihpb(i)
18208         jdssb(i)=newjhpb(i)
18209       enddo
18210
18211       return
18212       end subroutine dyn_set_nss
18213 ! Lipid transfer energy function
18214       subroutine Eliptransfer(eliptran)
18215 !C this is done by Adasko
18216 !C      print *,"wchodze"
18217 !C structure of box:
18218 !C      water
18219 !C--bordliptop-- buffore starts
18220 !C--bufliptop--- here true lipid starts
18221 !C      lipid
18222 !C--buflipbot--- lipid ends buffore starts
18223 !C--bordlipbot--buffore ends
18224       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18225       integer :: i
18226       eliptran=0.0
18227 !      print *, "I am in eliptran"
18228       do i=ilip_start,ilip_end
18229 !C       do i=1,1
18230         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18231          cycle
18232
18233         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18234         if (positi.le.0.0) positi=positi+boxzsize
18235 !C        print *,i
18236 !C first for peptide groups
18237 !c for each residue check if it is in lipid or lipid water border area
18238        if ((positi.gt.bordlipbot)  &
18239       .and.(positi.lt.bordliptop)) then
18240 !C the energy transfer exist
18241         if (positi.lt.buflipbot) then
18242 !C what fraction I am in
18243          fracinbuf=1.0d0-      &
18244              ((positi-bordlipbot)/lipbufthick)
18245 !C lipbufthick is thickenes of lipid buffore
18246          sslip=sscalelip(fracinbuf)
18247          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18248          eliptran=eliptran+sslip*pepliptran
18249          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18250          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18251 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18252
18253 !C        print *,"doing sccale for lower part"
18254 !C         print *,i,sslip,fracinbuf,ssgradlip
18255         elseif (positi.gt.bufliptop) then
18256          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18257          sslip=sscalelip(fracinbuf)
18258          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18259          eliptran=eliptran+sslip*pepliptran
18260          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18261          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18262 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18263 !C          print *, "doing sscalefor top part"
18264 !C         print *,i,sslip,fracinbuf,ssgradlip
18265         else
18266          eliptran=eliptran+pepliptran
18267 !C         print *,"I am in true lipid"
18268         endif
18269 !C       else
18270 !C       eliptran=elpitran+0.0 ! I am in water
18271        endif
18272        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18273        enddo
18274 ! here starts the side chain transfer
18275        do i=ilip_start,ilip_end
18276         if (itype(i,1).eq.ntyp1) cycle
18277         positi=(mod(c(3,i+nres),boxzsize))
18278         if (positi.le.0) positi=positi+boxzsize
18279 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18280 !c for each residue check if it is in lipid or lipid water border area
18281 !C       respos=mod(c(3,i+nres),boxzsize)
18282 !C       print *,positi,bordlipbot,buflipbot
18283        if ((positi.gt.bordlipbot) &
18284        .and.(positi.lt.bordliptop)) then
18285 !C the energy transfer exist
18286         if (positi.lt.buflipbot) then
18287          fracinbuf=1.0d0-   &
18288            ((positi-bordlipbot)/lipbufthick)
18289 !C lipbufthick is thickenes of lipid buffore
18290          sslip=sscalelip(fracinbuf)
18291          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18292          eliptran=eliptran+sslip*liptranene(itype(i,1))
18293          gliptranx(3,i)=gliptranx(3,i) &
18294       +ssgradlip*liptranene(itype(i,1))
18295          gliptranc(3,i-1)= gliptranc(3,i-1) &
18296       +ssgradlip*liptranene(itype(i,1))
18297 !C         print *,"doing sccale for lower part"
18298         elseif (positi.gt.bufliptop) then
18299          fracinbuf=1.0d0-  &
18300       ((bordliptop-positi)/lipbufthick)
18301          sslip=sscalelip(fracinbuf)
18302          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18303          eliptran=eliptran+sslip*liptranene(itype(i,1))
18304          gliptranx(3,i)=gliptranx(3,i)  &
18305        +ssgradlip*liptranene(itype(i,1))
18306          gliptranc(3,i-1)= gliptranc(3,i-1) &
18307       +ssgradlip*liptranene(itype(i,1))
18308 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18309         else
18310          eliptran=eliptran+liptranene(itype(i,1))
18311 !C         print *,"I am in true lipid"
18312         endif
18313         endif ! if in lipid or buffor
18314 !C       else
18315 !C       eliptran=elpitran+0.0 ! I am in water
18316         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18317        enddo
18318        return
18319        end  subroutine Eliptransfer
18320 !----------------------------------NANO FUNCTIONS
18321 !C-----------------------------------------------------------------------
18322 !C-----------------------------------------------------------
18323 !C This subroutine is to mimic the histone like structure but as well can be
18324 !C utilizet to nanostructures (infinit) small modification has to be used to
18325 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18326 !C gradient has to be modified at the ends
18327 !C The energy function is Kihara potential
18328 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18329 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18330 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18331 !C simple Kihara potential
18332       subroutine calctube(Etube)
18333       real(kind=8) :: vectube(3),enetube(nres*2)
18334       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18335        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18336        sc_aa_tube,sc_bb_tube
18337       integer :: i,j,iti
18338       Etube=0.0d0
18339       do i=itube_start,itube_end
18340         enetube(i)=0.0d0
18341         enetube(i+nres)=0.0d0
18342       enddo
18343 !C first we calculate the distance from tube center
18344 !C for UNRES
18345        do i=itube_start,itube_end
18346 !C lets ommit dummy atoms for now
18347        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18348 !C now calculate distance from center of tube and direction vectors
18349       xmin=boxxsize
18350       ymin=boxysize
18351 ! Find minimum distance in periodic box
18352         do j=-1,1
18353          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18354          vectube(1)=vectube(1)+boxxsize*j
18355          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18356          vectube(2)=vectube(2)+boxysize*j
18357          xminact=abs(vectube(1)-tubecenter(1))
18358          yminact=abs(vectube(2)-tubecenter(2))
18359            if (xmin.gt.xminact) then
18360             xmin=xminact
18361             xtemp=vectube(1)
18362            endif
18363            if (ymin.gt.yminact) then
18364              ymin=yminact
18365              ytemp=vectube(2)
18366             endif
18367          enddo
18368       vectube(1)=xtemp
18369       vectube(2)=ytemp
18370       vectube(1)=vectube(1)-tubecenter(1)
18371       vectube(2)=vectube(2)-tubecenter(2)
18372
18373 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18374 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18375
18376 !C as the tube is infinity we do not calculate the Z-vector use of Z
18377 !C as chosen axis
18378       vectube(3)=0.0d0
18379 !C now calculte the distance
18380        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18381 !C now normalize vector
18382       vectube(1)=vectube(1)/tub_r
18383       vectube(2)=vectube(2)/tub_r
18384 !C calculte rdiffrence between r and r0
18385       rdiff=tub_r-tubeR0
18386 !C and its 6 power
18387       rdiff6=rdiff**6.0d0
18388 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18389        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18390 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18391 !C       print *,rdiff,rdiff6,pep_aa_tube
18392 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18393 !C now we calculate gradient
18394        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18395             6.0d0*pep_bb_tube)/rdiff6/rdiff
18396 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18397 !C     &rdiff,fac
18398 !C now direction of gg_tube vector
18399         do j=1,3
18400         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18401         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18402         enddo
18403         enddo
18404 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18405 !C        print *,gg_tube(1,0),"TU"
18406
18407
18408        do i=itube_start,itube_end
18409 !C Lets not jump over memory as we use many times iti
18410          iti=itype(i,1)
18411 !C lets ommit dummy atoms for now
18412          if ((iti.eq.ntyp1)  &
18413 !C in UNRES uncomment the line below as GLY has no side-chain...
18414 !C      .or.(iti.eq.10)
18415         ) cycle
18416       xmin=boxxsize
18417       ymin=boxysize
18418         do j=-1,1
18419          vectube(1)=mod((c(1,i+nres)),boxxsize)
18420          vectube(1)=vectube(1)+boxxsize*j
18421          vectube(2)=mod((c(2,i+nres)),boxysize)
18422          vectube(2)=vectube(2)+boxysize*j
18423
18424          xminact=abs(vectube(1)-tubecenter(1))
18425          yminact=abs(vectube(2)-tubecenter(2))
18426            if (xmin.gt.xminact) then
18427             xmin=xminact
18428             xtemp=vectube(1)
18429            endif
18430            if (ymin.gt.yminact) then
18431              ymin=yminact
18432              ytemp=vectube(2)
18433             endif
18434          enddo
18435       vectube(1)=xtemp
18436       vectube(2)=ytemp
18437 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18438 !C     &     tubecenter(2)
18439       vectube(1)=vectube(1)-tubecenter(1)
18440       vectube(2)=vectube(2)-tubecenter(2)
18441
18442 !C as the tube is infinity we do not calculate the Z-vector use of Z
18443 !C as chosen axis
18444       vectube(3)=0.0d0
18445 !C now calculte the distance
18446        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18447 !C now normalize vector
18448       vectube(1)=vectube(1)/tub_r
18449       vectube(2)=vectube(2)/tub_r
18450
18451 !C calculte rdiffrence between r and r0
18452       rdiff=tub_r-tubeR0
18453 !C and its 6 power
18454       rdiff6=rdiff**6.0d0
18455 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18456        sc_aa_tube=sc_aa_tube_par(iti)
18457        sc_bb_tube=sc_bb_tube_par(iti)
18458        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18459        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18460              6.0d0*sc_bb_tube/rdiff6/rdiff
18461 !C now direction of gg_tube vector
18462          do j=1,3
18463           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18464           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18465          enddo
18466         enddo
18467         do i=itube_start,itube_end
18468           Etube=Etube+enetube(i)+enetube(i+nres)
18469         enddo
18470 !C        print *,"ETUBE", etube
18471         return
18472         end subroutine calctube
18473 !C TO DO 1) add to total energy
18474 !C       2) add to gradient summation
18475 !C       3) add reading parameters (AND of course oppening of PARAM file)
18476 !C       4) add reading the center of tube
18477 !C       5) add COMMONs
18478 !C       6) add to zerograd
18479 !C       7) allocate matrices
18480
18481
18482 !C-----------------------------------------------------------------------
18483 !C-----------------------------------------------------------
18484 !C This subroutine is to mimic the histone like structure but as well can be
18485 !C utilizet to nanostructures (infinit) small modification has to be used to
18486 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18487 !C gradient has to be modified at the ends
18488 !C The energy function is Kihara potential
18489 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18490 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18491 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18492 !C simple Kihara potential
18493       subroutine calctube2(Etube)
18494       real(kind=8) :: vectube(3),enetube(nres*2)
18495       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18496        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18497        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18498       integer:: i,j,iti
18499       Etube=0.0d0
18500       do i=itube_start,itube_end
18501         enetube(i)=0.0d0
18502         enetube(i+nres)=0.0d0
18503       enddo
18504 !C first we calculate the distance from tube center
18505 !C first sugare-phosphate group for NARES this would be peptide group
18506 !C for UNRES
18507        do i=itube_start,itube_end
18508 !C lets ommit dummy atoms for now
18509
18510        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18511 !C now calculate distance from center of tube and direction vectors
18512 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18513 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18514 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18515 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18516       xmin=boxxsize
18517       ymin=boxysize
18518         do j=-1,1
18519          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18520          vectube(1)=vectube(1)+boxxsize*j
18521          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18522          vectube(2)=vectube(2)+boxysize*j
18523
18524          xminact=abs(vectube(1)-tubecenter(1))
18525          yminact=abs(vectube(2)-tubecenter(2))
18526            if (xmin.gt.xminact) then
18527             xmin=xminact
18528             xtemp=vectube(1)
18529            endif
18530            if (ymin.gt.yminact) then
18531              ymin=yminact
18532              ytemp=vectube(2)
18533             endif
18534          enddo
18535       vectube(1)=xtemp
18536       vectube(2)=ytemp
18537       vectube(1)=vectube(1)-tubecenter(1)
18538       vectube(2)=vectube(2)-tubecenter(2)
18539
18540 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18541 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18542
18543 !C as the tube is infinity we do not calculate the Z-vector use of Z
18544 !C as chosen axis
18545       vectube(3)=0.0d0
18546 !C now calculte the distance
18547        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18548 !C now normalize vector
18549       vectube(1)=vectube(1)/tub_r
18550       vectube(2)=vectube(2)/tub_r
18551 !C calculte rdiffrence between r and r0
18552       rdiff=tub_r-tubeR0
18553 !C and its 6 power
18554       rdiff6=rdiff**6.0d0
18555 !C THIS FRAGMENT MAKES TUBE FINITE
18556         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18557         if (positi.le.0) positi=positi+boxzsize
18558 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18559 !c for each residue check if it is in lipid or lipid water border area
18560 !C       respos=mod(c(3,i+nres),boxzsize)
18561 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18562        if ((positi.gt.bordtubebot)  &
18563         .and.(positi.lt.bordtubetop)) then
18564 !C the energy transfer exist
18565         if (positi.lt.buftubebot) then
18566          fracinbuf=1.0d0-  &
18567            ((positi-bordtubebot)/tubebufthick)
18568 !C lipbufthick is thickenes of lipid buffore
18569          sstube=sscalelip(fracinbuf)
18570          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18571 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18572          enetube(i)=enetube(i)+sstube*tubetranenepep
18573 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18574 !C     &+ssgradtube*tubetranene(itype(i,1))
18575 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18576 !C     &+ssgradtube*tubetranene(itype(i,1))
18577 !C         print *,"doing sccale for lower part"
18578         elseif (positi.gt.buftubetop) then
18579          fracinbuf=1.0d0-  &
18580         ((bordtubetop-positi)/tubebufthick)
18581          sstube=sscalelip(fracinbuf)
18582          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18583          enetube(i)=enetube(i)+sstube*tubetranenepep
18584 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18585 !C     &+ssgradtube*tubetranene(itype(i,1))
18586 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18587 !C     &+ssgradtube*tubetranene(itype(i,1))
18588 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18589         else
18590          sstube=1.0d0
18591          ssgradtube=0.0d0
18592          enetube(i)=enetube(i)+sstube*tubetranenepep
18593 !C         print *,"I am in true lipid"
18594         endif
18595         else
18596 !C          sstube=0.0d0
18597 !C          ssgradtube=0.0d0
18598         cycle
18599         endif ! if in lipid or buffor
18600
18601 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18602        enetube(i)=enetube(i)+sstube* &
18603         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18604 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18605 !C       print *,rdiff,rdiff6,pep_aa_tube
18606 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18607 !C now we calculate gradient
18608        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18609              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18610 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18611 !C     &rdiff,fac
18612
18613 !C now direction of gg_tube vector
18614        do j=1,3
18615         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18616         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18617         enddo
18618          gg_tube(3,i)=gg_tube(3,i)  &
18619        +ssgradtube*enetube(i)/sstube/2.0d0
18620          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18621        +ssgradtube*enetube(i)/sstube/2.0d0
18622
18623         enddo
18624 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18625 !C        print *,gg_tube(1,0),"TU"
18626         do i=itube_start,itube_end
18627 !C Lets not jump over memory as we use many times iti
18628          iti=itype(i,1)
18629 !C lets ommit dummy atoms for now
18630          if ((iti.eq.ntyp1) &
18631 !!C in UNRES uncomment the line below as GLY has no side-chain...
18632            .or.(iti.eq.10) &
18633           ) cycle
18634           vectube(1)=c(1,i+nres)
18635           vectube(1)=mod(vectube(1),boxxsize)
18636           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18637           vectube(2)=c(2,i+nres)
18638           vectube(2)=mod(vectube(2),boxysize)
18639           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18640
18641       vectube(1)=vectube(1)-tubecenter(1)
18642       vectube(2)=vectube(2)-tubecenter(2)
18643 !C THIS FRAGMENT MAKES TUBE FINITE
18644         positi=(mod(c(3,i+nres),boxzsize))
18645         if (positi.le.0) positi=positi+boxzsize
18646 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18647 !c for each residue check if it is in lipid or lipid water border area
18648 !C       respos=mod(c(3,i+nres),boxzsize)
18649 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18650
18651        if ((positi.gt.bordtubebot)  &
18652         .and.(positi.lt.bordtubetop)) then
18653 !C the energy transfer exist
18654         if (positi.lt.buftubebot) then
18655          fracinbuf=1.0d0- &
18656             ((positi-bordtubebot)/tubebufthick)
18657 !C lipbufthick is thickenes of lipid buffore
18658          sstube=sscalelip(fracinbuf)
18659          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18660 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18661          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18662 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18663 !C     &+ssgradtube*tubetranene(itype(i,1))
18664 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18665 !C     &+ssgradtube*tubetranene(itype(i,1))
18666 !C         print *,"doing sccale for lower part"
18667         elseif (positi.gt.buftubetop) then
18668          fracinbuf=1.0d0- &
18669         ((bordtubetop-positi)/tubebufthick)
18670
18671          sstube=sscalelip(fracinbuf)
18672          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18673          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18674 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18675 !C     &+ssgradtube*tubetranene(itype(i,1))
18676 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18677 !C     &+ssgradtube*tubetranene(itype(i,1))
18678 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18679         else
18680          sstube=1.0d0
18681          ssgradtube=0.0d0
18682          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18683 !C         print *,"I am in true lipid"
18684         endif
18685         else
18686 !C          sstube=0.0d0
18687 !C          ssgradtube=0.0d0
18688         cycle
18689         endif ! if in lipid or buffor
18690 !CEND OF FINITE FRAGMENT
18691 !C as the tube is infinity we do not calculate the Z-vector use of Z
18692 !C as chosen axis
18693       vectube(3)=0.0d0
18694 !C now calculte the distance
18695        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18696 !C now normalize vector
18697       vectube(1)=vectube(1)/tub_r
18698       vectube(2)=vectube(2)/tub_r
18699 !C calculte rdiffrence between r and r0
18700       rdiff=tub_r-tubeR0
18701 !C and its 6 power
18702       rdiff6=rdiff**6.0d0
18703 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18704        sc_aa_tube=sc_aa_tube_par(iti)
18705        sc_bb_tube=sc_bb_tube_par(iti)
18706        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18707                        *sstube+enetube(i+nres)
18708 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18709 !C now we calculate gradient
18710        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18711             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18712 !C now direction of gg_tube vector
18713          do j=1,3
18714           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18715           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18716          enddo
18717          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18718        +ssgradtube*enetube(i+nres)/sstube
18719          gg_tube(3,i-1)= gg_tube(3,i-1) &
18720        +ssgradtube*enetube(i+nres)/sstube
18721
18722         enddo
18723         do i=itube_start,itube_end
18724           Etube=Etube+enetube(i)+enetube(i+nres)
18725         enddo
18726 !C        print *,"ETUBE", etube
18727         return
18728         end subroutine calctube2
18729 !=====================================================================================================================================
18730       subroutine calcnano(Etube)
18731       real(kind=8) :: vectube(3),enetube(nres*2), &
18732       enecavtube(nres*2)
18733       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18734        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
18735        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
18736        integer:: i,j,iti
18737
18738       Etube=0.0d0
18739 !      print *,itube_start,itube_end,"poczatek"
18740       do i=itube_start,itube_end
18741         enetube(i)=0.0d0
18742         enetube(i+nres)=0.0d0
18743       enddo
18744 !C first we calculate the distance from tube center
18745 !C first sugare-phosphate group for NARES this would be peptide group
18746 !C for UNRES
18747        do i=itube_start,itube_end
18748 !C lets ommit dummy atoms for now
18749        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18750 !C now calculate distance from center of tube and direction vectors
18751       xmin=boxxsize
18752       ymin=boxysize
18753       zmin=boxzsize
18754
18755         do j=-1,1
18756          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18757          vectube(1)=vectube(1)+boxxsize*j
18758          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18759          vectube(2)=vectube(2)+boxysize*j
18760          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18761          vectube(3)=vectube(3)+boxzsize*j
18762
18763
18764          xminact=dabs(vectube(1)-tubecenter(1))
18765          yminact=dabs(vectube(2)-tubecenter(2))
18766          zminact=dabs(vectube(3)-tubecenter(3))
18767
18768            if (xmin.gt.xminact) then
18769             xmin=xminact
18770             xtemp=vectube(1)
18771            endif
18772            if (ymin.gt.yminact) then
18773              ymin=yminact
18774              ytemp=vectube(2)
18775             endif
18776            if (zmin.gt.zminact) then
18777              zmin=zminact
18778              ztemp=vectube(3)
18779             endif
18780          enddo
18781       vectube(1)=xtemp
18782       vectube(2)=ytemp
18783       vectube(3)=ztemp
18784
18785       vectube(1)=vectube(1)-tubecenter(1)
18786       vectube(2)=vectube(2)-tubecenter(2)
18787       vectube(3)=vectube(3)-tubecenter(3)
18788
18789 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18790 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18791 !C as the tube is infinity we do not calculate the Z-vector use of Z
18792 !C as chosen axis
18793 !C      vectube(3)=0.0d0
18794 !C now calculte the distance
18795        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18796 !C now normalize vector
18797       vectube(1)=vectube(1)/tub_r
18798       vectube(2)=vectube(2)/tub_r
18799       vectube(3)=vectube(3)/tub_r
18800 !C calculte rdiffrence between r and r0
18801       rdiff=tub_r-tubeR0
18802 !C and its 6 power
18803       rdiff6=rdiff**6.0d0
18804 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18805        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18806 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18807 !C       print *,rdiff,rdiff6,pep_aa_tube
18808 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18809 !C now we calculate gradient
18810        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
18811             6.0d0*pep_bb_tube)/rdiff6/rdiff
18812 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18813 !C     &rdiff,fac
18814          if (acavtubpep.eq.0.0d0) then
18815 !C go to 667
18816          enecavtube(i)=0.0
18817          faccav=0.0
18818          else
18819          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
18820          enecavtube(i)=  &
18821         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
18822         /denominator
18823          enecavtube(i)=0.0
18824          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
18825         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
18826         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
18827         /denominator**2.0d0
18828 !C         faccav=0.0
18829 !C         fac=fac+faccav
18830 !C 667     continue
18831          endif
18832
18833         do j=1,3
18834         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18835         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18836         enddo
18837         enddo
18838
18839        do i=itube_start,itube_end
18840         enecavtube(i)=0.0d0
18841 !C Lets not jump over memory as we use many times iti
18842          iti=itype(i,1)
18843 !C lets ommit dummy atoms for now
18844          if ((iti.eq.ntyp1) &
18845 !C in UNRES uncomment the line below as GLY has no side-chain...
18846 !C      .or.(iti.eq.10)
18847          ) cycle
18848       xmin=boxxsize
18849       ymin=boxysize
18850       zmin=boxzsize
18851         do j=-1,1
18852          vectube(1)=dmod((c(1,i+nres)),boxxsize)
18853          vectube(1)=vectube(1)+boxxsize*j
18854          vectube(2)=dmod((c(2,i+nres)),boxysize)
18855          vectube(2)=vectube(2)+boxysize*j
18856          vectube(3)=dmod((c(3,i+nres)),boxzsize)
18857          vectube(3)=vectube(3)+boxzsize*j
18858
18859
18860          xminact=dabs(vectube(1)-tubecenter(1))
18861          yminact=dabs(vectube(2)-tubecenter(2))
18862          zminact=dabs(vectube(3)-tubecenter(3))
18863
18864            if (xmin.gt.xminact) then
18865             xmin=xminact
18866             xtemp=vectube(1)
18867            endif
18868            if (ymin.gt.yminact) then
18869              ymin=yminact
18870              ytemp=vectube(2)
18871             endif
18872            if (zmin.gt.zminact) then
18873              zmin=zminact
18874              ztemp=vectube(3)
18875             endif
18876          enddo
18877       vectube(1)=xtemp
18878       vectube(2)=ytemp
18879       vectube(3)=ztemp
18880
18881 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18882 !C     &     tubecenter(2)
18883       vectube(1)=vectube(1)-tubecenter(1)
18884       vectube(2)=vectube(2)-tubecenter(2)
18885       vectube(3)=vectube(3)-tubecenter(3)
18886 !C now calculte the distance
18887        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18888 !C now normalize vector
18889       vectube(1)=vectube(1)/tub_r
18890       vectube(2)=vectube(2)/tub_r
18891       vectube(3)=vectube(3)/tub_r
18892
18893 !C calculte rdiffrence between r and r0
18894       rdiff=tub_r-tubeR0
18895 !C and its 6 power
18896       rdiff6=rdiff**6.0d0
18897        sc_aa_tube=sc_aa_tube_par(iti)
18898        sc_bb_tube=sc_bb_tube_par(iti)
18899        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18900 !C       enetube(i+nres)=0.0d0
18901 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18902 !C now we calculate gradient
18903        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
18904             6.0d0*sc_bb_tube/rdiff6/rdiff
18905 !C       fac=0.0
18906 !C now direction of gg_tube vector
18907 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
18908          if (acavtub(iti).eq.0.0d0) then
18909 !C go to 667
18910          enecavtube(i+nres)=0.0d0
18911          faccav=0.0d0
18912          else
18913          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
18914          enecavtube(i+nres)=   &
18915         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
18916         /denominator
18917 !C         enecavtube(i)=0.0
18918          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
18919         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
18920         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
18921         /denominator**2.0d0
18922 !C         faccav=0.0
18923          fac=fac+faccav
18924 !C 667     continue
18925          endif
18926 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
18927 !C     &   enecavtube(i),faccav
18928 !C         print *,"licz=",
18929 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
18930 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
18931          do j=1,3
18932           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18933           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18934          enddo
18935         enddo
18936
18937
18938
18939         do i=itube_start,itube_end
18940           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
18941          +enecavtube(i+nres)
18942         enddo
18943 !C        print *,"ETUBE", etube
18944         return
18945         end subroutine calcnano
18946
18947 !===============================================
18948 !--------------------------------------------------------------------------------
18949 !C first for shielding is setting of function of side-chains
18950
18951        subroutine set_shield_fac2
18952        real(kind=8) :: div77_81=0.974996043d0, &
18953         div4_81=0.2222222222d0
18954        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
18955          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
18956          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
18957          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
18958 !C the vector between center of side_chain and peptide group
18959        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
18960          pept_group,costhet_grad,cosphi_grad_long, &
18961          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
18962          sh_frac_dist_grad,pep_side
18963         integer i,j,k
18964 !C      write(2,*) "ivec",ivec_start,ivec_end
18965       do i=1,nres
18966         fac_shield(i)=0.0d0
18967         do j=1,3
18968         grad_shield(j,i)=0.0d0
18969         enddo
18970       enddo
18971       do i=ivec_start,ivec_end
18972 !C      do i=1,nres-1
18973 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
18974       ishield_list(i)=0
18975       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
18976 !Cif there two consequtive dummy atoms there is no peptide group between them
18977 !C the line below has to be changed for FGPROC>1
18978       VolumeTotal=0.0
18979       do k=1,nres
18980        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
18981        dist_pep_side=0.0
18982        dist_side_calf=0.0
18983        do j=1,3
18984 !C first lets set vector conecting the ithe side-chain with kth side-chain
18985       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
18986 !C      pep_side(j)=2.0d0
18987 !C and vector conecting the side-chain with its proper calfa
18988       side_calf(j)=c(j,k+nres)-c(j,k)
18989 !C      side_calf(j)=2.0d0
18990       pept_group(j)=c(j,i)-c(j,i+1)
18991 !C lets have their lenght
18992       dist_pep_side=pep_side(j)**2+dist_pep_side
18993       dist_side_calf=dist_side_calf+side_calf(j)**2
18994       dist_pept_group=dist_pept_group+pept_group(j)**2
18995       enddo
18996        dist_pep_side=sqrt(dist_pep_side)
18997        dist_pept_group=sqrt(dist_pept_group)
18998        dist_side_calf=sqrt(dist_side_calf)
18999       do j=1,3
19000         pep_side_norm(j)=pep_side(j)/dist_pep_side
19001         side_calf_norm(j)=dist_side_calf
19002       enddo
19003 !C now sscale fraction
19004        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19005 !C       print *,buff_shield,"buff"
19006 !C now sscale
19007         if (sh_frac_dist.le.0.0) cycle
19008 !C        print *,ishield_list(i),i
19009 !C If we reach here it means that this side chain reaches the shielding sphere
19010 !C Lets add him to the list for gradient
19011         ishield_list(i)=ishield_list(i)+1
19012 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19013 !C this list is essential otherwise problem would be O3
19014         shield_list(ishield_list(i),i)=k
19015 !C Lets have the sscale value
19016         if (sh_frac_dist.gt.1.0) then
19017          scale_fac_dist=1.0d0
19018          do j=1,3
19019          sh_frac_dist_grad(j)=0.0d0
19020          enddo
19021         else
19022          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19023                         *(2.0d0*sh_frac_dist-3.0d0)
19024          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19025                        /dist_pep_side/buff_shield*0.5d0
19026          do j=1,3
19027          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19028 !C         sh_frac_dist_grad(j)=0.0d0
19029 !C         scale_fac_dist=1.0d0
19030 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19031 !C     &                    sh_frac_dist_grad(j)
19032          enddo
19033         endif
19034 !C this is what is now we have the distance scaling now volume...
19035       short=short_r_sidechain(itype(k,1))
19036       long=long_r_sidechain(itype(k,1))
19037       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19038       sinthet=short/dist_pep_side*costhet
19039 !C now costhet_grad
19040 !C       costhet=0.6d0
19041 !C       sinthet=0.8
19042        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19043 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19044 !C     &             -short/dist_pep_side**2/costhet)
19045 !C       costhet_fac=0.0d0
19046        do j=1,3
19047          costhet_grad(j)=costhet_fac*pep_side(j)
19048        enddo
19049 !C remember for the final gradient multiply costhet_grad(j)
19050 !C for side_chain by factor -2 !
19051 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19052 !C pep_side0pept_group is vector multiplication
19053       pep_side0pept_group=0.0d0
19054       do j=1,3
19055       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19056       enddo
19057       cosalfa=(pep_side0pept_group/ &
19058       (dist_pep_side*dist_side_calf))
19059       fac_alfa_sin=1.0d0-cosalfa**2
19060       fac_alfa_sin=dsqrt(fac_alfa_sin)
19061       rkprim=fac_alfa_sin*(long-short)+short
19062 !C      rkprim=short
19063
19064 !C now costhet_grad
19065        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19066 !C       cosphi=0.6
19067        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19068        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19069            dist_pep_side**2)
19070 !C       sinphi=0.8
19071        do j=1,3
19072          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19073       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19074       *(long-short)/fac_alfa_sin*cosalfa/ &
19075       ((dist_pep_side*dist_side_calf))* &
19076       ((side_calf(j))-cosalfa* &
19077       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19078 !C       cosphi_grad_long(j)=0.0d0
19079         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19080       *(long-short)/fac_alfa_sin*cosalfa &
19081       /((dist_pep_side*dist_side_calf))* &
19082       (pep_side(j)- &
19083       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19084 !C       cosphi_grad_loc(j)=0.0d0
19085        enddo
19086 !C      print *,sinphi,sinthet
19087       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19088      &                    /VSolvSphere_div
19089 !C     &                    *wshield
19090 !C now the gradient...
19091       do j=1,3
19092       grad_shield(j,i)=grad_shield(j,i) &
19093 !C gradient po skalowaniu
19094                      +(sh_frac_dist_grad(j)*VofOverlap &
19095 !C  gradient po costhet
19096             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19097         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19098             sinphi/sinthet*costhet*costhet_grad(j) &
19099            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19100         )*wshield
19101 !C grad_shield_side is Cbeta sidechain gradient
19102       grad_shield_side(j,ishield_list(i),i)=&
19103              (sh_frac_dist_grad(j)*-2.0d0&
19104              *VofOverlap&
19105             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19106        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19107             sinphi/sinthet*costhet*costhet_grad(j)&
19108            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19109             )*wshield
19110
19111        grad_shield_loc(j,ishield_list(i),i)=   &
19112             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19113       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19114             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19115              ))&
19116              *wshield
19117       enddo
19118       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19119       enddo
19120       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19121
19122 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19123       enddo
19124       return
19125       end subroutine set_shield_fac2
19126 !----------------------------------------------------------------------------
19127 ! SOUBROUTINE FOR AFM
19128        subroutine AFMvel(Eafmforce)
19129        use MD_data, only:totTafm
19130       real(kind=8),dimension(3) :: diffafm
19131       real(kind=8) :: afmdist,Eafmforce
19132        integer :: i
19133 !C Only for check grad COMMENT if not used for checkgrad
19134 !C      totT=3.0d0
19135 !C--------------------------------------------------------
19136 !C      print *,"wchodze"
19137       afmdist=0.0d0
19138       Eafmforce=0.0d0
19139       do i=1,3
19140       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19141       afmdist=afmdist+diffafm(i)**2
19142       enddo
19143       afmdist=dsqrt(afmdist)
19144 !      totTafm=3.0
19145       Eafmforce=0.5d0*forceAFMconst &
19146       *(distafminit+totTafm*velAFMconst-afmdist)**2
19147 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19148       do i=1,3
19149       gradafm(i,afmend-1)=-forceAFMconst* &
19150        (distafminit+totTafm*velAFMconst-afmdist) &
19151        *diffafm(i)/afmdist
19152       gradafm(i,afmbeg-1)=forceAFMconst* &
19153       (distafminit+totTafm*velAFMconst-afmdist) &
19154       *diffafm(i)/afmdist
19155       enddo
19156 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19157       return
19158       end subroutine AFMvel
19159 !---------------------------------------------------------
19160        subroutine AFMforce(Eafmforce)
19161
19162       real(kind=8),dimension(3) :: diffafm
19163 !      real(kind=8) ::afmdist
19164       real(kind=8) :: afmdist,Eafmforce
19165       integer :: i
19166       afmdist=0.0d0
19167       Eafmforce=0.0d0
19168       do i=1,3
19169       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19170       afmdist=afmdist+diffafm(i)**2
19171       enddo
19172       afmdist=dsqrt(afmdist)
19173 !      print *,afmdist,distafminit
19174       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19175       do i=1,3
19176       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19177       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19178       enddo
19179 !C      print *,'AFM',Eafmforce
19180       return
19181       end subroutine AFMforce
19182
19183 !-----------------------------------------------------------------------------
19184 #ifdef WHAM
19185       subroutine read_ssHist
19186 !      implicit none
19187 !      Includes
19188 !      include 'DIMENSIONS'
19189 !      include "DIMENSIONS.FREE"
19190 !      include 'COMMON.FREE'
19191 !     Local variables
19192       integer :: i,j
19193       character(len=80) :: controlcard
19194
19195       do i=1,dyn_nssHist
19196         call card_concat(controlcard,.true.)
19197         read(controlcard,*) &
19198              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19199       enddo
19200
19201       return
19202       end subroutine read_ssHist
19203 #endif
19204 !-----------------------------------------------------------------------------
19205       integer function indmat(i,j)
19206 !el
19207 ! get the position of the jth ijth fragment of the chain coordinate system
19208 ! in the fromto array.
19209         integer :: i,j
19210
19211         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19212       return
19213       end function indmat
19214 !-----------------------------------------------------------------------------
19215       real(kind=8) function sigm(x)
19216 !el
19217        real(kind=8) :: x
19218         sigm=0.25d0*x
19219       return
19220       end function sigm
19221 !-----------------------------------------------------------------------------
19222 !-----------------------------------------------------------------------------
19223       subroutine alloc_ener_arrays
19224 !EL Allocation of arrays used by module energy
19225       use MD_data, only: mset
19226 !el local variables
19227       integer :: i,j
19228
19229       if(nres.lt.100) then
19230         maxconts=nres
19231       elseif(nres.lt.200) then
19232         maxconts=0.8*nres       ! Max. number of contacts per residue
19233       else
19234         maxconts=0.6*nres ! (maxconts=maxres/4)
19235       endif
19236       maxcont=12*nres   ! Max. number of SC contacts
19237       maxvar=6*nres     ! Max. number of variables
19238 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19239       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19240 !----------------------
19241 ! arrays in subroutine init_int_table
19242 !el#ifdef MPI
19243 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19244 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19245 !el#endif
19246       allocate(nint_gr(nres))
19247       allocate(nscp_gr(nres))
19248       allocate(ielstart(nres))
19249       allocate(ielend(nres))
19250 !(maxres)
19251       allocate(istart(nres,maxint_gr))
19252       allocate(iend(nres,maxint_gr))
19253 !(maxres,maxint_gr)
19254       allocate(iscpstart(nres,maxint_gr))
19255       allocate(iscpend(nres,maxint_gr))
19256 !(maxres,maxint_gr)
19257       allocate(ielstart_vdw(nres))
19258       allocate(ielend_vdw(nres))
19259 !(maxres)
19260
19261       allocate(lentyp(0:nfgtasks-1))
19262 !(0:maxprocs-1)
19263 !----------------------
19264 ! commom.contacts
19265 !      common /contacts/
19266       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19267       allocate(icont(2,maxcont))
19268 !(2,maxcont)
19269 !      common /contacts1/
19270       allocate(num_cont(0:nres+4))
19271 !(maxres)
19272       allocate(jcont(maxconts,nres))
19273 !(maxconts,maxres)
19274       allocate(facont(maxconts,nres))
19275 !(maxconts,maxres)
19276       allocate(gacont(3,maxconts,nres))
19277 !(3,maxconts,maxres)
19278 !      common /contacts_hb/
19279       allocate(gacontp_hb1(3,maxconts,nres))
19280       allocate(gacontp_hb2(3,maxconts,nres))
19281       allocate(gacontp_hb3(3,maxconts,nres))
19282       allocate(gacontm_hb1(3,maxconts,nres))
19283       allocate(gacontm_hb2(3,maxconts,nres))
19284       allocate(gacontm_hb3(3,maxconts,nres))
19285       allocate(gacont_hbr(3,maxconts,nres))
19286       allocate(grij_hb_cont(3,maxconts,nres))
19287 !(3,maxconts,maxres)
19288       allocate(facont_hb(maxconts,nres))
19289
19290       allocate(ees0p(maxconts,nres))
19291       allocate(ees0m(maxconts,nres))
19292       allocate(d_cont(maxconts,nres))
19293       allocate(ees0plist(maxconts,nres))
19294
19295 !(maxconts,maxres)
19296       allocate(num_cont_hb(nres))
19297 !(maxres)
19298       allocate(jcont_hb(maxconts,nres))
19299 !(maxconts,maxres)
19300 !      common /rotat/
19301       allocate(Ug(2,2,nres))
19302       allocate(Ugder(2,2,nres))
19303       allocate(Ug2(2,2,nres))
19304       allocate(Ug2der(2,2,nres))
19305 !(2,2,maxres)
19306       allocate(obrot(2,nres))
19307       allocate(obrot2(2,nres))
19308       allocate(obrot_der(2,nres))
19309       allocate(obrot2_der(2,nres))
19310 !(2,maxres)
19311 !      common /precomp1/
19312       allocate(mu(2,nres))
19313       allocate(muder(2,nres))
19314       allocate(Ub2(2,nres))
19315       Ub2(1,:)=0.0d0
19316       Ub2(2,:)=0.0d0
19317       allocate(Ub2der(2,nres))
19318       allocate(Ctobr(2,nres))
19319       allocate(Ctobrder(2,nres))
19320       allocate(Dtobr2(2,nres))
19321       allocate(Dtobr2der(2,nres))
19322 !(2,maxres)
19323       allocate(EUg(2,2,nres))
19324       allocate(EUgder(2,2,nres))
19325       allocate(CUg(2,2,nres))
19326       allocate(CUgder(2,2,nres))
19327       allocate(DUg(2,2,nres))
19328       allocate(Dugder(2,2,nres))
19329       allocate(DtUg2(2,2,nres))
19330       allocate(DtUg2der(2,2,nres))
19331 !(2,2,maxres)
19332 !      common /precomp2/
19333       allocate(Ug2Db1t(2,nres))
19334       allocate(Ug2Db1tder(2,nres))
19335       allocate(CUgb2(2,nres))
19336       allocate(CUgb2der(2,nres))
19337 !(2,maxres)
19338       allocate(EUgC(2,2,nres))
19339       allocate(EUgCder(2,2,nres))
19340       allocate(EUgD(2,2,nres))
19341       allocate(EUgDder(2,2,nres))
19342       allocate(DtUg2EUg(2,2,nres))
19343       allocate(Ug2DtEUg(2,2,nres))
19344 !(2,2,maxres)
19345       allocate(Ug2DtEUgder(2,2,2,nres))
19346       allocate(DtUg2EUgder(2,2,2,nres))
19347 !(2,2,2,maxres)
19348 !      common /rotat_old/
19349       allocate(costab(nres))
19350       allocate(sintab(nres))
19351       allocate(costab2(nres))
19352       allocate(sintab2(nres))
19353 !(maxres)
19354 !      common /dipmat/
19355       allocate(a_chuj(2,2,maxconts,nres))
19356 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19357       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19358 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19359 !      common /contdistrib/
19360       allocate(ncont_sent(nres))
19361       allocate(ncont_recv(nres))
19362
19363       allocate(iat_sent(nres))
19364 !(maxres)
19365       allocate(iint_sent(4,nres,nres))
19366       allocate(iint_sent_local(4,nres,nres))
19367 !(4,maxres,maxres)
19368       allocate(iturn3_sent(4,0:nres+4))
19369       allocate(iturn4_sent(4,0:nres+4))
19370       allocate(iturn3_sent_local(4,nres))
19371       allocate(iturn4_sent_local(4,nres))
19372 !(4,maxres)
19373       allocate(itask_cont_from(0:nfgtasks-1))
19374       allocate(itask_cont_to(0:nfgtasks-1))
19375 !(0:max_fg_procs-1)
19376
19377
19378
19379 !----------------------
19380 ! commom.deriv;
19381 !      common /derivat/
19382       allocate(dcdv(6,maxdim))
19383       allocate(dxdv(6,maxdim))
19384 !(6,maxdim)
19385       allocate(dxds(6,nres))
19386 !(6,maxres)
19387       allocate(gradx(3,-1:nres,0:2))
19388       allocate(gradc(3,-1:nres,0:2))
19389 !(3,maxres,2)
19390       allocate(gvdwx(3,-1:nres))
19391       allocate(gvdwc(3,-1:nres))
19392       allocate(gelc(3,-1:nres))
19393       allocate(gelc_long(3,-1:nres))
19394       allocate(gvdwpp(3,-1:nres))
19395       allocate(gvdwc_scpp(3,-1:nres))
19396       allocate(gradx_scp(3,-1:nres))
19397       allocate(gvdwc_scp(3,-1:nres))
19398       allocate(ghpbx(3,-1:nres))
19399       allocate(ghpbc(3,-1:nres))
19400       allocate(gradcorr(3,-1:nres))
19401       allocate(gradcorr_long(3,-1:nres))
19402       allocate(gradcorr5_long(3,-1:nres))
19403       allocate(gradcorr6_long(3,-1:nres))
19404       allocate(gcorr6_turn_long(3,-1:nres))
19405       allocate(gradxorr(3,-1:nres))
19406       allocate(gradcorr5(3,-1:nres))
19407       allocate(gradcorr6(3,-1:nres))
19408       allocate(gliptran(3,-1:nres))
19409       allocate(gliptranc(3,-1:nres))
19410       allocate(gliptranx(3,-1:nres))
19411       allocate(gshieldx(3,-1:nres))
19412       allocate(gshieldc(3,-1:nres))
19413       allocate(gshieldc_loc(3,-1:nres))
19414       allocate(gshieldx_ec(3,-1:nres))
19415       allocate(gshieldc_ec(3,-1:nres))
19416       allocate(gshieldc_loc_ec(3,-1:nres))
19417       allocate(gshieldx_t3(3,-1:nres))
19418       allocate(gshieldc_t3(3,-1:nres))
19419       allocate(gshieldc_loc_t3(3,-1:nres))
19420       allocate(gshieldx_t4(3,-1:nres))
19421       allocate(gshieldc_t4(3,-1:nres))
19422       allocate(gshieldc_loc_t4(3,-1:nres))
19423       allocate(gshieldx_ll(3,-1:nres))
19424       allocate(gshieldc_ll(3,-1:nres))
19425       allocate(gshieldc_loc_ll(3,-1:nres))
19426       allocate(grad_shield(3,-1:nres))
19427       allocate(gg_tube_sc(3,-1:nres))
19428       allocate(gg_tube(3,-1:nres))
19429       allocate(gradafm(3,-1:nres))
19430 !(3,maxres)
19431       allocate(grad_shield_side(3,50,nres))
19432       allocate(grad_shield_loc(3,50,nres))
19433 ! grad for shielding surroing
19434       allocate(gloc(0:maxvar,0:2))
19435       allocate(gloc_x(0:maxvar,2))
19436 !(maxvar,2)
19437       allocate(gel_loc(3,-1:nres))
19438       allocate(gel_loc_long(3,-1:nres))
19439       allocate(gcorr3_turn(3,-1:nres))
19440       allocate(gcorr4_turn(3,-1:nres))
19441       allocate(gcorr6_turn(3,-1:nres))
19442       allocate(gradb(3,-1:nres))
19443       allocate(gradbx(3,-1:nres))
19444 !(3,maxres)
19445       allocate(gel_loc_loc(maxvar))
19446       allocate(gel_loc_turn3(maxvar))
19447       allocate(gel_loc_turn4(maxvar))
19448       allocate(gel_loc_turn6(maxvar))
19449       allocate(gcorr_loc(maxvar))
19450       allocate(g_corr5_loc(maxvar))
19451       allocate(g_corr6_loc(maxvar))
19452 !(maxvar)
19453       allocate(gsccorc(3,-1:nres))
19454       allocate(gsccorx(3,-1:nres))
19455 !(3,maxres)
19456       allocate(gsccor_loc(-1:nres))
19457 !(maxres)
19458       allocate(dtheta(3,2,-1:nres))
19459 !(3,2,maxres)
19460       allocate(gscloc(3,-1:nres))
19461       allocate(gsclocx(3,-1:nres))
19462 !(3,maxres)
19463       allocate(dphi(3,3,-1:nres))
19464       allocate(dalpha(3,3,-1:nres))
19465       allocate(domega(3,3,-1:nres))
19466 !(3,3,maxres)
19467 !      common /deriv_scloc/
19468       allocate(dXX_C1tab(3,nres))
19469       allocate(dYY_C1tab(3,nres))
19470       allocate(dZZ_C1tab(3,nres))
19471       allocate(dXX_Ctab(3,nres))
19472       allocate(dYY_Ctab(3,nres))
19473       allocate(dZZ_Ctab(3,nres))
19474       allocate(dXX_XYZtab(3,nres))
19475       allocate(dYY_XYZtab(3,nres))
19476       allocate(dZZ_XYZtab(3,nres))
19477 !(3,maxres)
19478 !      common /mpgrad/
19479       allocate(jgrad_start(nres))
19480       allocate(jgrad_end(nres))
19481 !(maxres)
19482 !----------------------
19483
19484 !      common /indices/
19485       allocate(ibond_displ(0:nfgtasks-1))
19486       allocate(ibond_count(0:nfgtasks-1))
19487       allocate(ithet_displ(0:nfgtasks-1))
19488       allocate(ithet_count(0:nfgtasks-1))
19489       allocate(iphi_displ(0:nfgtasks-1))
19490       allocate(iphi_count(0:nfgtasks-1))
19491       allocate(iphi1_displ(0:nfgtasks-1))
19492       allocate(iphi1_count(0:nfgtasks-1))
19493       allocate(ivec_displ(0:nfgtasks-1))
19494       allocate(ivec_count(0:nfgtasks-1))
19495       allocate(iset_displ(0:nfgtasks-1))
19496       allocate(iset_count(0:nfgtasks-1))
19497       allocate(iint_count(0:nfgtasks-1))
19498       allocate(iint_displ(0:nfgtasks-1))
19499 !(0:max_fg_procs-1)
19500 !----------------------
19501 ! common.MD
19502 !      common /mdgrad/
19503       allocate(gcart(3,-1:nres))
19504       allocate(gxcart(3,-1:nres))
19505 !(3,0:MAXRES)
19506       allocate(gradcag(3,-1:nres))
19507       allocate(gradxag(3,-1:nres))
19508 !(3,MAXRES)
19509 !      common /back_constr/
19510 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19511       allocate(dutheta(nres))
19512       allocate(dugamma(nres))
19513 !(maxres)
19514       allocate(duscdiff(3,nres))
19515       allocate(duscdiffx(3,nres))
19516 !(3,maxres)
19517 !el i io:read_fragments
19518 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19519 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19520 !      common /qmeas/
19521 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19522 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19523       allocate(mset(0:nprocs))  !(maxprocs/20)
19524       mset(:)=0
19525 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19526 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19527       allocate(dUdconst(3,0:nres))
19528       allocate(dUdxconst(3,0:nres))
19529       allocate(dqwol(3,0:nres))
19530       allocate(dxqwol(3,0:nres))
19531 !(3,0:MAXRES)
19532 !----------------------
19533 ! common.sbridge
19534 !      common /sbridge/ in io_common: read_bridge
19535 !el    allocate((:),allocatable :: iss  !(maxss)
19536 !      common /links/  in io_common: read_bridge
19537 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19538 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19539 !      common /dyn_ssbond/
19540 ! and side-chain vectors in theta or phi.
19541       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19542 !(maxres,maxres)
19543 !      do i=1,nres
19544 !        do j=i+1,nres
19545       dyn_ssbond_ij(:,:)=1.0d300
19546 !        enddo
19547 !      enddo
19548
19549 !      if (nss.gt.0) then
19550         allocate(idssb(maxdim),jdssb(maxdim))
19551 !        allocate(newihpb(nss),newjhpb(nss))
19552 !(maxdim)
19553 !      endif
19554       allocate(ishield_list(nres))
19555       allocate(shield_list(50,nres))
19556       allocate(dyn_ss_mask(nres))
19557       allocate(fac_shield(nres))
19558 !(maxres)
19559       dyn_ss_mask(:)=.false.
19560 !----------------------
19561 ! common.sccor
19562 ! Parameters of the SCCOR term
19563 !      common/sccor/
19564 !el in io_conf: parmread
19565 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19566 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19567 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19568 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19569 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19570 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19571 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19572 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19573 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
19574 !----------------
19575       allocate(gloc_sc(3,0:2*nres,0:10))
19576 !(3,0:maxres2,10)maxres2=2*maxres
19577       allocate(dcostau(3,3,3,2*nres))
19578       allocate(dsintau(3,3,3,2*nres))
19579       allocate(dtauangle(3,3,3,2*nres))
19580       allocate(dcosomicron(3,3,3,2*nres))
19581       allocate(domicron(3,3,3,2*nres))
19582 !(3,3,3,maxres2)maxres2=2*maxres
19583 !----------------------
19584 ! common.var
19585 !      common /restr/
19586       allocate(varall(maxvar))
19587 !(maxvar)(maxvar=6*maxres)
19588       allocate(mask_theta(nres))
19589       allocate(mask_phi(nres))
19590       allocate(mask_side(nres))
19591 !(maxres)
19592 !----------------------
19593 ! common.vectors
19594 !      common /vectors/
19595       allocate(uy(3,nres))
19596       allocate(uz(3,nres))
19597 !(3,maxres)
19598       allocate(uygrad(3,3,2,nres))
19599       allocate(uzgrad(3,3,2,nres))
19600 !(3,3,2,maxres)
19601
19602       return
19603       end subroutine alloc_ener_arrays
19604 !-----------------------------------------------------------------------------
19605 !-----------------------------------------------------------------------------
19606       end module energy